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

Binary file not shown.

LICENSE+25−6
@@ -1,11 +1,30 @@
1−Copyright 2012-present Evan Czaplicki
1+Copyright (c) 2012-present, Evan Czaplicki
2
2
3−Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
3+All rights reserved.
4
4
5−1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
6
7
8+ * Redistributions of source code must retain the above copyright
7−2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9+ notice, this list of conditions and the following disclaimer.
8
10
9−3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
10
15
11−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
16+ * Neither the name of Evan Czaplicki nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+5−10
@@ -1,22 +1,17 @@
1−# Elm
1+# The Elm Compiler
2
2
3−A delightful language for reliable webapps.
3+Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
4
4
5−Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6−
7−
8−<br>
9
5
10## Install
6## Install
11
7
12−✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
8+Follow [these instructions][installer]!
13
9
14−For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
10+ [installer]: https://guide.elm-lang.org/install.html
15
11
16−<br>
17
12
18## Help
13## Help
19
14
20If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
15If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
21
16
22−[slack]: http://elmlang.herokuapp.com/
17+[slack]: http://elmlang.herokuapp.com/
builder/src/BackgroundWriter.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module BackgroundWriter
3− ( Scope
4− , withScope
5− , writeBinary
6− )
7− where
8−
9−
10−import Control.Concurrent (forkIO)
11−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12−import qualified Data.Binary as Binary
13−import Data.Foldable (traverse_)
14−
15−import qualified File
16−
17−
18−
19−-- BACKGROUND WRITER
20−
21−
22−newtype Scope =
23− Scope (MVar [MVar ()])
24−
25−
26−withScope :: (Scope -> IO a) -> IO a
27−withScope callback =
28− do workList <- newMVar []
29− result <- callback (Scope workList)
30− mvars <- takeMVar workList
31− traverse_ takeMVar mvars
32− return result
33−
34−
35−writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36−writeBinary (Scope workList) path value =
37− do mvar <- newEmptyMVar
38− _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39− oldWork <- takeMVar workList
40− let !newWork = mvar:oldWork
41− putMVar workList newWork
42−
builder/src/Build.hs+333−645
@@ -1,16 +1,12 @@
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns #-}
3module Build
3module Build
4 ( fromExposed
4 ( fromExposed
5− , fromPaths
5+ , fromMains
6− , fromRepl
7 , Artifacts(..)
6 , Artifacts(..)
8− , Root(..)
7+ , Main(..)
9 , Module(..)
8 , Module(..)
10 , CachedInterface(..)
9 , CachedInterface(..)
11− , ReplArtifacts(..)
12− , DocsGoal(..)
13− , getRootNames
14 )
10 )
15 where
11 where
16
12
@@ -18,8 +14,8 @@ module Build
18import Control.Concurrent (forkIO)
14import Control.Concurrent (forkIO)
19import Control.Concurrent.MVar
15import Control.Concurrent.MVar
20import Control.Monad (filterM, mapM_, sequence_)
16import Control.Monad (filterM, mapM_, sequence_)
21−import qualified Data.ByteString as B
22import qualified Data.Char as Char
17import qualified Data.Char as Char
18+import qualified Data.Either as Either
23import qualified Data.Graph as Graph
19import qualified Data.Graph as Graph
24import qualified Data.List as List
20import qualified Data.List as List
25import qualified Data.Map.Utils as Map
21import qualified Data.Map.Utils as Map
@@ -29,32 +25,25 @@ import qualified Data.Maybe as Maybe
29import qualified Data.Name as Name
25import qualified Data.Name as Name
30import qualified Data.NonEmptyList as NE
26import qualified Data.NonEmptyList as NE
31import qualified Data.OneOrMore as OneOrMore
27import qualified Data.OneOrMore as OneOrMore
32−import qualified Data.Set as Set
33import qualified System.Directory as Dir
28import qualified System.Directory as Dir
34import qualified System.FilePath as FP
29import qualified System.FilePath as FP
35import System.FilePath ((</>), (<.>))
30import System.FilePath ((</>), (<.>))
36
31
37−import qualified AST.Canonical as Can
38import qualified AST.Source as Src
32import qualified AST.Source as Src
39import qualified AST.Optimized as Opt
33import qualified AST.Optimized as Opt
40import qualified Compile
34import qualified Compile
41import qualified Elm.Details as Details
35import qualified Elm.Details as Details
42−import qualified Elm.Docs as Docs
43import qualified Elm.Interface as I
36import qualified Elm.Interface as I
44import qualified Elm.ModuleName as ModuleName
37import qualified Elm.ModuleName as ModuleName
45import qualified Elm.Outline as Outline
38import qualified Elm.Outline as Outline
46import qualified Elm.Package as Pkg
39import qualified Elm.Package as Pkg
47import qualified File
40import qualified File
48−import qualified Json.Encode as E
49import qualified Parse.Module as Parse
41import qualified Parse.Module as Parse
50import qualified Reporting
42import qualified Reporting
51import qualified Reporting.Annotation as A
43import 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
56import qualified Reporting.Exit as Exit
44import qualified Reporting.Exit as Exit
57−import qualified Reporting.Render.Type.Localizer as L
45+import qualified Reporting.Problem as Problem
46+import qualified Reporting.Render.Type.Localizer as Localizer
58import qualified Stuff
47import qualified Stuff
59
48
60
49
@@ -66,57 +55,27 @@ data Env =
66 Env
55 Env
67 { _key :: Reporting.BKey
56 { _key :: Reporting.BKey
68 , _root :: FilePath
57 , _root :: FilePath
69− , _project :: Parse.ProjectType
58+ , _pkg :: Pkg.Name
70− , _srcDirs :: [AbsoluteSrcDir]
59+ , _srcDirs :: [FilePath]
71− , _buildID :: Details.BuildID
72 , _locals :: Map.Map ModuleName.Raw Details.Local
60 , _locals :: Map.Map ModuleName.Raw Details.Local
73 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
61 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
74 }
62 }
75
63
76
64
77−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
65+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
78−makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
66+makeEnv key root (Details.Details _ validOutline locals foreigns _) =
79 case validOutline of
67 case validOutline of
80− Details.ValidApp givenSrcDirs ->
68+ Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->
81− do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82− return $ Env key root Parse.Application srcDirs buildID locals foreigns
69+ Env key root Pkg.dummyName srcDirs locals foreigns
83
70
84− Details.ValidPkg pkg _ _ ->
71+ Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
85− do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
86− return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
72+ Env key root pkg ["src"] locals foreigns
87−
88−
89−
90−-- SOURCE DIRECTORY
91−
92−
93−newtype AbsoluteSrcDir =
94− AbsoluteSrcDir FilePath
95−
96−
97−toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98−toAbsoluteSrcDir root srcDir =
99− AbsoluteSrcDir <$> Dir.canonicalizePath
100− (
101− case srcDir of
102− Outline.AbsoluteSrcDir dir -> dir
103− Outline.RelativeSrcDir dir -> root </> dir
104− )
105−
106−
107−addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108−addRelative (AbsoluteSrcDir srcDir) path =
109− srcDir </> path
110
73
111
74
112
75
113-- FORK
76-- FORK
114
77
115
78
116−-- PERF try using IORef semephore on file crawl phase?
117−-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
118−-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
119−--
120fork :: IO a -> IO (MVar a)
79fork :: IO a -> IO (MVar a)
121fork work =
80fork work =
122 do mvar <- newEmptyMVar
81 do mvar <- newEmptyMVar
@@ -134,22 +93,21 @@ forkWithKey func dict =
134-- FROM EXPOSED
93-- FROM EXPOSED
135
94
136
95
137−fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
96+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
138−fromExposed style root details docsGoal exposed@(NE.List e es) =
97+fromExposed style root details (NE.List e es) =
139 Reporting.trackBuild style $ \key ->
98 Reporting.trackBuild style $ \key ->
140− do env <- makeEnv key root details
99+ do let env = makeEnv key root details
141 dmvar <- Details.loadInterfaces root details
100 dmvar <- Details.loadInterfaces root details
142
101
143 -- crawl
102 -- crawl
144 mvar <- newEmptyMVar
103 mvar <- newEmptyMVar
145− let docsNeed = toDocsNeed docsGoal
146− roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
104+ roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
147 putMVar mvar roots
105 putMVar mvar roots
148 mapM_ readMVar roots
106 mapM_ readMVar roots
149 statuses <- traverse readMVar =<< readMVar mvar
107 statuses <- traverse readMVar =<< readMVar mvar
150
108
151 -- compile
109 -- compile
152− midpoint <- checkMidpoint dmvar statuses
110+ midpoint <- checkExposedMidpoint dmvar statuses
153 case midpoint of
111 case midpoint of
154 Left problem ->
112 Left problem ->
155 return (Left (Exit.BuildProjectProblem problem))
113 return (Left (Exit.BuildProjectProblem problem))
@@ -160,18 +118,18 @@ fromExposed style root details docsGoal exposed@(NE.List e es) =
160 putMVar rmvar resultMVars
118 putMVar rmvar resultMVars
161 results <- traverse readMVar resultMVars
119 results <- traverse readMVar resultMVars
162 writeDetails root details results
120 writeDetails root details results
163− finalizeExposed root docsGoal exposed results
121+ return (detectProblems results)
164
122
165
123
166
124
167−-- FROM PATHS
125+-- FROM MAINS
168
126
169
127
170data Artifacts =
128data Artifacts =
171 Artifacts
129 Artifacts
172 { _name :: Pkg.Name
130 { _name :: Pkg.Name
173 , _deps :: Dependencies
131 , _deps :: Dependencies
174− , _roots :: NE.List Root
132+ , _mains :: NE.List Main
175 , _modules :: [Module]
133 , _modules :: [Module]
176 }
134 }
177
135
@@ -185,25 +143,25 @@ type Dependencies =
185 Map.Map ModuleName.Canonical I.DependencyInterface
143 Map.Map ModuleName.Canonical I.DependencyInterface
186
144
187
145
188−fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
146+fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189−fromPaths style root details paths =
147+fromMains style root details paths =
190 Reporting.trackBuild style $ \key ->
148 Reporting.trackBuild style $ \key ->
191− do env <- makeEnv key root details
149+ do let env = makeEnv key root details
192
150
193− elroots <- findRoots env paths
151+ elmains <- findMains env paths
194− case elroots of
152+ case elmains of
195 Left problem ->
153 Left problem ->
196 return (Left (Exit.BuildProjectProblem problem))
154 return (Left (Exit.BuildProjectProblem problem))
197
155
198− Right lroots ->
156+ Right lmains ->
199 do -- crawl
157 do -- crawl
200 dmvar <- Details.loadInterfaces root details
158 dmvar <- Details.loadInterfaces root details
201 smvar <- newMVar Map.empty
159 smvar <- newMVar Map.empty
202− srootMVars <- traverse (fork . crawlRoot env smvar) lroots
160+ smainMVars <- traverse (fork . crawlMain env smvar) lmains
203− sroots <- traverse readMVar srootMVars
161+ smains <- traverse readMVar smainMVars
204 statuses <- traverse readMVar =<< readMVar smvar
162 statuses <- traverse readMVar =<< readMVar smvar
205
163
206− midpoint <- checkMidpointAndRoots dmvar statuses sroots
164+ midpoint <- checkMainsMidpoint dmvar statuses smains
207 case midpoint of
165 case midpoint of
208 Left problem ->
166 Left problem ->
209 return (Left (Exit.BuildProjectProblem problem))
167 return (Left (Exit.BuildProjectProblem problem))
@@ -213,26 +171,10 @@ fromPaths style root details paths =
213 rmvar <- newEmptyMVar
171 rmvar <- newEmptyMVar
214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
172 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
215 putMVar rmvar resultsMVars
173 putMVar rmvar resultsMVars
216− rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
174+ rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
217 results <- traverse readMVar resultsMVars
175 results <- traverse readMVar resultsMVars
218 writeDetails root details results
176 writeDetails root details results
219− toArtifacts env foreigns results <$> traverse readMVar rrootMVars
177+ toArtifacts env foreigns results <$> traverse readMVar rmainMVars
220−
221−
222−
223−-- GET ROOT NAMES
224−
225−
226−getRootNames :: Artifacts -> NE.List ModuleName.Raw
227−getRootNames (Artifacts _ _ roots _) =
228− fmap getRootName roots
229−
230−
231−getRootName :: Root -> ModuleName.Raw
232−getRootName root =
233− case root of
234− Inside name -> name
235− Outside name _ _ -> name
236
178
237
179
238
180
@@ -245,9 +187,9 @@ type StatusDict =
245
187
246data Status
188data Status
247 = SCached Details.Local
189 = SCached Details.Local
248− | SChanged Details.Local B.ByteString Src.Module DocsNeed
190+ | SChanged Details.Local Src.Module
249− | SBadImport Import.Problem
191+ | SNotFound Problem.Find
250− | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
192+ | SNotValid Problem.Syntax
251 | SForeign Pkg.Name
193 | SForeign Pkg.Name
252 | SKernel
194 | SKernel
253
195
@@ -262,34 +204,38 @@ crawlDeps env mvar deps blockedValue =
262 mapM_ readMVar statuses
204 mapM_ readMVar statuses
263 return blockedValue
205 return blockedValue
264 where
206 where
265− crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
207+ crawlNew name () = fork (crawlModule env mvar name)
266
208
267
209
268−crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
210+crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
269−crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
211+crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
270 do let fileName = ModuleName.toFilePath name <.> "elm"
212 do let fileName = ModuleName.toFilePath name <.> "elm"
213+ let inRoot path = File.exists (root </> path)
271
214
272− paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
215+ paths <- filterM inRoot (map (</> fileName) srcDirs)
273
216
274 case paths of
217 case paths of
275 [path] ->
218 [path] ->
276 case Map.lookup name foreigns of
219 case Map.lookup name foreigns of
277 Just (Details.Foreign dep deps) ->
220 Just (Details.Foreign dep deps) ->
278− return $ SBadImport $ Import.Ambiguous path [] dep deps
221+ return $ SNotFound $ Problem.Ambiguous path [] dep deps
279
222
280 Nothing ->
223 Nothing ->
281− do newTime <- File.getTime path
282− case Map.lookup name locals of
224+ case Map.lookup name locals of
283− Nothing ->
225+ Nothing ->
284− crawlFile env mvar docsNeed name path newTime buildID
226+ crawlFile env mvar name path
285
227
286− Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
228+ Just local@(Details.Local oldPath oldTime deps _) ->
287− if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
229+ if path /= oldPath
230+ then crawlFile env mvar name path
231+ else
232+ do newTime <- File.getTime path
233+ if oldTime < newTime
288− then crawlFile env mvar docsNeed name path newTime lastChange
234+ then crawlFile env mvar name path
289− else crawlDeps env mvar deps (SCached local)
235+ else crawlDeps env mvar deps (SCached local)
290
236
291 p1:p2:ps ->
237 p1:p2:ps ->
292− return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
238+ return $ SNotFound $ Problem.AmbiguousLocal p1 p2 ps
293
239
294 [] ->
240 [] ->
295 case Map.lookup name foreigns of
241 case Map.lookup name foreigns of
@@ -299,43 +245,44 @@ crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar do
299 return $ SForeign dep
245 return $ SForeign dep
300
246
301 d:ds ->
247 d:ds ->
302− return $ SBadImport $ Import.AmbiguousForeign dep d ds
248+ return $ SNotFound $ Problem.AmbiguousForeign dep d ds
303
249
304 Nothing ->
250 Nothing ->
305− if Name.isKernel name && Parse.isKernel projectType then
251+ if Name.isKernel name && Pkg.isKernel pkg then
306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
252 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
307− return $ if exists then SKernel else SBadImport Import.NotFound
253+ return $ if exists then SKernel else SNotFound Problem.NotFound
308 else
254 else
309− return $ SBadImport Import.NotFound
255+ return $ SNotFound Problem.NotFound
310
256
311
257
312−crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
258+crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
313−crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
259+crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
260+ do time <- File.getTime path
314− do source <- File.readUtf8 (root </> path)
261+ bytes <- File.readUtf8 (root </> path)
315
262
316− case Parse.fromByteString projectType source of
263+ case Parse.fromByteString pkg bytes of
317− Left err ->
318− return $ SBadSyntax path time source err
319−
320− Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
264+ Right modul@(Src.Module maybeActualName _ imports values _ _ _ _) ->
321 case maybeActualName of
265 case maybeActualName of
322− Nothing ->
323− return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
324−
325− Just name@(A.At _ actualName) ->
266+ Just actualName ->
326 if expectedName == actualName then
267 if expectedName == actualName then
327 let
268 let
328 deps = map Src.getImportName imports
269 deps = map Src.getImportName imports
329− local = Details.Local path time deps (any isMain values) lastChange buildID
270+ local = Details.Local path time deps (any isMain values)
330 in
271 in
331− crawlDeps env mvar deps (SChanged local source modul docsNeed)
272+ crawlDeps env mvar deps (SChanged local modul)
332 else
273 else
333− return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
274+ return $ SNotValid $ Problem.BadModuleName_Mismatch expectedName actualName
275+
276+ Nothing ->
277+ return $ SNotValid $ Problem.BadModuleName_Unspecified expectedName
278+
279+ Left syntaxError ->
280+ return $ SNotValid $ Problem.SyntaxProblem path time syntaxError
334
281
335
282
336isMain :: A.Located Src.Value -> Bool
283isMain :: A.Located Src.Value -> Bool
337isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
284isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
338− name == Name._main
285+ name == Name.main
339
286
340
287
341
288
@@ -347,11 +294,10 @@ type ResultDict =
347
294
348
295
349data Result
296data Result
350− = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
297+ = RNew Details.Local I.Interface Opt.LocalGraph
351− | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
298+ | RSame Details.Local I.Interface Opt.LocalGraph
352− | RCached Bool Details.BuildID (MVar CachedInterface)
299+ | RCached Bool (MVar CachedInterface)
353− | RNotFound Import.Problem
300+ | RProblem Problem.Problem
354− | RProblem Error.Module
355 | RBlocked
301 | RBlocked
356 | RForeign I.Interface
302 | RForeign I.Interface
357 | RKernel
303 | RKernel
@@ -364,68 +310,57 @@ data CachedInterface
364
310
365
311
366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
312checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
367−checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
313+checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
368 case status of
314 case status of
369− SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
315+ SCached local@(Details.Local path time deps hasMain) ->
370 do results <- readMVar resultsMVar
316 do results <- readMVar resultsMVar
371− depsStatus <- checkDeps root results deps lastCompile
317+ depsStatus <- checkDeps root results deps
372 case depsStatus of
318 case depsStatus of
373 DepsChange ifaces ->
319 DepsChange ifaces ->
374− do source <- File.readUtf8 path
320+ do bytes <- File.readUtf8 path
375− case Parse.fromByteString projectType source of
321+ case Parse.fromByteString pkg bytes of
376− Right modul -> compile env (DocsNeed False) local source ifaces modul
322+ Right modul -> compile env local ifaces modul
377− Left err ->
323+ Left syntaxError ->
378− return $ RProblem $
324+ return $ RProblem $ Problem.BadSyntax $
379− Error.Module name path time source (Error.BadSyntax err)
325+ Problem.SyntaxProblem path time syntaxError
380
326
381 DepsSame _ _ ->
327 DepsSame _ _ ->
382 do mvar <- newMVar Unneeded
328 do mvar <- newMVar Unneeded
383− return (RCached hasMain lastChange mvar)
329+ return (RCached hasMain mvar)
384
330
385 DepsBlock ->
331 DepsBlock ->
386 return RBlocked
332 return RBlocked
387
333
388− DepsNotFound problems ->
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
397−
398− SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
334+ SChanged local@(Details.Local _ _ deps _) modul ->
399 do results <- readMVar resultsMVar
335 do results <- readMVar resultsMVar
400− depsStatus <- checkDeps root results deps lastCompile
336+ depsStatus <- checkDeps root results deps
401 case depsStatus of
337 case depsStatus of
402 DepsChange ifaces ->
338 DepsChange ifaces ->
403− compile env docsNeed local source ifaces modul
339+ compile env local ifaces modul
404
340
405 DepsSame same cached ->
341 DepsSame same cached ->
406− do maybeLoaded <- loadInterfaces root same cached
342+ do maybeLoaded <- checkCachedInterfaces root cached
407 case maybeLoaded of
343 case maybeLoaded of
344+ Nothing ->
408− Nothing -> return RBlocked
345+ return RBlocked
346+
347+ Just loaded ->
348+ do let ifaces = Map.union loaded (Map.fromList same)
409− Just ifaces -> compile env docsNeed local source ifaces modul
349+ compile env local ifaces modul
410
350
411 DepsBlock ->
351 DepsBlock ->
412 return RBlocked
352 return RBlocked
413
353
414− DepsNotFound problems ->
354+ SNotFound findProblem ->
415− return $ RProblem $ Error.Module name path time source $
355+ return (RProblem (Problem.BadFind findProblem))
416− Error.BadImports (toImportErrors env results imports problems)
417−
418− SBadImport importProblem ->
419− return (RNotFound importProblem)
420
356
421− SBadSyntax path time source err ->
357+ SNotValid syntaxProblem ->
422− return $ RProblem $ Error.Module name path time source $
358+ return (RProblem (Problem.BadSyntax syntaxProblem))
423− Error.BadSyntax err
424
359
425 SForeign home ->
360 SForeign home ->
426 case foreigns ! ModuleName.Canonical home name of
361 case foreigns ! ModuleName.Canonical home name of
427 I.Public iface -> return (RForeign iface)
362 I.Public iface -> return (RForeign iface)
428− I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
363+ I.Private _ _ _ -> error "loading private interface in Build"
429
364
430 SKernel ->
365 SKernel ->
431 return RKernel
366 return RKernel
@@ -439,112 +374,71 @@ data DepsStatus
439 = DepsChange (Map.Map ModuleName.Raw I.Interface)
374 = DepsChange (Map.Map ModuleName.Raw I.Interface)
440 | DepsSame [Dep] [CDep]
375 | DepsSame [Dep] [CDep]
441 | DepsBlock
376 | DepsBlock
442− | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
443
377
444
378
445−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
379+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
446−checkDeps root results deps lastCompile =
380+checkDeps root results deps =
447− checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
381+ checkDepsHelp root results deps [] [] []
448
382
449
383
450type Dep = (ModuleName.Raw, I.Interface)
384type Dep = (ModuleName.Raw, I.Interface)
451type CDep = (ModuleName.Raw, MVar CachedInterface)
385type CDep = (ModuleName.Raw, MVar CachedInterface)
452
386
453
387
454−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
388+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> IO DepsStatus
455−checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
389+checkDepsHelp root results deps new same cached =
456 case deps of
390 case deps of
391+ [] ->
392+ if null new
393+ then return (DepsSame same cached)
394+ else
395+ do maybeLoaded <- checkCachedInterfaces root cached
396+ case maybeLoaded of
397+ Nothing ->
398+ return DepsBlock
399+
400+ Just loaded ->
401+ return $ DepsChange $
402+ Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
403+
457 dep:otherDeps ->
404 dep:otherDeps ->
458 do result <- readMVar (results ! dep)
405 do result <- readMVar (results ! dep)
459 case result of
406 case result of
460− RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
407+ RNew _ iface _ ->
461− checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
408+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached
462
409
463− RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
410+ RSame _ iface _ ->
464− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
411+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached
465
412
466− RCached _ lastChange mvar ->
413+ RCached _ mvar ->
467− checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
414+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached)
468−
469− RNotFound prob ->
470− checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471
415
472 RProblem _ ->
416 RProblem _ ->
473− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
417+ return DepsBlock
474
418
475 RBlocked ->
419 RBlocked ->
476− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
420+ return DepsBlock
477
421
478 RForeign iface ->
422 RForeign iface ->
479− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
423+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached
480
424
481 RKernel ->
425 RKernel ->
482− checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
426+ checkDepsHelp root results otherDeps new same cached
483−
484−
485− [] ->
486− case reverse importProblems of
487− p:ps ->
488− return $ DepsNotFound (NE.List p ps)
489−
490− [] ->
491− if isBlocked then
492− return $ DepsBlock
493−
494− else if null new && lastDepChange <= lastCompile then
495− return $ DepsSame same cached
496−
497− else
498− do maybeLoaded <- loadInterfaces root same cached
499− case maybeLoaded of
500− Nothing -> return DepsBlock
501− Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
502−
503−
504−
505−-- TO IMPORT ERROR
506−
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− ]
517−
518− unimportedModules =
519− Set.difference knownModules (Set.fromList (map Src.getImportName imports))
520−
521− regionDict =
522− Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
523−
524− toError (name, problem) =
525− Import.Error (regionDict ! name) name unimportedModules problem
526− in
527− fmap toError problems
528
427
529
428
530
429
531−-- LOAD CACHED INTERFACES
430+-- CACHED INTERFACE
532
431
533
432
534−loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
433+checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535−loadInterfaces root same cached =
434+checkCachedInterfaces root deps =
536− do loading <- traverse (fork . loadInterface root) cached
435+ do loading <- traverse (fork . checkCache root) deps
537− maybeLoaded <- traverse readMVar loading
436+ loaded <- traverse readMVar loading
538− case sequence maybeLoaded of
437+ return $ Map.fromList <$> sequence loaded
539− Nothing ->
540− return Nothing
541−
542− Just loaded ->
543− return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
544
438
545
439
546−loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
440+checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
547−loadInterface root (name, ciMvar) =
441+checkCache root (name, ciMvar) =
548 do cachedInterface <- takeMVar ciMvar
442 do cachedInterface <- takeMVar ciMvar
549 case cachedInterface of
443 case cachedInterface of
550 Corrupted ->
444 Corrupted ->
@@ -571,8 +465,8 @@ loadInterface root (name, ciMvar) =
571-- CHECK PROJECT
465-- CHECK PROJECT
572
466
573
467
574−checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
468+checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575−checkMidpoint dmvar statuses =
469+checkExposedMidpoint dmvar statuses =
576 case checkForCycles statuses of
470 case checkForCycles statuses of
577 Nothing ->
471 Nothing ->
578 do maybeForeigns <- readMVar dmvar
472 do maybeForeigns <- readMVar dmvar
@@ -585,11 +479,11 @@ checkMidpoint dmvar statuses =
585 return (Left (Exit.BP_Cycle name names))
479 return (Left (Exit.BP_Cycle name names))
586
480
587
481
588−checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
482+checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589−checkMidpointAndRoots dmvar statuses sroots =
483+checkMainsMidpoint dmvar statuses smains =
590 case checkForCycles statuses of
484 case checkForCycles statuses of
591 Nothing ->
485 Nothing ->
592− case checkUniqueRoots statuses sroots of
486+ case checkUniqueMains statuses smains of
593 Nothing ->
487 Nothing ->
594 do maybeForeigns <- readMVar dmvar
488 do maybeForeigns <- readMVar dmvar
595 case maybeForeigns of
489 case maybeForeigns of
@@ -640,25 +534,25 @@ addToGraph name status graph =
640 let
534 let
641 dependencies =
535 dependencies =
642 case status of
536 case status of
643− SCached (Details.Local _ _ deps _ _ _) -> deps
537+ SCached (Details.Local _ _ deps _) -> deps
644− SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
538+ SChanged (Details.Local _ _ deps _) _ -> deps
645− SBadImport _ -> []
539+ SNotFound _ -> []
646− SBadSyntax _ _ _ _ -> []
540+ SNotValid _ -> []
647− SForeign _ -> []
541+ SForeign _ -> []
648− SKernel -> []
542+ SKernel -> []
649 in
543 in
650 (name, name, dependencies) : graph
544 (name, name, dependencies) : graph
651
545
652
546
653
547
654−-- CHECK UNIQUE ROOTS
548+-- CHECK UNIQUE MAINS
655
549
656
550
657−checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
551+checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
658−checkUniqueRoots insides sroots =
552+checkUniqueMains insides smains =
659 let
553 let
660 outsidesDict =
554 outsidesDict =
661− Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
555+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
662 in
556 in
663 case Map.traverseWithKey checkOutside outsidesDict of
557 case Map.traverseWithKey checkOutside outsidesDict of
664 Left problem ->
558 Left problem ->
@@ -670,78 +564,61 @@ checkUniqueRoots insides sroots =
670 Left problem -> Just problem
564 Left problem -> Just problem
671
565
672
566
673−rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
567+mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
674−rootStatusToNamePathPair sroot =
568+mainStatusToNamePathPair smain =
675− case sroot of
569+ case smain of
676− SInside _ -> Nothing
570+ SInside _ -> Nothing
677− SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
571+ SOutsideOk (Details.Local path _ _ _) modul -> Just (Src.getName modul, OneOrMore.one path)
678− SOutsideErr _ -> Nothing
572+ SOutsideErr _ -> Nothing
679
573
680
574
681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
575checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
682checkOutside name paths =
576checkOutside name paths =
683 case OneOrMore.destruct NE.List paths of
577 case OneOrMore.destruct NE.List paths of
684 NE.List p [] -> Right p
578 NE.List p [] -> Right p
685− NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
579+ NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
686
580
687
581
688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
582checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
689checkInside name p1 status =
583checkInside name p1 status =
690 case status of
584 case status of
691− SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
585+ SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
692− SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
586+ SChanged (Details.Local p2 _ _ _) _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
693− SBadImport _ -> Right ()
587+ SNotFound _ -> Right ()
694− SBadSyntax _ _ _ _ -> Right ()
588+ SNotValid _ -> Right ()
695− SForeign _ -> Right ()
589+ SForeign _ -> Right ()
696− SKernel -> Right ()
590+ SKernel -> Right ()
697
591
698
592
699
593
700-- COMPILE MODULE
594-- COMPILE MODULE
701
595
702
596
703−compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
597+compile :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
704−compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
598+compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) ifaces modul =
705− let
706− pkg = projectTypeToPkg projectType
707− in
708 case Compile.compile pkg ifaces modul of
599 case Compile.compile pkg ifaces modul of
709 Right (Compile.Artifacts canonical annotations objects) ->
600 Right (Compile.Artifacts canonical annotations objects) ->
710− case makeDocs docsNeed canonical of
711− Left err ->
712− return $ RProblem $
713− Error.Module (Src.getName modul) path time source (Error.BadDocs err)
714−
715− Right docs ->
716− do let name = Src.getName modul
601+ do let name = Src.getName modul
717− let iface = I.fromModule pkg canonical annotations
602+ let iface = I.fromModule pkg canonical annotations
718− let elmi = Stuff.elmi root name
719− File.writeBinary (Stuff.elmo root name) objects
603+ File.writeBinary (Stuff.elmo root name) objects
720− maybeOldi <- File.readBinary elmi
604+ maybeOldi <- File.readBinary (Stuff.elmi root name)
721− case maybeOldi of
605+ case maybeOldi of
722− Just oldi | oldi == iface ->
606+ Just oldi | oldi == iface ->
723− do -- iface should be fully forced by equality check
607+ do -- iface should be fully forced by equality check
724− Reporting.report key Reporting.BDone
608+ Reporting.report key Reporting.BDone
725− let local = Details.Local path time deps main lastChange buildID
726− return (RSame local iface objects docs)
609+ return (RSame local iface objects)
727−
610+
728− _ ->
611+ _ ->
729− do -- iface may be lazy still
612+ do -- iface may be lazy still
613+ -- TODO try adding forkIO here
730− File.writeBinary elmi iface
614+ File.writeBinary (Stuff.elmi root name) iface
731− Reporting.report key Reporting.BDone
615+ Reporting.report key Reporting.BDone
732− let local = Details.Local path time deps main buildID buildID
733− return (RNew local iface objects docs)
616+ return (RNew local iface objects)
734−
617+
735− Left err ->
618+ Left errors ->
619+ do Reporting.report key Reporting.BDone
736− return $ RProblem $
620+ return $ RProblem $ Problem.BadContent $
737− Error.Module (Src.getName modul) path time source err
621+ Problem.Module (Src.getName modul) path time errors (Localizer.fromModule modul)
738−
739−
740−projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741−projectTypeToPkg projectType =
742− case projectType of
743− Parse.Package pkg -> pkg
744− Parse.Application -> Pkg.dummyName
745
622
746
623
747
624
@@ -749,210 +626,44 @@ projectTypeToPkg projectType =
749
626
750
627
751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
628writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
752−writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
629+writeDetails root (Details.Details time outline locals foreigns extras) results =
753 File.writeBinary (Stuff.details root) $
630 File.writeBinary (Stuff.details root) $
754− Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
631+ Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
755
632
756
633
757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
634addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
758addNewLocal name result locals =
635addNewLocal name result locals =
759 case result of
636 case result of
760− RNew local _ _ _ -> Map.insert name local locals
637+ RNew local _ _ -> Map.insert name local locals
761− RSame local _ _ _ -> Map.insert name local locals
638+ RSame local _ _ -> Map.insert name local locals
762− RCached _ _ _ -> locals
639+ RCached _ _ -> locals
763− RNotFound _ -> locals
764− RProblem _ -> locals
640+ RProblem _ -> locals
765− RBlocked -> locals
641+ RBlocked -> locals
766− RForeign _ -> locals
642+ RForeign _ -> locals
767− RKernel -> locals
643+ RKernel -> locals
768−
769
644
770
645
771−-- FINALIZE EXPOSED
772
646
647+-- DETECT PROBLEMS
773
648
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
649
780− [] ->
650+detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
651+detectProblems results =
781− case Map.foldr addErrors [] results of
652+ case Map.foldr addProblem [] results of
782− [] -> Right <$> finalizeDocs docsGoal results
653+ [] -> Right ()
783− e:es -> return $ Left $ Exit.BuildBadModules root e es
654+ p:ps -> Left (Exit.BuildModuleProblems p ps)
784
655
785
656
786−addErrors :: Result -> [Error.Module] -> [Error.Module]
657+addProblem :: Result -> [Problem.Problem] -> [Problem.Problem]
787−addErrors result errors =
658+addProblem result problems =
788 case result of
659 case result of
789− RNew _ _ _ _ -> errors
660+ RNew _ _ _ -> problems
790− RSame _ _ _ _ -> errors
661+ RSame _ _ _ -> problems
791− RCached _ _ _ -> errors
662+ RCached _ _ -> problems
792− RNotFound _ -> errors
793− RProblem e -> e:errors
663+ RProblem p -> p:problems
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
664+ RBlocked -> problems
808− RForeign _ -> problems
665+ RForeign _ -> problems
809− RKernel -> problems
810−
811−
812−
813−-- DOCS
814−
815−
816−data DocsGoal a where
817− KeepDocs :: DocsGoal Docs.Documentation
818− WriteDocs :: FilePath -> DocsGoal ()
819− IgnoreDocs :: DocsGoal ()
820−
821−
822−newtype DocsNeed =
823− DocsNeed { needsDocs :: Bool }
824−
825−
826−toDocsNeed :: DocsGoal a -> DocsNeed
827−toDocsNeed goal =
828− case goal of
829− IgnoreDocs -> DocsNeed False
830− WriteDocs _ -> DocsNeed True
831− KeepDocs -> DocsNeed True
832−
833−
834−makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
835−makeDocs (DocsNeed isNeeded) modul =
836− if isNeeded then
837− case Docs.fromModule modul of
838− Right docs -> Right (Just docs)
839− Left err -> Left err
840− else
841− Right Nothing
842−
843−
844−finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
845−finalizeDocs goal results =
846− case goal of
847− KeepDocs ->
848− return $ Map.mapMaybe toDocs results
849−
850− WriteDocs path ->
851− E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
852−
853− IgnoreDocs ->
854− return ()
855−
856−
857−toDocs :: Result -> Maybe Docs.Module
858−toDocs result =
859− case result of
860− RNew _ _ _ d -> d
861− RSame _ _ _ d -> d
862− RCached _ _ _ -> Nothing
863− RNotFound _ -> Nothing
864− RProblem _ -> Nothing
865− RBlocked -> Nothing
866− RForeign _ -> Nothing
867− RKernel -> Nothing
666+ RKernel -> problems
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
956
667
957
668
958
669
@@ -964,25 +675,25 @@ finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Mod
964
675
965
676
966
677
967−-- FIND ROOT
678+-- FIND MAIN
968
679
969
680
970−data RootLocation
681+data MainLocation
971 = LInside ModuleName.Raw
682 = LInside ModuleName.Raw
972 | LOutside FilePath
683 | LOutside FilePath
973
684
974
685
975−findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
686+findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
976−findRoots env paths =
687+findMains env paths =
977− do mvars <- traverse (fork . getRootInfo env) paths
688+ do mvars <- traverse (fork . findLocation env) paths
978− einfos <- traverse readMVar mvars
689+ elocs <- traverse readMVar mvars
979− return $ checkRoots =<< sequence einfos
690+ return $ checkLocations =<< sequence elocs
980
691
981
692
982−checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
693+checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
983−checkRoots infos =
694+checkLocations locations =
984 let
695 let
985− toOneOrMore loc@(RootInfo absolute _ _) =
696+ toOneOrMore loc@(Location absolute _ _) =
986 (absolute, OneOrMore.one loc)
697 (absolute, OneOrMore.one loc)
987
698
988 fromOneOrMore loc locs =
699 fromOneOrMore loc locs =
@@ -990,83 +701,70 @@ checkRoots infos =
990 [] -> Right ()
701 [] -> Right ()
991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
702 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
992 in
703 in
993− fmap (\_ -> fmap _location infos) $
704+ fmap (\_ -> fmap _location locations) $
994 traverse (OneOrMore.destruct fromOneOrMore) $
705 traverse (OneOrMore.destruct fromOneOrMore) $
995− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
706+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
996
707
997
708
998
709
999−-- ROOT INFO
710+-- LOCATIONS
1000
711
1001
712
1002−data RootInfo =
713+data Location =
1003− RootInfo
714+ Location
1004 { _absolute :: FilePath
715 { _absolute :: FilePath
1005 , _relative :: FilePath
716 , _relative :: FilePath
1006− , _location :: RootLocation
717+ , _location :: MainLocation
1007 }
718 }
1008
719
1009
720
1010−getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
721+findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
1011−getRootInfo env path =
722+findLocation env path =
1012 do exists <- File.exists path
723 do exists <- File.exists path
1013 if exists
724 if exists
1014− then getRootInfoHelp env path =<< Dir.canonicalizePath path
725+ then isInsideSrcDirs env path <$> Dir.canonicalizePath path
1015 else return (Left (Exit.BP_PathUnknown path))
726 else return (Left (Exit.BP_PathUnknown path))
1016
727
1017
728
1018−getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
729+isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
1019−getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
730+isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
1020 let
731 let
1021 (dirs, file) = FP.splitFileName absolutePath
732 (dirs, file) = FP.splitFileName absolutePath
1022− (final, ext) = FP.splitExtension file
733+ (final, ext) = break (=='.') file
1023 in
734 in
1024 if ext /= ".elm"
735 if ext /= ".elm"
1025− then
1026− return $ Left $ Exit.BP_WithBadExtension path
736+ then Left (Exit.BP_WithBadExtension path)
1027 else
737 else
1028 let
738 let
739+ roots = FP.splitDirectories root
1029− absoluteSegments = FP.splitDirectories dirs ++ [final]
740+ segments = FP.splitDirectories dirs ++ [final]
1030 in
741 in
1031− case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
742+ case dropPrefix roots segments of
1032− [] ->
743+ Nothing ->
1033− return $ Right $ RootInfo absolutePath path (LOutside path)
744+ Right (Location absolutePath path (LOutside path))
1034−
745+
1035− [(_, Right names)] ->
746+ Just relativeSegments ->
1036− do let name = Name.fromChars (List.intercalate "." names)
747+ let
1037− matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
748+ (exits, maybes) =
1038− case matchingDirs of
749+ Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
1039− d1:d2:_ ->
750+ in
1040− do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
751+ case (exits, Maybe.catMaybes maybes) of
1041− let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042− return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043−
1044− _ ->
1045− return $ Right $ RootInfo absolutePath path (LInside name)
752+ (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
1046−
753+ ([], []) -> Right (Location absolutePath path (LOutside path))
1047− [(s, Left names)] ->
1048− return $ Left $ Exit.BP_RootNameInvalid path s names
1049−
1050− (s1,_):(s2,_):_ ->
1051− return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
754+ (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
1052−
755+ (exit:_, _) -> Left exit
1053−
756+
1054−
757+
1055−isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
758+isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
1056−isInsideSrcDirByName names srcDir =
759+isInsideSrcDirsHelp segments srcDir =
1057− File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1058−
1059−
1060−isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061−isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1062 case dropPrefix (FP.splitDirectories srcDir) segments of
760 case dropPrefix (FP.splitDirectories srcDir) segments of
1063 Nothing ->
761 Nothing ->
1064− Nothing
762+ Right Nothing
1065
763
1066 Just names ->
764 Just names ->
1067 if all isGoodName names
765 if all isGoodName names
1068− then Just (srcDir, Right names)
766+ then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
1069− else Just (srcDir, Left names)
767+ else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1070
768
1071
769
1072isGoodName :: [Char] -> Bool
770isGoodName :: [Char] -> Bool
@@ -1079,8 +777,6 @@ isGoodName name =
1079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
777 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1080
778
1081
779
1082−-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083−--
1084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
780dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1085dropPrefix roots paths =
781dropPrefix roots paths =
1086 case roots of
782 case roots of
@@ -1089,162 +785,154 @@ dropPrefix roots paths =
1089
785
1090 r:rs ->
786 r:rs ->
1091 case paths of
787 case paths of
1092− [] -> Nothing
788+ [] -> Nothing
1093 p:ps -> if r == p then dropPrefix rs ps else Nothing
789 p:ps -> if r == p then dropPrefix rs ps else Nothing
1094
790
1095
791
1096
792
1097−-- CRAWL ROOTS
793+-- CRAWL MAINS
1098
794
1099
795
1100−data RootStatus
796+data MainStatus
1101 = SInside ModuleName.Raw
797 = SInside ModuleName.Raw
1102− | SOutsideOk Details.Local B.ByteString Src.Module
798+ | SOutsideOk Details.Local Src.Module
1103− | SOutsideErr Error.Module
799+ | SOutsideErr Problem.Syntax
1104
800
1105
801
1106−crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
802+crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1107−crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
803+crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1108− case root of
804+ case given of
1109 LInside name ->
805 LInside name ->
1110 do statusMVar <- newEmptyMVar
806 do statusMVar <- newEmptyMVar
1111 statusDict <- takeMVar mvar
807 statusDict <- takeMVar mvar
1112 putMVar mvar (Map.insert name statusMVar statusDict)
808 putMVar mvar (Map.insert name statusMVar statusDict)
1113− putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
809+ putMVar statusMVar =<< crawlModule env mvar name
1114 return (SInside name)
810 return (SInside name)
1115
811
1116 LOutside path ->
812 LOutside path ->
1117 do time <- File.getTime path
813 do time <- File.getTime path
1118− source <- File.readUtf8 path
814+ bytes <- File.readUtf8 path
1119− case Parse.fromByteString projectType source of
815+ case Parse.fromByteString pkg bytes of
1120− Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
816+ Right modul@(Src.Module _ _ imports values _ _ _ _) ->
1121 do let deps = map Src.getImportName imports
817 do let deps = map Src.getImportName imports
1122− let local = Details.Local path time deps (any isMain values) buildID buildID
818+ let local = Details.Local path time deps (any isMain values)
1123− crawlDeps env mvar deps (SOutsideOk local source modul)
819+ crawlDeps env mvar deps (SOutsideOk local modul)
1124
820
1125 Left syntaxError ->
821 Left syntaxError ->
1126− return $ SOutsideErr $
822+ return (SOutsideErr (Problem.SyntaxProblem path time syntaxError))
1127− Error.Module "???" path time source (Error.BadSyntax syntaxError)
1128
823
1129
824
1130
825
1131−-- CHECK ROOTS
826+-- CHECK MAINS
1132
827
1133
828
1134−data RootResult
829+data MainResult
1135 = RInside ModuleName.Raw
830 = RInside ModuleName.Raw
1136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
831 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1137− | ROutsideErr Error.Module
832+ | ROutsideErr Problem.Problem
1138 | ROutsideBlocked
833 | ROutsideBlocked
1139
834
1140
835
1141−checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
836+checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1142−checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
837+checkMain env@(Env _ root _ _ _ _) results pendingMain =
1143− case rootStatus of
838+ case pendingMain of
1144 SInside name ->
839 SInside name ->
1145 return (RInside name)
840 return (RInside name)
1146
841
1147− SOutsideErr err ->
842+ SOutsideErr syntaxProblem ->
1148− return (ROutsideErr err)
843+ return (ROutsideErr (Problem.BadSyntax syntaxProblem))
1149
844
1150− SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
845+ SOutsideOk local@(Details.Local _ _ deps _) modul ->
1151− do depsStatus <- checkDeps root results deps lastCompile
846+ do depsStatus <- checkDeps root results deps
1152 case depsStatus of
847 case depsStatus of
1153 DepsChange ifaces ->
848 DepsChange ifaces ->
1154− compileOutside env local source ifaces modul
849+ return $ compileOutside env local ifaces modul
1155
850
1156 DepsSame same cached ->
851 DepsSame same cached ->
1157− do maybeLoaded <- loadInterfaces root same cached
852+ do maybeLoaded <- checkCachedInterfaces root cached
1158 case maybeLoaded of
853 case maybeLoaded of
854+ Nothing ->
1159− Nothing -> return ROutsideBlocked
855+ return ROutsideBlocked
856+
857+ Just loaded ->
858+ do let ifaces = Map.union loaded (Map.fromList same)
1160− Just ifaces -> compileOutside env local source ifaces modul
859+ return $ compileOutside env local ifaces modul
1161
860
1162 DepsBlock ->
861 DepsBlock ->
1163 return ROutsideBlocked
862 return ROutsideBlocked
1164
863
1165− DepsNotFound problems ->
1166− return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1167− Error.BadImports (toImportErrors env results imports problems)
1168−
1169
864
1170−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
865+compileOutside :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
1171−compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
866+compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) ifaces modul =
1172 let
867 let
1173− pkg = projectTypeToPkg projectType
1174 name = Src.getName modul
868 name = Src.getName modul
1175 in
869 in
1176 case Compile.compile pkg ifaces modul of
870 case Compile.compile pkg ifaces modul of
1177 Right (Compile.Artifacts canonical annotations objects) ->
871 Right (Compile.Artifacts canonical annotations objects) ->
1178− do Reporting.report key Reporting.BDone
1179− return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
872+ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1180
873
1181 Left errors ->
874 Left errors ->
875+ ROutsideErr $ Problem.BadContent $
1182− return $ ROutsideErr $ Error.Module name path time source errors
876+ Problem.Module name path time errors (Localizer.fromModule modul)
1183
877
1184
878
1185
879
1186-- TO ARTIFACTS
880-- TO ARTIFACTS
1187
881
1188
882
1189−data Root
883+data Main
1190 = Inside ModuleName.Raw
884 = Inside ModuleName.Raw
1191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
885 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1192
886
1193
887
1194−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
888+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1195−toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
889+toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1196− case gatherProblemsOrMains results rootResults of
890+ case gatherProblemsOrMains results mainResults of
1197− Left (NE.List e es) ->
891+ Left (NE.List p ps) ->
1198− Left (Exit.BuildBadModules root e es)
892+ Left (Exit.BuildModuleProblems p ps)
1199
893
1200− Right roots ->
894+ Right mains ->
1201− Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
895+ Right $ Artifacts pkg foreigns mains $
1202− Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
896+ Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1203
897
1204
898
1205−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
899+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Problem.Problem) (NE.List Main)
1206−gatherProblemsOrMains results (NE.List rootResult rootResults) =
900+gatherProblemsOrMains results (NE.List mainResult mainResults) =
1207 let
901 let
1208− addResult result (es, roots) =
902+ sortMain result (ps, mains) =
1209 case result of
903 case result of
1210− RInside n -> ( es, Inside n : roots)
904+ RInside n -> ( ps, Inside n : mains)
1211− ROutsideOk n i o -> ( es, Outside n i o : roots)
905+ ROutsideOk n i o -> ( ps, Outside n i o : mains)
1212− ROutsideErr e -> (e:es, roots)
906+ ROutsideErr p -> (p:ps, mains)
1213− ROutsideBlocked -> ( es, roots)
907+ ROutsideBlocked -> ( ps, mains)
1214
908
1215− errors = Map.foldr addErrors [] results
909+ problems = Map.foldr addProblem [] results
1216 in
910 in
1217− case (rootResult, foldr addResult (errors, []) rootResults) of
911+ case (mainResult, foldr sortMain (problems, []) mainResults) of
1218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
912 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1219− (RInside _ , (e:es, _ )) -> Left (NE.List e es)
913+ (RInside _ , (p:ps, _ )) -> Left (NE.List p ps)
1220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
914 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1221− (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
915+ (ROutsideOk _ _ _, (p:ps, _ )) -> Left (NE.List p ps)
1222− (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
916+ (ROutsideErr p , ( ps, _ )) -> Left (NE.List p ps)
1223 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
917 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1224− (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
918+ (ROutsideBlocked , (p:ps, _ )) -> Left (NE.List p ps)
1225
919
1226
920
1227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
921addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1228addInside name result modules =
922addInside name result modules =
1229 case result of
923 case result of
1230− RNew _ iface objs _ -> Fresh name iface objs : modules
924+ RNew _ iface objs -> Fresh name iface objs : modules
1231− RSame _ iface objs _ -> Fresh name iface objs : modules
925+ RSame _ iface objs -> Fresh name iface objs : modules
1232− RCached main _ mvar -> Cached name main mvar : modules
926+ RCached main mvar -> Cached name main mvar : modules
1233− RNotFound _ -> error (badInside name)
1234− RProblem _ -> error (badInside name)
927+ RProblem _ -> error ("I missed the error in `" ++ Name.toChars name ++ "` module.")
1235− RBlocked -> error (badInside name)
928+ RBlocked -> error ("I missed the error in `" ++ Name.toChars name ++ "` module.")
1236− RForeign _ -> modules
929+ RForeign _ -> modules
1237− RKernel -> modules
930+ RKernel -> modules
1238−
931+
1239−
932+
1240−badInside :: ModuleName.Raw -> [Char]
1241−badInside name =
1242− "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1243−
1244−
1245−addOutside :: RootResult -> [Module] -> [Module]
933+addOutside :: MainResult -> [Module] -> [Module]
1246−addOutside root modules =
934+addOutside main modules =
1247− case root of
935+ case main of
1248 RInside _ -> modules
936 RInside _ -> modules
1249 ROutsideOk name iface objs -> Fresh name iface objs : modules
937 ROutsideOk name iface objs -> Fresh name iface objs : modules
1250 ROutsideErr _ -> modules
938 ROutsideErr _ -> modules
builder/src/Deps/Bump.hsdeleted−37
@@ -1,37 +0,0 @@
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+5−7
@@ -18,7 +18,7 @@ import qualified Data.List as List
18import qualified Data.Map as Map
18import qualified Data.Map as Map
19import qualified Data.Name as Name
19import qualified Data.Name as Name
20import qualified Data.Set as Set
20import qualified Data.Set as Set
21−import qualified System.Directory as Dir
21+import qualified Data.Utf8 as Utf8
22import System.FilePath ((</>))
22import System.FilePath ((</>))
23
23
24import qualified Deps.Website as Website
24import qualified Deps.Website as Website
@@ -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 (Name.splitDots name)
207+ reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 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,8 +357,7 @@ changeMagnitude (Changes added changed removed) =
357
357
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359getDocs cache manager name version =
359getDocs cache manager name version =
360− do let home = Stuff.package cache name version
360+ do let path = Stuff.package cache name version </> "docs.json"
361− let path = home </> "docs.json"
362 exists <- File.exists path
361 exists <- File.exists path
363 if exists
362 if exists
364 then
363 then
@@ -375,9 +374,8 @@ getDocs cache manager name version =
375 Http.get manager url [] Exit.DP_Http $ \body ->
374 Http.get manager url [] Exit.DP_Http $ \body ->
376 case D.fromByteString Docs.decoder body of
375 case D.fromByteString Docs.decoder body of
377 Right docs ->
376 Right docs ->
378− do Dir.createDirectoryIfMissing True home
379− File.writeUtf8 path body
377+ do File.writeUtf8 path body
380 return $ Right docs
378 return $ Right docs
381
379
382 Left _ ->
380 Left _ ->
383− return $ Left $ Exit.DP_Data url body
381+ return $ Left Exit.DP_Data
builder/src/Deps/Registry.hs+68−35
@@ -16,8 +16,11 @@ 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)
19import qualified Data.List as List
20import qualified Data.List as List
20import qualified Data.Map.Strict as Map
21import qualified Data.Map.Strict as Map
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
21
24
22import qualified Deps.Website as Website
25import qualified Deps.Website as Website
23import qualified Elm.Package as Pkg
26import qualified Elm.Package as Pkg
@@ -25,8 +28,8 @@ import qualified Elm.Version as V
25import qualified File
28import qualified File
26import qualified Http
29import qualified Http
27import qualified Json.Decode as D
30import qualified Json.Decode as D
28−import qualified Parse.Primitives as P
29import qualified Reporting.Exit as Exit
31import qualified Reporting.Exit as Exit
32+import qualified Reporting.Suggest as Suggest
30import qualified Stuff
33import qualified Stuff
31
34
32
35
@@ -54,7 +57,11 @@ data KnownVersions =
54
57
55read :: Stuff.PackageCache -> IO (Maybe Registry)
58read :: Stuff.PackageCache -> IO (Maybe Registry)
56read cache =
59read cache =
57− File.readBinary (Stuff.registry cache)
60+ do let path = Stuff.registry cache
61+ exists <- File.exists path
62+ if exists
63+ then File.readBinary path
64+ else return Nothing
58
65
59
66
60
67
@@ -79,19 +86,26 @@ addEntry (KnownVersions _ vs) count =
79
86
80allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
87allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
81allPkgsDecoder =
88allPkgsDecoder =
82− let
89+ do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
83− keyDecoder =
90+ checkKeys pairs Map.empty
84− Pkg.keyDecoder bail
91+ where
92+ checkKeys pairs pkgs =
93+ case pairs of
94+ [] ->
95+ return pkgs
85
96
86− versionsDecoder =
97+ (key, versions) : rest ->
87− D.list (D.mapError (\_ -> ()) V.decoder)
98+ case Pkg.fromString key of
99+ Right pkg ->
100+ case List.sortBy (flip compare) versions of
101+ [] ->
102+ D.failure ()
88
103
89− toKnownVersions versions =
104+ v:vs ->
90− case List.sortBy (flip compare) versions of
91− v:vs -> return (KnownVersions v vs)
105+ checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
106+
107+ Left _ ->
92− [] -> D.failure ()
108+ D.failure ()
93− in
94− D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
95
109
96
110
97
111
@@ -130,26 +144,22 @@ addNew (name, version) versions =
130 Map.alter (Just . add) name versions
144 Map.alter (Just . add) name versions
131
145
132
146
133−
134−-- NEW PACKAGE DECODER
135−
136−
137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
147newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
138newPkgDecoder =
148newPkgDecoder =
139− D.customString newPkgParser bail
149+ do str <- D.string
140−
150+ case Utf8.split 0x40 {-@-} str of
151+ [key, value] ->
152+ case Pkg.fromString key of
153+ Right pkg ->
154+ case V.fromString value of
155+ Just vsn -> return (pkg, vsn)
156+ Nothing -> D.failure ()
141
157
142−newPkgParser :: P.Parser () (Pkg.Name, V.Version)
158+ Left _ ->
143−newPkgParser =
159+ D.failure ()
144− do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
145− P.word1 0x40 {-@-} bail
146− vsn <- P.specialize (\_ _ _ -> ()) V.parser
147− return (pkg, vsn)
148
160
149−
161+ _ ->
150−bail :: row -> col -> ()
162+ D.failure ()
151−bail _ _ =
152− ()
153
163
154
164
155
165
@@ -180,7 +190,33 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
180getVersions' name (Registry _ versions) =
190getVersions' name (Registry _ versions) =
181 case Map.lookup name versions of
191 case Map.lookup name versions of
182 Just kvs -> Right kvs
192 Just kvs -> Right kvs
183− Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
193+ Nothing -> Left $ nearbyNames name (Map.keys versions)
194+
195+
196+nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197+nearbyNames (Pkg.Name author1 project1) possibleNames =
198+ let
199+ authorDist = authorDistance (Name.toChars author1)
200+ projectDist = projectDistance (Name.toChars project1)
201+
202+ addDistance name@(Pkg.Name author2 project2) =
203+ ( authorDist author2 + projectDist project2, name )
204+ in
205+ map snd $ take 4 $
206+ List.sortBy (compare `on` fst) $
207+ map addDistance possibleNames
208+
209+
210+authorDistance :: String -> Name.Name -> Int
211+authorDistance bad possibility =
212+ abs (Suggest.distance bad (Name.toChars possibility))
213+
214+
215+projectDistance :: String -> Name.Name -> Int
216+projectDistance bad possibility =
217+ if possibility == "elm" || possibility == "elm-explorations"
218+ then 0
219+ else abs (Suggest.distance bad (Name.toChars possibility))
184
220
185
221
186
222
@@ -189,14 +225,11 @@ getVersions' name (Registry _ versions) =
189
225
190post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
226post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
191post manager path decoder callback =
227post manager path decoder callback =
192− let
193− url = Website.route path []
194− in
195− Http.post manager url [] Exit.RP_Http $
228+ Http.post manager (Website.route path []) [] Exit.RP_Http $
196 \body ->
229 \body ->
197 case D.fromByteString decoder body of
230 case D.fromByteString decoder body of
198 Right a -> Right <$> callback a
231 Right a -> Right <$> callback a
199− Left _ -> return $ Left $ Exit.RP_Data url body
232+ Left _ -> return $ Left Exit.RP_Data
200
233
201
234
202
235
builder/src/Deps/Solver.hs+29−31
@@ -94,7 +94,6 @@ data Details =
94
94
95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96verify cache connection registry constraints =
96verify cache connection registry constraints =
97− Stuff.withRegistryLock cache $
98 case try constraints of
97 case try constraints of
99 Solver solver ->
98 Solver solver ->
100 solver (State cache connection registry Map.empty)
99 solver (State cache connection registry Map.empty)
@@ -131,7 +130,6 @@ data AppSolution =
131
130
132addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
131addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
133addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
132addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134− Stuff.withRegistryLock cache $
135 let
133 let
136 allIndirects = Map.union indirect testIndirect
134 allIndirects = Map.union indirect testIndirect
137 allDirects = Map.union direct testDirect
135 allDirects = Map.union direct testDirect
@@ -313,11 +311,10 @@ getConstraints pkg vsn =
313 back state
311 back state
314
312
315 Online manager ->
313 Online manager ->
316− do let url = Website.metadata pkg vsn "elm.json"
314+ do result <- Http.get manager (Website.metadata pkg vsn "elm.json") [] id (return . Right)
317− result <- Http.get manager url [] id (return . Right)
318 case result of
315 case result of
319 Left httpProblem ->
316 Left httpProblem ->
320− err (Exit.SolverBadHttp pkg vsn httpProblem)
317+ err (Exit.SolverBadHttp httpProblem)
321
318
322 Right body ->
319 Right body ->
323 case D.fromByteString constraintsDecoder body of
320 case D.fromByteString constraintsDecoder body of
@@ -327,9 +324,11 @@ getConstraints pkg vsn =
327 ok (toNewState cs) cs back
324 ok (toNewState cs) cs back
328
325
329 Left _ ->
326 Left _ ->
330− err (Exit.SolverBadHttpData pkg vsn url)
327+ err (Exit.SolverBadHttpData pkg vsn)
331
328
332
329
330+-- TODO write constraintsDecoder to be a bit faster
331+--
333constraintsDecoder :: D.Decoder () Constraints
332constraintsDecoder :: D.Decoder () Constraints
334constraintsDecoder =
333constraintsDecoder =
335 do outline <- D.mapError (const ()) Outline.decoder
334 do outline <- D.mapError (const ()) Outline.decoder
@@ -351,31 +350,30 @@ data Env =
351
350
352initEnv :: IO (Either Exit.RegistryProblem Env)
351initEnv :: IO (Either Exit.RegistryProblem Env)
353initEnv =
352initEnv =
354− do mvar <- newEmptyMVar
353+ do mvar <- newEmptyMVar
355− _ <- forkIO $ putMVar mvar =<< Http.getManager
354+ _ <- forkIO $ putMVar mvar =<< Http.getManager
356− cache <- Stuff.getPackageCache
355+ cache <- Stuff.getPackageCache
357− Stuff.withRegistryLock cache $
358− do maybeRegistry <- Registry.read cache
356+ maybeRegistry <- Registry.read cache
359− manager <- readMVar mvar
357+ manager <- readMVar mvar
360−
358+
361− case maybeRegistry of
359+ case maybeRegistry of
362− Nothing ->
360+ Nothing ->
363− do eitherRegistry <- Registry.fetch manager cache
361+ do eitherRegistry <- Registry.fetch manager cache
364− case eitherRegistry of
362+ case eitherRegistry of
365− Right latestRegistry ->
363+ Right latestRegistry ->
366− return $ Right $ Env cache manager (Online manager) latestRegistry
364+ return $ Right $ Env cache manager (Online manager) latestRegistry
367−
365+
368− Left problem ->
366+ Left problem ->
369− return $ Left $ problem
367+ return $ Left $ problem
370−
368+
371− Just cachedRegistry ->
369+ Just cachedRegistry ->
372− do eitherRegistry <- Registry.update manager cache cachedRegistry
370+ do eitherRegistry <- Registry.update manager cache cachedRegistry
373− case eitherRegistry of
371+ case eitherRegistry of
374− Right latestRegistry ->
372+ Right latestRegistry ->
375− return $ Right $ Env cache manager (Online manager) latestRegistry
373+ return $ Right $ Env cache manager (Online manager) latestRegistry
376−
374+
377− Left _ ->
375+ Left _ ->
378− return $ Right $ Env cache manager Offline cachedRegistry
376+ return $ Right $ Env cache manager Offline cachedRegistry
379
377
380
378
381
379
builder/src/Elm/Bump.hsnew file+137
@@ -0,0 +1,137 @@
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+97−195
@@ -2,7 +2,6 @@
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Elm.Details
3module Elm.Details
4 ( Details(..)
4 ( Details(..)
5− , BuildID
6 , ValidOutline(..)
5 , ValidOutline(..)
7 , Local(..)
6 , Local(..)
8 , Foreign(..)
7 , Foreign(..)
@@ -16,32 +15,25 @@ module Elm.Details
16
15
17import Control.Concurrent (forkIO)
16import Control.Concurrent (forkIO)
18import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
17import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
19−import Control.Monad (liftM, liftM2, liftM3)
18+import Control.Monad (liftM, liftM2, liftM4)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
19import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Either as Either
22import qualified Data.Map as Map
20import qualified Data.Map as Map
23import qualified Data.Map.Utils as Map
21import qualified Data.Map.Utils as Map
24import qualified Data.Map.Merge.Strict as Map
22import qualified Data.Map.Merge.Strict as Map
25−import qualified Data.Maybe as Maybe
26import qualified Data.Name as Name
23import qualified Data.Name as Name
27−import qualified Data.NonEmptyList as NE
28import qualified Data.OneOrMore as OneOrMore
24import qualified Data.OneOrMore as OneOrMore
29import qualified Data.Set as Set
25import qualified Data.Set as Set
30import qualified Data.Utf8 as Utf8
26import qualified Data.Utf8 as Utf8
31−import Data.Word (Word64)
32import qualified System.Directory as Dir
27import qualified System.Directory as Dir
33import System.FilePath ((</>), (<.>))
28import System.FilePath ((</>), (<.>))
34
29
35−import qualified AST.Canonical as Can
36import qualified AST.Source as Src
30import qualified AST.Source as Src
37import qualified AST.Optimized as Opt
31import qualified AST.Optimized as Opt
38−import qualified BackgroundWriter as BW
39import qualified Compile
32import qualified Compile
40import qualified Deps.Registry as Registry
33import qualified Deps.Registry as Registry
41import qualified Deps.Solver as Solver
34import qualified Deps.Solver as Solver
42import qualified Deps.Website as Website
35import qualified Deps.Website as Website
43import qualified Elm.Constraint as Con
36import qualified Elm.Constraint as Con
44−import qualified Elm.Docs as Docs
45import qualified Elm.Interface as I
37import qualified Elm.Interface as I
46import qualified Elm.Kernel as Kernel
38import qualified Elm.Kernel as Kernel
47import qualified Elm.ModuleName as ModuleName
39import qualified Elm.ModuleName as ModuleName
@@ -51,10 +43,8 @@ import qualified Elm.Version as V
51import qualified File
43import qualified File
52import qualified Http
44import qualified Http
53import qualified Json.Decode as D
45import qualified Json.Decode as D
54−import qualified Json.Encode as E
55import qualified Parse.Module as Parse
46import qualified Parse.Module as Parse
56import qualified Reporting
47import qualified Reporting
57−import qualified Reporting.Annotation as A
58import qualified Reporting.Exit as Exit
48import qualified Reporting.Exit as Exit
59import qualified Reporting.Task as Task
49import qualified Reporting.Task as Task
60import qualified Stuff
50import qualified Stuff
@@ -68,42 +58,23 @@ data Details =
68 Details
58 Details
69 { _outlineTime :: File.Time
59 { _outlineTime :: File.Time
70 , _outline :: ValidOutline
60 , _outline :: ValidOutline
71− , _buildID :: BuildID
72 , _locals :: Map.Map ModuleName.Raw Local
61 , _locals :: Map.Map ModuleName.Raw Local
73 , _foreigns :: Map.Map ModuleName.Raw Foreign
62 , _foreigns :: Map.Map ModuleName.Raw Foreign
74 , _extras :: Extras
63 , _extras :: Extras
75 }
64 }
76
65
77
66
78−type BuildID = Word64
67+data ValidOutline
68+ = ValidApp Outline.AppOutline
69+ | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)
79
70
80
71
81−data ValidOutline
82− = ValidApp (NE.List Outline.SrcDir)
83− | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
84−
85−
86−-- NOTE: we need two ways to detect if a file must be recompiled:
87−--
88−-- (1) _time is the modification time from the last time we compiled the file.
89−-- By checking EQUALITY with the current modification time, we can detect file
90−-- saves and `git checkout` of previous versions. Both need a recompile.
91−--
92−-- (2) _lastChange is the BuildID from the last time a new interface file was
93−-- generated, and _lastCompile is the BuildID from the last time the file was
94−-- compiled. These may be different if a file is recompiled but the interface
95−-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
96−-- imports, we need to recompile. This can happen when a project has multiple
97−-- entrypoints and some modules are compiled less often than their imports.
98−--
99data Local =
72data Local =
100 Local
73 Local
101 { _path :: FilePath
74 { _path :: FilePath
102 , _time :: File.Time
75 , _time :: File.Time
103 , _deps :: [ModuleName.Raw]
76 , _deps :: [ModuleName.Raw]
104 , _main :: Bool
77 , _main :: Bool
105− , _lastChange :: BuildID
106− , _lastCompile :: BuildID
107 }
78 }
108
79
109
80
@@ -125,14 +96,14 @@ type Interfaces =
125
96
126
97
127loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
98loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
128−loadObjects root (Details _ _ _ _ _ extras) =
99+loadObjects root (Details _ _ _ _ extras) =
129 case extras of
100 case extras of
130 ArtifactsFresh _ o -> newMVar (Just o)
101 ArtifactsFresh _ o -> newMVar (Just o)
131 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
102 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
132
103
133
104
134loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
105loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
135−loadInterfaces root (Details _ _ _ _ _ extras) =
106+loadInterfaces root (Details _ _ _ _ extras) =
136 case extras of
107 case extras of
137 ArtifactsFresh i _ -> newMVar (Just i)
108 ArtifactsFresh i _ -> newMVar (Just i)
138 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
109 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
@@ -142,11 +113,11 @@ loadInterfaces root (Details _ _ _ _ _ extras) =
142-- VERIFY INSTALL -- used by Install
113-- VERIFY INSTALL -- used by Install
143
114
144
115
145−verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
116+verifyInstall :: FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
146−verifyInstall scope root (Solver.Env cache manager connection registry) outline =
117+verifyInstall root (Solver.Env cache manager connection registry) outline =
147 do time <- File.getTime (root </> "elm.json")
118 do time <- File.getTime (root </> "elm.json")
148 let key = Reporting.ignorer
119 let key = Reporting.ignorer
149− let env = Env key scope root cache manager connection registry
120+ let env = Env key root cache manager connection registry
150 case outline of
121 case outline of
151 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
122 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
152 Outline.App app -> Task.run (verifyApp env time app >> return ())
123 Outline.App app -> Task.run (verifyApp env time app >> return ())
@@ -156,28 +127,28 @@ verifyInstall scope root (Solver.Env cache manager connection registry) outline
156-- LOAD -- used by Make, Repl, Reactor
127-- LOAD -- used by Make, Repl, Reactor
157
128
158
129
159−load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
130+load :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)
160−load style scope root =
131+load style root =
161 do newTime <- File.getTime (root </> "elm.json")
132 do newTime <- File.getTime (root </> "elm.json")
162 maybeDetails <- File.readBinary (Stuff.details root)
133 maybeDetails <- File.readBinary (Stuff.details root)
163 case maybeDetails of
134 case maybeDetails of
164 Nothing ->
135 Nothing ->
165− generate style scope root newTime
136+ generate style root newTime
166
137
167− Just details@(Details oldTime _ buildID _ _ _) ->
138+ Just details@(Details oldTime _ _ _ _) ->
168 if oldTime == newTime
139 if oldTime == newTime
169− then return (Right details { _buildID = buildID + 1 })
140+ then return (Right details)
170− else generate style scope root newTime
141+ else generate style root newTime
171
142
172
143
173
144
174-- GENERATE
145-- GENERATE
175
146
176
147
177−generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
148+generate :: Reporting.Style -> FilePath -> File.Time -> IO (Either Exit.Details Details)
178−generate style scope root time =
149+generate style root time =
179 Reporting.trackDetails style $ \key ->
150 Reporting.trackDetails style $ \key ->
180− do result <- initEnv key scope root
151+ do result <- initEnv key root
181 case result of
152 case result of
182 Left exit ->
153 Left exit ->
183 return (Left exit)
154 return (Left exit)
@@ -195,7 +166,6 @@ generate style scope root time =
195data Env =
166data Env =
196 Env
167 Env
197 { _key :: Reporting.DKey
168 { _key :: Reporting.DKey
198− , _scope :: BW.Scope
199 , _root :: FilePath
169 , _root :: FilePath
200 , _cache :: Stuff.PackageCache
170 , _cache :: Stuff.PackageCache
201 , _manager :: Http.Manager
171 , _manager :: Http.Manager
@@ -204,8 +174,8 @@ data Env =
204 }
174 }
205
175
206
176
207−initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
177+initEnv :: Reporting.DKey -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
208−initEnv key scope root =
178+initEnv key root =
209 do mvar <- fork Solver.initEnv
179 do mvar <- fork Solver.initEnv
210 eitherOutline <- Outline.read root
180 eitherOutline <- Outline.read root
211 case eitherOutline of
181 case eitherOutline of
@@ -219,7 +189,7 @@ initEnv key scope root =
219 return $ Left $ Exit.DetailsCannotGetRegistry problem
189 return $ Left $ Exit.DetailsCannotGetRegistry problem
220
190
221 Right (Solver.Env cache manager connection registry) ->
191 Right (Solver.Env cache manager connection registry) ->
222− return $ Right (Env key scope root cache manager connection registry, outline)
192+ return $ Right (Env key root cache manager connection registry, outline)
223
193
224
194
225
195
@@ -230,25 +200,24 @@ type Task a = Task.Task Exit.Details a
230
200
231
201
232verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
202verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
233−verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
203+verifyPkg env time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
234 if Con.goodElm elm
204 if Con.goodElm elm
235 then
205 then
236 do solution <- verifyConstraints env =<< union noDups direct testDirect
206 do solution <- verifyConstraints env =<< union noDups direct testDirect
237− let exposedList = Outline.flattenExposed exposed
238− let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
207+ let vsns = Map.map (\(Solver.Details v _) -> v) solution
239− verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
208+ verifyDependencies env time (ValidPkg outline vsns) solution direct
240 else
209 else
241 Task.throw $ Exit.DetailsBadElmInPkg elm
210 Task.throw $ Exit.DetailsBadElmInPkg elm
242
211
243
212
244verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
213verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
245−verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
214+verifyApp env time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
246 if elmVersion == V.compiler
215 if elmVersion == V.compiler
247 then
216 then
248 do stated <- checkAppDeps outline
217 do stated <- checkAppDeps outline
249 actual <- verifyConstraints env (Map.map Con.exactly stated)
218 actual <- verifyConstraints env (Map.map Con.exactly stated)
250 if Map.size stated == Map.size actual
219 if Map.size stated == Map.size actual
251− then verifyDependencies env time (ValidApp srcDirs) actual direct
220+ then verifyDependencies env time (ValidApp outline) actual direct
252 else Task.throw $ Exit.DetailsHandEditedDependencies
221 else Task.throw $ Exit.DetailsHandEditedDependencies
253 else
222 else
254 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
223 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
@@ -266,7 +235,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
266
235
267
236
268verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
237verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
269−verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
238+verifyConstraints (Env _ _ cache _ connection registry) constraints =
270 do result <- Task.io $ Solver.verify cache connection registry constraints
239 do result <- Task.io $ Solver.verify cache connection registry constraints
271 case result of
240 case result of
272 Solver.Ok details -> return details
241 Solver.Ok details -> return details
@@ -312,30 +281,27 @@ fork work =
312
281
313
282
314verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
283verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
315−verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
284+verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =
316 Task.eio id $
285 Task.eio id $
317 do Reporting.report key (Reporting.DStart (Map.size solution))
286 do Reporting.report key (Reporting.DStart (Map.size solution))
318 mvar <- newEmptyMVar
287 mvar <- newEmptyMVar
319− mvars <- Stuff.withRegistryLock cache $
320− Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
288+ mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
321 putMVar mvar mvars
289 putMVar mvar mvars
322 deps <- traverse readMVar mvars
290 deps <- traverse readMVar mvars
323 case sequence deps of
291 case sequence deps of
324− Left _ ->
292+ Left problem ->
325− do home <- Stuff.getElmHome
293+ error "TODO verifyDependencies" problem
326− return $ Left $ Exit.DetailsBadDeps home $
327− Maybe.catMaybes $ Either.lefts $ Map.elems deps
328
294
329 Right artifacts ->
295 Right artifacts ->
330 let
296 let
331 objs = Map.foldr addObjects Opt.empty artifacts
297 objs = Map.foldr addObjects Opt.empty artifacts
332 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
298 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
333− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
299+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
334− details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
300+ details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)
335 in
301 in
336− do BW.writeBinary scope (Stuff.objects root) objs
302+ do File.writeBinary (Stuff.objects root) objs
337− BW.writeBinary scope (Stuff.interfaces root) ifaces
303+ File.writeBinary (Stuff.interfaces root) ifaces
338− BW.writeBinary scope (Stuff.details root) details
304+ File.writeBinary (Stuff.details root) details
339 return (Right details)
305 return (Right details)
340
306
341
307
@@ -375,36 +341,44 @@ data Artifacts =
375
341
376
342
377type Dep =
343type Dep =
378− Either (Maybe Exit.DetailsBadDep) Artifacts
344+ Either Problem Artifacts
345+
346+
347+data Problem
348+ = BadDownload Exit.PackageProblem
349+ | BadBuild
350+ | BadDependency
379
351
380
352
381verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
353verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
382−verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
354+verifyDep (Env key _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
355+ let
383− do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
356+ fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
357+ in
384− exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
358+ do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
385 if exists
359 if exists
386 then
360 then
387 do Reporting.report key Reporting.DCached
361 do Reporting.report key Reporting.DCached
388 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
362 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
389 case maybeCache of
363 case maybeCache of
390 Nothing ->
364 Nothing ->
391− build key cache depsMVar pkg details fingerprint Set.empty
365+ build key cache depsMVar pkg details (Set.singleton fingerprint)
392
366
393 Just (ArtifactCache fingerprints artifacts) ->
367 Just (ArtifactCache fingerprints artifacts) ->
394 if Set.member fingerprint fingerprints
368 if Set.member fingerprint fingerprints
395 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
369 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
396− else build key cache depsMVar pkg details fingerprint fingerprints
370+ else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)
397 else
371 else
398 do Reporting.report key Reporting.DRequested
372 do Reporting.report key Reporting.DRequested
399 result <- downloadPackage cache manager pkg vsn
373 result <- downloadPackage cache manager pkg vsn
400 case result of
374 case result of
401− Left problem ->
375+ Left p ->
402 do Reporting.report key (Reporting.DFailed pkg vsn)
376 do Reporting.report key (Reporting.DFailed pkg vsn)
403− return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
377+ return (Left (BadDownload p))
404
378
405 Right () ->
379 Right () ->
406 do Reporting.report key (Reporting.DReceived pkg vsn)
380 do Reporting.report key (Reporting.DReceived pkg vsn)
407− build key cache depsMVar pkg details fingerprint Set.empty
381+ build key cache depsMVar pkg details (Set.singleton fingerprint)
408
382
409
383
410
384
@@ -426,17 +400,17 @@ type Fingerprint =
426-- BUILD
400-- BUILD
427
401
428
402
429−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
403+build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Dep
430−build key cache depsMVar pkg (Solver.Details vsn _) f fs =
404+build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
431 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
405 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
432 case eitherOutline of
406 case eitherOutline of
433 Left _ ->
407 Left _ ->
434 do Reporting.report key Reporting.DBroken
408 do Reporting.report key Reporting.DBroken
435− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
409+ return (Left BadBuild)
436
410
437 Right (Outline.App _) ->
411 Right (Outline.App _) ->
438 do Reporting.report key Reporting.DBroken
412 do Reporting.report key Reporting.DBroken
439− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
413+ return (Left BadBuild)
440
414
441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
415 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
442 do allDeps <- readMVar depsMVar
416 do allDeps <- readMVar depsMVar
@@ -444,22 +418,21 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
444 case sequence directDeps of
418 case sequence directDeps of
445 Left _ ->
419 Left _ ->
446 do Reporting.report key Reporting.DBroken
420 do Reporting.report key Reporting.DBroken
447− return $ Left $ Nothing
421+ return (Left BadDependency)
448
422
449 Right directArtifacts ->
423 Right directArtifacts ->
450 do let src = Stuff.package cache pkg vsn </> "src"
424 do let src = Stuff.package cache pkg vsn </> "src"
451 let foreignDeps = gatherForeignInterfaces directArtifacts
425 let foreignDeps = gatherForeignInterfaces directArtifacts
452 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
426 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
453− docsStatus <- getDocsStatus cache pkg vsn
454 mvar <- newEmptyMVar
427 mvar <- newEmptyMVar
455− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
428+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) exposedDict
456 putMVar mvar mvars
429 putMVar mvar mvars
457 mapM_ readMVar mvars
430 mapM_ readMVar mvars
458 maybeStatuses <- traverse readMVar =<< readMVar mvar
431 maybeStatuses <- traverse readMVar =<< readMVar mvar
459 case sequence maybeStatuses of
432 case sequence maybeStatuses of
460 Nothing ->
433 Nothing ->
461 do Reporting.report key Reporting.DBroken
434 do Reporting.report key Reporting.DBroken
462− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
435+ return (Left BadBuild)
463
436
464 Just statuses ->
437 Just statuses ->
465 do rmvar <- newEmptyMVar
438 do rmvar <- newEmptyMVar
@@ -469,7 +442,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
469 case sequence maybeResults of
442 case sequence maybeResults of
470 Nothing ->
443 Nothing ->
471 do Reporting.report key Reporting.DBroken
444 do Reporting.report key Reporting.DBroken
472− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
445+ return (Left BadBuild)
473
446
474 Just results ->
447 Just results ->
475 let
448 let
@@ -477,10 +450,8 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
477 ifaces = gatherInterfaces exposedDict results
450 ifaces = gatherInterfaces exposedDict results
478 objects = gatherObjects results
451 objects = gatherObjects results
479 artifacts = Artifacts ifaces objects
452 artifacts = Artifacts ifaces objects
480− fingerprints = Set.insert f fs
481 in
453 in
482− do writeDocs cache pkg vsn docsStatus results
483− File.writeBinary path (ArtifactCache fingerprints artifacts)
454+ do File.writeBinary path (ArtifactCache fingerprints artifacts)
484 Reporting.report key Reporting.DBuilt
455 Reporting.report key Reporting.DBuilt
485 return (Right artifacts)
456 return (Right artifacts)
486
457
@@ -497,7 +468,7 @@ gatherObjects results =
497addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
468addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
498addLocalGraph name status graph =
469addLocalGraph name status graph =
499 case status of
470 case status of
500− RLocal _ objs _ -> Opt.addLocalGraph objs graph
471+ RLocal _ objs -> Opt.addLocalGraph objs graph
501 RForeign _ -> graph
472 RForeign _ -> graph
502 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
473 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
503 RKernelForeign -> graph
474 RKernelForeign -> graph
@@ -516,10 +487,10 @@ gatherInterfaces exposed artifacts =
516toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
487toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
517toLocalInterface func result =
488toLocalInterface func result =
518 case result of
489 case result of
519− RLocal iface _ _ -> Just (func iface)
490+ RLocal iface _ -> Just (func iface)
520− RForeign _ -> Nothing
491+ RForeign _ -> Nothing
521− RKernelLocal _ -> Nothing
492+ RKernelLocal _ -> Nothing
522− RKernelForeign -> Nothing
493+ RKernelForeign -> Nothing
523
494
524
495
525
496
@@ -562,14 +533,14 @@ type StatusDict =
562
533
563
534
564data Status
535data Status
565− = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
536+ = SLocal (Map.Map ModuleName.Raw ()) Src.Module
566 | SForeign I.Interface
537 | SForeign I.Interface
567 | SKernelLocal [Kernel.Chunk]
538 | SKernelLocal [Kernel.Chunk]
568 | SKernelForeign
539 | SKernelForeign
569
540
570
541
571−crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)
542+crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
572−crawlModule foreignDeps mvar pkg src docsStatus name =
543+crawlModule foreignDeps mvar pkg src name =
573 do let path = src </> ModuleName.toFilePath name <.> "elm"
544 do let path = src </> ModuleName.toFilePath name <.> "elm"
574 exists <- File.exists path
545 exists <- File.exists path
575 case Map.lookup name foreignDeps of
546 case Map.lookup name foreignDeps of
@@ -583,7 +554,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name =
583
554
584 Nothing ->
555 Nothing ->
585 if exists then
556 if exists then
586− crawlFile foreignDeps mvar pkg src docsStatus name path
557+ crawlFile foreignDeps mvar pkg src name path
587
558
588 else if Pkg.isKernel pkg && Name.isKernel name then
559 else if Pkg.isKernel pkg && Name.isKernel name then
589 crawlKernel foreignDeps mvar pkg src name
560 crawlKernel foreignDeps mvar pkg src name
@@ -592,13 +563,13 @@ crawlModule foreignDeps mvar pkg src docsStatus name =
592 return Nothing
563 return Nothing
593
564
594
565
595−crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
566+crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
596−crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
567+crawlFile foreignDeps mvar pkg src name path =
597 do bytes <- File.readUtf8 path
568 do bytes <- File.readUtf8 path
598− case Parse.fromByteString (Parse.Package pkg) bytes of
569+ case Parse.fromByteString pkg bytes of
599− Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
570+ Right modul@(Src.Module (Just actualName) _ imports _ _ _ _ _) | name == actualName ->
600 do deps <- crawlImports foreignDeps mvar pkg src imports
571 do deps <- crawlImports foreignDeps mvar pkg src imports
601− return (Just (SLocal docsStatus deps modul))
572+ return (Just (SLocal deps modul))
602
573
603 _ ->
574 _ ->
604 return Nothing
575 return Nothing
@@ -609,7 +580,7 @@ crawlImports foreignDeps mvar pkg src imports =
609 do statusDict <- takeMVar mvar
580 do statusDict <- takeMVar mvar
610 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
581 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
611 let news = Map.difference deps statusDict
582 let news = Map.difference deps statusDict
612− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
583+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) news
613 putMVar mvar (Map.union mvars statusDict)
584 putMVar mvar (Map.union mvars statusDict)
614 mapM_ readMVar mvars
585 mapM_ readMVar mvars
615 return deps
586 return deps
@@ -645,7 +616,7 @@ getDepHome fi =
645
616
646
617
647data Result
618data Result
648− = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)
619+ = RLocal !I.Interface !Opt.LocalGraph
649 | RForeign I.Interface
620 | RForeign I.Interface
650 | RKernelLocal [Kernel.Chunk]
621 | RKernelLocal [Kernel.Chunk]
651 | RKernelForeign
622 | RKernelForeign
@@ -654,7 +625,7 @@ data Result
654compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
625compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
655compile pkg mvar status =
626compile pkg mvar status =
656 case status of
627 case status of
657− SLocal docsStatus deps modul ->
628+ SLocal deps modul ->
658 do resultsDict <- readMVar mvar
629 do resultsDict <- readMVar mvar
659 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
630 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
660 case sequence maybeResults of
631 case sequence maybeResults of
@@ -667,11 +638,7 @@ compile pkg mvar status =
667 return Nothing
638 return Nothing
668
639
669 Right (Compile.Artifacts canonical annotations objects) ->
640 Right (Compile.Artifacts canonical annotations objects) ->
670− let
671− ifaces = I.fromModule pkg canonical annotations
641+ return (Just (RLocal (I.fromModule pkg canonical annotations) objects))
672− docs = makeDocs docsStatus canonical
673− in
674− return (Just (RLocal ifaces objects docs))
675
642
676 SForeign iface ->
643 SForeign iface ->
677 return (Just (RForeign iface))
644 return (Just (RForeign iface))
@@ -686,59 +653,10 @@ compile pkg mvar status =
686getInterface :: Result -> Maybe I.Interface
653getInterface :: Result -> Maybe I.Interface
687getInterface result =
654getInterface result =
688 case result of
655 case result of
689− RLocal iface _ _ -> Just iface
656+ RLocal iface _ -> Just iface
690− RForeign iface -> Just iface
657+ RForeign iface -> Just iface
691− RKernelLocal _ -> Nothing
658+ RKernelLocal _ -> Nothing
692− RKernelForeign -> Nothing
659+ 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
742
660
743
661
744
662
@@ -747,27 +665,24 @@ toDocs result =
747
665
748downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
666downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
749downloadPackage cache manager pkg vsn =
667downloadPackage cache manager pkg vsn =
750− let
751− url = Website.metadata pkg vsn "endpoint.json"
752− in
753 do eitherByteString <-
668 do eitherByteString <-
754− Http.get manager url [] id (return . Right)
669+ Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)
755
670
756 case eitherByteString of
671 case eitherByteString of
757 Left err ->
672 Left err ->
758− return $ Left $ Exit.PP_BadEndpointRequest err
673+ return (Left (Exit.PP_BadEndpointRequest err))
759
674
760 Right byteString ->
675 Right byteString ->
761 case D.fromByteString endpointDecoder byteString of
676 case D.fromByteString endpointDecoder byteString of
762 Left _ ->
677 Left _ ->
763− return $ Left $ Exit.PP_BadEndpointContent url
678+ return (Left Exit.PP_BadEndpointContent)
764
679
765 Right (endpoint, expectedHash) ->
680 Right (endpoint, expectedHash) ->
766− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
681+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
767 \(sha, archive) ->
682 \(sha, archive) ->
768 if expectedHash == Http.shaToChars sha
683 if expectedHash == Http.shaToChars sha
769 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
684 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
770− else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
685+ else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
771
686
772
687
773endpointDecoder :: D.Decoder e (String, String)
688endpointDecoder :: D.Decoder e (String, String)
@@ -782,40 +697,27 @@ endpointDecoder =
782
697
783
698
784instance Binary Details where
699instance Binary Details where
785− put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
786− get =
787− do a <- get
788− b <- get
789− c <- get
790− d <- get
791− e <- get
792− return (Details a b c d e ArtifactsCached)
700+ get = do { a <- get; b <- get; c <- get; d <- get; return (Details a b c d ArtifactsCached) }
701+ put (Details a b c d _) = put a >> put b >> put c >> put d
793
702
794
703
795instance Binary ValidOutline where
704instance Binary ValidOutline where
796 put outline =
705 put outline =
797 case outline of
706 case outline of
798− ValidApp a -> putWord8 0 >> put a
707+ ValidApp a -> putWord8 0 >> put a
799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
708+ ValidPkg a b -> putWord8 1 >> put a >> put b
800
709
801 get =
710 get =
802 do n <- getWord8
711 do n <- getWord8
803 case n of
712 case n of
804 0 -> liftM ValidApp get
713 0 -> liftM ValidApp get
805− 1 -> liftM3 ValidPkg get get get
714+ 1 -> liftM2 ValidPkg get get
806− _ -> fail "binary encoding of ValidOutline was corrupted"
715+ _ -> error "binary encoding of ValidOutline was corrupted"
807
716
808
717
809instance Binary Local where
718instance Binary Local where
719+ get = liftM4 Local get get get get
810− put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
720+ put (Local a b c d) = put a >> put b >> put c >> put d
811− get =
812− do a <- get
813− b <- get
814− c <- get
815− d <- get
816− e <- get
817− f <- get
818− return (Local a b c d e f)
819
721
820
722
821instance Binary Foreign where
723instance Binary Foreign where
builder/src/Elm/Diff.hsnew file+284
@@ -0,0 +1,284 @@
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+115−148
@@ -1,11 +1,10 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
2+{-# LANGUAGE 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(..)
9 , read
8 , read
10 , write
9 , write
11 , encode
10 , encode
@@ -19,12 +18,10 @@ module Elm.Outline
19import Prelude hiding (read)
18import Prelude hiding (read)
20import Control.Monad (filterM, liftM)
19import Control.Monad (filterM, liftM)
21import Data.Binary (Binary, get, put, getWord8, putWord8)
20import 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.NonEmptyList as NE
23+import qualified Data.Utf8 as Utf8
24−import qualified Data.OneOrMore as OneOrMore
25−import Foreign.Ptr (minusPtr)
26import qualified System.Directory as Dir
24import qualified System.Directory as Dir
27−import qualified System.FilePath as FP
28import System.FilePath ((</>))
25import System.FilePath ((</>))
29
26
30import qualified Elm.Constraint as Con
27import qualified Elm.Constraint as Con
@@ -35,9 +32,6 @@ import qualified Elm.Version as V
35import qualified File
32import qualified File
36import qualified Json.Decode as D
33import qualified Json.Decode as D
37import qualified Json.Encode as E
34import qualified Json.Encode as E
38−import Json.Encode ((==>))
39−import qualified Json.String as Json
40−import qualified Parse.Primitives as P
41import qualified Reporting.Exit as Exit
35import qualified Reporting.Exit as Exit
42
36
43
37
@@ -53,7 +47,7 @@ data Outline
53data AppOutline =
47data AppOutline =
54 AppOutline
48 AppOutline
55 { _app_elm_version :: V.Version
49 { _app_elm_version :: V.Version
56− , _app_source_dirs :: NE.List SrcDir
50+ , _app_source_dirs :: [FilePath]
57 , _app_deps_direct :: Map.Map Pkg.Name V.Version
51 , _app_deps_direct :: Map.Map Pkg.Name V.Version
58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
52 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
59 , _app_test_direct :: Map.Map Pkg.Name V.Version
53 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -64,7 +58,7 @@ data AppOutline =
64data PkgOutline =
58data PkgOutline =
65 PkgOutline
59 PkgOutline
66 { _pkg_name :: Pkg.Name
60 { _pkg_name :: Pkg.Name
67− , _pkg_summary :: Json.String
61+ , _pkg_summary :: Utf8.String
68 , _pkg_license :: Licenses.License
62 , _pkg_license :: Licenses.License
69 , _pkg_version :: V.Version
63 , _pkg_version :: V.Version
70 , _pkg_exposed :: Exposed
64 , _pkg_exposed :: Exposed
@@ -76,21 +70,16 @@ data PkgOutline =
76
70
77data Exposed
71data Exposed
78 = ExposedList [ModuleName.Raw]
72 = ExposedList [ModuleName.Raw]
79− | ExposedDict [(Json.String, [ModuleName.Raw])]
73+ | ExposedDict [(Utf8.String, [ModuleName.Raw])]
80−
81−
82−data SrcDir
83− = AbsoluteSrcDir FilePath
84− | RelativeSrcDir FilePath
85
74
86
75
87
76
88-- DEFAULTS
77-- DEFAULTS
89
78
90
79
91−defaultSummary :: Json.String
80+defaultSummary :: Utf8.String
92defaultSummary =
81defaultSummary =
93− Json.fromChars "helpful summary of your project, less than 80 characters"
82+ "helpful summary of your project, less than 80 characters"
94
83
95
84
96
85
@@ -125,8 +114,8 @@ encode outline =
125 case outline of
114 case outline of
126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
115 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
127 E.object
116 E.object
128− [ "type" ==> E.chars "application"
117+ [ "type" ==> E.string "application"
129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
118+ , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs
130 , "elm-version" ==> V.encode elm
119 , "elm-version" ==> V.encode elm
131 , "dependencies" ==>
120 , "dependencies" ==>
132 E.object
121 E.object
@@ -142,7 +131,7 @@ encode outline =
142
131
143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
132 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
144 E.object
133 E.object
145− [ "type" ==> E.string (Json.fromChars "package")
134+ [ "type" ==> E.string "package"
146 , "name" ==> Pkg.encode name
135 , "name" ==> Pkg.encode name
147 , "summary" ==> E.string summary
136 , "summary" ==> E.string summary
148 , "license" ==> Licenses.encode license
137 , "license" ==> Licenses.encode license
@@ -154,6 +143,11 @@ encode outline =
154 ]
143 ]
155
144
156
145
146+(==>) :: a -> b -> (a, b)
147+(==>) a b =
148+ (a, b)
149+
150+
157encodeExposed :: Exposed -> E.Value
151encodeExposed :: Exposed -> E.Value
158encodeExposed exposed =
152encodeExposed exposed =
159 case exposed of
153 case exposed of
@@ -171,14 +165,7 @@ encodeModule name =
171
165
172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
166encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
173encodeDeps encodeValue deps =
167encodeDeps encodeValue deps =
174− E.dict Pkg.toJsonString encodeValue deps
168+ E.dict Pkg.toString 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
182
169
183
170
184
171
@@ -194,72 +181,19 @@ read root =
194
181
195 Right outline ->
182 Right outline ->
196 case outline of
183 case outline of
197− Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
184+ Pkg _ ->
198− return $
199− if Map.notMember Pkg.core deps && pkg /= Pkg.core
200− then Left Exit.OutlineNoPkgCore
201− else Right outline
185+ return $ Right outline
202−
203− App (AppOutline _ srcDirs direct indirect _ _)
204− | Map.notMember Pkg.core direct ->
205− return $ Left Exit.OutlineNoAppCore
206−
207− | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
208− return $ Left Exit.OutlineNoAppJson
209−
210− | otherwise ->
211− do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
212− case map toGiven badDirs of
213− d:ds ->
214− return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
215−
216− [] ->
217− do maybeDups <- detectDuplicates root (NE.toList srcDirs)
218− case maybeDups of
219− Nothing ->
220− return $ Right outline
221−
222− Just (canonicalDir, (dir1,dir2)) ->
223− return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
224−
225−
226−isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227−isSrcDirMissing root srcDir =
228− not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
229−
230−
231−toGiven :: SrcDir -> FilePath
232−toGiven srcDir =
233− case srcDir of
234− AbsoluteSrcDir dir -> dir
235− RelativeSrcDir dir -> dir
236−
237−
238−toAbsolute :: FilePath -> SrcDir -> FilePath
239−toAbsolute root srcDir =
240− case srcDir of
241− AbsoluteSrcDir dir -> dir
242− RelativeSrcDir dir -> root </> dir
243−
244−
245−detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
246−detectDuplicates root srcDirs =
247− do pairs <- traverse (toPair root) srcDirs
248− return $ Map.lookupMin $ Map.mapMaybe isDup $
249− Map.fromListWith OneOrMore.more pairs
250−
251
186
252−toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
187+ App (AppOutline _ srcDirs _ _ _ _) ->
253−toPair root srcDir =
188+ do badDirs <- filterM (isBadSrcDir root) srcDirs
254− do key <- Dir.canonicalizePath (toAbsolute root srcDir)
189+ case badDirs of
255− return (key, OneOrMore.one (toGiven srcDir))
190+ [] -> return $ Right outline
191+ d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)
256
192
257
193
258−isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
194+isBadSrcDir :: FilePath -> FilePath -> IO Bool
259−isDup paths =
195+isBadSrcDir root dir =
260− case paths of
196+ not <$> Dir.doesDirectoryExist (root </> dir)
261− OneOrMore.One _ -> Nothing
262− OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
263
197
264
198
265
199
@@ -272,21 +206,23 @@ type Decoder a =
272
206
273decoder :: Decoder Outline
207decoder :: Decoder Outline
274decoder =
208decoder =
275− let
276− application = Json.fromChars "application"
277− package = Json.fromChars "package"
278− in
279 do tipe <- D.field "type" D.string
209 do tipe <- D.field "type" D.string
210+ case tipe of
211+ "application" ->
280− if | tipe == application -> App <$> appDecoder
212+ App <$> appDecoder
213+
214+ "package" ->
281− | tipe == package -> Pkg <$> pkgDecoder
215+ Pkg <$> pkgDecoder
216+
217+ other ->
282− | otherwise -> D.failure Exit.OP_BadType
218+ D.failure (Exit.OP_BadType other)
283
219
284
220
285appDecoder :: Decoder AppOutline
221appDecoder :: Decoder AppOutline
286appDecoder =
222appDecoder =
287 AppOutline
223 AppOutline
288 <$> D.field "elm-version" versionDecoder
224 <$> D.field "elm-version" versionDecoder
289− <*> D.field "source-directories" dirsDecoder
225+ <*> D.field "source-directories" (D.list dirDecoder)
290 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
226 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
291 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
227 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
292 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
228 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
@@ -296,7 +232,7 @@ appDecoder =
296pkgDecoder :: Decoder PkgOutline
232pkgDecoder :: Decoder PkgOutline
297pkgDecoder =
233pkgDecoder =
298 PkgOutline
234 PkgOutline
299− <$> D.field "name" nameDecoder
235+ <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)
300 <*> D.field "summary" summaryDecoder
236 <*> D.field "summary" summaryDecoder
301 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
237 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
302 <*> D.field "version" versionDecoder
238 <*> D.field "version" versionDecoder
@@ -310,21 +246,17 @@ pkgDecoder =
310-- JSON DECODE HELPERS
246-- JSON DECODE HELPERS
311
247
312
248
313−nameDecoder :: Decoder Pkg.Name
314−nameDecoder =
315− D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316−
317−
318−summaryDecoder :: Decoder Json.String
249+summaryDecoder :: Decoder Utf8.String
319summaryDecoder =
250summaryDecoder =
320− D.customString
251+ do summary <- D.string
321− (boundParser 80 Exit.OP_BadSummaryTooLong)
252+ if Utf8.size summary < 80
253+ then return summary
322− (\_ _ -> Exit.OP_BadSummaryTooLong)
254+ else D.failure Exit.OP_BadSummaryTooLong
323
255
324
256
325versionDecoder :: Decoder V.Version
257versionDecoder :: Decoder V.Version
326versionDecoder =
258versionDecoder =
327− D.mapError (uncurry Exit.OP_BadVersion) V.decoder
259+ D.mapError Exit.OP_BadVersion V.decoder
328
260
329
261
330constraintDecoder :: Decoder Con.Constraint
262constraintDecoder :: Decoder Con.Constraint
@@ -334,19 +266,24 @@ constraintDecoder =
334
266
335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
267depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
336depsDecoder valueDecoder =
268depsDecoder valueDecoder =
337− D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
269+ Map.fromList <$> (
270+ traverse validateKey =<< D.pairs valueDecoder
271+ )
338
272
339
273
340−dirsDecoder :: Decoder (NE.List SrcDir)
274+validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
341−dirsDecoder =
275+validateKey (key, value) =
342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
276+ case Pkg.fromString key of
277+ Right name ->
278+ return (name, value)
343
279
280+ Left _ ->
281+ D.failure (Exit.OP_BadDependencyName key)
344
282
345−toSrcDir :: FilePath -> SrcDir
283+
346−toSrcDir path =
284+dirDecoder :: Decoder FilePath
347− if FP.isRelative path
285+dirDecoder =
348− then RelativeSrcDir path
286+ Utf8.toChars <$> D.string
349− else AbsoluteSrcDir path
350
287
351
288
352
289
@@ -357,51 +294,81 @@ exposedDecoder :: Decoder Exposed
357exposedDecoder =
294exposedDecoder =
358 D.oneOf
295 D.oneOf
359 [ ExposedList <$> D.list moduleDecoder
296 [ ExposedList <$> D.list moduleDecoder
360− , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
297+ , do pairs <- D.pairs (D.list moduleDecoder)
298+ traverse_ (checkHeader . fst) pairs
299+ return (ExposedDict pairs)
361 ]
300 ]
362
301
363
302
364moduleDecoder :: Decoder ModuleName.Raw
303moduleDecoder :: Decoder ModuleName.Raw
365moduleDecoder =
304moduleDecoder =
366− D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
305+ D.mapError Exit.OP_BadModuleName ModuleName.decoder
367
306
368
307
369−headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
308+checkHeader :: Utf8.String -> Decoder ()
370−headerKeyDecoder =
309+checkHeader header =
371− D.KeyDecoder
310+ if Utf8.size header < 20
372− (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
311+ then return ()
373− (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
312+ else D.failure (Exit.OP_BadModuleHeaderTooLong header)
374
313
375
314
376
315
377−-- BOUND PARSER
316+-- BINARY
378
317
379
318
380−boundParser :: Int -> x -> P.Parser x Json.String
319+instance Binary Outline where
381−boundParser bound tooLong =
320+ put outline =
382− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
321+ case outline of
383− let
322+ App a -> putWord8 0 >> put a
384− len = minusPtr end pos
323+ Pkg a -> putWord8 1 >> put a
385− newCol = col + fromIntegral len
386− in
387− if len < bound
388− then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
389− else cerr row newCol (\_ _ -> tooLong)
390
324
325+ get =
326+ do n <- getWord8
327+ case n of
328+ 0 -> liftM App get
329+ 1 -> liftM Pkg get
330+ _ -> error "binary encoding of Outline was corrupted"
391
331
392
332
393−-- BINARY
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
394
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)
395
345
346+
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+
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+
396−instance Binary SrcDir where
363+instance Binary Exposed where
397− put outline =
364+ put exposed =
398− case outline of
365+ case exposed of
399− AbsoluteSrcDir a -> putWord8 0 >> put a
366+ ExposedList a -> putWord8 0 >> put a
400− RelativeSrcDir a -> putWord8 1 >> put a
367+ ExposedDict a -> putWord8 1 >> put a
401
368
402 get =
369 get =
403 do n <- getWord8
370 do n <- getWord8
404 case n of
371 case n of
405− 0 -> liftM AbsoluteSrcDir get
372+ 0 -> liftM ExposedList get
406− 1 -> liftM RelativeSrcDir get
373+ 1 -> liftM ExposedDict get
407− _ -> fail "binary encoding of SrcDir was corrupted"
374+ _ -> error "binary encoding of ProjectDeps was corrupted"
builder/src/Elm/Publish.hsnew file+255
@@ -0,0 +1,255 @@
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+5−28
@@ -1,7 +1,6 @@
1module File
1module File
2 ( Time
2 ( Time
3 , getTime
3 , getTime
4− , zeroTime
5 , writeBinary
4 , writeBinary
6 , readBinary
5 , readBinary
7 , writeUtf8
6 , writeUtf8
@@ -24,7 +23,6 @@ import qualified Data.ByteString.Builder as B
24import qualified Data.ByteString.Lazy as LBS
23import qualified Data.ByteString.Lazy as LBS
25import qualified Data.Fixed as Fixed
24import qualified Data.Fixed as Fixed
26import qualified Data.List as List
25import qualified Data.List as List
27−import qualified Data.Time.Clock as Time
28import qualified Data.Time.Clock.POSIX as Time
26import qualified Data.Time.Clock.POSIX as Time
29import qualified Foreign.ForeignPtr as FPtr
27import qualified Foreign.ForeignPtr as FPtr
30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
28import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
@@ -46,15 +44,11 @@ newtype Time = Time Fixed.Pico
46getTime :: FilePath -> IO Time
44getTime :: FilePath -> IO Time
47getTime path =
45getTime path =
48 fmap
46 fmap
47+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
48+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
50 (Dir.getModificationTime path)
49 (Dir.getModificationTime path)
51
50
52
51
53−zeroTime :: Time
54−zeroTime =
55− Time 0
56−
57−
58instance Binary.Binary Time where
52instance Binary.Binary Time where
59 put (Time time) = Binary.put time
53 put (Time time) = Binary.put time
60 get = Time <$> Binary.get
54 get = Time <$> Binary.get
@@ -78,21 +72,8 @@ readBinary path =
78 then
72 then
79 do result <- Binary.decodeFileOrFail path
73 do result <- Binary.decodeFileOrFail path
80 case result of
74 case result of
81− Right a ->
82− return (Just a)
75+ Right a -> return (Just a)
83−
84− Left (offset, message) ->
85− do IO.hPutStrLn IO.stderr $ unlines $
86− [ "+-------------------------------------------------------------------------------"
87− , "| Corrupt File: " ++ path
88− , "| Byte Offset: " ++ show offset
89− , "| Message: " ++ message
90− , "|"
91− , "| Please report this to https://github.com/elm/compiler/issues"
92− , "| Trying to continue anyway."
93− , "+-------------------------------------------------------------------------------"
94− ]
95− return Nothing
76+ Left e -> return Nothing
96 else
77 else
97 return Nothing
78 return Nothing
98
79
@@ -190,11 +171,7 @@ writeEntry destination root entry =
190 let
171 let
191 path = drop root (Zip.eRelativePath entry)
172 path = drop root (Zip.eRelativePath entry)
192 in
173 in
193− if List.isPrefixOf "src/" path
174+ if List.isPrefixOf "src/" path then
194− || path == "LICENSE"
195− || path == "README.md"
196− || path == "elm.json"
197− then
198 if not (null path) && last path == '/'
175 if not (null path) && last path == '/'
199 then Dir.createDirectoryIfMissing True (destination </> path)
176 then Dir.createDirectoryIfMissing True (destination </> path)
200 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
builder/src/Generate.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module Generate
3− ( debug
4− , dev
5− , prod
6− , repl
7− )
8− where
9−
10−
11−import Prelude hiding (cycle, print)
12−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13−import Control.Monad (liftM2)
14−import qualified Data.ByteString.Builder as B
15−import Data.Map ((!))
16−import qualified Data.Map as Map
17−import qualified Data.Maybe as Maybe
18−import qualified Data.Name as N
19−import qualified Data.NonEmptyList as NE
20−
21−import qualified AST.Optimized as Opt
22−import qualified Build
23−import qualified Elm.Compiler.Type.Extract as Extract
24−import qualified Elm.Details as Details
25−import qualified Elm.Interface as I
26−import qualified Elm.ModuleName as ModuleName
27−import qualified Elm.Package as Pkg
28−import qualified File
29−import qualified Generate.JavaScript as JS
30−import qualified Generate.Mode as Mode
31−import qualified Nitpick.Debug as Nitpick
32−import qualified Reporting.Exit as Exit
33−import qualified Reporting.Task as Task
34−import qualified Stuff
35−
36−
37−-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38−-- desireable to have Repl and Reactor to keep foreign objects in memory
39−-- to make things a bit faster?
40−
41−
42−
43−-- GENERATORS
44−
45−
46−type Task a =
47− Task.Task Exit.Generate a
48−
49−
50−debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51−debug root details (Build.Artifacts pkg ifaces roots modules) =
52− do loading <- loadObjects root details modules
53− types <- loadTypes root ifaces modules
54− objects <- finalizeObjects loading
55− let mode = Mode.Dev (Just types)
56− let graph = objectsToGlobalGraph objects
57− let mains = gatherMains pkg objects roots
58− return $ JS.generate mode graph mains
59−
60−
61−dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62−dev root details (Build.Artifacts pkg _ roots modules) =
63− do objects <- finalizeObjects =<< loadObjects root details modules
64− let mode = Mode.Dev Nothing
65− let graph = objectsToGlobalGraph objects
66− let mains = gatherMains pkg objects roots
67− return $ JS.generate mode graph mains
68−
69−
70−prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71−prod root details (Build.Artifacts pkg _ roots modules) =
72− do objects <- finalizeObjects =<< loadObjects root details modules
73− checkForDebugUses objects
74− let graph = objectsToGlobalGraph objects
75− let mode = Mode.Prod (Mode.shortenFieldNames graph)
76− let mains = gatherMains pkg objects roots
77− return $ JS.generate mode graph mains
78−
79−
80−repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81−repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82− do objects <- finalizeObjects =<< loadObjects root details modules
83− let graph = objectsToGlobalGraph objects
84− return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85−
86−
87−
88−-- CHECK FOR DEBUG
89−
90−
91−checkForDebugUses :: Objects -> Task ()
92−checkForDebugUses (Objects _ locals) =
93− case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94− [] -> return ()
95− m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96−
97−
98−
99−-- GATHER MAINS
100−
101−
102−gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103−gatherMains pkg (Objects _ locals) roots =
104− Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105−
106−
107−lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108−lookupMain pkg locals root =
109− let
110− toPair name (Opt.LocalGraph maybeMain _ _) =
111− (,) (ModuleName.Canonical pkg name) <$> maybeMain
112− in
113− case root of
114− Build.Inside name -> toPair name =<< Map.lookup name locals
115− Build.Outside name _ g -> toPair name g
116−
117−
118−
119−-- LOADING OBJECTS
120−
121−
122−data LoadingObjects =
123− LoadingObjects
124− { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125− , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126− }
127−
128−
129−loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130−loadObjects root details modules =
131− Task.io $
132− do mvar <- Details.loadObjects root details
133− mvars <- traverse (loadObject root) modules
134− return $ LoadingObjects mvar (Map.fromList mvars)
135−
136−
137−loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138−loadObject root modul =
139− case modul of
140− Build.Fresh name _ graph ->
141− do mvar <- newMVar (Just graph)
142− return (name, mvar)
143−
144− Build.Cached name _ _ ->
145− do mvar <- newEmptyMVar
146− _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147− return (name, mvar)
148−
149−
150−
151−-- FINALIZE OBJECTS
152−
153−
154−data Objects =
155− Objects
156− { _foreign :: Opt.GlobalGraph
157− , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158− }
159−
160−
161−finalizeObjects :: LoadingObjects -> Task Objects
162−finalizeObjects (LoadingObjects mvar mvars) =
163− Task.eio id $
164− do result <- readMVar mvar
165− results <- traverse readMVar mvars
166− case liftM2 Objects result (sequence results) of
167− Just loaded -> return (Right loaded)
168− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169−
170−
171−objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172−objectsToGlobalGraph (Objects globals locals) =
173− foldr Opt.addLocalGraph globals locals
174−
175−
176−
177−-- LOAD TYPES
178−
179−
180−loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181−loadTypes root ifaces modules =
182− Task.eio id $
183− do mvars <- traverse (loadTypesHelp root) modules
184− let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185− results <- traverse readMVar mvars
186− case sequence results of
187− Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189−
190−
191−loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192−loadTypesHelp root modul =
193− case modul of
194− Build.Fresh name iface _ ->
195− newMVar (Just (Extract.fromInterface name iface))
196−
197− Build.Cached name _ ciMVar ->
198− do cachedInterface <- readMVar ciMVar
199− case cachedInterface of
200− Build.Unneeded ->
201− do mvar <- newEmptyMVar
202− _ <- forkIO $
203− do maybeIface <- File.readBinary (Stuff.elmi root name)
204− putMVar mvar (Extract.fromInterface name <$> maybeIface)
205− return mvar
206−
207− Build.Loaded iface ->
208− newMVar (Just (Extract.fromInterface name iface))
209−
210− Build.Corrupted ->
211− newMVar Nothing
builder/src/Http.hs+1−14
@@ -16,7 +16,6 @@ module Http
16 -- upload
16 -- upload
17 , upload
17 , upload
18 , filePart
18 , filePart
19− , jsonPart
20 , stringPart
19 , stringPart
21 )
20 )
22 where
21 where
@@ -27,7 +26,6 @@ import qualified Codec.Archive.Zip as Zip
27import Control.Exception (SomeException, handle)
26import Control.Exception (SomeException, handle)
28import qualified Data.Binary as Binary
27import qualified Data.Binary as Binary
29import qualified Data.Binary.Get as Binary
28import qualified Data.Binary.Get as Binary
30−import qualified Data.ByteString.Builder as B
31import qualified Data.ByteString.Char8 as BS
29import qualified Data.ByteString.Char8 as BS
32import qualified Data.Digest.Pure.SHA as SHA
30import qualified Data.Digest.Pure.SHA as SHA
33import qualified Data.String as String
31import qualified Data.String as String
@@ -36,10 +34,8 @@ import Network.HTTP.Client
36import Network.HTTP.Client.TLS (tlsManagerSettings)
34import Network.HTTP.Client.TLS (tlsManagerSettings)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
35import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38import Network.HTTP.Types.Method (Method, methodGet, methodPost)
36import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
40import qualified Network.HTTP.Client.MultipartFormData as Multi
37import qualified Network.HTTP.Client.MultipartFormData as Multi
41
38
42−import qualified Json.Encode as Encode
43import qualified Elm.Version as V
39import qualified Elm.Version as V
44
40
45
41
@@ -230,15 +226,6 @@ filePart name filePath =
230 Multi.partFileSource (String.fromString name) filePath
226 Multi.partFileSource (String.fromString name) filePath
231
227
232
228
233−jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
234−jsonPart name filePath value =
235− let
236− body =
237− Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
238− in
239− Multi.partFileRequestBody (String.fromString name) filePath body
240−
241−
242stringPart :: String -> String -> Multi.Part
229stringPart :: String -> String -> Multi.Part
243stringPart name string =
230stringPart name string =
244− Multi.partBS (String.fromString name) (BS.pack string)
231+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hs+22−43
@@ -1,7 +1,6 @@
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Reporting
2module Reporting
3 ( Style
3 ( Style
4− , silent
5 , json
4 , json
6 , terminal
5 , terminal
7 --
6 --
@@ -33,7 +32,7 @@ import qualified Data.ByteString.Builder as B
33import qualified Data.NonEmptyList as NE
32import qualified Data.NonEmptyList as NE
34import qualified System.Exit as Exit
33import qualified System.Exit as Exit
35import qualified System.Info as Info
34import qualified System.Info as Info
36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
35+import System.IO (hFlush, hPutStr, stderr, stdout)
37
36
38import qualified Elm.ModuleName as ModuleName
37import qualified Elm.ModuleName as ModuleName
39import qualified Elm.Package as Pkg
38import qualified Elm.Package as Pkg
@@ -50,16 +49,10 @@ import qualified Reporting.Exit.Help as Help
50
49
51
50
52data Style
51data Style
53− = Silent
54− | Json
52+ = Json
55 | Terminal (MVar ())
53 | Terminal (MVar ())
56
54
57
55
58−silent :: Style
59−silent =
60− Silent
61−
62−
63json :: Style
56json :: Style
64json =
57json =
65 Json
58 Json
@@ -78,9 +71,7 @@ attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
78attempt toReport work =
71attempt toReport work =
79 do result <- work `catch` reportExceptionsNicely
72 do result <- work `catch` reportExceptionsNicely
80 case result of
73 case result of
81− Right a ->
82− return a
74+ Right a -> return a
83−
84 Left x ->
75 Left x ->
85 do Exit.toStderr (toReport x)
76 do Exit.toStderr (toReport x)
86 Exit.exitFailure
77 Exit.exitFailure
@@ -90,14 +81,9 @@ attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
90attemptWithStyle style toReport work =
81attemptWithStyle style toReport work =
91 do result <- work `catch` reportExceptionsNicely
82 do result <- work `catch` reportExceptionsNicely
92 case result of
83 case result of
93− Right a ->
94− return a
84+ Right a -> return a
95−
96 Left x ->
85 Left x ->
97 case style of
86 case style of
98− Silent ->
99− do Exit.exitFailure
100−
101 Json ->
87 Json ->
102 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
88 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
103 Exit.exitFailure
89 Exit.exitFailure
@@ -122,6 +108,11 @@ badMark =
122 D.red $ if isWindows then "X" else "✗"
108 D.red $ if isWindows then "X" else "✗"
123
109
124
110
111+_waitingMark :: D.Doc
112+_waitingMark =
113+ D.dullyellow $ if isWindows then "-" else "→"
114+
115+
125isWindows :: Bool
116isWindows :: Bool
126isWindows =
117isWindows =
127 Info.os == "mingw32"
118 Info.os == "mingw32"
@@ -177,9 +168,6 @@ type DKey = Key DMsg
177trackDetails :: Style -> (DKey -> IO a) -> IO a
168trackDetails :: Style -> (DKey -> IO a) -> IO a
178trackDetails style callback =
169trackDetails style callback =
179 case style of
170 case style of
180− Silent ->
181− callback (Key (\_ -> return ()))
182−
183 Json ->
171 Json ->
184 callback (Key (\_ -> return ()))
172 callback (Key (\_ -> return ()))
185
173
@@ -264,8 +252,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
264putDownload mark pkg vsn =
252putDownload mark pkg vsn =
265 Help.toStdout $ D.indent 2 $
253 Help.toStdout $ D.indent 2 $
266 mark
254 mark
267− <+> D.fromPackage pkg
255+ <+> D.fromUtf8 (Pkg.toString pkg)
268− <+> D.fromVersion vsn
256+ <+> D.fromUtf8 (V.toString vsn)
269 <> "\n"
257 <> "\n"
270
258
271
259
@@ -309,9 +297,6 @@ type BResult a = Either Exit.BuildProblem a
309trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
297trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
310trackBuild style callback =
298trackBuild style callback =
311 case style of
299 case style of
312− Silent ->
313− callback (Key (\_ -> return ()))
314−
315 Json ->
300 Json ->
316 callback (Key (\_ -> return ()))
301 callback (Key (\_ -> return ()))
317
302
@@ -364,10 +349,10 @@ toFinalMessage done result =
364
349
365 Left problem ->
350 Left problem ->
366 case problem of
351 case problem of
367− Exit.BuildBadModules _ _ [] ->
352+ Exit.BuildModuleProblems _ [] ->
368 "Detected problems in 1 module."
353 "Detected problems in 1 module."
369
354
370− Exit.BuildBadModules _ _ (_:ps) ->
355+ Exit.BuildModuleProblems _ (_:ps) ->
371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
356 "Detected problems in " ++ show (2 + length ps) ++ " modules."
372
357
373 Exit.BuildProjectProblem _ ->
358 Exit.BuildProjectProblem _ ->
@@ -381,9 +366,6 @@ toFinalMessage done result =
381reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
366reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
382reportGenerate style names output =
367reportGenerate style names output =
383 case style of
368 case style of
384− Silent ->
385− return ()
386−
387 Json ->
369 Json ->
388 return ()
370 return ()
389
371
@@ -446,23 +428,20 @@ reportExceptionsNicely e =
446
428
447
429
448putException :: SomeException -> IO ()
430putException :: SomeException -> IO ()
449−putException e = do
431+putException e =
450− hPutStrLn stderr ""
451 Help.toStderr $ D.stack $
432 Help.toStderr $ D.stack $
452− [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
453− , D.reflow $
433+ [ D.reflow $
454− "I ran into something that bypassed the normal error reporting process!\
434+ "Oh no! I ran into something that bypassed the normal error reporting process!\
455 \ I extracted whatever information I could from the internal error:"
435 \ I extracted whatever information I could from the internal error:"
456 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
436 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
457 , D.reflow $
437 , D.reflow $
458− "These errors are usually pretty confusing, so start by asking around on one of\
438+ "These errors are usually pretty confusing, so start by asking around on Slack\
459− \ forums listed at https://elm-lang.org/community to see if anyone can get you\
460− \ unstuck quickly."
439+ \ or Discourse to see if anyone can get you unstuck quickly."
461− , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
440+ , "------------------------------------------------------------"
462 , D.reflow $
441 , D.reflow $
463− "If you are feeling up to it, please try to get your code down to the smallest\
442+ "From there, if you are feeling up to it, please try to get your code down to the\
464− \ version that still triggers this message. Ideally in a single Main.elm and\
443+ \ smallest version that still triggers this message. Ideally in a single Main.elm\
465− \ elm.json file."
444+ \ and elm.json file."
466 , D.reflow $
445 , D.reflow $
467 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
446 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
468 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
447 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
builder/src/Reporting/Exit.hs+366−1625
@@ -1,27 +1,31 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Exit
2module Reporting.Exit
3+ ( Exit(..)
4+ --
5+ , Init(..)
3− ( Init(..), initToReport
6+ , initToReport
7+ --
8+ , Diff(..)
4− , Diff(..), diffToReport
9+ , diffToReport
5− , Make(..), makeToReport
10+ --
6− , Bump(..), bumpToReport
11+ , Install(..)
7− , Repl(..), replToReport
8− , Publish(..), publishToReport
9− , Install(..), installToReport
12+ , installToReport
10− , Reactor(..), reactorToReport
11− , newPackageOverview
12 --
13 --
13 , Solver(..)
14 , Solver(..)
15+ --
14 , Outline(..)
16 , Outline(..)
15 , OutlineProblem(..)
17 , OutlineProblem(..)
18+ --
16 , Details(..)
19 , Details(..)
17− , DetailsBadDep(..)
18− , PackageProblem(..)
19 , RegistryProblem(..)
20 , RegistryProblem(..)
21+ , PackageProblem(..)
22+ --
23+ , Make(..)
20 , BuildProblem(..)
24 , BuildProblem(..)
21 , BuildProjectProblem(..)
25 , BuildProjectProblem(..)
22− , DocsProblem(..)
26+ , makeToReport
23− , Generate(..)
24 --
27 --
28+ , DocsProblem(..)
25 , toString
29 , toString
26 , toStderr
30 , toStderr
27 , toJson
31 , toJson
@@ -29,56 +33,59 @@ module Reporting.Exit
29 where
33 where
30
34
31
35
32−import qualified Data.ByteString as BS
33−import qualified Data.ByteString.UTF8 as BS_UTF8
34import qualified Data.List as List
36import qualified Data.List as List
35−import qualified Data.Map as Map
37+import qualified Data.Utf8 as Utf8
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 ((</>), (<.>))
43
38
44import qualified Elm.Constraint as C
39import qualified Elm.Constraint as C
45import qualified Elm.Magnitude as M
40import qualified Elm.Magnitude as M
46import qualified Elm.ModuleName as ModuleName
41import qualified Elm.ModuleName as ModuleName
47import qualified Elm.Package as Pkg
42import qualified Elm.Package as Pkg
48import qualified Elm.Version as V
43import qualified Elm.Version as V
49−import qualified File
50import qualified Http
44import qualified Http
51−import qualified Json.Decode as Decode
52import qualified Json.Encode as Encode
45import 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
56import Reporting.Doc ((<>))
46import Reporting.Doc ((<>))
57import qualified Reporting.Doc as D
47import qualified Reporting.Doc as D
58−import qualified Reporting.Error.Import as Import
59import qualified Reporting.Error.Json as Json
48import qualified Reporting.Error.Json as Json
60import qualified Reporting.Exit.Help as Help
49import qualified Reporting.Exit.Help as Help
61−import qualified Reporting.Error as Error
50+import qualified Reporting.Problem as Problem
62−import qualified Reporting.Render.Code as Code
63−
64−
65
51
66−-- RENDERERS
67
52
68
53
69−toString :: Help.Report -> String
54+-- ALL POSSIBLE ERRORS
70−toString report =
71− Help.toString (Help.reportToDoc report)
72
55
73
56
74−toStderr :: Help.Report -> IO ()
57+data Exit
75−toStderr report =
58+ -- bump
76− Help.toStderr (Help.reportToDoc report)
59+ = BumpApplication
60+ | BumpUnexpectedVersion V.Version [V.Version]
61+ | BumpMustHaveLatestRegistry RegistryProblem
62+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
63+ -- publish
64+ | PublishMustHaveLatestRegistry RegistryProblem
65+ | PublishApplication
66+ | PublishNotInitialVersion V.Version
67+ | PublishAlreadyPublished V.Version
68+ | PublishInvalidBump V.Version V.Version
69+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
70+ | PublishNoSummary
71+ | PublishNoExposed
72+ | PublishNoReadme
73+ | PublishShortReadme
74+ | PublishNoLicense
75+ | PublishCannotGetTag Http.Error
76+ | PublishCannotGetZip Http.Error
77+ | PublishCannotDecodeZip
78+ | PublishCannotGetDocs DocsProblem
79+ | PublishCannotRegister Http.Error
80+ | PublishMissingTag V.Version
81+ | PublishNoGit
82+ | PublishLocalChanges V.Version
77
83
78
84
79−toJson :: Help.Report -> Encode.Value
85+data DocsProblem
80−toJson report =
86+ = DP_Http Http.Error
81− Help.reportToJson report
87+ | DP_Data
88+ | DP_Cache
82
89
83
90
84
91
@@ -109,18 +116,13 @@ initToReport exit =
109
116
110 InitNoOfflineSolution pkgs ->
117 InitNoOfflineSolution pkgs ->
111 Help.report "NO OFFLINE SOLUTION" Nothing
118 Help.report "NO OFFLINE SOLUTION" Nothing
112− "I tried to create an elm.json with the following direct dependencies:"
119+ (error "TODO InitNoOfflineSolution" pkgs)
113− [ D.indent 4 $ D.vcat $
120+ (error "TODO InitNoOfflineSolution" pkgs)
114− map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
121+ -- note about Russia IP addresses?
115− , D.reflow $
122+ -- ask if they are on a plane or train
116− "I could not find compatible versions though, but that may be because I could not\
117− \ connect to https://package.elm-lang.org to get the latest list of packages. Are\
118− \ you able to connect to the internet? Please ask around one of the community\
119− \ forums at https://elm-lang.org/community for help!"
120− ]
121
123
122 InitSolverProblem solver ->
124 InitSolverProblem solver ->
123− toSolverReport solver
125+ error "TODO InitSolverProblem" solver
124
126
125 InitAlreadyExists ->
127 InitAlreadyExists ->
126 Help.report "EXISTING PROJECT" Nothing
128 Help.report "EXISTING PROJECT" Nothing
@@ -131,9 +133,8 @@ initToReport exit =
131 ]
133 ]
132 ]
134 ]
133
135
134− InitRegistryProblem problem ->
136+ InitRegistryProblem _ ->
135− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
137+ error "TODO InitRegistryProblem"
136− "I need the list of published packages before I can start initializing projects"
137
138
138
139
139
140
@@ -141,48 +142,22 @@ initToReport exit =
141
142
142
143
143data Diff
144data Diff
144− = DiffNoOutline
145− | DiffBadOutline Outline
146− | DiffApplication
145+ = DiffApplication
147− | DiffNoExposed
148 | DiffUnpublished
146 | DiffUnpublished
149 | DiffUnknownPackage Pkg.Name [Pkg.Name]
147 | DiffUnknownPackage Pkg.Name [Pkg.Name]
150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
148 | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151− | DiffDocsProblem V.Version DocsProblem
149+ | DiffCannotFindDocs DocsProblem
152 | DiffMustHaveLatestRegistry RegistryProblem
150 | DiffMustHaveLatestRegistry RegistryProblem
153− | DiffBadDetails Details
154− | DiffBadBuild BuildProblem
155
151
156
152
157diffToReport :: Diff -> Help.Report
153diffToReport :: Diff -> Help.Report
158diffToReport diff =
154diffToReport diff =
159 case diff of
155 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−
171 DiffApplication ->
156 DiffApplication ->
172− Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
157+ Help.report "CANNOT DIFF APPLICATIONS" Nothing
173− "Your elm.json says this project is an application, but `elm diff` only works\
158+ "I cannot perform diffs on applications, only packages! If you are\
174− \ with packages. That way there are previously published versions of the API to\
175− \ diff against!"
176− [ D.reflow $ "If you are just curious to see a diff, try running this command:"
159+ \ just curious to see a diff, try running this command:"
177− , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
160+ [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
178− ]
179−
180− DiffNoExposed ->
181− Help.report "NO EXPOSED MODULES" (Just "elm.json")
182− "Your elm.json has no \"exposed-modules\" which means there is no public API at\
183− \ all right now! What am I supposed to diff?"
184− [ D.reflow $
185− "Try adding some modules back to the \"exposed-modules\" field."
186 ]
161 ]
187
162
188 DiffUnpublished ->
163 DiffUnpublished ->
@@ -194,16 +169,16 @@ diffToReport diff =
194 Help.report "UNKNOWN PACKAGE" Nothing
169 Help.report "UNKNOWN PACKAGE" Nothing
195 ( "I cannot find a package called:"
170 ( "I cannot find a package called:"
196 )
171 )
197− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
172+ [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
198 , "Maybe you want one of these instead?"
173 , "Maybe you want one of these instead?"
199− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
174+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
200 , "But check <https://package.elm-lang.org> to see all possibilities!"
175 , "But check <https://package.elm-lang.org> to see all possibilities!"
201 ]
176 ]
202
177
203 DiffUnknownVersion _pkg vsn realVersions ->
178 DiffUnknownVersion _pkg vsn realVersions ->
204 Help.docReport "UNKNOWN VERSION" Nothing
179 Help.docReport "UNKNOWN VERSION" Nothing
205 ( D.fillSep $
180 ( D.fillSep $
206− [ "Version", D.red (D.fromVersion vsn)
181+ [ "Version", D.red (D.fromUtf8 (V.toString vsn))
207 , "has", "never", "been", "published,", "so", "I"
182 , "has", "never", "been", "published,", "so", "I"
208 , "cannot", "diff", "against", "it."
183 , "cannot", "diff", "against", "it."
209 ]
184 ]
@@ -212,57 +187,230 @@ diffToReport diff =
212 , D.indent 4 $ D.dullyellow $ D.vcat $
187 , D.indent 4 $ D.dullyellow $ D.vcat $
213 let
188 let
214 sameMajor v1 v2 = V._major v1 == V._major v2
189 sameMajor v1 v2 = V._major v1 == V._major v2
215− mkRow vsns = D.hsep $ map D.fromVersion vsns
190+ mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
216 in
191 in
217 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
192 map mkRow $ List.groupBy sameMajor (List.sort realVersions)
218 , "Want one of those instead?"
193 , "Want one of those instead?"
219 ]
194 ]
220
195
221− DiffDocsProblem version problem ->
196+ DiffCannotFindDocs problem ->
222− toDocsProblemReport problem $
197+ error "TODO DiffCannotFindDocs" problem
223− "I need the docs for " ++ V.toChars version ++ " to compute this diff"
224
198
225 DiffMustHaveLatestRegistry problem ->
199 DiffMustHaveLatestRegistry problem ->
226− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
200+ error "TODO DiffMustHaveLatestRegistry" problem
227− "I need the latest list of published packages before I do this diff"
228
201
229− DiffBadDetails details ->
230− toDetailsReport details
231
202
232− DiffBadBuild buildProblem ->
233− toBuildProblemReport buildProblem
234
203
204+-- INSTALL
235
205
236
206
237−-- BUMP
207+data Install
208+ = InstallNoProject
209+ | InstallNoArgs FilePath
210+ | InstallNoOnlineSolution
211+ | InstallNoOfflineSolution
212+ | InstallHadSolverTrouble Solver
213+ | InstallUnknownPackageOnline [Pkg.Name]
214+ | InstallUnknownPackageOffline [Pkg.Name]
215+ | InstallHasBadDetails Details
238
216
239
217
240−data Bump
218+installToReport :: Install -> Help.Report
241− = BumpNoOutline
219+installToReport exit =
242− | BumpBadOutline Outline
220+ case exit of
243− | BumpApplication
221+ InstallNoProject ->
244− | BumpUnexpectedVersion V.Version [V.Version]
222+ Help.report "NEW PROJECT?" Nothing
245− | BumpMustHaveLatestRegistry RegistryProblem
223+ "Are you trying to start a new project? Try this command instead:"
246− | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
224+ [ D.indent 4 $ D.green "elm init"
247− | BumpBadDetails Details
225+ , D.reflow "It will help you get started!"
248− | BumpNoExposed
226+ ]
249− | BumpBadBuild BuildProblem
250
227
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+ ]
251
250
252−bumpToReport :: Bump -> Help.Report
251+ InstallNoOnlineSolution ->
253−bumpToReport bump =
252+ Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`
254− case bump of
253+ "This usually happens if you try to modify dependency constraints by\
255− BumpNoOutline ->
254+ \ hand. I recommend deleting any dependency you added recently (or all\
256− Help.report "BUMP WHAT?" Nothing
255+ \ of them if things are bad) and then adding them again with:"
257− "I cannot find an elm.json so I am not sure what you want me to bump."
256+ [ D.indent 4 $ D.green "elm install"
258− [ D.reflow $
257+ , D.reflow $
259− "Elm packages always have an elm.json that says current the version number. If\
258+ "And do not be afaid to ask for help on Slack if you get stuck!"
260− \ you run this command from a directory with an elm.json file, I will try to bump\
261− \ the version in there based on the API changes."
262 ]
259 ]
263
260
264− BumpBadOutline outline ->
261+ InstallNoOfflineSolution ->
265− toOutlineReport outline
262+ error "TODO InstallNoOfflineSolution"
263+
264+ InstallHadSolverTrouble solver ->
265+ error "TODO InstallHadSolverTrouble" solver
266+
267+ InstallUnknownPackageOnline suggestions ->
268+ error "TODO InstallUnknownPackageOnline" suggestions
269+
270+ InstallUnknownPackageOffline suggestions ->
271+ error "TODO InstallUnknownPackageOffline" suggestions
272+
273+ InstallHasBadDetails _ ->
274+ error "TODO InstallHasBadDetails"
275+
276+
277+{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?
278+ Help.report "OLD DEPENDENCIES" (Just "elm.json")
279+ ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
280+ )
281+ [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
282+ , D.reflow $
283+ "This may be because it is not upgraded yet. It may be because a\
284+ \ better solution came along, so there was no need to upgrade it.\
285+ \ Etc. Try asking around on Slack to learn more about the topic."
286+ , D.toSimpleNote
287+ "Whatever the case, please be kind to the relevant package authors! Having\
288+ \ friendly interactions with users is great motivation, and conversely, getting\
289+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
290+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
291+ \ goals, etc. They face obstacles outside of their technical work you will never\
292+ \ know about, so please assume the best and try to be patient and supportive!"
293+ ]
294+-}
295+
296+
297+
298+-- SOLVER
299+
300+
301+data Solver
302+ = SolverBadCacheData Pkg.Name V.Version
303+ | SolverBadHttpData Pkg.Name V.Version
304+ | SolverBadHttp Http.Error
305+
306+
307+
308+-- OUTLINE
309+
310+
311+data Outline
312+ = OutlineHasBadStructure (Json.Error OutlineProblem)
313+ | OutlineHasBadSrcDirs FilePath [FilePath]
314+
315+
316+data OutlineProblem
317+ = OP_BadType Utf8.String
318+ | OP_BadPkgName Pkg.BadName
319+ | OP_BadVersion Utf8.String
320+ | OP_BadConstraint C.Error
321+ | OP_BadModuleName Utf8.String
322+ | OP_BadModuleHeaderTooLong Utf8.String
323+ | OP_BadDependencyName Utf8.String
324+ | OP_BadLicense Utf8.String [Utf8.String]
325+ | OP_BadSummaryTooLong
326+
327+
328+
329+-- DETAILS
330+
331+
332+data Details
333+ = DetailsCorrupt
334+ | DetailsNoSolution
335+ | DetailsNoOfflineSolution
336+ | DetailsSolverProblem Solver
337+ | DetailsBadElmInPkg C.Constraint
338+ | DetailsBadElmInAppOutline V.Version
339+ | DetailsHandEditedDependencies
340+ | DetailsBadOutline Outline
341+ | DetailsCannotGetRegistry RegistryProblem
342+ | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem
343+
344+
345+data RegistryProblem
346+ = RP_Http Http.Error
347+ | RP_Data
348+
349+
350+data PackageProblem
351+ = PP_BadEndpointRequest Http.Error
352+ | PP_BadEndpointContent
353+ | PP_BadArchiveRequest Http.Error
354+ | PP_BadArchiveContent
355+ | PP_BadArchiveHash String String
356+
357+
358+
359+-- MAKE
360+
361+
362+data Make
363+ = MakeNeedsOutline
364+ | MakeCannotOptimizeAndDebug
365+ | MakeBlockedByDetailsProblem Details
366+ | MakeAppNeedsFileNames
367+ | MakePkgNeedsExposing
368+ | MakeMultipleFilesIntoHtml
369+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
370+ | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
371+ | MakeCannotBuild BuildProblem
372+ | MakeCannotLoadArtifacts
373+
374+
375+data BuildProblem
376+ = BuildModuleProblems 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
266
414
267 BumpApplication ->
415 BumpApplication ->
268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
416 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
@@ -274,7 +422,7 @@ bumpToReport bump =
274 Help.docReport "CANNOT BUMP" (Just "elm.json")
422 Help.docReport "CANNOT BUMP" (Just "elm.json")
275 ( D.fillSep
423 ( D.fillSep
276 ["Your","elm.json","says","I","should","bump","relative","to","version"
424 ["Your","elm.json","says","I","should","bump","relative","to","version"
277− ,D.red (D.fromVersion vsn) <> ","
425+ ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
278 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
426 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
279 ,"That","means","there","is","no","API","for","me","to","diff","against","and"
427 ,"That","means","there","is","no","API","for","me","to","diff","against","and"
280 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
428 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
@@ -283,116 +431,19 @@ bumpToReport bump =
283 [ D.fillSep $
431 [ D.fillSep $
284 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
432 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
285 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
433 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
286− , D.vcat $ map (D.green . D.fromVersion) versions
434+ , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
287 ]
435 ]
288
436
289 BumpMustHaveLatestRegistry problem ->
437 BumpMustHaveLatestRegistry problem ->
290− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
438+ error "TODO BumpMustHaveLatestRegistry" problem
291− "I need the latest list of published packages before I can bump any versions"
292−
293− BumpCannotFindDocs _ version problem ->
294− toDocsProblemReport problem $
295− "I need the docs for " ++ V.toChars version ++ " to compute the next version number"
296−
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− ]
386
439
387− PublishBadOutline outline ->
440+ BumpCannotFindDocs name version problem ->
388− toOutlineReport outline
441+ error "TODO BumpCannotFindDocs" name version problem
389
442
390− PublishBadDetails problem ->
443+ -- publish
391− toDetailsReport problem
392
444
393 PublishMustHaveLatestRegistry problem ->
445 PublishMustHaveLatestRegistry problem ->
394− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
446+ error "TODO PublishMustHaveLatestRegistry" problem
395− "I need the latest list of published packages to make sure this is safe to publish"
396
447
397 PublishApplication ->
448 PublishApplication ->
398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
449 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
@@ -401,7 +452,7 @@ publishToReport publish =
401 Help.docReport "INVALID VERSION" Nothing
452 Help.docReport "INVALID VERSION" Nothing
402 ( D.fillSep
453 ( D.fillSep
403 ["I","cannot","publish"
454 ["I","cannot","publish"
404− ,D.red (D.fromVersion vsn)
455+ ,D.red (D.fromUtf8 (V.toString vsn))
405 ,"as","the","initial","version."
456 ,"as","the","initial","version."
406 ]
457 ]
407 )
458 )
@@ -415,7 +466,7 @@ publishToReport publish =
415 Help.docReport "ALREADY PUBLISHED" Nothing
466 Help.docReport "ALREADY PUBLISHED" Nothing
416 ( D.vcat
467 ( D.vcat
417 [ D.fillSep
468 [ D.fillSep
418− [ "Version", D.green (D.fromVersion vsn)
469+ [ "Version", D.green (D.fromUtf8 (V.toString vsn))
419 , "has", "already", "been", "published.", "You", "cannot"
470 , "has", "already", "been", "published.", "You", "cannot"
420 , "publish", "it", "again!"
471 , "publish", "it", "again!"
421 ]
472 ]
@@ -432,14 +483,14 @@ publishToReport publish =
432 Help.docReport "INVALID VERSION" (Just "elm.json")
483 Help.docReport "INVALID VERSION" (Just "elm.json")
433 ( D.fillSep $
484 ( D.fillSep $
434 ["Your","elm.json","says","the","next","version","should","be"
485 ["Your","elm.json","says","the","next","version","should","be"
435− ,D.red (D.fromVersion statedVersion) <> ","
486+ ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
436 ,"but","that","is","not","valid","based","on","the","previously"
487 ,"but","that","is","not","valid","based","on","the","previously"
437 ,"published","versions."
488 ,"published","versions."
438 ]
489 ]
439 )
490 )
440 [ D.fillSep $
491 [ D.fillSep $
441 ["Change","the","version","back","to"
492 ["Change","the","version","back","to"
442− ,D.green (D.fromVersion latestVersion)
493+ ,D.green (D.fromUtf8 (V.toString latestVersion))
443 ,"which","is","the","most","recently","published","version."
494 ,"which","is","the","most","recently","published","version."
444 ,"From","there,","have","Elm","bump","the","version","by","running:"
495 ,"From","there,","have","Elm","bump","the","version","by","running:"
445 ]
496 ]
@@ -454,7 +505,7 @@ publishToReport publish =
454 (
505 (
455 D.fillSep $
506 D.fillSep $
456 ["Your","elm.json","says","the","next","version","should","be"
507 ["Your","elm.json","says","the","next","version","should","be"
457− ,D.red (D.fromVersion new) <> ","
508+ ,D.red (D.fromUtf8 (V.toString new)) <> ","
458 ,"indicating","a",D.fromChars (M.toChars magnitude)
509 ,"indicating","a",D.fromChars (M.toChars magnitude)
459 ,"change","to","the","public","API."
510 ,"change","to","the","public","API."
460 ,"This","does","not","match","the","API","diff","given","by:"
511 ,"This","does","not","match","the","API","diff","given","by:"
@@ -467,7 +518,7 @@ publishToReport publish =
467 ["This","command","says","this","is","a"
518 ["This","command","says","this","is","a"
468 ,D.fromChars (M.toChars realMagnitude)
519 ,D.fromChars (M.toChars realMagnitude)
469 ,"change,","so","the","next","version","should","be"
520 ,"change,","so","the","next","version","should","be"
470− ,D.green (D.fromVersion realNew) <> "."
521+ ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
471 ,"Double","check","everything","to","make","sure","you"
522 ,"Double","check","everything","to","make","sure","you"
472 ,"are","publishing","what","you","want!"
523 ,"are","publishing","what","you","want!"
473 ]
524 ]
@@ -497,17 +548,16 @@ publishToReport publish =
497 ]
548 ]
498 )
549 )
499 [ D.reflow $
550 [ D.reflow $
500− "Which modules do you want users of the package to have access to? Add their\
551+ "What is the point of a package that has no modules?!"
501− \ names to the \"exposed-modules\" list."
502 ]
552 ]
503
553
504 PublishNoReadme ->
554 PublishNoReadme ->
505− toBadReadmeReport "NO README" $
555+ badReadmeReport "NO README" $
506 "Every published package must have a helpful README.md\
556 "Every published package must have a helpful README.md\
507 \ file, but I do not see one in your project."
557 \ file, but I do not see one in your project."
508
558
509 PublishShortReadme ->
559 PublishShortReadme ->
510− toBadReadmeReport "SHORT README" $
560+ badReadmeReport "SHORT README" $
511 "This README.md is too short. Having more details will help\
561 "This README.md is too short. Having more details will help\
512 \ people assess your package quickly and fairly."
562 \ people assess your package quickly and fairly."
513
563
@@ -524,8 +574,20 @@ publishToReport publish =
524 \ named LICENSE. Add that file and you will be all set!"
574 \ named LICENSE. Add that file and you will be all set!"
525 ]
575 ]
526
576
527− PublishBuildProblem buildProblem ->
577+ PublishCannotGetTag httpError ->
528− toBuildProblemReport buildProblem
578+ error "TODO PublishCannotGetTag" httpError
579+
580+ PublishCannotGetZip httpError ->
581+ error "TODO PublishCannotGetZip" httpError
582+
583+ PublishCannotDecodeZip ->
584+ error "TODO PublishCannotDecodeZip"
585+
586+ PublishCannotGetDocs docsProblem ->
587+ error "TODO PublishCannotGetDocs" docsProblem
588+
589+ PublishCannotRegister httpError ->
590+ error "TODO PublishCannotRegister" httpError
529
591
530 PublishMissingTag version ->
592 PublishMissingTag version ->
531 let vsn = V.toChars version in
593 let vsn = V.toChars version in
@@ -546,70 +608,6 @@ publishToReport publish =
546 , "The -m flag is for a helpful message. Try to make it more informative!"
608 , "The -m flag is for a helpful message. Try to make it more informative!"
547 ]
609 ]
548
610
549− PublishCannotGetTag version httpError ->
550− case httpError of
551− Http.BadHttp _ (HTTP.StatusCodeException response _)
552− | HTTP.statusCode (HTTP.responseStatus response) == 404 ->
553− let vsn = V.toChars version in
554− Help.report "NO TAG ON GITHUB" Nothing
555− ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
556− [ D.reflow
557− "Run the following command to make this tag available on GitHub:"
558− , D.indent 4 $ D.dullyellow $ D.fromChars $
559− "git push origin " ++ vsn
560− , D.reflow
561− "This will make it possible to find your code online based on the version number."
562− ]
563−
564− _ ->
565− toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
566− "I need to check that the version tag is registered on GitHub"
567−
568− PublishCannotGetTagData version url body ->
569− Help.report "PROBLEM VERIFYING TAG" Nothing
570− ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
571− [ D.indent 4 $ D.dullyellow $ D.fromChars url
572− , D.reflow $
573− "I got the data back, but it was not what I was expecting. The response\
574− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
575− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
576− , D.indent 4 $ D.dullyellow $ D.fromChars $
577− if BS.length body <= 76
578− then BS_UTF8.toString body
579− else take 73 (BS_UTF8.toString body) ++ "..."
580− , D.reflow $
581− "Does this error keep showing up? Maybe there is something weird with your\
582− \ internet connection. We have gotten reports that schools, businesses,\
583− \ airports, etc. sometimes intercept requests and add things to the body\
584− \ or change its contents entirely. Could that be the problem?"
585− ]
586−
587− PublishCannotGetZip httpError ->
588− toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
589− "I need to check that folks can download and build the source code when they\
590− \ install this package"
591−
592− PublishCannotDecodeZip url ->
593− Help.report "PROBLEM DOWNLOADING CODE" Nothing
594− "I need to check that folks can download and build the source code when they\
595− \ install this package, so I downloaded the code from:"
596− [ D.indent 4 $ D.dullyellow $ D.fromChars url
597− , D.reflow $
598− "I was unable to unzip the archive though. Maybe there is something weird with\
599− \ your internet connection. We have gotten reports that schools, businesses,\
600− \ airports, etc. sometimes intercept requests and add things to the body or\
601− \ change its contents entirely. Could that be the problem?"
602− ]
603−
604− PublishCannotGetDocs old new docsProblem ->
605− toDocsProblemReport docsProblem $
606− "I need the docs for " ++ V.toChars old ++ " to verify that "
607− ++ V.toChars new ++ " really does come next"
608−
609− PublishCannotRegister httpError ->
610− toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
611− "I need to send information about your package to the package website"
612−
613 PublishNoGit ->
611 PublishNoGit ->
614 Help.report "NO GIT" Nothing
612 Help.report "NO GIT" Nothing
615 "I searched your PATH environment variable for `git` and could not\
613 "I searched your PATH environment variable for `git` and could not\
@@ -639,21 +637,9 @@ publishToReport publish =
639 ++ vsn ++ "` and publish your code from there."
637 ++ vsn ++ "` and publish your code from there."
640 ]
638 ]
641
639
642− PublishZipBadDetails _ ->
643− badZipReport
644
640
645− PublishZipApplication ->
646− badZipReport
647−
648− PublishZipNoExposed ->
649− badZipReport
650−
651− PublishZipBuildProblem _ ->
652− badZipReport
653−
654−
655−toBadReadmeReport :: String -> String -> Help.Report
641+badReadmeReport :: String -> String -> Help.Report
656−toBadReadmeReport title summary =
642+badReadmeReport title summary =
657 Help.report title (Just "README.md") summary
643 Help.report title (Just "README.md") summary
658 [ D.reflow $
644 [ D.reflow $
659 "When people look at your README, they are wondering:"
645 "When people look at your README, they are wondering:"
@@ -666,653 +652,32 @@ toBadReadmeReport title summary =
666 \ most common usage scenario. Show people what they can expect if\
652 \ most common usage scenario. Show people what they can expect if\
667 \ they learn more!"
653 \ they learn more!"
668 , D.toSimpleNote $
654 , D.toSimpleNote $
669− "By publishing your package, you are inviting people to invest time in\
655+ "By publishing your package, you are inviting people to invest time\
670− \ understanding your work. Spending an hour on your README to communicate your\
656+ \ in understanding your work. Spending an hour to communicate your\
671− \ knowledge more clearly can save the community days or weeks of time in\
657+ \ knowledge more clearly can save the community days or weeks of time\
672− \ aggregate, and saving time in aggregate is the whole point of publishing\
658+ \ in aggregate, and saving time in aggregate is the whole point of\
673− \ packages! People really appreciate it, and it makes the whole ecosystem feel\
659+ \ publishing packages! People really appreciate it, and it makes the\
674− \ nicer!"
660+ \ whole ecosystem feel nicer!"
675− ]
676−
677−
678−badZipReport :: Help.Report
679−badZipReport =
680− Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681− "Before publishing packages, I download the code from GitHub and try to build it\
682− \ from scratch. That way I can be more confident that it will work for other\
683− \ people too. But I am not able to build it!"
684− [ D.reflow $
685− "I was just able to build your local copy though. Is there some way the version\
686− \ on GitHub could be different?"
687 ]
661 ]
688
662
689
663
690
664
691−-- DOCS
665+-- DETAILS TO REPORT
692−
693−
694−data DocsProblem
695− = DP_Http Http.Error
696− | DP_Data String BS.ByteString
697− | DP_Cache
698−
699−
700−toDocsProblemReport :: DocsProblem -> String -> Help.Report
701−toDocsProblemReport problem context =
702− case problem of
703− DP_Http httpError ->
704− toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705−
706− DP_Data url body ->
707− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708− [ D.indent 4 $ D.dullyellow $ D.fromChars url
709− , D.reflow $
710− "I got the data back, but it was not what I was expecting. The response\
711− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713− , D.indent 4 $ D.dullyellow $ D.fromChars $
714− if BS.length body <= 76
715− then BS_UTF8.toString body
716− else take 73 (BS_UTF8.toString body) ++ "..."
717− , D.reflow $
718− "Does this error keep showing up? Maybe there is something weird with your\
719− \ internet connection. We have gotten reports that schools, businesses,\
720− \ airports, etc. sometimes intercept requests and add things to the body\
721− \ or change its contents entirely. Could that be the problem?"
722− ]
723−
724− DP_Cache ->
725− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726− [ D.reflow $
727− "I deleted the cached version, so the next run should download a fresh copy of\
728− \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729− \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730− \ for some reason."
731− ]
732−
733−
734−
735−-- INSTALL
736−
737−
738−data Install
739− = InstallNoOutline
740− | InstallBadOutline Outline
741− | InstallBadRegistry RegistryProblem
742− | InstallNoArgs FilePath
743− | InstallNoOnlineAppSolution Pkg.Name
744− | InstallNoOfflineAppSolution Pkg.Name
745− | InstallNoOnlinePkgSolution Pkg.Name
746− | InstallNoOfflinePkgSolution Pkg.Name
747− | InstallHadSolverTrouble Solver
748− | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749− | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750− | InstallBadDetails Details
751−
752−
753−installToReport :: Install -> Help.Report
754−installToReport exit =
755− case exit of
756− InstallNoOutline ->
757− Help.report "NEW PROJECT?" Nothing
758− "Are you trying to start a new project? Try this command instead:"
759− [ D.indent 4 $ D.green "elm init"
760− , D.reflow "It will help you get started!"
761− ]
762
666
763− InstallBadOutline outline ->
764− toOutlineReport outline
765
667
766− InstallBadRegistry problem ->
668+detailsToReport :: Details -> Help.Report
767− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
669+detailsToReport details =
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 =
1279 case details of
670 case details of
1280− DetailsNoSolution ->
671+ DetailsCorrupt ->
1281− Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")
672+ error "TODO DetailsCorrupt"
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
1308
673
1309 DetailsBadElmInPkg constraint ->
674 DetailsBadElmInPkg constraint ->
1310 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
675 Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1311 "Your elm.json says this package needs a version of Elm in this range:"
676 "Your elm.json says this package needs a version of Elm in this range:"
1312− [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint
677+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint
1313 , D.fillSep
678 , D.fillSep
1314 [ "But", "you", "are", "using", "Elm"
679 [ "But", "you", "are", "using", "Elm"
1315− , D.red (D.fromVersion V.compiler)
680+ , D.red (D.fromUtf8 (V.toString V.compiler))
1316 , "right", "now."
681 , "right", "now."
1317 ]
682 ]
1318 ]
683 ]
@@ -1322,286 +687,40 @@ toDetailsReport details =
1322 "Your elm.json says this application needs a different version of Elm."
687 "Your elm.json says this application needs a different version of Elm."
1323 [ D.fillSep
688 [ D.fillSep
1324 [ "It", "requires"
689 [ "It", "requires"
1325− , D.green (D.fromVersion version) <> ","
690+ , D.green (D.fromUtf8 (V.toString version)) <> ","
1326 , "but", "you", "are", "using"
691 , "but", "you", "are", "using"
1327− , D.red (D.fromVersion V.compiler)
692+ , D.red (D.fromUtf8 (V.toString V.compiler))
1328 , "right", "now."
693 , "right", "now."
1329 ]
694 ]
1330 ]
695 ]
1331
696
1332 DetailsHandEditedDependencies ->
697 DetailsHandEditedDependencies ->
1333− Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
698+ error "TODO DetailsHandEditedDependencies"
1334− "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335− \ party tool) leaving them in an invalid state."
1336− [ D.fillSep
1337− ["Try","to","change","them","back","to","what","they","were","before!"
1338− ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339− ]
1340− , D.reflow $
1341− "Please ask for help on the community forums if you try those paths and are still\
1342− \ having problems!"
1343− ]
1344
699
1345− DetailsBadOutline outline ->
700+ DetailsBadOutline problem ->
1346− toOutlineReport outline
701+ error "TODO DetailsBadOutline" problem
1347
702
1348 DetailsCannotGetRegistry problem ->
703 DetailsCannotGetRegistry problem ->
1349− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
704+ error "TODO DetailsCannotGetRegistry" problem
1350− "I need the list of published packages to verify your dependencies"
1351−
1352− DetailsBadDeps cacheDir deps ->
1353− case List.sortOn toBadDepRank deps of
1354− [] ->
1355− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356− "I am not sure what is going wrong though."
1357− [ D.reflow $
1358− "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359− \ trying to build again. That will work if some cached files got corrupted\
1360− \ somehow."
1361− , D.reflow $
1362− "If that does not work, go to https://elm-lang.org/community and ask for\
1363− \ help. This is a weird case!"
1364− ]
1365−
1366− d:_ ->
1367− case d of
1368− BD_BadDownload pkg vsn packageProblem ->
1369− toPackageProblemReport pkg vsn packageProblem
1370−
1371− BD_BadBuild pkg vsn fingerprint ->
1372− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1373− "I ran into a compilation error when trying to build the following package:"
1374− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
1375− , D.reflow $
1376− "This probably means it has package constraints that are too wide. It may be\
1377− \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\
1378− \ over to https://elm-lang.org/community to get help figuring out how to take\
1379− \ this path!"
1380− , D.toSimpleNote $
1381− "To help with the root problem, please report this to the package author along\
1382− \ with the following information:"
1383− , D.indent 4 $ D.vcat $
1384− map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $
1385− Map.toList fingerprint
1386− , D.reflow $
1387− "If you want to help out even more, try building the package locally. That should\
1388− \ give you much more specific information about why this package is failing to\
1389− \ build, which will in turn make it easier for the package author to fix it!"
1390− ]
1391−
1392−
1393−toBadDepRank :: DetailsBadDep -> Int -- lower is better
1394−toBadDepRank badDep =
1395− case badDep of
1396− BD_BadDownload _ _ _ -> 0
1397− BD_BadBuild _ _ _ -> 1
1398−
1399−
1400−
1401−-- PACKAGE PROBLEM
1402−
1403−
1404−data PackageProblem
1405− = PP_BadEndpointRequest Http.Error
1406− | PP_BadEndpointContent String
1407− | PP_BadArchiveRequest Http.Error
1408− | PP_BadArchiveContent String
1409− | PP_BadArchiveHash String String String
1410−
1411−
1412−toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report
1413−toPackageProblemReport pkg vsn problem =
1414− let
1415− thePackage =
1416− Pkg.toChars pkg ++ " " ++ V.toChars vsn
1417− in
1418− case problem of
1419− PP_BadEndpointRequest httpError ->
1420− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1421− "I need to find the latest download link for " ++ thePackage
1422−
1423− PP_BadEndpointContent url ->
1424− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1425− (
1426− "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"
1427− )
1428− [ D.indent 4 $ D.dullyellow $ D.fromChars url
1429− , D.reflow $
1430− "Is something weird with your internet connection. We have gotten reports that\
1431− \ schools, businesses, airports, etc. sometimes intercept requests and add things\
1432− \ to the body or change its contents entirely. Could that be the problem?"
1433− ]
1434−
1435− PP_BadArchiveRequest httpError ->
1436− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $
1437− "I was trying to download the source code for " ++ thePackage
1438
705
1439− PP_BadArchiveContent url ->
706+ DetailsCannotBuildPackage name version problem ->
1440− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
707+ error "TODO DetailsCannotBuildPackage" name version problem
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
708
1452− PP_BadArchiveHash url expectedHash actualHash ->
709+ DetailsNoSolution ->
1453− Help.report "CORRUPT PACKAGE DATA" Nothing
710+ error "TODO DetailsNoSolution"
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
711
712+ DetailsNoOfflineSolution ->
713+ error "TODO DetailsNoOfflineSolution"
1583
714
715+ DetailsSolverProblem _ ->
716+ error "TODO DetailsSolverProblem"
1584
717
1585−-- MAKE
1586−
1587−
1588−data Make
1589− = MakeNoOutline
1590− | MakeCannotOptimizeAndDebug
1591− | MakeBadDetails Details
1592− | MakeAppNeedsFileNames
1593− | MakePkgNeedsExposing
1594− | MakeMultipleFilesIntoHtml
1595− | MakeNoMain
1596− | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597− | MakeCannotBuild BuildProblem
1598− | MakeBadGenerate Generate
1599
718
1600
719
1601makeToReport :: Make -> Help.Report
720makeToReport :: Make -> Help.Report
1602makeToReport make =
721makeToReport make =
1603 case make of
722 case make of
1604− MakeNoOutline ->
723+ MakeNeedsOutline ->
1605 Help.report "NO elm.json FILE" Nothing
724 Help.report "NO elm.json FILE" Nothing
1606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
725 "It looks like you are starting a new Elm project. Very exciting! Try running:"
1607 [ D.indent 4 $ D.green $ "elm init"
726 [ D.indent 4 $ D.green $ "elm init"
@@ -1622,344 +741,27 @@ makeToReport make =
1622 \ at once though! Pick just one of those flags and it should work!"
741 \ at once though! Pick just one of those flags and it should work!"
1623 ]
742 ]
1624
743
1625− MakeBadDetails detailsProblem ->
744+ MakeBlockedByDetailsProblem detailsProblem ->
1626− toDetailsReport detailsProblem
745+ detailsToReport detailsProblem
1627
746
1628 MakeAppNeedsFileNames ->
747 MakeAppNeedsFileNames ->
1629 Help.report "NO INPUT" Nothing
748 Help.report "NO INPUT" Nothing
1630− "What should I make though? I need specific files like:"
749+ "What should I make though? I need a specific file like this:"
1631− [ D.vcat
1632− [ D.indent 4 $ D.green "elm make src/Main.elm"
750+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1633− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1634− ]
1635− , D.reflow $
751+ , D.reflow
1636− "I recommend reading through https://guide.elm-lang.org for guidance on what to\
752+ "However many files you give, I will create one JS file out of them."
1637− \ actually put in those files!"
1638 ]
753 ]
1639
754
1640 MakePkgNeedsExposing ->
755 MakePkgNeedsExposing ->
1641− Help.report "NO INPUT" Nothing
756+ error "TODO MakePkgNeedsExposing"
1642− "What should I make though? I need specific files like:"
1643− [ D.vcat
1644− [ D.indent 4 $ D.green "elm make src/Main.elm"
1645− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646− ]
1647− , D.reflow $
1648− "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649− \ I will try to compile the relevant files."
1650− ]
1651
757
1652 MakeMultipleFilesIntoHtml ->
758 MakeMultipleFilesIntoHtml ->
1653− Help.report "TOO MANY FILES" Nothing
759+ error "TODO MakeMultipleFilesIntoHtml"
1654− (
1655− "When producing an HTML file, I can only handle one file."
1656− )
1657− [ D.fillSep
1658− ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"
1659− ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"
1660− ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."
1661− ]
1662− , D.fillSep
1663− ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"
1664− ,"`main`","values","available","in","a","single","JavaScript","file.","Then"
1665− ,"you","can","make","your","own","customized","HTML","file","that","embeds"
1666− ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"
1667− ,"dependencies","between","modules,","so","it","should","be","smaller","than"
1668− ,"compiling","each","module","separately."
1669− ]
1670− ]
1671
760
1672− MakeNoMain ->
761+ MakeNonMainFilesIntoJavaScript _ _ ->
1673− Help.report "NO MAIN" Nothing
762+ error "TODO MakeNonMainFilesIntoJavaScript"
1674− (
1675− "When producing an HTML file, I require that the given file has a `main` value.\
1676− \ That way I have something to show on screen!"
1677− )
1678− [ D.reflow $
1679− "Try adding a `main` value to your file? Or if you just want to verify that this\
1680− \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1681− \ altogether."
1682− , D.toSimpleNote $
1683− "Adding a `main` value can be as brief as adding something like this:"
1684− , D.vcat
1685− [ D.fillSep [D.cyan "import","Html"]
1686− , ""
1687− , D.fillSep [D.green "main","="]
1688− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1689− ]
1690− , D.reflow $
1691− "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\
1692− \ looking through https://guide.elm-lang.org for more guidance on how to fill in\
1693− \ the `main` value."
1694− ]
1695
763
1696− MakeNonMainFilesIntoJavaScript m ms ->
764+ MakeCannotOptimizeDebugValues 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 ->
1963 Help.report "DEBUG REMNANTS" Nothing
765 Help.report "DEBUG REMNANTS" Nothing
1964 "There are uses of the `Debug` module in the following modules:"
766 "There are uses of the `Debug` module in the following modules:"
1965 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
767 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)
@@ -1968,7 +770,7 @@ toGenerateReport problem =
1968 "The issue is that --optimize strips out info needed by `Debug` functions.\
770 "The issue is that --optimize strips out info needed by `Debug` functions.\
1969 \ Here are two examples:"
771 \ Here are two examples:"
1970 , D.indent 4 $ D.reflow $
772 , D.indent 4 $ D.reflow $
1971− "(1) It shortens record field names. This makes the generated JavaScript\
773+ "(1) It shortens record field names. This makes the generated JavaScript is\
1972 \ smaller, but `Debug.toString` cannot know the real field names anymore."
774 \ smaller, but `Debug.toString` cannot know the real field names anymore."
1973 , D.indent 4 $ D.reflow $
775 , D.indent 4 $ D.reflow $
1974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
776 "(2) Values like `type Height = Height Float` are unboxed. This reduces\
@@ -1981,89 +783,28 @@ toGenerateReport problem =
1981 \ exists!"
783 \ exists!"
1982 ]
784 ]
1983
785
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+ ]
1984
804
1985
805
1986−-- CORRUPT CACHE
806+ BuildModuleProblems p ps ->
1987−
807+ error "TODO MakeCannotBuild" p ps
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
2067
808
2068− ReplBlocked ->
809+ MakeCannotLoadArtifacts ->
2069− corruptCacheReport
810+ error "TODO MakeCannotLoadArtifacts"
builder/src/Reporting/Exit/Assets.hsnew file+227
@@ -0,0 +1,227 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Assets
3+ ( Exit(..)
4+ , ElmJsonProblem(..)
5+ , toReport
6+ , BadElmJsonContent(..)
7+ , badContentToDocs
8+ )
9+ where
10+
11+
12+import qualified Data.Text as Text
13+
14+import qualified Elm.Package as Pkg
15+import Reporting.Doc ((<>))
16+import qualified Reporting.Doc as D
17+import qualified Reporting.Exit.Help as Help
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit
25+ = BadElmJson ElmJsonProblem
26+ | CorruptElmJson Pkg.Name Pkg.Version
27+ | CorruptDocumentation Pkg.Name Pkg.Version
28+ | CorruptBinary FilePath FilePath
29+
30+
31+
32+-- ELM JSON PROBLEM
33+
34+
35+data ElmJsonProblem
36+ = BadJson D.Doc
37+ | BadSrcDir FilePath
38+ | NoPkgCore
39+ | NoAppCore
40+ | NoAppJson
41+
42+
43+
44+-- TO REPORT
45+
46+
47+toReport :: Exit -> Help.Report
48+toReport exit =
49+ case exit of
50+ CorruptElmJson pkg vsn ->
51+ corruptJsonToReport "elm.json" pkg vsn
52+
53+ CorruptDocumentation pkg vsn ->
54+ corruptJsonToReport "docs.json" pkg vsn
55+
56+ CorruptBinary elmHome path ->
57+ Help.report "CORRUPT BINARY" (Just path)
58+ ("The binary data at " ++ path ++ " is corrupt.")
59+ [ D.reflow "Elm caches build artifacts in the following directories:"
60+ , D.dullyellow $ D.indent 4 $ D.vcat $
61+ [ D.fromString elmHome
62+ , "elm-stuff/"
63+ ]
64+ , D.reflow
65+ "Maybe you recently installed a command line tool or editor plugin that messes\
66+ \ with them? They definitely should not be doing that, but you never know! So\
67+ \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68+ \ help reveal the corrupting influence."
69+ ]
70+
71+ BadElmJson problem ->
72+ elmJsonProblemToReport problem
73+
74+
75+
76+-- CORRUPT JSON
77+
78+
79+corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80+corruptJsonToReport path pkg vsn =
81+ Help.report "CORRUPT JSON" Nothing
82+ ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83+ ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84+ )
85+ [ D.reflow $
86+ "I removed it from my file cache, so if it was some transient\
87+ \ error it should be fixed if you try the same thing again.\
88+ \ Please report this if it seems like an Elm problem though!"
89+ ]
90+
91+
92+
93+-- BAD ELM JSON
94+
95+
96+elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97+elmJsonProblemToReport problem =
98+ case problem of
99+ BadJson doc ->
100+ Help.jsonReport "BAD JSON" (Just "elm.json") doc
101+
102+ BadSrcDir dir ->
103+ Help.report "BAD JSON" (Just "elm.json")
104+ "The \"source-directories\" in your elm.json lists the following directory:"
105+ [ D.indent 4 (D.dullyellow (D.fromString dir))
106+ , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107+ ]
108+
109+ NoPkgCore ->
110+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
111+ "A package must have \"elm/core\" as a dependency. Try running:"
112+ [ D.indent 4 $ D.green $ "elm install elm/core"
113+ , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114+ ]
115+
116+ NoAppCore ->
117+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
118+ "An application must have \"elm/core\" as a dependency. Try running:"
119+ [ D.indent 4 $ D.green $ "elm install elm/core"
120+ , D.reflow "It has some supporting code that is needed by every Elm application!"
121+ ]
122+
123+ NoAppJson ->
124+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
125+ "An application must have \"elm/json\" as a dependency. Try running:"
126+ [ D.indent 4 $ D.green $ "elm install elm/json"
127+ , D.reflow "It helps me handle flags and ports."
128+ ]
129+
130+
131+
132+-- PROBLEM TO DOCS
133+
134+
135+data BadElmJsonContent
136+ = BadType Text.Text
137+ | BadPkgName String
138+ | BadVersion Text.Text
139+ | BadConstraint String
140+ | BadModuleName Text.Text
141+ | BadModuleHeaderTooLong Text.Text
142+ | BadDependencyName Text.Text
143+ | BadLicense Text.Text [Text.Text]
144+ | BadDirectoryNotString
145+ | BadSummaryTooLong
146+
147+
148+badContentToDocs :: BadElmJsonContent -> [D.Doc]
149+badContentToDocs badContent =
150+ case badContent of
151+ BadType _ ->
152+ ["The","only","valid","types","of","elm.json","are"
153+ ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154+ ]
155+
156+ BadPkgName problem ->
157+ map D.fromString (words problem)
158+
159+ BadVersion txt ->
160+ ["You","provided",D.red (D.fromString (show txt))
161+ ,"which","is","not","a","valid","version.","I","need","something","like"
162+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163+ ]
164+
165+ BadConstraint problem ->
166+ map D.fromString (words ("It is not a valid constraint. " ++ problem))
167+
168+ BadModuleName name ->
169+ ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170+ ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171+ ]
172+
173+ BadModuleHeaderTooLong header ->
174+ ["The",D.fromString (show header),"header","is","too","long."
175+ ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176+ ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177+ ]
178+
179+ BadDependencyName name ->
180+ ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181+ ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182+ ,"the","package","website,","and","installing","it","with","the"
183+ ,D.green "`elm install`","command","instead."
184+ ]
185+
186+ BadLicense _given suggestions ->
187+ case suggestions of
188+ [] ->
189+ ["I","need","an","OSI","approved","SPDX","license,","like"
190+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191+ ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192+ ]
193+
194+ code:codes ->
195+ ["I","need","an","OSI","approved","SPDX","license."]
196+ ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197+ ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198+
199+ BadDirectoryNotString ->
200+ ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201+ ]
202+
203+ BadSummaryTooLong ->
204+ ["Your","summary","is","too","long.","I","need","it","to"
205+ ,"be",D.green "under",D.green "80",D.green "characters."
206+ ]
207+
208+
209+oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210+oneOf code codes =
211+ let
212+ toDoc spdx =
213+ D.green (D.fromString (show spdx))
214+ in
215+ case codes of
216+ [] ->
217+ [toDoc code]
218+
219+ [code2] ->
220+ [toDoc code,"or",toDoc code2]
221+
222+ _:_ ->
223+ let
224+ these = code : init codes
225+ final = last codes
226+ in
227+ map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Compile.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Exit.Compile
4+ ( Exit(..)
5+ , toJson
6+ , toDoc
7+ )
8+ where
9+
10+
11+import qualified Data.List as List
12+import qualified Data.Time.Clock as Time
13+
14+import qualified Elm.Compiler as Compiler
15+import qualified Elm.ModuleName as ModuleName
16+import qualified Json.Encode as Encode
17+import qualified Reporting.Doc as D
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit =
25+ Exit
26+ { _name :: ModuleName.Raw
27+ , _path :: FilePath
28+ , _time :: Time.UTCTime
29+ , _source :: String
30+ , _errors :: [Compiler.Error]
31+ }
32+
33+
34+
35+-- TO JSON
36+
37+
38+toJson :: Exit -> Encode.Value
39+toJson (Exit name path _ source errors) =
40+ Compiler.errorsToJson name path source errors
41+
42+
43+
44+-- TO DOC
45+
46+
47+toDoc :: Exit -> [Exit] -> D.Doc
48+toDoc e es =
49+ let
50+ (exit, exits) = sortByTime e es
51+ in
52+ D.vcat (toDocHelp exit exits)
53+
54+
55+toDocHelp :: Exit -> [Exit] -> [D.Doc]
56+toDocHelp e1 exits =
57+ case exits of
58+ [] ->
59+ [exitToDoc e1]
60+
61+ e2 : otherErrors ->
62+ exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors
63+
64+
65+exitToDoc :: Exit -> D.Doc
66+exitToDoc (Exit _name path _time source errors) =
67+ Compiler.errorsToDoc path source errors
68+
69+
70+separator :: ModuleName.Raw -> ModuleName.Raw -> D.Doc
71+separator beforeName afterName =
72+ let
73+ before = ModuleName.nameToChars beforeName ++ " ↑ "
74+ after = " ↓ " ++ ModuleName.nameToChars afterName
75+ in
76+ D.dullred $ D.vcat $
77+ [ D.indent (80 - length before) (D.fromChars before)
78+ , "====o======================================================================o===="
79+ , D.fromChars after
80+ , D.empty
81+ , D.empty
82+ ]
83+
84+
85+
86+-- SORT BY TIME
87+
88+
89+sortByTime :: Exit -> [Exit] -> (Exit, [Exit])
90+sortByTime exit exits =
91+ case List.sortBy timeCompare exits of
92+ [] ->
93+ (exit, [])
94+
95+ e:es ->
96+ if _time exit < _time e then
97+ (exit, e:es)
98+ else
99+ (e, List.insertBy timeCompare exit es)
100+
101+
102+timeCompare :: Exit -> Exit -> Ordering
103+timeCompare e1 e2 =
104+ compare (_time e1) (_time e2)
builder/src/Reporting/Exit/Crawl.hsnew file+345
@@ -0,0 +1,345 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Crawl
3+ ( Exit(..)
4+ , Problem(..)
5+ , Origin(..)
6+ , SrcDirs(..)
7+ , toReport
8+ )
9+ where
10+
11+
12+import qualified Data.Char as Char
13+import qualified Data.Map as Map
14+import qualified Data.Time.Clock as Time
15+
16+import qualified Elm.Compiler as Compiler
17+import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Package as Pkg
19+import qualified Elm.Version as V
20+import Reporting.Doc ((<+>), (<>))
21+import qualified Reporting.Doc as D
22+import qualified Reporting.Exit.Compile as Compile
23+import qualified Reporting.Exit.Help as Help
24+
25+
26+
27+-- EXIT
28+
29+
30+data Exit
31+ = RootFileNotFound FilePath
32+ | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33+ | RootNameless FilePath
34+ | DependencyProblems Problem [Problem]
35+ | BadKernelHeader FilePath
36+
37+
38+data Problem
39+ = ModuleNotFound Origin ModuleName.Raw SrcDirs
40+ | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41+ | BadHeader FilePath Time.UTCTime String Compiler.Error
42+ | ModuleNameReservedForKernel Origin ModuleName.Raw
43+ | ModuleNameMissing FilePath ModuleName.Raw
44+ | ModuleNameMismatch
45+ FilePath
46+ ModuleName.Raw -- expected
47+ ModuleName.Raw -- actual
48+ | PortsInPackage FilePath ModuleName.Raw
49+ | EffectsUnexpected FilePath ModuleName.Raw
50+
51+
52+data Origin
53+ = ElmJson
54+ | File FilePath
55+ | Module FilePath ModuleName.Raw
56+
57+
58+data SrcDirs
59+ = App [FilePath]
60+ | Pkg
61+
62+
63+
64+-- TO REPORT
65+
66+
67+toReport :: Exit -> Help.Report
68+toReport exit =
69+ case exit of
70+ RootFileNotFound path ->
71+ Help.report "FILE NOT FOUND" Nothing
72+ "You want me to compile this file:"
73+ [ D.indent 4 $ D.dullyellow $ D.fromChars path
74+ , "I cannot find it though! Is there a typo?"
75+ ]
76+
77+ RootModuleNameDuplicate name paths ->
78+ Help.report "DUPLICATE NAMES" Nothing
79+ "I am trying to compile multiple modules with the same name:"
80+ [ D.indent 4 $ D.dullyellow $ D.vcat $
81+ map D.fromChars paths
82+ , D.fillSep $
83+ [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84+ , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85+ , "Change", "them", "to", "have", "unique", "names", "and", "you"
86+ , "should", "be", "all", "set!"
87+ ]
88+ ]
89+
90+ RootNameless path ->
91+ namelessToDoc path "Main"
92+
93+ DependencyProblems problem otherProblems ->
94+ case otherProblems of
95+ [] ->
96+ problemToReport problem
97+
98+ _ ->
99+ problemToReport problem
100+ -- error "TODO handle multiple dependency errors"
101+
102+ BadKernelHeader filePath ->
103+ Help.report "BAD KERNEL HEADER" Nothing
104+ "I ran into a bad header in this file:"
105+ [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106+ , D.reflow $
107+ "NOTE: Kernel code is only available to core Elm libraries to ensure\
108+ \ the portability and security of the Elm ecosystem. This restriction\
109+ \ also makes it possible to improve code gen (i.e. performance) without\
110+ \ disrupting the ecosystem."
111+ ]
112+
113+
114+
115+-- PROBLEM TO REPORT
116+
117+
118+problemToReport :: Problem -> Help.Report
119+problemToReport problem =
120+ case problem of
121+ ModuleNotFound origin name srcDirs ->
122+ notFoundToDoc origin name srcDirs
123+
124+ ModuleAmbiguous origin child paths pkgs ->
125+ ambiguousToDoc origin child paths pkgs
126+
127+ BadHeader path time source compilerError ->
128+ let
129+ compilerExit =
130+ Compile.Exit "???" path time source [compilerError]
131+ in
132+ Help.compilerReport compilerExit []
133+
134+ ModuleNameMissing path name ->
135+ namelessToDoc path name
136+
137+ ModuleNameMismatch path expected actual ->
138+ Help.report "MODULE NAME MISMATCH" (Just path)
139+ ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140+ )
141+ [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142+ , "Looks like a typo or copy/paste error. Instead it needs to say:"
143+ , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144+ , "Make the change and you should be all set!"
145+ ]
146+
147+ ModuleNameReservedForKernel origin name ->
148+ kernelNameToDoc origin name
149+
150+ PortsInPackage path name ->
151+ badTagToDoc path name "port" "port-modules" $
152+ "Packages cannot have any `port` modules."
153+
154+ EffectsUnexpected path name ->
155+ badTagToDoc path name "effect" "effect-modules" $
156+ "Creating `effect` modules is relatively experimental. There are a\
157+ \ couple in @elm repos right now, but we have decided to be very\
158+ \ cautious in expanding its usage."
159+
160+
161+badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162+badTagToDoc path name tag hintName summary =
163+ Help.report
164+ ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165+ (Just path)
166+ summary
167+ [ D.fillSep $
168+ [ "Get", "rid", "of", "all", "the"
169+ , D.red (D.fromChars tag)
170+ , "stuff", "in"
171+ , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172+ , "to", "proceed."
173+ ]
174+ , D.toSimpleNote $
175+ "You can learn the reasoning behind this design choice at "
176+ ++ D.makeLink hintName
177+ ]
178+
179+
180+
181+-- NAMELESS
182+
183+
184+namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185+namelessToDoc path name =
186+ Help.report "UNNAMED MODULE" (Just path)
187+ ( "The `" ++ ModuleName.nameToChars name
188+ ++ "` module must start with a line like this:"
189+ )
190+ [ D.indent 4 $ D.dullyellow $ D.fromChars $
191+ "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192+ , D.reflow $
193+ "Try adding that as the first line of your file!"
194+ , D.toSimpleNote $
195+ "It is best to replace (..) with an explicit list of types and\
196+ \ functions you want to expose. If you know a value is only used\
197+ \ WITHIN this module, it is extra easy to refactor. This kind of\
198+ \ information is great, especially as your project grows!"
199+ ]
200+
201+
202+
203+-- NOT FOUND
204+
205+
206+notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207+notFoundToDoc origin child srcDirs =
208+ case origin of
209+ ElmJson ->
210+ Help.report "MODULE NOT FOUND" (Just "elm.json")
211+ "Your elm.json says your project has the following module:"
212+ [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213+ , D.reflow $
214+ "When creating packages, all modules must live in the src/ directory."
215+ ]
216+
217+ File path ->
218+ Help.report "UNKNOWN IMPORT" (Just path)
219+ ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220+ (notFoundDetails child srcDirs)
221+
222+ Module path parent ->
223+ Help.report "UNKNOWN IMPORT" (Just path)
224+ ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225+ (notFoundDetails child srcDirs)
226+
227+
228+notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229+notFoundDetails child srcDirs =
230+ let
231+ simulatedCode =
232+ D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233+ in
234+ case Map.lookup child Pkg.suggestions of
235+ Just pkg ->
236+ [ simulatedCode
237+ , D.reflow $
238+ "Do you want the one from the " ++ Pkg.toChars pkg
239+ ++ " package? If so, run this command to add that dependency to your elm.json file:"
240+ , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241+ , case srcDirs of
242+ Pkg ->
243+ D.reflow $
244+ "If you want a local file, make sure the `"
245+ ++ ModuleName.nameToChars child
246+ ++ "` module is in your src/ directory."
247+
248+ App _ ->
249+ D.reflow $
250+ "If you want a local file, make sure the `"
251+ ++ ModuleName.nameToChars child
252+ ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253+ ]
254+
255+ Nothing ->
256+ [ simulatedCode
257+ , "I cannot find that module! Is there a typo in the module name?"
258+ , D.reflow $
259+ case srcDirs of
260+ Pkg ->
261+ "When creating a package, all modules must live in the src/ directory."
262+
263+ App [] ->
264+ "The \"source-directories\" field of your elm.json is empty, so I only\
265+ \ searched in packages. Maybe you need to add a \"src\" directory there?"
266+
267+ App [dir] ->
268+ "The \"source-directories\" field of your elm.json tells me to only look in the "
269+ ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270+
271+ App (dir:_:_) ->
272+ "The \"source-directories\" field of your elm.json tells me to look in directories like "
273+ ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274+ ]
275+
276+
277+ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278+ambiguousToDoc origin child paths pkgs =
279+ let
280+ pkgToString (Pkg.Canonical pkg vsn) =
281+ "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282+
283+ makeReport maybePath summary yellowString =
284+ Help.report "AMBIGUOUS IMPORT" maybePath summary
285+ [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286+ , D.reflow $
287+ "I found multiple module with that name though:"
288+ , D.indent 4 $ D.dullyellow $ D.vcat $
289+ map D.fromChars $ paths ++ map pkgToString pkgs
290+ , D.reflow $
291+ if null paths then
292+ "It looks like the name clash is in your dependencies, which is\
293+ \ out of your control. Elm does not support this scenario right\
294+ \ now, but it may be worthwhile. Please open an issue describing\
295+ \ your scenario so we can gather more usage information!"
296+ else
297+ "Which is the right one? Try renaming your modules to have unique names."
298+ ]
299+ in
300+ case origin of
301+ ElmJson ->
302+ makeReport
303+ Nothing
304+ "Your elm.json wants the following module:"
305+ (ModuleName.nameToChars child)
306+
307+ File path ->
308+ makeReport
309+ (Just path)
310+ ("The file at " ++ path ++ " has an ambiguous import:")
311+ ("import " ++ ModuleName.nameToChars child)
312+
313+ Module path parent ->
314+ makeReport
315+ (Just path)
316+ ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317+ ("import " ++ ModuleName.nameToChars child)
318+
319+
320+kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321+kernelNameToDoc origin kernelName =
322+ let
323+ (maybePath, statement) =
324+ case origin of
325+ ElmJson ->
326+ ( Nothing
327+ , "Your elm.json says your project has the following module:"
328+ )
329+
330+ File path ->
331+ ( Just path
332+ , "This file is trying to import the following module:"
333+ )
334+
335+ Module path parent ->
336+ ( Just path
337+ , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338+ )
339+ in
340+ Help.report "BAD MODULE NAME" maybePath statement
341+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342+ , D.reflow $
343+ "But names like that are reserved for internal use.\
344+ \ Switch to a name outside of the Elm/Kernel/ namespace."
345+ ]
builder/src/Reporting/Exit/Deps.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Deps
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Constraint as Con
10+import qualified Elm.Package as Pkg
11+import qualified Elm.Version as V
12+import Reporting.Doc ((<>))
13+import qualified Reporting.Doc as D
14+import qualified Reporting.Exit.Help as Help
15+
16+
17+
18+-- EXITS
19+
20+
21+data Exit
22+ = CorruptVersionCache FilePath Pkg.Name
23+ | PackageNotFound Pkg.Name [Pkg.Name]
24+ -- verify
25+ | PkgBadElm Con.Constraint
26+ | AppBadElm V.Version
27+ | AppMissingTrans [(Pkg.Name, V.Version)]
28+ | BadDeps
29+ | BuildFailure FilePath Pkg.Name V.Version
30+
31+
32+
33+-- TO DOC
34+
35+
36+toReport :: Exit -> Help.Report
37+toReport exit =
38+ case exit of
39+ CorruptVersionCache elmHome pkg ->
40+ Help.report "CORRUPT CACHE" Nothing
41+ ( "I ran into an unknown package while exploring dependencies:"
42+ )
43+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44+ , D.reflow $
45+ "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46+ \ Maybe some program is messing with it? It is just cached files,\
47+ \ so you can delete it and see if that fixes the issue."
48+ ]
49+
50+ PackageNotFound package suggestions ->
51+ Help.docReport "PACKAGE NOT FOUND" Nothing
52+ ( D.fillSep
53+ ["I","cannot","find","a"
54+ ,D.red (D.fromUtf8 (Pkg.toString package))
55+ ,"package","on","the","package","website."
56+ ]
57+ )
58+ [ "Maybe you want one of these instead?"
59+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60+ , "But check <https://package.elm-lang.org> to see all possibilities!"
61+ ]
62+
63+ PkgBadElm constraint ->
64+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65+ "Your elm.json says this package needs a version of Elm in this range:"
66+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67+ , D.fillSep
68+ [ "But", "you", "are", "using", "Elm"
69+ , D.red (D.fromUtf8 (V.toString V.compiler))
70+ , "right", "now."
71+ ]
72+ ]
73+
74+ AppBadElm version ->
75+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76+ "Your elm.json says this application needs a different version of Elm."
77+ [ D.fillSep
78+ [ "It", "requires"
79+ , D.green (D.fromUtf8 (V.toString version)) <> ","
80+ , "but", "you", "are", "using"
81+ , D.red (D.fromUtf8 (V.toString V.compiler))
82+ , "right", "now."
83+ ]
84+ ]
85+
86+ AppMissingTrans missingDeps ->
87+ let
88+ toEntry (pkg, vsn) =
89+ "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90+ in
91+ Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92+ "Your elm.json is missing some \"indirect\" dependencies:"
93+ [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94+ , D.fillSep
95+ ["This","usually","means","you","are","editing","elm.json","by","hand."
96+ ,"It","is","much","more","reliable","to","use","the"
97+ ,D.green "elm install","command","instead."
98+ ]
99+ ]
100+
101+ BadDeps ->
102+ Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103+ "The dependencies in your elm.json are not compatible."
104+ [ D.fillSep
105+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106+ ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107+ ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108+ ]
109+ , D.reflow $
110+ "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111+ \ you try those paths and still cannot figure it out!"
112+ ]
113+
114+ BuildFailure elmHome pkg vsn ->
115+ Help.report "CORRUPT DEPENDENCY" Nothing
116+ "I ran into a problem while building the following package:"
117+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118+ , D.fillSep
119+ ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120+ ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121+ ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122+ ]
123+ ]
builder/src/Reporting/Exit/Help.hs+12−11
@@ -14,6 +14,7 @@ module Reporting.Exit.Help
14 where
14 where
15
15
16
16
17+import qualified Data.Utf8 as Utf8
17import GHC.IO.Handle (hIsTerminalDevice)
18import GHC.IO.Handle (hIsTerminalDevice)
18import System.IO (Handle, hPutStr, stderr, stdout)
19import System.IO (Handle, hPutStr, stderr, stdout)
19
20
@@ -21,7 +22,7 @@ import qualified Json.Encode as E
21import Json.Encode ((==>))
22import Json.Encode ((==>))
22import Reporting.Doc ((<+>))
23import Reporting.Doc ((<+>))
23import qualified Reporting.Doc as D
24import qualified Reporting.Doc as D
24−import qualified Reporting.Error as Error
25+import qualified Reporting.Exit.Compile as Compile
25
26
26
27
27
28
@@ -29,7 +30,7 @@ import qualified Reporting.Error as Error
29
30
30
31
31data Report
32data Report
32− = CompilerReport FilePath Error.Module [Error.Module]
33+ = CompilerReport Compile.Exit [Compile.Exit]
33 | Report
34 | Report
34 { _title :: String
35 { _title :: String
35 , _path :: Maybe FilePath
36 , _path :: Maybe FilePath
@@ -52,7 +53,7 @@ jsonReport =
52 Report
53 Report
53
54
54
55
55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
56+compilerReport :: Compile.Exit -> [Compile.Exit] -> Report
56compilerReport =
57compilerReport =
57 CompilerReport
58 CompilerReport
58
59
@@ -64,8 +65,8 @@ compilerReport =
64reportToDoc :: Report -> D.Doc
65reportToDoc :: Report -> D.Doc
65reportToDoc report_ =
66reportToDoc report_ =
66 case report_ of
67 case report_ of
67− CompilerReport root e es ->
68+ CompilerReport e es ->
68− Error.toDoc root e es
69+ Compile.toDoc e es
69
70
70 Report title maybePath message ->
71 Report title maybePath message ->
71 let
72 let
@@ -94,17 +95,17 @@ reportToDoc report_ =
94reportToJson :: Report -> E.Value
95reportToJson :: Report -> E.Value
95reportToJson report_ =
96reportToJson report_ =
96 case report_ of
97 case report_ of
97− CompilerReport _ e es ->
98+ CompilerReport e es ->
98 E.object
99 E.object
99− [ "type" ==> E.chars "compile-errors"
100+ [ "type" ==> E.string "compile-errors"
100− , "errors" ==> E.list Error.toJson (e:es)
101+ , "errors" ==> E.list Compile.toJson (e:es)
101 ]
102 ]
102
103
103 Report title maybePath message ->
104 Report title maybePath message ->
104 E.object
105 E.object
105− [ "type" ==> E.chars "error"
106+ [ "type" ==> E.string "error"
106− , "path" ==> maybe E.null E.chars maybePath
107+ , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath
107− , "title" ==> E.chars title
108+ , "title" ==> E.string (Utf8.fromChars title)
108 , "message" ==> D.encode message
109 , "message" ==> D.encode message
109 ]
110 ]
110
111
builder/src/Reporting/Exit/Http.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Http
3+ ( Exit(..)
4+ , toReport
5+ , BadJson(..)
6+ , badJsonToDocs
7+ )
8+ where
9+
10+
11+import qualified Data.Text as Text
12+
13+import Reporting.Doc ((<>))
14+import qualified Reporting.Doc as D
15+import qualified Reporting.Exit.Help as Help
16+
17+
18+
19+-- EXITS
20+
21+
22+data Exit
23+ = Unknown String
24+ | BadJson String D.Doc
25+ | BadZipData
26+ | BadZipSha String String
27+
28+
29+
30+-- TO REPORT
31+
32+
33+toReport :: String -> Exit -> Help.Report
34+toReport url exit =
35+ let
36+ urlDoc =
37+ D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38+ in
39+ case exit of
40+ Unknown message ->
41+ Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42+ [ urlDoc
43+ , D.stack
44+ [ "Here is the error message I was able to extract:"
45+ , D.indent 4 $ D.reflow message
46+ ]
47+ ]
48+
49+ BadJson path doc ->
50+ Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51+
52+ BadZipData ->
53+ Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54+ [ urlDoc
55+ , D.reflow $
56+ "If it is a transient issue, it should be fixed if you try this\
57+ \ again. If it seems like an Elm problem, please report it though!"
58+ ]
59+
60+ BadZipSha expectedHash actualHash ->
61+ Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62+ [ urlDoc
63+ , D.reflow "I check the hash the zip, and it seems off:"
64+ , D.vcat $ map D.fromString $
65+ [ " Expected: " ++ expectedHash
66+ , " Actual: " ++ actualHash
67+ ]
68+ , D.reflow $
69+ "This usually means that the package author moved the version\
70+ \ tag, so report it to them and see if that is the issue. Folks\
71+ \ on Elm slack can probably help as well."
72+ ]
73+
74+
75+
76+-- BAD JSON
77+
78+
79+data BadJson
80+ = BadNewPkg Text.Text
81+ | BadAllPkg Text.Text String
82+ | BadAllVsn Text.Text
83+
84+
85+badJsonToDocs :: BadJson -> [D.Doc]
86+badJsonToDocs badJson =
87+ case badJson of
88+ BadNewPkg txt ->
89+ ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90+ ,"but","I","need","entries","like"
91+ ,D.green "\"elm/core@6.0.0\"" <> "."
92+ ]
93+
94+ BadAllPkg txt suggestion ->
95+ ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96+ ]
97+ ++ map D.fromString (words suggestion)
98+
99+ BadAllVsn txt ->
100+ ["You","provided",D.red (D.fromString (show txt))
101+ ,"which","is","not","a","valid","version.","I","need","something","like"
102+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103+ ]
104+
builder/src/Reporting/Task.hs−17
@@ -3,10 +3,8 @@ module Reporting.Task
3 ( Task
3 ( Task
4 , run
4 , run
5 , throw
5 , throw
6− , mapError
7 --
6 --
8 , io
7 , io
9− , mio
10 , eio
8 , eio
11 )
9 )
12 where
10 where
@@ -33,12 +31,6 @@ throw x =
33 Task $ \_ err -> err x
31 Task $ \_ err -> err x
34
32
35
33
36−mapError :: (x -> y) -> Task x a -> Task y a
37−mapError func (Task task) =
38− Task $ \ok err ->
39− task ok (err . func)
40−
41−
42
34
43-- IO
35-- IO
44
36
@@ -49,15 +41,6 @@ io work =
49 Task $ \ok _ -> work >>= ok
41 Task $ \ok _ -> work >>= ok
50
42
51
43
52−mio :: x -> IO (Maybe a) -> Task x a
53−mio x work =
54− Task $ \ok err ->
55− do result <- work
56− case result of
57− Just a -> ok a
58− Nothing -> err x
59−
60−
61eio :: (x -> y) -> IO (Either x a) -> Task y a
44eio :: (x -> y) -> IO (Either x a) -> Task y a
62eio func work =
45eio func work =
63 Task $ \ok err ->
46 Task $ \ok err ->
builder/src/Stuff.hs+9−8
@@ -8,8 +8,8 @@ module Stuff
8 , elmo
8 , elmo
9 , temp
9 , temp
10 , findRoot
10 , findRoot
11− , withRootLock
11+ , withProjectLock
12− , withRegistryLock
12+ , withCacheLock
13 , PackageCache
13 , PackageCache
14 , getPackageCache
14 , getPackageCache
15 , registry
15 , registry
@@ -120,16 +120,17 @@ findRootHelp dirs =
120-- LOCKS
120-- LOCKS
121
121
122
122
123−withRootLock :: FilePath -> IO a -> IO a
123+withProjectLock :: FilePath -> IO a -> IO a
124−withRootLock root work =
124+withProjectLock root work =
125 do let dir = stuff root
125 do let dir = stuff root
126 Dir.createDirectoryIfMissing True dir
126 Dir.createDirectoryIfMissing True dir
127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
127+ Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
128
128
129
129
130−withRegistryLock :: PackageCache -> IO a -> IO a
130+withCacheLock :: PackageCache -> IO a -> IO a
131−withRegistryLock (PackageCache dir) work =
131+withCacheLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
132+ Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
133+
133
134
134
135
135
136
cabal.configdeleted−2
@@ -1,2 +0,0 @@
1−profiling: False
2−library-profiling: True
compiler/src/AST/Canonical.hs+8−11
@@ -56,14 +56,12 @@ 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
59
60
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
65import qualified Elm.ModuleName as ModuleName
64import qualified Elm.ModuleName as ModuleName
66−import qualified Elm.String as ES
67import qualified Reporting.Annotation as A
65import qualified Reporting.Annotation as A
68
66
69
67
@@ -84,10 +82,10 @@ data Expr_
84 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
82 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
85 | VarDebug ModuleName.Canonical Name Annotation
83 | VarDebug ModuleName.Canonical Name Annotation
86 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
84 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
87− | Chr ES.String
85+ | Chr Utf8.String
88− | Str ES.String
86+ | Str Utf8.String
89 | Int Int
87 | Int Int
90− | Float EF.Float
88+ | Float (Utf8.Under256 Float)
91 | List [Expr]
89 | List [Expr]
92 | Negate Expr
90 | Negate Expr
93 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
91 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -152,8 +150,8 @@ data Pattern_
152 | PList [Pattern]
150 | PList [Pattern]
153 | PCons Pattern Pattern
151 | PCons Pattern Pattern
154 | PBool Union Bool
152 | PBool Union Bool
155− | PChr ES.String
153+ | PChr Utf8.String
156− | PStr ES.String
154+ | PStr Utf8.String
157 | PInt Int
155 | PInt Int
158 | PCtor
156 | PCtor
159 { _p_home :: ModuleName.Canonical
157 { _p_home :: ModuleName.Canonical
@@ -233,7 +231,6 @@ data Module =
233 Module
231 Module
234 { _name :: ModuleName.Canonical
232 { _name :: ModuleName.Canonical
235 , _exports :: Exports
233 , _exports :: Exports
236− , _docs :: Src.Docs
237 , _decls :: Decls
234 , _decls :: Decls
238 , _unions :: Map.Map Name Union
235 , _unions :: Map.Map Name Union
239 , _aliases :: Map.Map Name Alias
236 , _aliases :: Map.Map Name Alias
@@ -342,7 +339,7 @@ instance Binary CtorOpts where
342 0 -> return Normal
339 0 -> return Normal
343 1 -> return Enum
340 1 -> return Enum
344 2 -> return Unbox
341 2 -> return Unbox
345− _ -> fail "binary encoding of CtorOpts was corrupted"
342+ _ -> error "binary encoding of CtorOpts was corrupted"
346
343
347
344
348instance Binary Annotation where
345instance Binary Annotation where
@@ -393,7 +390,7 @@ instance Binary AliasType where
393 case n of
390 case n of
394 0 -> liftM Holey get
391 0 -> liftM Holey get
395 1 -> liftM Filled get
392 1 -> liftM Filled get
396− _ -> fail "binary encoding of AliasType was corrupted"
393+ _ -> error "binary encoding of AliasType was corrupted"
397
394
398
395
399instance Binary FieldType where
396instance Binary FieldType where
compiler/src/AST/Optimized.hs+13−14
@@ -27,15 +27,14 @@ 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
30
31
31import qualified AST.Canonical as Can
32import qualified AST.Canonical as Can
32import qualified AST.Utils.Shader as Shader
33import qualified AST.Utils.Shader as Shader
33import qualified Data.Index as Index
34import 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
39import qualified Optimize.DecisionTree as DT
38import qualified Optimize.DecisionTree as DT
40import qualified Reporting.Annotation as A
39import qualified Reporting.Annotation as A
41
40
@@ -46,10 +45,10 @@ import qualified Reporting.Annotation as A
46
45
47data Expr
46data Expr
48 = Bool Bool
47 = Bool Bool
49− | Chr ES.String
48+ | Chr Utf8.String
50− | Str ES.String
49+ | Str Utf8.String
51 | Int Int
50 | Int Int
52− | Float EF.Float
51+ | Float (Utf8.Under256 Float)
53 | VarLocal Name
52 | VarLocal Name
54 | VarGlobal Global
53 | VarGlobal Global
55 | VarEnum Global Index.ZeroBased
54 | VarEnum Global Index.ZeroBased
@@ -135,7 +134,7 @@ data GlobalGraph =
135data LocalGraph =
134data LocalGraph =
136 LocalGraph
135 LocalGraph
137 { _l_main :: Maybe Main
136 { _l_main :: Maybe Main
138− , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
137+ , _l_nodes :: Map.Map Global Node -- TODO profile switching Global to Name
139 , _l_fields :: Map.Map Name Int
138 , _l_fields :: Map.Map Name Int
140 }
139 }
141
140
@@ -308,7 +307,7 @@ instance Binary Expr where
308 24 -> pure Unit
307 24 -> pure Unit
309 25 -> liftM3 Tuple get get get
308 25 -> liftM3 Tuple get get get
310 26 -> liftM3 Shader get get get
309 26 -> liftM3 Shader get get get
311− _ -> fail "problem getting Opt.Expr binary"
310+ _ -> error "problem getting Opt.Expr binary"
312
311
313
312
314instance Binary Def where
313instance Binary Def where
@@ -322,7 +321,7 @@ instance Binary Def where
322 case word of
321 case word of
323 0 -> liftM2 Def get get
322 0 -> liftM2 Def get get
324 1 -> liftM3 TailDef get get get
323 1 -> liftM3 TailDef get get get
325− _ -> fail "problem getting Opt.Def binary"
324+ _ -> error "problem getting Opt.Def binary"
326
325
327
326
328instance Binary Destructor where
327instance Binary Destructor where
@@ -345,7 +344,7 @@ instance Binary Path where
345 1 -> liftM2 Field get get
344 1 -> liftM2 Field get get
346 2 -> liftM Unbox get
345 2 -> liftM Unbox get
347 3 -> liftM Root get
346 3 -> liftM Root get
348− _ -> fail "problem getting Opt.Path binary"
347+ _ -> error "problem getting Opt.Path binary"
349
348
350
349
351instance (Binary a) => Binary (Decider a) where
350instance (Binary a) => Binary (Decider a) where
@@ -361,7 +360,7 @@ instance (Binary a) => Binary (Decider a) where
361 0 -> liftM Leaf get
360 0 -> liftM Leaf get
362 1 -> liftM3 Chain get get get
361 1 -> liftM3 Chain get get get
363 2 -> liftM3 FanOut get get get
362 2 -> liftM3 FanOut get get get
364− _ -> fail "problem getting Opt.Decider binary"
363+ _ -> error "problem getting Opt.Decider binary"
365
364
366
365
367instance Binary Choice where
366instance Binary Choice where
@@ -375,7 +374,7 @@ instance Binary Choice where
375 case word of
374 case word of
376 0 -> liftM Inline get
375 0 -> liftM Inline get
377 1 -> liftM Jump get
376 1 -> liftM Jump get
378− _ -> fail "problem getting Opt.Choice binary"
377+ _ -> error "problem getting Opt.Choice binary"
379
378
380
379
381
380
@@ -400,7 +399,7 @@ instance Binary Main where
400 case word of
399 case word of
401 0 -> return Static
400 0 -> return Static
402 1 -> liftM2 Dynamic get get
401 1 -> liftM2 Dynamic get get
403− _ -> fail "problem getting Opt.Main binary"
402+ _ -> error "problem getting Opt.Main binary"
404
403
405
404
406instance Binary Node where
405instance Binary Node where
@@ -432,7 +431,7 @@ instance Binary Node where
432 8 -> liftM2 Kernel get get
431 8 -> liftM2 Kernel get get
433 9 -> liftM2 PortIncoming get get
432 9 -> liftM2 PortIncoming get get
434 10 -> liftM2 PortOutgoing get get
433 10 -> liftM2 PortOutgoing get get
435− _ -> fail "problem getting Opt.Node binary"
434+ _ -> error "problem getting Opt.Node binary"
436
435
437
436
438instance Binary EffectsType where
437instance Binary EffectsType where
@@ -448,4 +447,4 @@ instance Binary EffectsType where
448 0 -> return Cmd
447 0 -> return Cmd
449 1 -> return Sub
448 1 -> return Sub
450 2 -> return Fx
449 2 -> return Fx
451− _ -> fail "problem getting Opt.EffectsType binary"
450+ _ -> error "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+19−36
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module AST.Source
3module AST.Source
3 ( Expr, Expr_(..), VarType(..)
4 ( Expr, Expr_(..), VarType(..)
4 , Def(..)
5 , Def(..)
@@ -11,12 +12,10 @@ module AST.Source
11 , Value(..)
12 , Value(..)
12 , Union(..)
13 , Union(..)
13 , Alias(..)
14 , Alias(..)
14− , Infix(..)
15+ , Binop(..)
15 , Port(..)
16 , Port(..)
16 , Effects(..)
17 , Effects(..)
17 , Manager(..)
18 , Manager(..)
18− , Docs(..)
19− , Comment(..)
20 , Exposing(..)
19 , Exposing(..)
21 , Exposed(..)
20 , Exposed(..)
22 , Privacy(..)
21 , Privacy(..)
@@ -25,13 +24,10 @@ module AST.Source
25
24
26
25
27import Data.Name (Name)
26import Data.Name (Name)
28−import qualified Data.Name as Name
27+import qualified Data.Utf8 as Utf8
29
28
30import qualified AST.Utils.Binop as Binop
29import qualified AST.Utils.Binop as Binop
31import qualified AST.Utils.Shader as Shader
30import 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
35import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
36
32
37
33
@@ -43,10 +39,10 @@ type Expr = A.Located Expr_
43
39
44
40
45data Expr_
41data Expr_
46− = Chr ES.String
42+ = Chr Utf8.String
47− | Str ES.String
43+ | Str Utf8.String
48 | Int Int
44 | Int Int
49− | Float EF.Float
45+ | Float (Utf8.Under256 Float)
50 | Var VarType Name
46 | Var VarType Name
51 | VarQual VarType Name Name
47 | VarQual VarType Name Name
52 | List [Expr]
48 | List [Expr]
@@ -97,8 +93,8 @@ data Pattern_
97 | PCtorQual A.Region Name Name [Pattern]
93 | PCtorQual A.Region Name Name [Pattern]
98 | PList [Pattern]
94 | PList [Pattern]
99 | PCons Pattern Pattern
95 | PCons Pattern Pattern
100− | PChr ES.String
96+ | PChr Utf8.String
101− | PStr ES.String
97+ | PStr Utf8.String
102 | PInt Int
98 | PInt Int
103
99
104
100
@@ -126,26 +122,22 @@ data Type_
126
122
127data Module =
123data Module =
128 Module
124 Module
129− { _name :: Maybe (A.Located Name)
125+ { _name :: Maybe Name
130 , _exports :: A.Located Exposing
126 , _exports :: A.Located Exposing
131− , _docs :: Docs
132 , _imports :: [Import]
127 , _imports :: [Import]
133 , _values :: [A.Located Value]
128 , _values :: [A.Located Value]
134 , _unions :: [A.Located Union]
129 , _unions :: [A.Located Union]
135 , _aliases :: [A.Located Alias]
130 , _aliases :: [A.Located Alias]
136− , _binops :: [A.Located Infix]
131+ , _binops :: [A.Located Binop]
137 , _effects :: Effects
132 , _effects :: Effects
138 }
133 }
139
134
140
135
141getName :: Module -> Name
136getName :: Module -> Name
142−getName (Module maybeName _ _ _ _ _ _ _ _) =
137+getName (Module maybeName _ _ _ _ _ _ _) =
143 case maybeName of
138 case maybeName of
144− Just (A.At _ name) ->
139+ Just name -> name
145− name
146−
147− Nothing ->
140+ Nothing -> "Main"
148− Name._Main
149
141
150
142
151getImportName :: Import -> Name
143getImportName :: Import -> Name
@@ -164,7 +156,7 @@ data Import =
164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
156data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
157data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
166data Alias = Alias (A.Located Name) [A.Located Name] Type
158data Alias = Alias (A.Located Name) [A.Located Name] Type
167−data Infix = Infix Name Binop.Associativity Binop.Precedence Name
159+data Binop = Binop Name Binop.Associativity Binop.Precedence Name
168data Port = Port (A.Located Name) Type
160data Port = Port (A.Located Name) Type
169
161
170
162
@@ -180,30 +172,21 @@ data Manager
180 | Fx (A.Located Name) (A.Located Name)
172 | Fx (A.Located Name) (A.Located Name)
181
173
182
174
183−data Docs
184− = NoDocs A.Region
185− | YesDocs Comment [(Name, Comment)]
186−
187−
188−newtype Comment =
189− Comment P.Snippet
190−
191−
192
175
193-- EXPOSING
176-- EXPOSING
194
177
195
178
196data Exposing
179data Exposing
197 = Open
180 = Open
198− | Explicit [Exposed]
181+ | Explicit [A.Located Exposed]
199
182
200
183
201data Exposed
184data Exposed
202− = Lower (A.Located Name)
185+ = Lower Name
203− | Upper (A.Located Name) Privacy
186+ | Upper Name Privacy
204− | Operator A.Region Name
187+ | Operator Name
205
188
206
189
207data Privacy
190data Privacy
208− = Public A.Region
191+ = Public
209 | Private
192 | Private
compiler/src/AST/Utils/Binop.hs+6−5
@@ -41,11 +41,12 @@ instance Binary Precedence where
41instance Binary Associativity where
41instance Binary Associativity where
42 get =
42 get =
43 do n <- getWord8
43 do n <- getWord8
44+ return $
44− case n of
45+ case n of
45− 0 -> return Left
46+ 0 -> Left
46− 1 -> return Non
47+ 1 -> Non
47− 2 -> return Right
48+ 2 -> Right
48− _ -> fail "Error reading valid associativity from serialized string"
49+ _ -> error "Error reading valid associativity from serialized string"
49
50
50 put assoc =
51 put assoc =
51 putWord8 $
52 putWord8 $
compiler/src/AST/Utils/Shader.hs+4−51
@@ -4,27 +4,22 @@ module AST.Utils.Shader
4 ( Source
4 ( Source
5 , Types(..)
5 , Types(..)
6 , Type(..)
6 , Type(..)
7− , fromChars
8− , toJsStringBuilder
9 )
7 )
10 where
8 where
11
9
12
10
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
18import qualified Data.Map as Map
11import qualified Data.Map as Map
19import qualified Data.Name as Name
12import qualified Data.Name as Name
13+import qualified Data.Utf8 as Utf8
20
14
21
15
22
16
23-- SOURCE
17-- SOURCE
24
18
25
19
26−newtype Source =
20+type Source = Utf8.VeryLong SOURCE
27− Source BS.ByteString
21+
22+data SOURCE
28
23
29
24
30
25
@@ -47,45 +42,3 @@ data Type
47 | V4
42 | V4
48 | M4
43 | M4
49 | Texture
44 | 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,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module AST.Utils.Type
3module AST.Utils.Type
3 ( delambda
4 ( delambda
4 , dealias
5 , dealias
compiler/src/Canonicalize/Environment.hs+20−50
@@ -4,8 +4,6 @@ module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5 , Exposed
5 , Exposed
6 , Qualified
6 , Qualified
7− , Info(..)
8− , mergeInfo
9 , Var(..)
7 , Var(..)
10 , Type(..)
8 , Type(..)
11 , Ctor(..)
9 , Ctor(..)
@@ -22,8 +20,8 @@ module Canonicalize.Environment
22
20
23import qualified Data.Map.Merge.Strict as Map
21import qualified Data.Map.Merge.Strict as Map
24import qualified Data.Map.Strict as Map
22import qualified Data.Map.Strict as Map
23+import qualified Data.Map.Strict.Internal as I
25import qualified Data.Name as Name
24import qualified Data.Name as Name
26−import qualified Data.OneOrMore as OneOrMore
27
25
28import qualified AST.Utils.Binop as Binop
26import qualified AST.Utils.Binop as Binop
29import qualified AST.Canonical as Can
27import qualified AST.Canonical as Can
@@ -60,34 +58,11 @@ data Env =
60
58
61
59
62type Exposed a =
60type Exposed a =
63− Map.Map Name.Name (Info a)
61+ Map.Map Name.Name (Map.Map ModuleName.Canonical a)
64
62
65
63
66type Qualified a =
64type Qualified a =
67− Map.Map Name.Name (Map.Map Name.Name (Info a))
65+ Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
68−
69−
70−
71−-- INFO
72−
73−
74−data Info a
75− = Specific ModuleName.Canonical a
76− | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77−
78−
79−mergeInfo :: Info a -> Info a -> Info a
80−mergeInfo info1 info2 =
81− case info1 of
82− Specific h1 _ ->
83− case info2 of
84− Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86−
87− Ambiguous h1 hs1 ->
88− case info2 of
89− Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
91
66
92
67
93
68
@@ -97,8 +72,7 @@ mergeInfo info1 info2 =
97data Var
72data Var
98 = Local A.Region
73 = Local A.Region
99 | TopLevel A.Region
74 | TopLevel A.Region
100− | Foreign ModuleName.Canonical Can.Annotation
75+ | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
101− | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
102
76
103
77
104
78
@@ -165,10 +139,7 @@ addLocalLeft _ region =
165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
139addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
166addLocalBoth name region var =
140addLocalBoth name region var =
167 case var of
141 case var of
168− Foreign _ _ ->
142+ Foreign _ ->
169− Result.ok (Local region)
170−
171− Foreigns _ _ ->
172 Result.ok (Local region)
143 Result.ok (Local region)
173
144
174 Local parentRegion ->
145 Local parentRegion ->
@@ -179,18 +150,17 @@ addLocalBoth name region var =
179
150
180
151
181
152
182−
183-- FIND TYPE
153-- FIND TYPE
184
154
185
155
186findType :: A.Region -> Env -> Name.Name -> Result i w Type
156findType :: A.Region -> Env -> Name.Name -> Result i w Type
187findType region (Env _ _ ts _ _ _ qts _) name =
157findType region (Env _ _ ts _ _ _ qts _) name =
188 case Map.lookup name ts of
158 case Map.lookup name ts of
189− Just (Specific _ tipe) ->
159+ Just (I.Bin 1 _ tipe _ _) ->
190 Result.ok tipe
160 Result.ok tipe
191
161
192− Just (Ambiguous h hs) ->
162+ Just homes ->
193− Result.throw (Error.AmbiguousType region Nothing name h hs)
163+ Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
194
164
195 Nothing ->
165 Nothing ->
196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -201,11 +171,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
201 case Map.lookup prefix qts of
171 case Map.lookup prefix qts of
202 Just qualified ->
172 Just qualified ->
203 case Map.lookup name qualified of
173 case Map.lookup name qualified of
204− Just (Specific _ tipe) ->
174+ Just (I.Bin 1 _ tipe _ _) ->
205 Result.ok tipe
175 Result.ok tipe
206
176
207− Just (Ambiguous h hs) ->
177+ Just homes ->
208− Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
178+ Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
209
179
210 Nothing ->
180 Nothing ->
211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -221,11 +191,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
191findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
223 case Map.lookup name cs of
193 case Map.lookup name cs of
224− Just (Specific _ ctor) ->
194+ Just (I.Bin 1 _ ctor _ _) ->
225 Result.ok ctor
195 Result.ok ctor
226
196
227− Just (Ambiguous h hs) ->
197+ Just homes ->
228− Result.throw (Error.AmbiguousVariant region Nothing name h hs)
198+ Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
229
199
230 Nothing ->
200 Nothing ->
231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
201 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -236,11 +206,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
236 case Map.lookup prefix qcs of
206 case Map.lookup prefix qcs of
237 Just qualified ->
207 Just qualified ->
238 case Map.lookup name qualified of
208 case Map.lookup name qualified of
239− Just (Specific _ pattern) ->
209+ Just (I.Bin 1 _ pattern _ _) ->
240 Result.ok pattern
210 Result.ok pattern
241
211
242− Just (Ambiguous h hs) ->
212+ Just homes ->
243− Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
213+ Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
244
214
245 Nothing ->
215 Nothing ->
246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
216 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -256,11 +226,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
226findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
257findBinop region (Env _ _ _ _ binops _ _ _) name =
227findBinop region (Env _ _ _ _ binops _ _ _) name =
258 case Map.lookup name binops of
228 case Map.lookup name binops of
259− Just (Specific _ binop) ->
229+ Just (I.Bin 1 _ binop _ _) ->
260 Result.ok binop
230 Result.ok binop
261
231
262− Just (Ambiguous h hs) ->
232+ Just homes ->
263− Result.throw (Error.AmbiguousBinop region name h hs)
233+ Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
264
234
265 Nothing ->
235 Nothing ->
266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
236 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
compiler/src/Canonicalize/Environment/Dups.hs+3−6
@@ -57,11 +57,8 @@ detectHelp toError name values =
57 OneOrMore.One (Info _ value) ->
57 OneOrMore.One (Info _ value) ->
58 return value
58 return value
59
59
60− OneOrMore.More left right ->
60+ OneOrMore.More _ _ ->
61− let
62− (Info r1 _, Info r2 _) =
61+ let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in
63− OneOrMore.getFirstTwo left right
64− in
65 Result.throw (toError name r1 r2)
62 Result.throw (toError name r1 r2)
66
63
67
64
@@ -105,7 +102,7 @@ one name region value =
105
102
106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
103insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107insert name region value dict =
104insert name region value dict =
108− Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
105+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
109
106
110
107
111union :: Dict a -> Dict a -> Dict a
108union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+37−49
@@ -35,14 +35,7 @@ type Result i w a =
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
36createInitialEnv home ifaces imports =
36createInitialEnv home ifaces imports =
37 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
37 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38− Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
38+ Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
39−
40−
41−infoToVar :: Env.Info Can.Annotation -> Env.Var
42−infoToVar info =
43− case info of
44− Env.Specific home tipe -> Env.Foreign home tipe
45− Env.Ambiguous h hs -> Env.Foreigns h hs
46
39
47
40
48
41
@@ -68,7 +61,7 @@ emptyState =
68
61
69emptyTypes :: Env.Exposed Env.Type
62emptyTypes :: Env.Exposed Env.Type
70emptyTypes =
63emptyTypes =
71− Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
64+ Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
72
65
73
66
74
67
@@ -109,8 +102,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
109 (Map.mapMaybeWithKey (unionToType home) unions)
102 (Map.mapMaybeWithKey (unionToType home) unions)
110 (Map.mapMaybeWithKey (aliasToType home) aliases)
103 (Map.mapMaybeWithKey (aliasToType home) aliases)
111
104
112− !vars = Map.map (Env.Specific home) defs
105+ !vars = Map.map (Map.singleton home) defs
113− !types = Map.map (Env.Specific home . fst) rawTypeInfo
106+ !types = Map.map (Map.singleton home . fst) rawTypeInfo
114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
107 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
115
108
116 !qvs2 = addQualified prefix vars qvs
109 !qvs2 = addQualified prefix vars qvs
@@ -136,7 +129,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
136
129
137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138addExposed =
131addExposed =
139− Map.unionWith Env.mergeInfo
132+ Map.unionWith Map.union
140
133
141
134
142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -157,7 +150,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
150unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158 let
151 let
159 addCtor dict (Can.Ctor ctor index _ args) =
152 addCtor dict (Can.Ctor ctor index _ args) =
160− Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
153+ Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
161 in
154 in
162 ( Env.Union (length vars) home
155 ( Env.Union (length vars) home
163 , List.foldl' addCtor Map.empty ctors
156 , List.foldl' addCtor Map.empty ctors
@@ -188,7 +181,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
188 (Can.TAlias home name avars (Can.Filled tipe))
181 (Can.TAlias home name avars (Can.Filled tipe))
189 (Can.fieldsToList fields)
182 (Can.fieldsToList fields)
190 in
183 in
191− Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
184+ Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
192
185
193 _ ->
186 _ ->
194 Map.empty
187 Map.empty
@@ -199,9 +192,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
199-- BINOP
192-- BINOP
200
193
201
194
202−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
195+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
203binopToBinop home op (I.Binop name annotation associativity precedence) =
196binopToBinop home op (I.Binop name annotation associativity precedence) =
204− Env.Specific home (Env.Binop op home name annotation associativity precedence)
197+ Map.singleton home (Env.Binop op home name annotation associativity precedence)
205
198
206
199
207
200
@@ -214,19 +207,19 @@ addExposedValue
214 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
207 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215 -> Map.Map Name.Name I.Binop
208 -> Map.Map Name.Name I.Binop
216 -> State
209 -> State
217− -> Src.Exposed
210+ -> A.Located Src.Exposed
218 -> Result i w State
211 -> Result i w State
219−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
212+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
220 case exposed of
213 case exposed of
221− Src.Lower (A.At region name) ->
214+ Src.Lower name ->
222 case Map.lookup name vars of
215 case Map.lookup name vars of
223 Just info ->
216 Just info ->
224− Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
217+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
225
218
226 Nothing ->
219 Nothing ->
227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
220 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228
221
229− Src.Upper (A.At region name) privacy ->
222+ Src.Upper name privacy ->
230 case privacy of
223 case privacy of
231 Src.Private ->
224 Src.Private ->
232 case Map.lookup name types of
225 case Map.lookup name types of
@@ -234,43 +227,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
234 case tipe of
227 case tipe of
235 Env.Union _ _ ->
228 Env.Union _ _ ->
236 let
229 let
237− !ts2 = Map.insert name (Env.Specific home tipe) ts
230+ !ts2 = Map.insert name (Map.singleton home tipe) ts
238 in
231 in
239 Result.ok (State vs ts2 cs bs qvs qts qcs)
232 Result.ok (State vs ts2 cs bs qvs qts qcs)
240
233
241 Env.Alias _ _ _ _ ->
234 Env.Alias _ _ _ _ ->
242 let
235 let
243− !ts2 = Map.insert name (Env.Specific home tipe) ts
236+ !ts2 = Map.insert name (Map.singleton home tipe) ts
244 !cs2 = addExposed cs ctors
237 !cs2 = addExposed cs ctors
245 in
238 in
246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
239 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247
240
248 Nothing ->
241 Nothing ->
249− case checkForCtorMistake name types of
242+ case Map.lookup name (toCtors types) of
250− tipe:_ ->
243+ Just tipe ->
251 Result.throw $ Error.ImportCtorByName region name tipe
244 Result.throw $ Error.ImportCtorByName region name tipe
252
245
253− [] ->
246+ Nothing ->
254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
247 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255
248
256− Src.Public dotDotRegion ->
249+ Src.Public ->
257 case Map.lookup name types of
250 case Map.lookup name types of
258 Just (tipe, ctors) ->
251 Just (tipe, ctors) ->
259 case tipe of
252 case tipe of
260 Env.Union _ _ ->
253 Env.Union _ _ ->
261 let
254 let
262− !ts2 = Map.insert name (Env.Specific home tipe) ts
255+ !ts2 = Map.insert name (Map.singleton home tipe) ts
263 !cs2 = addExposed cs ctors
256 !cs2 = addExposed cs ctors
264 in
257 in
265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
258 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266
259
267 Env.Alias _ _ _ _ ->
260 Env.Alias _ _ _ _ ->
268− Result.throw (Error.ImportOpenAlias dotDotRegion name)
261+ Result.throw (Error.ImportOpenAlias region name)
269
262
270 Nothing ->
263 Nothing ->
271 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
264 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272
265
273− Src.Operator region op ->
266+ Src.Operator op ->
274 case Map.lookup op binops of
267 case Map.lookup op binops of
275 Just binop ->
268 Just binop ->
276 let
269 let
@@ -282,23 +275,18 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
275 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283
276
284
277
278+
285−checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
279+toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
286−checkForCtorMistake givenName types =
280+toCtors types =
287− Map.foldr addMatches [] types
281+ Map.foldr addCtors Map.empty types
288 where
282 where
289− addMatches (_, exposedCtors) matches =
283+ addCtors (_, exposedCtors) dict =
290− Map.foldrWithKey addMatch matches exposedCtors
284+ Map.foldrWithKey addCtor dict exposedCtors
291−
285+
292− addMatch ctorName info matches =
286+ addCtor ctorName homes dict =
293− if ctorName /= givenName
294− then matches
295− else
296− case info of
287+ case Map.elems homes of
297− Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
288+ [Env.Ctor _ tipeName _ _ _] ->
298− tipeName : matches
289+ Map.insert ctorName tipeName dict
299−
290+
300− Env.Specific _ (Env.RecordCtor _ _ _) ->
291+ _ ->
301− matches
292+ dict
302−
303− Env.Ambiguous _ _ ->
304− matches
compiler/src/Canonicalize/Environment/Local.hs+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
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112 do arity <- checkUnionFreeVars union
112 do arity <- checkUnionFreeVars union
113− let one = Env.Specific home (Env.Union arity home)
113+ let one = Map.singleton home (Env.Union arity home)
114 Result.ok $ Map.insert name one types
114 Result.ok $ Map.insert name one types
115
115
116
116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134 do args <- checkAliasFreeVars alias
134 do args <- checkAliasFreeVars alias
135 ctype <- Type.canonicalize env tipe
135 ctype <- Type.canonicalize env tipe
136− let one = Env.Specific home (Env.Alias (length args) home args ctype)
136+ let one = Map.singleton home (Env.Alias (length args) home args ctype)
137 let ts1 = Map.insert name one ts
137 let ts1 = Map.insert name one ts
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139
139
@@ -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
281 )
281 )
282
282
283
283
284−type CtorDups = Dups.Dict (Env.Info Env.Ctor)
284+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
285
285
286
286
287
287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297 ,
297 ,
298 case ctipe of
298 case ctipe of
299 Can.TRecord fields Nothing ->
299 Can.TRecord fields Nothing ->
300− Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
300+ Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
301
301
302 _ ->
302 _ ->
303 Dups.none
303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351
351
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Env.Specific home $
354+ Dups.one name region $ Map.singleton home $
355 Env.Ctor home typeName union index args
355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+7−6
@@ -14,6 +14,7 @@ import Control.Monad (foldM)
14import qualified Data.Graph as Graph
14import qualified Data.Graph as Graph
15import qualified Data.List as List
15import qualified Data.List as List
16import qualified Data.Map.Strict as Map
16import qualified Data.Map.Strict as Map
17+import qualified Data.Map.Strict.Internal as I
17import qualified Data.Name as Name
18import qualified Data.Name as Name
18
19
19import qualified AST.Canonical as Can
20import qualified AST.Canonical as Can
@@ -695,15 +696,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
695 Env.TopLevel _ ->
696 Env.TopLevel _ ->
696 logVar name (Can.VarTopLevel localHome name)
697 logVar name (Can.VarTopLevel localHome name)
697
698
698− Env.Foreign home annotation ->
699+ Env.Foreign (I.Bin 1 home annotation _ _) ->
699 Result.ok $
700 Result.ok $
700 if home == ModuleName.debug then
701 if home == ModuleName.debug then
701 Can.VarDebug localHome name annotation
702 Can.VarDebug localHome name annotation
702 else
703 else
703 Can.VarForeign home name annotation
704 Can.VarForeign home name annotation
704
705
705− Env.Foreigns h hs ->
706+ Env.Foreign homes ->
706− Result.throw (Error.AmbiguousVar region Nothing name h hs)
707+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
707
708
708 Nothing ->
709 Nothing ->
709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
710 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -714,15 +715,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714 case Map.lookup prefix qvs of
715 case Map.lookup prefix qvs of
715 Just qualified ->
716 Just qualified ->
716 case Map.lookup name qualified of
717 case Map.lookup name qualified of
717− Just (Env.Specific home annotation) ->
718+ Just (I.Bin 1 home annotation _ _) ->
718 Result.ok $
719 Result.ok $
719 if home == ModuleName.debug then
720 if home == ModuleName.debug then
720 Can.VarDebug localHome name annotation
721 Can.VarDebug localHome name annotation
721 else
722 else
722 Can.VarForeign home name annotation
723 Can.VarForeign home name annotation
723
724
724− Just (Env.Ambiguous h hs) ->
725+ Just homes ->
725− Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
726+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
726
727
727 Nothing ->
728 Nothing ->
728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
729 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Canonicalize/Module.hs+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 docs imports values _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports 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 docs imports values _ _ bino
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 docs cvalues cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports 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.Infix -> ( Name.Name, Can.Binop )
64+canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
65+canonicalizeBinop (A.At _ (Src.Binop 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− -> Src.Exposed
239+ -> A.Located Src.Exposed
240 -> Result i w (Dups.Dict (A.Located Can.Export))
240 -> Result i w (Dups.Dict (A.Located Can.Export))
241−checkExposed values unions aliases binops effects exposed =
241+checkExposed values unions aliases binops effects (A.At region exposed) =
242 case exposed of
242 case exposed of
243− Src.Lower (A.At region name) ->
243+ Src.Lower name ->
244 if Map.member name values then
244 if Map.member name values then
245 ok name region Can.ExportValue
245 ok name region Can.ExportValue
246 else
246 else
@@ -252,23 +252,23 @@ checkExposed values unions aliases binops effects exposed =
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253 ports ++ Map.keys values
253 ports ++ Map.keys values
254
254
255− Src.Operator region name ->
255+ Src.Operator name ->
256 if Map.member name binops then
256 if Map.member name binops then
257 ok name region Can.ExportBinop
257 ok name region Can.ExportBinop
258 else
258 else
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260 Map.keys binops
260 Map.keys binops
261
261
262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
262+ Src.Upper name Src.Public ->
263 if Map.member name unions then
263 if Map.member name unions then
264 ok name region Can.ExportUnionOpen
264 ok name region Can.ExportUnionOpen
265 else if Map.member name aliases then
265 else if Map.member name aliases then
266− Result.throw $ Error.ExportOpenAlias dotDotRegion name
266+ Result.throw $ Error.ExportOpenAlias region name
267 else
267 else
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
269 Map.keys unions ++ Map.keys aliases
269 Map.keys unions ++ Map.keys aliases
270
270
271− Src.Upper (A.At region name) Src.Private ->
271+ Src.Upper name Src.Private ->
272 if Map.member name unions then
272 if Map.member name unions then
273 ok name region Can.ExportUnionClosed
273 ok name region Can.ExportUnionClosed
274 else if Map.member name aliases then
274 else if Map.member name aliases then
compiler/src/Canonicalize/Pattern.hs+2−3
@@ -8,7 +8,6 @@ module Canonicalize.Pattern
8 where
8 where
9
9
10
10
11−import qualified Data.List as List
12import qualified Data.Map.Strict as Map
11import qualified Data.Map.Strict as Map
13import qualified Data.Name as Name
12import qualified Data.Name as Name
14
13
@@ -174,8 +173,8 @@ logVar name region value =
174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175logFields fields value =
174logFields fields value =
176 let
175 let
177− addField dict (A.At region name) =
176+ addField (A.At region name) dict =
178 Dups.insert name region region dict
177 Dups.insert name region region dict
179 in
178 in
180 Result.Result $ \bindings warnings _ ok ->
179 Result.Result $ \bindings warnings _ ok ->
181− ok (List.foldl' addField bindings fields) warnings value
180+ ok (foldr addField bindings fields) warnings value
compiler/src/Compile.hs+18−26
@@ -8,6 +8,7 @@ module Compile
8
8
9import qualified Data.Map as Map
9import qualified Data.Map as Map
10import qualified Data.Name as Name
10import qualified Data.Name as Name
11+import qualified Data.OneOrMore as OneOrMore
11
12
12import qualified AST.Source as Src
13import qualified AST.Source as Src
13import qualified AST.Canonical as Can
14import qualified AST.Canonical as Can
@@ -20,7 +21,7 @@ import qualified Nitpick.PatternMatches as PatternMatches
20import qualified Optimize.Module as Optimize
21import qualified Optimize.Module as Optimize
21import qualified Reporting.Error as E
22import qualified Reporting.Error as E
22import qualified Reporting.Result as R
23import qualified Reporting.Result as R
23−import qualified Reporting.Render.Type.Localizer as Localizer
24+import qualified Reporting.Warning as W
24import qualified Type.Constrain.Module as Type
25import qualified Type.Constrain.Module as Type
25import qualified Type.Solve as Type
26import qualified Type.Solve as Type
26
27
@@ -39,12 +40,13 @@ data Artifacts =
39 }
40 }
40
41
41
42
42−compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
43+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either (OneOrMore.OneOrMore E.Error) Artifacts
43compile pkg ifaces modul =
44compile pkg ifaces modul =
45+ snd $ R.run $
44 do canonical <- canonicalize pkg ifaces modul
46 do canonical <- canonicalize pkg ifaces modul
45− annotations <- typeCheck modul canonical
47+ annotations <- typeCheck canonical
46 () <- nitpick canonical
48 () <- nitpick canonical
47− objects <- optimize modul annotations canonical
49+ objects <- optimize annotations canonical
48 return (Artifacts canonical annotations objects)
50 return (Artifacts canonical annotations objects)
49
51
50
52
@@ -52,41 +54,31 @@ compile pkg ifaces modul =
52-- PHASES
54-- PHASES
53
55
54
56
55−canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
57+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> R.Result i [W.Warning] E.Error Can.Module
56canonicalize pkg ifaces modul =
58canonicalize pkg ifaces modul =
57− case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
59+ R.mapError E.Canonicalize $ Canonicalize.canonicalize pkg ifaces modul
58− Right canonical ->
59− Right canonical
60−
61− Left errors ->
62− Left $ E.BadNames errors
63
60
64
61
65−typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
62+typeCheck :: Can.Module -> R.Result i w E.Error (Map.Map Name.Name Can.Annotation)
66−typeCheck modul canonical =
63+typeCheck canonical =
67 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
64 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
68 Right annotations ->
65 Right annotations ->
69− Right annotations
66+ R.ok annotations
70
67
71 Left errors ->
68 Left errors ->
72− Left (E.BadTypes (Localizer.fromModule modul) errors)
69+ R.throw (E.Type errors)
73
70
74
71
75−nitpick :: Can.Module -> Either E.Error ()
72+nitpick :: Can.Module -> R.Result i w E.Error ()
76nitpick canonical =
73nitpick canonical =
77 case PatternMatches.check canonical of
74 case PatternMatches.check canonical of
78 Right () ->
75 Right () ->
79− Right ()
76+ R.ok ()
80
77
81 Left errors ->
78 Left errors ->
82− Left (E.BadPatterns errors)
79+ R.throw (E.Pattern errors)
83
80
84
81
85−optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
82+optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> R.Result i [W.Warning] E.Error Opt.LocalGraph
86−optimize modul annotations canonical =
83+optimize annotations canonical =
87− case snd $ R.run $ Optimize.optimize annotations canonical of
84+ R.mapError E.Main $ Optimize.optimize annotations canonical
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,7 +1,6 @@
1module Data.Map.Utils
1module Data.Map.Utils
2 ( fromKeys
2 ( fromKeys
3 , fromKeysA
3 , fromKeysA
4− , fromValues
5 , any
4 , any
6 )
5 )
7 where
6 where
@@ -26,11 +25,6 @@ fromKeysA toValue keys =
26 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
25 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
27
26
28
27
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−
34
28
35-- ANY
29-- ANY
36
30
compiler/src/Data/Name.hs+177−166
@@ -1,119 +1,130 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module Data.Name
3module Data.Name
4 ( Name
4 ( Name
5− --
5+ , toUtf8
6− , toChars
6+ , fromUtf8
7− , toElmString
7+ , toEscapedBuilder
8− , toBuilder
8+ , Utf8.toBuilder
9− --
10− , fromPtr
9+ , Utf8.fromPtr
11− , fromChars
10+ , Utf8.fromChars
11+ , Utf8.toChars
12− --
12+ -- misc
13 , getKernel
13 , getKernel
14 , hasDot
14 , hasDot
15− , splitDots
16 , isKernel
15 , isKernel
17 , isNumberType
16 , isNumberType
18 , isComparableType
17 , isComparableType
19 , isAppendableType
18 , isAppendableType
20 , isCompappendType
19 , isCompappendType
21 , fromVarIndex
20 , fromVarIndex
21+ , fromReplCount
22 , fromWords
22 , fromWords
23 , fromManyNames
23 , fromManyNames
24 , fromTypeVariable
24 , fromTypeVariable
25 , fromTypeVariableScheme
25 , fromTypeVariableScheme
26 , sepBy
26 , sepBy
27− --
27+ -- interned
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, _Main, dollar, identity
33+ , node, program, main, dollar, identity
34− , replModule, replValueToPrint
34+ , replModule
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
42import qualified Data.ByteString.Builder.Internal as B
41import qualified Data.ByteString.Builder.Internal as B
43−import qualified Data.Coerce as Coerce
42+import Data.Coerce (coerce)
44import qualified Data.List as List
43import qualified Data.List as List
45−import qualified Data.String as Chars
46import qualified Data.Utf8 as Utf8
44import qualified Data.Utf8 as Utf8
45+import Foreign.Ptr (plusPtr, minusPtr)
47import GHC.Exts
46import GHC.Exts
48− ( Int(I#), Ptr
47+ ( Int(I#), Ptr(Ptr)
48+ , RealWorld
49 , MutableByteArray#
49 , MutableByteArray#
50 , isTrue#
50 , isTrue#
51 , newByteArray#
51 , newByteArray#
52 , sizeofByteArray#
52 , sizeofByteArray#
53+ , writeWord8OffAddr#
54+ , copyByteArrayToAddr#
53 , unsafeFreezeByteArray#
55 , unsafeFreezeByteArray#
54 )
56 )
57+import GHC.IO
55import GHC.ST (ST(ST), runST)
58import GHC.ST (ST(ST), runST)
56import GHC.Prim
59import GHC.Prim
57import GHC.Word (Word8(W8#))
60import GHC.Word (Word8(W8#))
58
61
59−import qualified Elm.String as ES
60−
61
62
62
63
63-- NAME
64-- NAME
64
65
65
66
66−type Name =
67+type Name = Utf8.Under256 NAME
67− Utf8.Utf8 ELM_NAME
68−
69−
70−data ELM_NAME
71−
72−
73−
74−-- INSTANCES
75−
76
68
77−instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78− fromString = Utf8.fromChars
79
69
80−instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
70+data NAME
81− get = Utf8.getUnder256
82− put = Utf8.putUnder256
83
71
84
72
73+toUtf8 :: Name -> Utf8.String
74+toUtf8 =
75+ coerce
85
76
86−-- TO
87
77
78+fromUtf8 :: Utf8.String -> Name
79+fromUtf8 =
80+ coerce
88
81
89−toChars :: Name -> [Char]
90−toChars =
91− Utf8.toChars
92
82
93
83
94−toElmString :: Name -> ES.String
84+-- TO ESCAPED BUILDER
95−toElmString =
96− Coerce.coerce
97
85
98
86
99−{-# INLINE toBuilder #-}
87+{-# INLINE toEscapedBuilder #-}
100−toBuilder :: Name -> B.Builder
88+toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
101−toBuilder =
89+toEscapedBuilder before after =
102− Utf8.toBuilder
90+ \name -> B.builder (toEscapedBuilderHelp before after name)
103
91
104
92
93+{-# INLINE toEscapedBuilderHelp #-}
94+toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
95+toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
96+ go 0 (I# (sizeofByteArray# ba#))
97+ where
98+ go !offset !len !(B.BufferRange bOffset bEnd) =
99+ let
100+ !bLen = minusPtr bEnd bOffset
101+ in
102+ if len <= bLen then
103+ do -- TODO test if writing word-by-word is faster
104+ stToIO (copyToPtr name offset bOffset len)
105+ stToIO (escape before after bOffset name offset len 0)
106+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
107+ k newBufferRange
108+ else
109+ do stToIO (copyToPtr name offset bOffset bLen)
110+ stToIO (escape before after bOffset name offset bLen 0)
111+ let !newOffset = offset + bLen
112+ let !newLength = len - bLen
113+ return $ B.bufferFull 1 bEnd (go newOffset newLength)
114+
115+
116+escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
117+escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
118+ if isTrue# (i# <# len#) then
119+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
120+ then
121+ do writeWordToPtr ptr i after
122+ escape before after ptr name offset len (i + 1)
123+ else
124+ do escape before after ptr name offset len (i + 1)
105
125
106−-- FROM
126+ else
107−
127+ return ()
108−
109−fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110−fromPtr =
111− Utf8.fromPtr
112−
113−
114−fromChars :: [Char] -> Name
115−fromChars =
116− Utf8.fromChars
117
128
118
129
119
130
@@ -122,12 +133,7 @@ fromChars =
122
133
123hasDot :: Name -> Bool
134hasDot :: Name -> Bool
124hasDot name =
135hasDot name =
125− Utf8.contains 0x2E {- . -} name
136+ Utf8.contains 0x2E {- . -} (coerce name)
126−
127−
128−splitDots :: Name -> [Name]
129−splitDots name =
130− Utf8.split 0x2E {- . -} name
131
137
132
138
133
139
@@ -175,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
175
181
176{-# NOINLINE prefix_kernel #-}
182{-# NOINLINE prefix_kernel #-}
177prefix_kernel :: Name
183prefix_kernel :: Name
178−prefix_kernel = fromChars "Elm.Kernel."
184+prefix_kernel = "Elm.Kernel."
179
185
180{-# NOINLINE prefix_number #-}
186{-# NOINLINE prefix_number #-}
181prefix_number :: Name
187prefix_number :: Name
182−prefix_number = fromChars "number"
188+prefix_number = "number"
183
189
184{-# NOINLINE prefix_comparable #-}
190{-# NOINLINE prefix_comparable #-}
185prefix_comparable :: Name
191prefix_comparable :: Name
186−prefix_comparable = fromChars "comparable"
192+prefix_comparable = "comparable"
187
193
188{-# NOINLINE prefix_appendable #-}
194{-# NOINLINE prefix_appendable #-}
189prefix_appendable :: Name
195prefix_appendable :: Name
190−prefix_appendable = fromChars "appendable"
196+prefix_appendable = "appendable"
191
197
192{-# NOINLINE prefix_compappend #-}
198{-# NOINLINE prefix_compappend #-}
193prefix_compappend :: Name
199prefix_compappend :: Name
194−prefix_compappend = fromChars "compappend"
200+prefix_compappend = "compappend"
195
201
196
202
197
203
@@ -202,11 +208,11 @@ fromVarIndex :: Int -> Name
202fromVarIndex n =
208fromVarIndex n =
203 runST
209 runST
204 (
210 (
205− do let !size = 2 + getIndexSize n
211+ do let !size = getIndexSize n
206 mba <- newByteArray size
212 mba <- newByteArray size
207 writeWord8 mba 0 0x5F {- _ -}
213 writeWord8 mba 0 0x5F {- _ -}
208 writeWord8 mba 1 0x76 {- v -}
214 writeWord8 mba 1 0x76 {- v -}
209− writeDigitsAtEnd mba size n
215+ writeDigits mba (size - 1) n
210 freeze mba
216 freeze mba
211 )
217 )
212
218
@@ -214,20 +220,19 @@ fromVarIndex n =
214{-# INLINE getIndexSize #-}
220{-# INLINE getIndexSize #-}
215getIndexSize :: Int -> Int
221getIndexSize :: Int -> Int
216getIndexSize n
222getIndexSize n
217− | n < 10 = 1
223+ | n < 10 = 3
218− | n < 100 = 2
224+ | n < 100 = 4
219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
225+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220
226
221
227
222
228
223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
229+writeDigits :: MBA s -> Int -> Int -> ST s ()
224−writeDigitsAtEnd !mba !oldOffset !n =
230+writeDigits !mba !offset !n =
225 do let (q,r) = quotRem n 10
231 do let (q,r) = quotRem n 10
226− let !newOffset = oldOffset - 1
227− writeWord8 mba newOffset (0x30 + fromIntegral r)
232+ writeWord8 mba offset (0x30 + fromIntegral r)
228 if q <= 0
233 if q <= 0
229 then return ()
234 then return ()
230− else writeDigitsAtEnd mba newOffset q
235+ else writeDigits mba (offset-1) q
231
236
232
237
233
238
@@ -250,7 +255,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
250 mba <- newByteArray size
255 mba <- newByteArray size
251 copyToMBA name mba
256 copyToMBA name mba
252 writeWord8 mba (I# len#) 0x5F {- _ -}
257 writeWord8 mba (I# len#) 0x5F {- _ -}
253− writeDigitsAtEnd mba size index
258+ writeDigits mba (size - 1) index
254 freeze mba
259 freeze mba
255 )
260 )
256 else
261 else
@@ -259,7 +264,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
259 do let !size = I# len# + getIndexSize index
264 do let !size = I# len# + getIndexSize index
260 mba <- newByteArray size
265 mba <- newByteArray size
261 copyToMBA name mba
266 copyToMBA name mba
262− writeDigitsAtEnd mba size index
267+ writeDigits mba (size - 1) index
263 freeze mba
268 freeze mba
264 )
269 )
265
270
@@ -278,61 +283,61 @@ fromTypeVariableScheme scheme =
278 freeze mba
283 freeze mba
279 else
284 else
280 do let (extra, letter) = quotRem scheme 26
285 do let (extra, letter) = quotRem scheme 26
281− let !size = 1 + getIndexSize extra
286+ let !size = getIndexSize extra
282 mba <- newByteArray size
287 mba <- newByteArray size
283 writeWord8 mba 0 (0x61 + fromIntegral letter)
288 writeWord8 mba 0 (0x61 + fromIntegral letter)
284− writeDigitsAtEnd mba size extra
289+ writeDigits mba (size - 1) extra
285 freeze mba
290 freeze mba
286 )
291 )
287
292
288
293
289
294
295+-- FROM REPL COUNT
296+
297+
298+fromReplCount :: Int -> Name
299+fromReplCount n =
300+ Utf8.fromChars ("repl_value_" ++ show n)
301+
302+
303+
290-- FROM MANY NAMES
304-- FROM MANY NAMES
291−--
292−-- Creating a unique name by combining all the subnames can create names
293−-- longer than 256 bytes relatively easily. So instead, the first given name
294−-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295−--
296−-- This should be a unique name since 0.19 disallows shadowing. It would not
297−-- be possible for multiple top-level cycles to include values with the same
298−-- name, so the important thing is to make the cycle name distinct from the
299−-- normal name. Same logic for destructuring patterns like (x,y)
300
305
301
306
302fromManyNames :: [Name] -> Name
307fromManyNames :: [Name] -> Name
303fromManyNames names =
308fromManyNames names =
304− case names of
309+ let
305− [] ->
306− blank
307− -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308− -- but maybe unused patterns should be stripped out instead
309−
310− Utf8.Utf8 ba# : _ ->
311− let
312− len# = sizeofByteArray# ba#
310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
313− in
311+ in
314− runST
312+ runST
315− (
313+ (
316− ST $ \s ->
314+ ST $ \s ->
317− case newByteArray# (len# +# 3#) s of
315+ case newByteArray# size# s of
316+ (# s, mba# #) ->
317+ case writeNames mba# 0# names s of
318− (# s, mba# #) ->
318+ s ->
319− case writeWord8Array# mba# 0# 0x5F## {-_-} s of
320− s ->
321− case writeWord8Array# mba# 1# 0x4D## {-M-} s of
322− s ->
323− case writeWord8Array# mba# 2# 0x24## {-$-} s of
324− s ->
325− case copyByteArray# ba# 0# mba# 3# len# s of
326− s ->
327− case unsafeFreezeByteArray# mba# s of
319+ case unsafeFreezeByteArray# mba# s of
328− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329− )
321+ )
330
322
331
323
332−{-# NOINLINE blank #-}
324+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
333−blank :: Name
325+writeNames mba# !offset# names s =
334−blank =
326+ case names of
335− fromWords [0x5F,0x4D,0x24] {-_M$-}
327+ [] ->
328+ s
329+
330+ (Utf8.Utf8 ba#) : names ->
331+ case writeWord8Array# mba# offset# 0x24## {- $ -} s of
332+ s ->
333+ let
334+ !offset1# = offset# +# 1#
335+ !len# = sizeofByteArray# ba#
336+ !newOffset# = offset1# +# len#
337+ in
338+ case copyByteArray# ba# 0# mba# offset1# len# s of
339+ s ->
340+ writeNames mba# newOffset# names s
336
341
337
342
338
343
@@ -418,6 +423,22 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
418 s -> (# s, () #)
423 s -> (# s, () #)
419
424
420
425
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+
421{-# INLINE copyToMBA #-}
442{-# INLINE copyToMBA #-}
422copyToMBA :: Name -> MBA s -> ST s ()
443copyToMBA :: Name -> MBA s -> ST s ()
423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -432,179 +453,169 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
432
453
433{-# NOINLINE int #-}
454{-# NOINLINE int #-}
434int :: Name
455int :: Name
435−int = fromChars "Int"
456+int = "Int"
436
457
437
458
438{-# NOINLINE float #-}
459{-# NOINLINE float #-}
439float :: Name
460float :: Name
440−float = fromChars "Float"
461+float = "Float"
441
462
442
463
443{-# NOINLINE bool #-}
464{-# NOINLINE bool #-}
444bool :: Name
465bool :: Name
445−bool = fromChars "Bool"
466+bool = "Bool"
446
467
447
468
448{-# NOINLINE char #-}
469{-# NOINLINE char #-}
449char :: Name
470char :: Name
450−char = fromChars "Char"
471+char = "Char"
451
472
452
473
453{-# NOINLINE string #-}
474{-# NOINLINE string #-}
454string :: Name
475string :: Name
455−string = fromChars "String"
476+string = "String"
456
477
457
478
458{-# NOINLINE maybe #-}
479{-# NOINLINE maybe #-}
459maybe :: Name
480maybe :: Name
460−maybe = fromChars "Maybe"
481+maybe = "Maybe"
461
482
462
483
463{-# NOINLINE result #-}
484{-# NOINLINE result #-}
464result :: Name
485result :: Name
465−result = fromChars "Result"
486+result = "Result"
466
487
467
488
468{-# NOINLINE list #-}
489{-# NOINLINE list #-}
469list :: Name
490list :: Name
470−list = fromChars "List"
491+list = "List"
471
492
472
493
473{-# NOINLINE array #-}
494{-# NOINLINE array #-}
474array :: Name
495array :: Name
475−array = fromChars "Array"
496+array = "Array"
476
497
477
498
478{-# NOINLINE dict #-}
499{-# NOINLINE dict #-}
479dict :: Name
500dict :: Name
480−dict = fromChars "Dict"
501+dict = "Dict"
481
502
482
503
483{-# NOINLINE tuple #-}
504{-# NOINLINE tuple #-}
484tuple :: Name
505tuple :: Name
485−tuple = fromChars "Tuple"
506+tuple = "Tuple"
486
507
487
508
488{-# NOINLINE jsArray #-}
509{-# NOINLINE jsArray #-}
489jsArray :: Name
510jsArray :: Name
490−jsArray = fromChars "JsArray"
511+jsArray = "JsArray"
491
512
492
513
493{-# NOINLINE task #-}
514{-# NOINLINE task #-}
494task :: Name
515task :: Name
495−task = fromChars "Task"
516+task = "Task"
496
517
497
518
498{-# NOINLINE router #-}
519{-# NOINLINE router #-}
499router :: Name
520router :: Name
500−router = fromChars "Router"
521+router = "Router"
501
522
502
523
503{-# NOINLINE cmd #-}
524{-# NOINLINE cmd #-}
504cmd :: Name
525cmd :: Name
505−cmd = fromChars "Cmd"
526+cmd = "Cmd"
506
527
507
528
508{-# NOINLINE sub #-}
529{-# NOINLINE sub #-}
509sub :: Name
530sub :: Name
510−sub = fromChars "Sub"
531+sub = "Sub"
511
532
512
533
513{-# NOINLINE platform #-}
534{-# NOINLINE platform #-}
514platform :: Name
535platform :: Name
515−platform = fromChars "Platform"
536+platform = "Platform"
516
537
517
538
518{-# NOINLINE virtualDom #-}
539{-# NOINLINE virtualDom #-}
519virtualDom :: Name
540virtualDom :: Name
520−virtualDom = fromChars "VirtualDom"
541+virtualDom = "VirtualDom"
521
542
522
543
523{-# NOINLINE shader #-}
544{-# NOINLINE shader #-}
524shader :: Name
545shader :: Name
525−shader = fromChars "Shader"
546+shader = "Shader"
526
547
527
548
528{-# NOINLINE debug #-}
549{-# NOINLINE debug #-}
529debug :: Name
550debug :: Name
530−debug = fromChars "Debug"
551+debug = "Debug"
531
552
532
553
533{-# NOINLINE debugger #-}
554{-# NOINLINE debugger #-}
534debugger :: Name
555debugger :: Name
535−debugger = fromChars "Debugger"
556+debugger = "Debugger"
536
557
537
558
538{-# NOINLINE bitwise #-}
559{-# NOINLINE bitwise #-}
539bitwise :: Name
560bitwise :: Name
540−bitwise = fromChars "Bitwise"
561+bitwise = "Bitwise"
541
562
542
563
543{-# NOINLINE basics #-}
564{-# NOINLINE basics #-}
544basics :: Name
565basics :: Name
545−basics = fromChars "Basics"
566+basics = "Basics"
546
567
547
568
548{-# NOINLINE utils #-}
569{-# NOINLINE utils #-}
549utils :: Name
570utils :: Name
550−utils = fromChars "Utils"
571+utils = "Utils"
551
572
552
573
553{-# NOINLINE negate #-}
574{-# NOINLINE negate #-}
554negate :: Name
575negate :: Name
555−negate = fromChars "negate"
576+negate = "negate"
556
577
557
578
558{-# NOINLINE true #-}
579{-# NOINLINE true #-}
559true :: Name
580true :: Name
560−true = fromChars "True"
581+true = "True"
561
582
562
583
563{-# NOINLINE false #-}
584{-# NOINLINE false #-}
564false :: Name
585false :: Name
565−false = fromChars "False"
586+false = "False"
566
587
567
588
568{-# NOINLINE value #-}
589{-# NOINLINE value #-}
569value :: Name
590value :: Name
570−value = fromChars "Value"
591+value = "Value"
571
592
572
593
573{-# NOINLINE node #-}
594{-# NOINLINE node #-}
574node :: Name
595node :: Name
575−node = fromChars "Node"
596+node = "Node"
576
597
577
598
578{-# NOINLINE program #-}
599{-# NOINLINE program #-}
579program :: Name
600program :: Name
580−program = fromChars "Program"
601+program = "Program"
581−
582
602
583−{-# NOINLINE _main #-}
584−_main :: Name
585−_main = fromChars "main"
586
603
587−
588−{-# NOINLINE _Main #-}
604+{-# NOINLINE main #-}
589−_Main :: Name
605+main :: Name
590−_Main = fromChars "Main"
606+main = "main"
591
607
592
608
593{-# NOINLINE dollar #-}
609{-# NOINLINE dollar #-}
594dollar :: Name
610dollar :: Name
595−dollar = fromChars "$"
611+dollar = "$"
596
612
597
613
598{-# NOINLINE identity #-}
614{-# NOINLINE identity #-}
599identity :: Name
615identity :: Name
600−identity = fromChars "identity"
616+identity = "identity"
601
617
602
618
603{-# NOINLINE replModule #-}
619{-# NOINLINE replModule #-}
604replModule :: Name
620replModule :: Name
605−replModule = fromChars "Elm_Repl"
621+replModule = "Elm_Repl"
606−
607−
608−{-# NOINLINE replValueToPrint #-}
609−replValueToPrint :: Name
610−replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hs−42
@@ -1,17 +1,10 @@
1module Data.NonEmptyList
1module Data.NonEmptyList
2 ( List(..)
2 ( List(..)
3− , singleton
4 , toList
3 , toList
5− , sortBy
6 )
4 )
7 where
5 where
8
6
9
7
10−import Control.Monad (liftM2)
11−import Data.Binary (Binary, get, put)
12−import qualified Data.List as List
13−
14−
15
8
16-- LIST
9-- LIST
17
10
@@ -20,11 +13,6 @@ data List a =
20 List a [a]
13 List a [a]
21
14
22
15
23−singleton :: a -> List a
24−singleton a =
25− List a []
26−
27−
28toList :: List a -> [a]
16toList :: List a -> [a]
29toList (List x xs) =
17toList (List x xs) =
30 x:xs
18 x:xs
@@ -46,33 +34,3 @@ instance Foldable List where
46 foldr step state (List x xs) = step x (foldr step state xs)
34 foldr step state (List x xs) = step x (foldr step state xs)
47 foldl step state (List x xs) = foldl step (step state x) xs
35 foldl step state (List x xs) = foldl step (step state x) xs
48 foldl1 step (List x xs) = foldl step x xs
36 foldl1 step (List x xs) = foldl step x xs
49−
50−
51−
52−-- SORT BY
53−
54−
55−sortBy :: (Ord b) => (a -> b) -> List a -> List a
56−sortBy toRank (List x xs) =
57− let
58− comparison a b =
59− compare (toRank a) (toRank b)
60− in
61− case List.sortBy comparison xs of
62− [] ->
63− List x []
64−
65− y:ys ->
66− case comparison x y of
67− LT -> List x (y:ys)
68− EQ -> List x (y: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/OneOrMore.hs+24−39
@@ -3,9 +3,9 @@ module Data.OneOrMore
3 ( OneOrMore(..)
3 ( OneOrMore(..)
4 , one
4 , one
5 , more
5 , more
6+ , toList
6 , map
7 , map
7 , destruct
8 , destruct
8− , getFirstTwo
9 )
9 )
10 where
10 where
11
11
@@ -33,6 +33,25 @@ more =
33
33
34
34
35
35
36+-- TO LIST
37+
38+
39+toList :: OneOrMore a -> [a]
40+toList oneOrMore =
41+ toListHelp oneOrMore []
42+
43+
44+toListHelp :: OneOrMore a -> [a] -> [a]
45+toListHelp oneOrMore list =
46+ case oneOrMore of
47+ One x ->
48+ x : list
49+
50+ More a b ->
51+ toListHelp a (toListHelp b list)
52+
53+
54+
36-- MAP
55-- MAP
37
56
38
57
@@ -52,48 +71,14 @@ map func oneOrMore =
52
71
53destruct :: (a -> [a] -> b) -> OneOrMore a -> b
72destruct :: (a -> [a] -> b) -> OneOrMore a -> b
54destruct func oneOrMore =
73destruct func oneOrMore =
55− destructLeft func oneOrMore []
74+ destructHelp func oneOrMore []
56
75
57
76
58−destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
77+destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
59−destructLeft func oneOrMore xs =
78+destructHelp func oneOrMore xs =
60 case oneOrMore of
79 case oneOrMore of
61 One x ->
80 One x ->
62 func x xs
81 func x xs
63
82
64 More a b ->
83 More a b ->
65− destructLeft func a (destructRight b xs)
84+ destructHelp func a (toListHelp b xs)
66−
67−
68−destructRight :: OneOrMore a -> [a] -> [a]
69−destructRight oneOrMore xs =
70− case oneOrMore of
71− One x ->
72− x : xs
73−
74− More a b ->
75− destructRight a (destructRight b xs)
76−
77−
78−
79−-- GET FIRST TWO
80−
81−
82−getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)
83−getFirstTwo left right =
84− case left of
85− One x ->
86− (x, getFirstOne right)
87−
88− More lleft lright ->
89− getFirstTwo lleft lright
90−
91−
92−getFirstOne :: OneOrMore a -> a
93−getFirstOne oneOrMore =
94− case oneOrMore of
95− One x ->
96− x
97−
98− More left _ ->
99− getFirstOne left
compiler/src/Data/Utf8.hs+300−158
@@ -1,42 +1,36 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Utf8
3module Data.Utf8
4+ ( String
4− ( Utf8(..)
5+ , Utf8(..)
6+ , VeryLong
7+ , Under256
5 , isEmpty
8 , isEmpty
6− , empty
7 , size
9 , size
8 , contains
10 , contains
11+ , containsDouble
9 , startsWith
12 , startsWith
10 , startsWithChar
13 , startsWithChar
11− , endsWithWord8
14+ , endsWithWord
12 , split
15 , split
13 , join
16 , join
14− --
17+ , all
15− , getUnder256
18+ , any
16− , putUnder256
19+ , toWord16
17− --
20+ , fromWord16
18− , getVeryLong
21+ -- conversions
19− , putVeryLong
22+ , fromChars
20− --
21 , toChars
23 , toChars
22 , toBuilder
24 , toBuilder
23− , toEscapedBuilder
24− --
25 , fromPtr
25 , fromPtr
26− , fromSnippet
26+ , fromChunks
27− , fromChars
27+ , Chunk(..)
28− --
29− , MBA
30− , newByteArray
31− , copyFromPtr
32− , writeWord8
33− , freeze
34 )
28 )
35 where
29 where
36
30
37
31
38import Prelude hiding (String, all, any, concat)
32import Prelude hiding (String, all, any, concat)
39−import Data.Binary (Get, get, getWord8, Put, put, putWord8)
33+import Data.Binary (Binary(..), Get, getWord8, putWord8)
40import Data.Binary.Put (putBuilder)
34import Data.Binary.Put (putBuilder)
41import Data.Binary.Get.Internal (readN)
35import Data.Binary.Get.Internal (readN)
42import Data.Bits ((.&.), shiftR)
36import Data.Bits ((.&.), shiftR)
@@ -44,6 +38,7 @@ import qualified Data.ByteString.Internal as B
44import qualified Data.ByteString.Builder.Internal as B
38import qualified Data.ByteString.Builder.Internal as B
45import qualified Data.Char as Char
39import qualified Data.Char as Char
46import qualified Data.List as List
40import qualified Data.List as List
41+import Data.String (IsString(..))
47import Foreign.ForeignPtr (touchForeignPtr)
42import Foreign.ForeignPtr (touchForeignPtr)
48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
43import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
49import Foreign.Ptr (minusPtr, plusPtr)
44import Foreign.Ptr (minusPtr, plusPtr)
@@ -58,35 +53,36 @@ import GHC.Exts
58 , copyByteArray#
53 , copyByteArray#
59 , copyAddrToByteArray#
54 , copyAddrToByteArray#
60 , copyByteArrayToAddr#
55 , copyByteArrayToAddr#
61− , writeWord8Array#
56+ , writeWord8Array#,
62 )
57 )
63import GHC.IO
58import GHC.IO
64import GHC.ST (ST(ST), runST)
59import GHC.ST (ST(ST), runST)
65import GHC.Prim
60import GHC.Prim
66−import GHC.Word (Word8(W8#))
61+import GHC.Word (Word8(W8#), Word16(W16#))
67−
68−import qualified Parse.Primitives as P
69
62
70
63
71
64
72-- UTF-8
65-- UTF-8
73
66
74
67
75−data Utf8 tipe =
68+data Utf8 size tipe =
76 Utf8 ByteArray#
69 Utf8 ByteArray#
77
70
78
71
72+type String = Utf8 VERY_LONG STRING
73+type VeryLong t = Utf8 VERY_LONG t
74+type Under256 t = Utf8 UNDER_256 t
79
75
80−-- EMPTY
76+data STRING
77+data VERY_LONG
78+data UNDER_256
81
79
82
80
83−{-# NOINLINE empty #-}
84−empty :: Utf8 t
85−empty =
86− runST (freeze =<< newByteArray 0)
87
81
82+-- IS EMPTY
88
83
84+
89−isEmpty :: Utf8 t -> Bool
85+isEmpty :: Utf8 l t -> Bool
90isEmpty (Utf8 ba#) =
86isEmpty (Utf8 ba#) =
91 isTrue# (sizeofByteArray# ba# ==# 0#)
87 isTrue# (sizeofByteArray# ba# ==# 0#)
92
88
@@ -95,7 +91,7 @@ isEmpty (Utf8 ba#) =
95-- SIZE
91-- SIZE
96
92
97
93
98−size :: Utf8 t -> Int
94+size :: Utf8 l t -> Int
99size (Utf8 ba#) =
95size (Utf8 ba#) =
100 I# (sizeofByteArray# ba#)
96 I# (sizeofByteArray# ba#)
101
97
@@ -104,7 +100,7 @@ size (Utf8 ba#) =
104-- CONTAINS
100-- CONTAINS
105
101
106
102
107−contains :: Word8 -> Utf8 t -> Bool
103+contains :: Word8 -> Utf8 l t -> Bool
108contains (W8# word#) (Utf8 ba#) =
104contains (W8# word#) (Utf8 ba#) =
109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
105 containsHelp word# ba# 0# (sizeofByteArray# ba#)
110
106
@@ -120,11 +116,32 @@ containsHelp word# ba# !offset# len# =
120
116
121
117
122
118
119+-- CONTAINS DOUBLE
120+
121+
122+containsDouble :: Word8 -> Utf8 l t -> Bool
123+containsDouble (W8# word#) (Utf8 ba#) =
124+ containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)
125+
126+
127+containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
128+containsDoubleHelp word# ba# !offset# len# =
129+ let !offset1# = offset# +# 1# in
130+ if isTrue# (offset1# <# len#) then
131+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))
132+ && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))
133+ then True
134+ else containsDoubleHelp word# ba# (offset# +# 1#) len#
135+ else
136+ False
137+
138+
139+
123-- STARTS WITH
140-- STARTS WITH
124
141
125
142
126{-# INLINE startsWith #-}
143{-# INLINE startsWith #-}
127−startsWith :: Utf8 t -> Utf8 t -> Bool
144+startsWith :: Utf8 l t -> Utf8 l t -> Bool
128startsWith (Utf8 ba1#) (Utf8 ba2#) =
145startsWith (Utf8 ba1#) (Utf8 ba2#) =
129 let
146 let
130 !len1# = sizeofByteArray# ba1#
147 !len1# = sizeofByteArray# ba1#
@@ -139,9 +156,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
139-- STARTS WITH CHAR
156-- STARTS WITH CHAR
140
157
141
158
142−startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
159+startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
143−startsWithChar isGood bytes@(Utf8 ba#) =
160+startsWithChar isGood str@(Utf8 ba#) =
144− if isEmpty bytes then
161+ if isEmpty str then
145 False
162 False
146 else
163 else
147 let
164 let
@@ -159,8 +176,8 @@ startsWithChar isGood bytes@(Utf8 ba#) =
159-- ENDS WITH WORD
176-- ENDS WITH WORD
160
177
161
178
162−endsWithWord8 :: Word8 -> Utf8 t -> Bool
179+endsWithWord :: Word8 -> Utf8 l t -> Bool
163−endsWithWord8 (W8# w#) (Utf8 ba#) =
180+endsWithWord (W8# w#) (Utf8 ba#) =
164 let len# = sizeofByteArray# ba# in
181 let len# = sizeofByteArray# ba# in
165 isTrue# (len# ># 0#)
182 isTrue# (len# ># 0#)
166 &&
183 &&
@@ -171,12 +188,12 @@ endsWithWord8 (W8# w#) (Utf8 ba#) =
171-- SPLIT
188-- SPLIT
172
189
173
190
174−split :: Word8 -> Utf8 t -> [Utf8 t]
191+split :: Word8 -> String -> [String]
175split (W8# divider#) str@(Utf8 ba#) =
192split (W8# divider#) str@(Utf8 ba#) =
176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
193 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
177
194
178
195
179−splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
196+splitHelp :: String -> Int -> [Int] -> [String]
180splitHelp str start offsets =
197splitHelp str start offsets =
181 case offsets of
198 case offsets of
182 [] ->
199 [] ->
@@ -197,7 +214,7 @@ findDividers divider# ba# !offset# len# revOffsets =
197 reverse revOffsets
214 reverse revOffsets
198
215
199
216
200−unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
217+unsafeSlice :: String -> Int -> Int -> String
201unsafeSlice str start end =
218unsafeSlice str start end =
202 let !len = end - start in
219 let !len = end - start in
203 if len == 0 then
220 if len == 0 then
@@ -213,7 +230,7 @@ unsafeSlice str start end =
213-- JOIN
230-- JOIN
214
231
215
232
216−join :: Word8 -> [Utf8 t] -> Utf8 t
233+join :: Word8 -> [String] -> String
217join sep strings =
234join sep strings =
218 case strings of
235 case strings of
219 [] ->
236 [] ->
@@ -227,7 +244,7 @@ join sep strings =
227 freeze mba
244 freeze mba
228
245
229
246
230−joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
247+joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
231joinHelp sep mba offset str strings =
248joinHelp sep mba offset str strings =
232 let
249 let
233 !len = size str
250 !len = size str
@@ -245,10 +262,46 @@ joinHelp sep mba offset str strings =
245
262
246
263
247
264
265+-- ALL
266+
267+
268+all :: (Char -> Bool) -> Utf8 l t -> Bool
269+all isGood utf8 =
270+ not (any (not . isGood) utf8)
271+
272+
273+
274+-- ANY
275+
276+
277+any :: (Char -> Bool) -> Utf8 l t -> Bool
278+any isGood (Utf8 ba#) =
279+ anyHelp isGood ba# 0# (sizeofByteArray# ba#)
280+
281+
282+anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool
283+anyHelp isGood ba# offset# len# =
284+ if isTrue# (offset# >=# len#) then
285+ False
286+ else
287+ let
288+ !w# = indexWord8Array# ba# offset#
289+ !(# char, width# #)
290+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
291+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
292+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
293+ | True = (# chr4 ba# offset# w#, 4# #)
294+ in
295+ if isGood char
296+ then True
297+ else anyHelp isGood ba# (offset# +# width#) len#
298+
299+
300+
248-- EQUAL
301-- EQUAL
249
302
250
303
251−instance Eq (Utf8 t) where
304+instance Eq (Utf8 l t) where
252 (==) (Utf8 ba1#) (Utf8 ba2#) =
305 (==) (Utf8 ba1#) (Utf8 ba2#) =
253 let
306 let
254 !len1# = sizeofByteArray# ba1#
307 !len1# = sizeofByteArray# ba1#
@@ -261,11 +314,9 @@ instance Eq (Utf8 t) where
261
314
262
315
263-- COMPARE
316-- COMPARE
264−--
265−-- TODO: is it fine to sort by length and only compare bytes on length ties?
266−--
267
317
318+
268−instance Ord (Utf8 t) where
319+instance Ord (Utf8 l t) where
269 compare (Utf8 ba1#) (Utf8 ba2#) =
320 compare (Utf8 ba1#) (Utf8 ba2#) =
270 let
321 let
271 !len1# = sizeofByteArray# ba1#
322 !len1# = sizeofByteArray# ba1#
@@ -282,20 +333,84 @@ instance Ord (Utf8 t) where
282
333
283
334
284
335
336+-- TO WORD16
337+
338+
339+toWord16 :: String -> Maybe Word16
340+toWord16 (Utf8 ba#) =
341+ let !len# = sizeofByteArray# ba# in
342+ if isTrue# (len# ==# 0#) then
343+ Nothing
344+ else
345+ let !w# = indexWord8Array# ba# 0# in
346+ if isTrue# (eqWord# w# 0x30##) then
347+ if isTrue# (len# ==# 1#) then Just 0 else Nothing
348+ else
349+ toWordHelp ba# 0# len# 0##
350+
351+
352+toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16
353+toWordHelp ba# offset# len# number# =
354+ if isTrue# (offset# <# len#) then
355+ let !w# = indexWord8Array# ba# offset# in
356+ if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then
357+ let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in
358+ toWordHelp ba# (offset# +# 1#) len# newNumber#
359+ else
360+ Nothing
361+ else
362+ Just (W16# number#)
363+
364+
365+
366+-- FROM WORD16
367+
368+
369+fromWord16 :: Word16 -> String
370+fromWord16 n =
371+ runST $
372+ do let !size = getWordSize n
373+ mba <- newByteArray size
374+ writeDigits mba (size - 1) n
375+ freeze mba
376+
377+
378+getWordSize :: Word16 -> Int
379+getWordSize n
380+ | n < 10 = 1
381+ | n < 100 = 2
382+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
383+
384+
385+writeDigits :: MBA s -> Int -> Word16 -> ST s ()
386+writeDigits !mba !offset !n =
387+ do let (q,r) = quotRem n 10
388+ writeWord8 mba offset (0x30 + fromIntegral r)
389+ if q <= 0
390+ then return ()
391+ else writeDigits mba (offset-1) q
392+
393+
394+
285-- FROM STRING
395-- FROM STRING
286
396
287
397
288−fromChars :: [Char] -> Utf8 t
398+fromChars :: [Char] -> Utf8 l t
289−fromChars chars =
399+fromChars =
290− runST
400+ fromString
291− (
401+
292− do mba <- newByteArray (sum (map getWidth chars))
293− writeChars mba 0 chars
294− )
295
402
403+instance IsString (Utf8 l t) where
404+ fromString str =
405+ runST
406+ (
407+ do mba <- newByteArray (sum (map getWidth str))
408+ writeString mba 0 str
409+ )
296
410
411+
297−writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
412+writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
298−writeChars !mba !offset chars =
413+writeString !mba !offset chars =
299 case chars of
414 case chars of
300 [] ->
415 [] ->
301 freeze mba
416 freeze mba
@@ -303,25 +418,25 @@ writeChars !mba !offset chars =
303 char : chars
418 char : chars
304 | n < 0x80 ->
419 | n < 0x80 ->
305 do writeWord8 mba (offset ) (fromIntegral n)
420 do writeWord8 mba (offset ) (fromIntegral n)
306− writeChars mba (offset + 1) chars
421+ writeString mba (offset + 1) chars
307
422
308 | n < 0x800 ->
423 | n < 0x800 ->
309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
424 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
425 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
311− writeChars mba (offset + 2) chars
426+ writeString mba (offset + 2) chars
312
427
313 | n < 0x10000 ->
428 | n < 0x10000 ->
314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
429 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
430 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
431 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
317− writeChars mba (offset + 3) chars
432+ writeString mba (offset + 3) chars
318
433
319 | otherwise ->
434 | otherwise ->
320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
435 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
436 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
437 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
438 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
324− writeChars mba (offset + 4) chars
439+ writeString mba (offset + 4) chars
325
440
326 where
441 where
327 n = Char.ord char
442 n = Char.ord char
@@ -339,10 +454,10 @@ getWidth char
339
454
340
455
341
456
342−-- TO CHARS
457+-- TO STRING
343
458
344
459
345−toChars :: Utf8 t -> [Char]
460+toChars :: Utf8 l t -> [Char]
346toChars (Utf8 ba#) =
461toChars (Utf8 ba#) =
347 toCharsHelp ba# 0# (sizeofByteArray# ba#)
462 toCharsHelp ba# 0# (sizeofByteArray# ba#)
348
463
@@ -412,13 +527,13 @@ chr4 ba# offset# firstWord# =
412
527
413
528
414{-# INLINE toBuilder #-}
529{-# INLINE toBuilder #-}
415−toBuilder :: Utf8 t -> B.Builder
530+toBuilder :: Utf8 l t -> B.Builder
416toBuilder =
531toBuilder =
417 \bytes -> B.builder (toBuilderHelp bytes)
532 \bytes -> B.builder (toBuilderHelp bytes)
418
533
419
534
420{-# INLINE toBuilderHelp #-}
535{-# INLINE toBuilderHelp #-}
421−toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
536+toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
422toBuilderHelp !bytes@(Utf8 ba#) k =
537toBuilderHelp !bytes@(Utf8 ba#) k =
423 go 0 (I# (sizeofByteArray# ba#))
538 go 0 (I# (sizeofByteArray# ba#))
424 where
539 where
@@ -438,57 +553,10 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
438
553
439
554
440
555
441−-- TO ESCAPED BUILDER
442−
443−
444−{-# INLINE toEscapedBuilder #-}
445−toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
446−toEscapedBuilder before after =
447− \name -> B.builder (toEscapedBuilderHelp before after name)
448−
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 ()
485−
486−
487−
488-- FROM PTR
556-- FROM PTR
489
557
490
558
491−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
559+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
492fromPtr pos end =
560fromPtr pos end =
493 unsafeDupablePerformIO (stToIO (
561 unsafeDupablePerformIO (stToIO (
494 do let !len = minusPtr end pos
562 do let !len = minusPtr end pos
@@ -499,48 +567,130 @@ fromPtr pos end =
499
567
500
568
501
569
502−-- FROM SNIPPET
570+-- FROM CHUNKS
503
571
504
572
505−fromSnippet :: P.Snippet -> Utf8 t
573+data Chunk
506−fromSnippet (P.Snippet fptr off len _ _) =
574+ = Slice (Ptr Word8) Int
575+ | Escape Word8
576+ | CodePoint Int
577+
578+
579+fromChunks :: [Chunk] -> Utf8 l t
580+fromChunks chunks =
507 unsafeDupablePerformIO (stToIO (
581 unsafeDupablePerformIO (stToIO (
508− do mba <- newByteArray len
582+ do let !len = sum (map chunkToWidth chunks)
509− let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
583+ mba <- newByteArray len
510− copyFromPtr pos mba 0 len
584+ writeChunks mba 0 chunks
511 freeze mba
585 freeze mba
512 ))
586 ))
513
587
514
588
589+chunkToWidth :: Chunk -> Int
590+chunkToWidth chunk =
591+ case chunk of
592+ Slice _ len ->
593+ len
594+
595+ Escape _ ->
596+ 2
597+
598+ CodePoint code ->
599+ if code < 0xFFFF then 6 else 12
600+
601+
602+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
603+writeChunks mba offset chunks =
604+ case chunks of
605+ [] ->
606+ return ()
607+
608+ chunk : chunks ->
609+ case chunk of
610+ Slice ptr len ->
611+ do copyFromPtr ptr mba offset len
612+ let !newOffset = offset + len
613+ writeChunks mba newOffset chunks
614+
615+ Escape word ->
616+ do writeWord8 mba offset 0x5C {- \ -}
617+ writeWord8 mba (offset + 1) word
618+ let !newOffset = offset + 2
619+ writeChunks mba newOffset chunks
620+
621+ CodePoint code ->
622+ if code < 0xFFFF then
623+ do writeCode mba offset code
624+ let !newOffset = offset + 6
625+ writeChunks mba newOffset chunks
626+ else
627+ do let (hi,lo) = divMod (code - 0x10000) 0x400
628+ writeCode mba (offset ) (hi + 0xD800)
629+ writeCode mba (offset + 6) (lo + 0xDC00)
630+ let !newOffset = offset + 12
631+ writeChunks mba newOffset chunks
632+
633+
634+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
635+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
636+writeCode mba offset code =
637+ do writeWord8 mba offset 0x5C {- \ -}
638+ writeWord8 mba offset 0x75 {- u -}
639+ writeHex mba (offset + 2) (shiftR code 12)
640+ writeHex mba (offset + 3) (shiftR code 8)
641+ writeHex mba (offset + 4) (shiftR code 4)
642+ writeHex mba (offset + 5) code
643+
644+
645+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
646+writeHex mba !offset !bits =
647+ do let !n = fromIntegral bits .&. 0x0F
648+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
515
649
516−-- BINARY
517
650
518
651
519−putUnder256 :: Utf8 t -> Put
652+-- UNDER 256 BINARY
520−putUnder256 bytes =
521− do putWord8 (fromIntegral (size bytes))
522− putBuilder (toBuilder bytes)
523
653
524
654
525−getUnder256 :: Get (Utf8 t)
655+instance Binary (Utf8 UNDER_256 t) where
526−getUnder256 =
656+ put bytes@(Utf8 ba#) =
657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
658+ putBuilder (toBuilder bytes)
659+ get =
527− do word <- getWord8
660+ getUnder256 =<< getWord8
528− let !n = fromIntegral word
529− readN n (copyFromByteString n)
530
661
531
662
532−putVeryLong :: Utf8 t -> Put
663+{-# INLINE getUnder256 #-}
533−putVeryLong bytes =
664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
534− do put (size bytes)
665+getUnder256 w =
535− putBuilder (toBuilder bytes)
666+ let !n = fromIntegral w in
667+ readN n (copyFromByteString n)
536
668
537
669
670+
671+-- VERY LONG BINARY
672+
673+
674+instance Binary (Utf8 VERY_LONG t) where
675+ put str =
676+ do put (size str)
677+ putBuilder (toBuilder str)
678+ get =
538−getVeryLong :: Get (Utf8 t)
679+ getVeryLong =<< get
680+
681+
682+{-# INLINE getVeryLong #-}
683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
539−getVeryLong =
684+getVeryLong n =
540− do n <- get
541− if n > 0
685+ if n > 0
542− then readN n (copyFromByteString n)
686+ then readN n (copyFromByteString n)
543− else return empty
687+ else return empty
688+
689+
690+{-# NOINLINE empty #-}
691+empty :: Utf8 l t
692+empty =
693+ runST (freeze =<< newByteArray 0)
544
694
545
695
546
696
@@ -548,7 +698,7 @@ getVeryLong =
548
698
549
699
550{-# INLINE copyFromByteString #-}
700{-# INLINE copyFromByteString #-}
551−copyFromByteString :: Int -> B.ByteString -> Utf8 t
701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t
552copyFromByteString len (B.PS fptr offset _) =
702copyFromByteString len (B.PS fptr offset _) =
553 unsafeDupablePerformIO
703 unsafeDupablePerformIO
554 (
704 (
@@ -567,21 +717,21 @@ data MBA s =
567 MBA# (MutableByteArray# s)
717 MBA# (MutableByteArray# s)
568
718
569
719
570−newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
720+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
571newByteArray (I# len#) =
721newByteArray (I# len#) =
572 ST $ \s ->
722 ST $ \s ->
573 case newByteArray# len# s of
723 case newByteArray# len# s of
574 (# s, mba# #) -> (# s, MBA# mba# #)
724 (# s, mba# #) -> (# s, MBA# mba# #)
575
725
576
726
577−freeze :: MBA s -> ST s (Utf8 t)
727+freeze :: MBA s -> ST s (Utf8 l t)
578freeze (MBA# mba#) =
728freeze (MBA# mba#) =
579 ST $ \s ->
729 ST $ \s ->
580 case unsafeFreezeByteArray# mba# s of
730 case unsafeFreezeByteArray# mba# s of
581 (# s, ba# #) -> (# s, Utf8 ba# #)
731 (# s, ba# #) -> (# s, Utf8 ba# #)
582
732
583
733
584−copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
734+copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
735copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
586 ST $ \s ->
736 ST $ \s ->
587 case copyByteArray# ba# offset# mba# i# len# s of
737 case copyByteArray# ba# offset# mba# i# len# s of
@@ -595,11 +745,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
595 s -> (# s, () #)
745 s -> (# s, () #)
596
746
597
747
598−copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
600− IO $ \s ->
750+ IO $ \s ->
601− case copyByteArrayToAddr# ba# offset# mba# len# s of
751+ case copyByteArrayToAddr# ba# offset# mba# len# s of
602− s -> (# s, () #)
752+ s -> (# s, () #)
603
753
604
754
605{-# INLINE writeWord8 #-}
755{-# INLINE writeWord8 #-}
@@ -608,11 +758,3 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
608 ST $ \s ->
758 ST $ \s ->
609 case writeWord8Array# mba# offset# w# s of
759 case writeWord8Array# mba# offset# w# s of
610 s -> (# s, () #)
760 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.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Compiler
3+ ( Compile.Artifacts(..)
4+ , compile
5+ , Error.Error
6+ , errorsToDoc
7+ , errorsToJson
8+ , Warning.Warning
9+ )
10+ where
11+
12+
13+import qualified Data.ByteString as BS
14+import qualified Data.Map as Map
15+import qualified Data.Name as Name
16+import qualified Data.Utf8 as Utf8
17+
18+import qualified Compile
19+import qualified Elm.Interface as I
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Elm.Package as Pkg
22+import qualified Json.Encode as E
23+import Json.Encode ((==>))
24+import qualified Reporting.Annotation as A
25+import qualified Reporting.Doc as D
26+import qualified Reporting.Error as Error
27+import qualified Reporting.Render.Code as Code
28+import qualified Reporting.Report as Report
29+import qualified Reporting.Result as Result
30+import qualified Reporting.Warning as Warning
31+
32+
33+
34+-- COMPILE
35+
36+
37+compile
38+ :: Pkg.Name
39+ -> Map.Map ModuleName.Raw ModuleName.Canonical
40+ -> I.Interfaces
41+ -> BS.ByteString
42+ -> ( [Warning.Warning], Either [Error.Error] Compile.Artifacts )
43+compile pkg importDict interfaces source =
44+ Result.run $ Compile.compile pkg importDict interfaces source
45+
46+
47+
48+-- ERRORS TO DOC
49+
50+
51+errorsToDoc :: FilePath -> String -> [Error.Error] -> D.Doc
52+errorsToDoc filePath source errors =
53+ let
54+ reports =
55+ concatMap (Error.toReports (Code.toSource source)) errors
56+ in
57+ D.vcat $ map (Report.toDoc filePath) reports
58+
59+
60+
61+-- ERRORS TO JSON
62+
63+
64+errorsToJson :: ModuleName.Raw -> FilePath -> String -> [Error.Error] -> E.Value
65+errorsToJson moduleName filePath source errors =
66+ let
67+ reports =
68+ concatMap (Error.toReports (Code.toSource source)) errors
69+ in
70+ E.object
71+ [ "path" ==> E.string (Utf8.fromChars filePath)
72+ , "name" ==> E.string (Name.toUtf8 moduleName)
73+ , "problems" ==> E.array (map reportToJson reports)
74+ ]
75+
76+
77+reportToJson :: Report.Report -> E.Value
78+reportToJson (Report.Report title region _sgstns message) =
79+ E.object
80+ [ "title" ==> E.string (Utf8.fromChars title)
81+ , "region" ==> encodeRegion region
82+ , "message" ==> D.encode message
83+ ]
84+
85+
86+encodeRegion :: A.Region -> E.Value
87+encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
88+ E.object
89+ [ "start" ==>
90+ E.object
91+ [ ("line", E.int (fromIntegral sr))
92+ , ("column", E.int (fromIntegral sc))
93+ ]
94+ , "end" ==>
95+ E.object
96+ [ ("line", E.int (fromIntegral er))
97+ , ("column", E.int (fromIntegral ec))
98+ ]
99+ ]
compiler/src/Elm/Compiler/Imports.hs+13−4
@@ -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− ( defaults
4+ ( addDefaults
5 )
5 )
6 where
6 where
7
7
@@ -14,6 +14,15 @@ 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+
17-- DEFAULTS
26-- DEFAULTS
18
27
19
28
@@ -49,14 +58,14 @@ closed =
49
58
50typeOpen :: Name.Name -> Src.Exposing
59typeOpen :: Name.Name -> Src.Exposing
51typeOpen name =
60typeOpen name =
52− Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
61+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
53
62
54
63
55typeClosed :: Name.Name -> Src.Exposing
64typeClosed :: Name.Name -> Src.Exposing
56typeClosed name =
65typeClosed name =
57− Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
66+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
58
67
59
68
60operator :: Name.Name -> Src.Exposing
69operator :: Name.Name -> Src.Exposing
61operator op =
70operator op =
62− Src.Explicit [ Src.Operator A.zero op ]
71+ Src.Explicit [ A.At A.zero (Src.Operator op) ]
compiler/src/Elm/Compiler/Type.hs+27−26
@@ -15,12 +15,9 @@ 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
18
19
19import qualified AST.Source as Src
20import 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
24import qualified Parse.Primitives as P
21import qualified Parse.Primitives as P
25import qualified Parse.Type as Type
22import qualified Parse.Type as Type
26import qualified Reporting.Annotation as A
23import qualified Reporting.Annotation as A
@@ -28,6 +25,10 @@ import qualified Reporting.Doc as D
28import qualified Reporting.Render.Type as RT
25import qualified Reporting.Render.Type as RT
29import qualified Reporting.Render.Type.Localizer as L
26import qualified Reporting.Render.Type.Localizer as L
30
27
28+import qualified Json.Decode as D
29+import qualified Json.Encode as E
30+import Json.Encode ((==>))
31+
31
32
32
33
33-- TYPES
34-- TYPES
@@ -113,16 +114,18 @@ collectLambdas tipe =
113
114
114encode :: Type -> E.Value
115encode :: Type -> E.Value
115encode tipe =
116encode tipe =
116− E.chars $ D.toLine (toDoc L.empty RT.None tipe)
117+ E.string $ Utf8.fromChars $ D.toLine (toDoc L.empty RT.None tipe)
117
118
118
119
119decoder :: D.Decoder () Type
120decoder :: D.Decoder () Type
120decoder =
121decoder =
121− let
122+ do str <- D.string
122− parser =
123+ case P.fromByteString Type.expression (error "TODO turn Utf8 to something that can be parsed" str) of
123− P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
124+ P.Ok (tipe, _, _) _ ->
124− in
125+ return (fromRawType tipe)
125− D.customString parser (\_ _ -> ())
126+
127+ P.Err _ _ _ _ ->
128+ D.failure ()
126
129
127
130
128fromRawType :: Src.Type -> Type
131fromRawType :: Src.Type -> Type
@@ -164,31 +167,29 @@ encodeMetadata :: DebugMetadata -> E.Value
164encodeMetadata (DebugMetadata msg aliases unions) =
167encodeMetadata (DebugMetadata msg aliases unions) =
165 E.object
168 E.object
166 [ "message" ==> encode msg
169 [ "message" ==> encode msg
167− , "aliases" ==> E.object (map toTypeAliasField aliases)
170+ , "aliases" ==> E.object (map toAliasField aliases)
168− , "unions" ==> E.object (map toCustomTypeField unions)
171+ , "unions" ==> E.object (map toUnionField unions)
169 ]
172 ]
170
173
171
174
172−toTypeAliasField :: Alias -> ( Json.String, E.Value )
175+toAliasField :: Alias -> ( Utf8.String, E.Value )
173−toTypeAliasField (Alias name args tipe) =
176+toAliasField (Alias name args tipe) =
174− ( Json.fromName name
177+ Name.toUtf8 name ==>
175− , E.object
178+ E.object
176 [ "args" ==> E.list E.name args
179 [ "args" ==> E.list E.name args
177 , "type" ==> encode tipe
180 , "type" ==> encode tipe
178 ]
181 ]
179− )
180
182
181
183
182−toCustomTypeField :: Union -> ( Json.String, E.Value )
184+toUnionField :: Union -> ( Utf8.String, E.Value )
183−toCustomTypeField (Union name args constructors) =
185+toUnionField (Union name args constructors) =
184− ( Json.fromName name
186+ Name.toUtf8 name ==>
185− , E.object
187+ E.object
186 [ "args" ==> E.list E.name args
188 [ "args" ==> E.list E.name args
187− , "tags" ==> E.object (map toVariantObject constructors)
189+ , "tags" ==> E.object (map toCtorObject constructors)
188 ]
190 ]
189− )
190
191
191
192
192−toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
193+toCtorObject :: (Name.Name, [Type]) -> ( Utf8.String, E.Value )
193−toVariantObject (name, args) =
194+toCtorObject (name, args) =
194− ( Json.fromName name, E.list encode args )
195+ Name.toUtf8 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− -- PERF profile Opt.Global representation
90+ -- TODO profile Opt.Global representation
91 -- current representation needs less allocation
91 -- current representation needs less allocation
92 -- but maybe the lookup is much worse
92 -- but maybe the lookup is much worse
93
93
compiler/src/Elm/Constraint.hs+77−55
@@ -5,6 +5,9 @@ module Elm.Constraint
5 , exactly
5 , exactly
6 , anything
6 , anything
7 , toChars
7 , toChars
8+ , toString
9+ , Error(..)
10+ , fromString
8 , satisfies
11 , satisfies
9 , check
12 , check
10 , intersect
13 , intersect
@@ -13,8 +16,6 @@ module Elm.Constraint
13 , untilNextMajor
16 , untilNextMajor
14 , untilNextMinor
17 , untilNextMinor
15 , expand
18 , expand
16− --
17− , Error(..)
18 , decoder
19 , decoder
19 , encode
20 , encode
20 )
21 )
@@ -23,12 +24,11 @@ module Elm.Constraint
23
24
24import Control.Monad (liftM4)
25import Control.Monad (liftM4)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
26import Data.Binary (Binary, get, put, getWord8, putWord8)
27+import qualified Data.Utf8 as Utf8
26
28
27import qualified Elm.Version as V
29import qualified Elm.Version as V
28import qualified Json.Decode as D
30import qualified Json.Decode as D
29import qualified Json.Encode as E
31import 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,21 +61,78 @@ anything =
61
61
62
62
63
63
64−-- TO CHARS
64+-- TO STRING
65
65
66
66
67−toChars :: Constraint -> [Char]
67+toChars :: Constraint -> String
68toChars constraint =
68toChars constraint =
69+ Utf8.toChars (toString constraint)
70+
71+
72+toString :: Constraint -> Utf8.String
73+toString constraint =
69 case constraint of
74 case constraint of
70 Range lower lowerOp upperOp upper ->
75 Range lower lowerOp upperOp upper ->
71− V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
76+ Utf8.join 0x20 {- -}
77+ [ V.toString lower
78+ , toStringHelp lowerOp
79+ , "v"
80+ , toStringHelp upperOp
81+ , V.toString upper
82+ ]
72
83
73
84
74−opToChars :: Op -> [Char]
85+toStringHelp :: Op -> Utf8.String
75−opToChars op =
86+toStringHelp op =
76 case op of
87 case op of
77− Less -> " < "
88+ Less -> "<"
78− LessOrEqual -> " <= "
89+ LessOrEqual -> "<="
90+
91+
92+
93+-- FROM STRING
94+
95+
96+data Error
97+ = BadLower Utf8.String
98+ | BadUpper Utf8.String
99+ | BadFormat
100+ | InvalidOp
101+ | InvalidRange V.Version V.Version
102+
103+
104+fromString :: Utf8.String -> Either Error Constraint
105+fromString string =
106+ case Utf8.split 0x20 {- -} string of
107+ [lower, lowerOp, "v", upperOp, upper] ->
108+ do lo <- versionFromString lower BadLower
109+ lop <- opFromString lowerOp
110+ hop <- opFromString upperOp
111+ hi <- versionFromString upper BadUpper
112+ if lo < hi
113+ then Right (Range lo lop hop hi)
114+ else Left (InvalidRange lo hi)
115+
116+ _ ->
117+ Left BadFormat
118+
119+
120+versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version
121+versionFromString string toError =
122+ case V.fromString string of
123+ Just vsn ->
124+ Right vsn
125+
126+ Nothing ->
127+ Left (toError string)
128+
129+
130+opFromString :: Utf8.String -> Either Error Op
131+opFromString text =
132+ case text of
133+ "<=" -> Right LessOrEqual
134+ "<" -> Right Less
135+ _ -> Left InvalidOp
79
136
80
137
81
138
@@ -188,12 +245,18 @@ expand constraint@(Range lower lowerOp upperOp upper) version
188
245
189encode :: Constraint -> E.Value
246encode :: Constraint -> E.Value
190encode constraint =
247encode constraint =
191− E.chars (toChars constraint)
248+ E.string (toString constraint)
192
249
193
250
194decoder :: D.Decoder Error Constraint
251decoder :: D.Decoder Error Constraint
195decoder =
252decoder =
196− D.customString parser BadFormat
253+ do str <- D.string
254+ case fromString str of
255+ Right constraint ->
256+ return constraint
257+
258+ Left err ->
259+ D.failure err
197
260
198
261
199
262
@@ -216,45 +279,4 @@ instance Binary Op where
216 case n of
279 case n of
217 0 -> return Less
280 0 -> return Less
218 1 -> return LessOrEqual
281 1 -> return LessOrEqual
219− _ -> fail "binary encoding of Op was corrupted"
282+ _ -> error "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+158−218
@@ -1,7 +1,8 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE OverloadedStrings #-}
3module Elm.Docs
3module Elm.Docs
4 ( Documentation
4 ( Documentation
5+ , toDict
5 , Module(..)
6 , Module(..)
6 , fromModule
7 , fromModule
7 , Union(..)
8 , Union(..)
@@ -17,35 +18,33 @@ module Elm.Docs
17 where
18 where
18
19
19
20
20−import qualified Data.Coerce as Coerce
21+import qualified Data.ByteString as B
21import qualified Data.List as List
22import qualified Data.List as List
22import Data.Map ((!))
23import Data.Map ((!))
23import qualified Data.Map as Map
24import 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.NonEmptyList as NE
26+import qualified Data.Text as Text
27−import qualified Data.OneOrMore as OneOrMore
27+import qualified Data.Text.Encoding as Text
28−import Data.Word (Word8)
29−import Foreign.Ptr (Ptr, plusPtr)
30
28
31import qualified AST.Canonical as Can
29import qualified AST.Canonical as Can
32−import qualified AST.Source as Src
33import qualified AST.Utils.Binop as Binop
30import qualified AST.Utils.Binop as Binop
31+import qualified Data.OneOrMore as OneOrMore
34import qualified Elm.Compiler.Type as Type
32import qualified Elm.Compiler.Type as Type
35import qualified Elm.Compiler.Type.Extract as Extract
33import qualified Elm.Compiler.Type.Extract as Extract
36import qualified Elm.ModuleName as ModuleName
34import qualified Elm.ModuleName as ModuleName
37import qualified Json.Decode as D
35import qualified Json.Decode as D
38import qualified Json.Encode as E
36import qualified Json.Encode as E
39import Json.Encode ((==>))
37import 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
46import qualified Reporting.Annotation as A
38import qualified Reporting.Annotation as A
39+import qualified Reporting.Error as Error
47import qualified Reporting.Error.Docs as E
40import qualified Reporting.Error.Docs as E
41+import qualified Reporting.Region as R
48import qualified Reporting.Result as Result
42import 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
49
48
50
49
51
50
@@ -56,6 +55,21 @@ type Documentation =
56 Map.Map Name.Name Module
55 Map.Map Name.Name Module
57
56
58
57
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+
59data Module =
73data Module =
60 Module
74 Module
61 { _name :: Name.Name
75 { _name :: Name.Name
@@ -66,7 +80,9 @@ data Module =
66 , _binops :: Map.Map Name.Name Binop
80 , _binops :: Map.Map Name.Name Binop
67 }
81 }
68
82
83+
69−type Comment = Json.String
84+type Comment = Text.Text
85+
70
86
71data Alias = Alias Comment [Name.Name] Type.Type
87data Alias = Alias Comment [Name.Name] Type.Type
72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
88data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -75,19 +91,14 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
75
91
76
92
77
93
78−-- JSON
94+-- JSON ENCODE / DECODE
79−
80−
81−encode :: Documentation -> E.Value
82−encode docs =
83− E.list encodeModule (Map.elems docs)
84
95
85
96
86−encodeModule :: Module -> E.Value
97+encode :: Module -> E.Value
87−encodeModule (Module name comment unions aliases values binops) =
98+encode (Module name comment unions aliases values binops) =
88 E.object $
99 E.object $
89 [ "name" ==> ModuleName.encode name
100 [ "name" ==> ModuleName.encode name
90− , "comment" ==> E.string comment
101+ , "comment" ==> E.text comment
91 , "unions" ==> E.list encodeUnion (Map.toList unions)
102 , "unions" ==> E.list encodeUnion (Map.toList unions)
92 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
93 , "values" ==> E.list encodeValue (Map.toList values)
104 , "values" ==> E.list encodeValue (Map.toList values)
@@ -96,31 +107,16 @@ encodeModule (Module name comment unions aliases values binops) =
96
107
97
108
98data Error
109data Error
99− = BadAssociativity
110+ = BadAssociativity Text.Text
100− | BadModuleName
111+ | BadName
101 | BadType
112 | BadType
102
113
103
114
104−decoder :: D.Decoder Error Documentation
115+decoder :: D.Decoder Error Module
105decoder =
116decoder =
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 =
121 Module
117 Module
122− <$> D.field "name" moduleNameDecoder
118+ <$> D.field "name" nameDecoder
123− <*> D.field "comment" D.string
119+ <*> D.field "comment" D.text
124 <*> D.field "unions" (dictDecoder union)
120 <*> D.field "unions" (dictDecoder union)
125 <*> D.field "aliases" (dictDecoder alias)
121 <*> D.field "aliases" (dictDecoder alias)
126 <*> D.field "values" (dictDecoder value)
122 <*> D.field "values" (dictDecoder value)
@@ -135,18 +131,13 @@ dictDecoder entryDecoder =
135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
136named entryDecoder =
132named entryDecoder =
137 (,)
133 (,)
138− <$> D.field "name" nameDecoder
134+ <$> D.field "name" D.name
139 <*> entryDecoder
135 <*> entryDecoder
140
136
141
137
142−nameDecoder :: D.Decoder e Name.Name
138+nameDecoder :: D.Decoder Error Name.Name
143nameDecoder =
139nameDecoder =
144− fmap Coerce.coerce D.string
145−
146−
147−moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148−moduleNameDecoder =
149− D.mapError (const BadModuleName) ModuleName.decoder
140+ D.mapError (const BadName) ModuleName.decoder
150
141
151
142
152typeDecoder :: D.Decoder Error Type.Type
143typeDecoder :: D.Decoder Error Type.Type
@@ -162,7 +153,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
162encodeUnion (name, Union comment args cases) =
153encodeUnion (name, Union comment args cases) =
163 E.object
154 E.object
164 [ "name" ==> E.name name
155 [ "name" ==> E.name name
165− , "comment" ==> E.string comment
156+ , "comment" ==> E.text comment
166 , "args" ==> E.list E.name args
157 , "args" ==> E.list E.name args
167 , "cases" ==> E.list encodeCase cases
158 , "cases" ==> E.list encodeCase cases
168 ]
159 ]
@@ -171,8 +162,8 @@ encodeUnion (name, Union comment args cases) =
171union :: D.Decoder Error Union
162union :: D.Decoder Error Union
172union =
163union =
173 Union
164 Union
174− <$> D.field "comment" D.string
165+ <$> D.field "comment" D.text
175− <*> D.field "args" (D.list nameDecoder)
166+ <*> D.field "args" (D.list D.name)
176 <*> D.field "cases" (D.list caseDecoder)
167 <*> D.field "cases" (D.list caseDecoder)
177
168
178
169
@@ -183,7 +174,7 @@ encodeCase ( tag, args ) =
183
174
184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
185caseDecoder =
176caseDecoder =
186− D.pair nameDecoder (D.list typeDecoder)
177+ D.pair D.name (D.list typeDecoder)
187
178
188
179
189
180
@@ -194,7 +185,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
194encodeAlias ( name, Alias comment args tipe) =
185encodeAlias ( name, Alias comment args tipe) =
195 E.object
186 E.object
196 [ "name" ==> E.name name
187 [ "name" ==> E.name name
197− , "comment" ==> E.string comment
188+ , "comment" ==> E.text comment
198 , "args" ==> E.list E.name args
189 , "args" ==> E.list E.name args
199 , "type" ==> Type.encode tipe
190 , "type" ==> Type.encode tipe
200 ]
191 ]
@@ -203,8 +194,8 @@ encodeAlias ( name, Alias comment args tipe) =
203alias :: D.Decoder Error Alias
194alias :: D.Decoder Error Alias
204alias =
195alias =
205 Alias
196 Alias
206− <$> D.field "comment" D.string
197+ <$> D.field "comment" D.text
207− <*> D.field "args" (D.list nameDecoder)
198+ <*> D.field "args" (D.list D.name)
208 <*> D.field "type" typeDecoder
199 <*> D.field "type" typeDecoder
209
200
210
201
@@ -216,7 +207,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
216encodeValue (name, Value comment tipe) =
207encodeValue (name, Value comment tipe) =
217 E.object
208 E.object
218 [ "name" ==> E.name name
209 [ "name" ==> E.name name
219− , "comment" ==> E.string comment
210+ , "comment" ==> E.text comment
220 , "type" ==> Type.encode tipe
211 , "type" ==> Type.encode tipe
221 ]
212 ]
222
213
@@ -224,7 +215,7 @@ encodeValue (name, Value comment tipe) =
224value :: D.Decoder Error Value
215value :: D.Decoder Error Value
225value =
216value =
226 Value
217 Value
227− <$> D.field "comment" D.string
218+ <$> D.field "comment" D.text
228 <*> D.field "type" typeDecoder
219 <*> D.field "type" typeDecoder
229
220
230
221
@@ -236,7 +227,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
236encodeBinop (name, Binop comment tipe assoc prec) =
227encodeBinop (name, Binop comment tipe assoc prec) =
237 E.object
228 E.object
238 [ "name" ==> E.name name
229 [ "name" ==> E.name name
239− , "comment" ==> E.string comment
230+ , "comment" ==> E.text comment
240 , "type" ==> Type.encode tipe
231 , "type" ==> Type.encode tipe
241 , "associativity" ==> encodeAssoc assoc
232 , "associativity" ==> encodeAssoc assoc
242 , "precedence" ==> encodePrec prec
233 , "precedence" ==> encodePrec prec
@@ -246,7 +237,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
246binop :: D.Decoder Error Binop
237binop :: D.Decoder Error Binop
247binop =
238binop =
248 Binop
239 Binop
249− <$> D.field "comment" D.string
240+ <$> D.field "comment" D.text
250 <*> D.field "type" typeDecoder
241 <*> D.field "type" typeDecoder
251 <*> D.field "associativity" assocDecoder
242 <*> D.field "associativity" assocDecoder
252 <*> D.field "precedence" precDecoder
243 <*> D.field "precedence" precDecoder
@@ -259,23 +250,19 @@ binop =
259encodeAssoc :: Binop.Associativity -> E.Value
250encodeAssoc :: Binop.Associativity -> E.Value
260encodeAssoc assoc =
251encodeAssoc assoc =
261 case assoc of
252 case assoc of
262− Binop.Left -> E.chars "left"
253+ Binop.Left -> E.text "left"
263− Binop.Non -> E.chars "non"
254+ Binop.Non -> E.text "non"
264− Binop.Right -> E.chars "right"
255+ Binop.Right -> E.text "right"
265
256
266
257
267assocDecoder :: D.Decoder Error Binop.Associativity
258assocDecoder :: D.Decoder Error Binop.Associativity
268assocDecoder =
259assocDecoder =
269− let
260+ do txt <- D.text
270− left = Json.fromChars "left"
261+ case txt of
271− non = Json.fromChars "non"
272− right = Json.fromChars "right"
273− in
274− do str <- D.string
275− if | str == left -> return Binop.Left
262+ "left" -> D.succeed Binop.Left
276− | str == non -> return Binop.Non
263+ "non" -> D.succeed Binop.Non
277− | str == right -> return Binop.Right
264+ "right" -> D.succeed Binop.Right
278− | otherwise -> D.failure BadAssociativity
265+ _ -> D.fail (BadAssociativity txt)
279
266
280
267
281
268
@@ -296,190 +283,142 @@ precDecoder =
296-- FROM MODULE
283-- FROM MODULE
297
284
298
285
299−fromModule :: Can.Module -> Either E.Error Module
286+fromModule :: Can.Module -> Result.Result i w Error.Error Module
300−fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
287+fromModule (Can.Module name docs exports decls unions aliases binops effects) =
301 case exports of
288 case exports of
302 Can.ExportEverything region ->
289 Can.ExportEverything region ->
303− Left (E.ImplicitExposing region)
290+ Result.throw $ Error.Docs $ E.ImplicitExposing region
304
291
305 Can.Export exportDict ->
292 Can.Export exportDict ->
306 case docs of
293 case docs of
307− Src.NoDocs region ->
294+ Can.NoDocs region ->
308− Left (E.NoDocs region)
295+ Result.throw $ Error.Docs $ E.NoDocs region
309
296
310− Src.YesDocs overview comments ->
297+ Can.YesDocs region overview comments ->
311− do names <- parseOverview overview
298+ do names <- parseOverview region overview
299+ Result.mapError Error.Docs $
312− checkNames exportDict names
300+ do checkNames exportDict names
313− checkDefs exportDict overview (Map.fromList comments) modul
301+ let types = gatherTypes decls Map.empty
302+ let info = Info comments types unions aliases binops effects
303+ inserters <- Map.traverseWithKey (checkExport info) exportDict
304+ return $ foldr ($) (emptyModule name overview) inserters
305+
306+
307+emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308+emptyModule (ModuleName.Canonical _ name) overview =
309+ Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
314
310
315
311
316
312
317-- PARSE OVERVIEW
313-- PARSE OVERVIEW
318
314
319
315
320−parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
316+parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
321−parseOverview (Src.Comment snippet) =
317+parseOverview (R.Region (R.Position row col) _) overview =
322− case P.fromSnippet (chompOverview []) E.BadEnd snippet of
318+ case P.runAt row (col + 3) (chompOverview []) overview of
323 Left err ->
319 Left err ->
324− Left (E.SyntaxProblem err)
320+ Result.throw (Error.Syntax err)
325
321
326 Right names ->
322 Right names ->
327− Right names
323+ Result.ok names
328−
329−
330−type Parser a =
331− P.Parser E.SyntaxProblem a
332
324
333
325
334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335chompOverview names =
327chompOverview names =
336− do isDocs <- chompUntilDocs
328+ do isDocs <- W.chompUntilDocs
337 if isDocs
329 if isDocs
338− then
330+ then chompOverviewHelp names
339− do Space.chomp E.Space
331+ else return names
332+
333+
334+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335+chompOverviewHelp names =
336+ do pos <- P.getPosition
337+ (W.SPos spos) <- W.whitespace
338+ if pos == spos
339+ then chompOverview names
340− chompOverview =<< chompDocs names
340+ else chompOverview =<< chompDocs names
341− else
342− return names
343
341
344
342
345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
346chompDocs names =
344chompDocs names =
347− do name <-
345+ do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
348− P.addLocation $
346+ spos <- W.whitespace
349− P.oneOf E.Name
347+ P.oneOf
350− [ Var.lower E.Name
348+ [ do P.checkSpace spos
351− , Var.upper E.Name
349+ Symbol.comma
352− , chompOperator
350+ P.spaces
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
362 chompDocs (name:names)
351 chompDocs (name:names)
352+ , return (name:names)
363 ]
353 ]
364− (name:names)
354+
365−
355+
366−
367−chompOperator :: Parser Name.Name
356+chompBinop :: Parser Name.Name
368−chompOperator =
357+chompBinop =
369− do word1 0x28 {-(-} E.Op
358+ do Symbol.leftParen
370− op <- Symbol.operator E.Op E.OpBad
359+ name <- Symbol.binop
371− word1 0x29 {-)-} E.Op
360+ Symbol.rightParen
372− return op
361+ return name
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)
409
362
410
363
411
364
412-- CHECK NAMES
365-- CHECK NAMES
413
366
414
367
415−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
368+type Result i w a =
416−checkNames exports names =
369+ Result.Result i w E.Error a
417− let
370+
418− docs = List.foldl' addName Map.empty names
371+
419− loneDoc = Map.traverseMissing onlyInDocs
372+type Dups =
420− loneExport = Map.traverseMissing onlyInExports
373+ Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
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))
426
374
427
375
428−type DocNameRegions =
376+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
429− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
377+checkNames exports names =
378+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379+ let overlap = Map.size (Map.intersection docs exports)
380+ if Map.size exports == overlap && overlap == Map.size docs
381+ then Result.ok ()
382+ else
383+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385+ Result.ok ()
430
386
431
387
432−addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
388+addName :: Dups -> A.Located Name.Name -> Dups
433addName dict (A.At region name) =
389addName dict (A.At region name) =
434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
435
391
436
392
437−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
393+isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
438isUnique name regions =
394isUnique name regions =
439 case regions of
395 case regions of
440 OneOrMore.One region ->
396 OneOrMore.One region ->
441 Result.ok region
397 Result.ok region
442
398
443− OneOrMore.More left right ->
399+ OneOrMore.More _ _ ->
444− let (r1, r2) = OneOrMore.getFirstTwo left right in
400+ let (r1:r2:_) = OneOrMore.toList regions in
445− Result.throw (E.NameDuplicate name r1 r2)
401+ Result.throw (E.Duplicate name r1 r2)
446
402
447
403
448−onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
404+onlyInDocs :: Name.Name -> R.Region -> Result i w a
449−onlyInDocs name regions =
405+onlyInDocs name region =
450− do region <- isUnique name regions
451− Result.throw $ E.NameOnlyInDocs name region
406+ Result.throw $ E.OnlyInDocs name region
452
407
453
408
454−onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
409+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
455onlyInExports name (A.At region _) =
410onlyInExports name (A.At region _) =
456− Result.throw $ E.NameOnlyInExports name region
411+ Result.throw $ E.OnlyInExports name region
457−
458−
459−
460−-- CHECK DEFS
461−
462
412
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
472
413
473
414
474−emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
415+-- CHECK EXPORTS
475−emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476− Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
477
416
478
417
479data Info =
418data Info =
480 Info
419 Info
481− { _iComments :: Map.Map Name.Name Src.Comment
420+ { _iComments :: Map.Map Name.Name Comment
482− , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
421+ , _iValues :: Types
483 , _iUnions :: Map.Map Name.Name Can.Union
422 , _iUnions :: Map.Map Name.Name Can.Union
484 , _iAliases :: Map.Map Name.Name Can.Alias
423 , _iAliases :: Map.Map Name.Name Can.Alias
485 , _iBinops :: Map.Map Name.Name Can.Binop
424 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -487,7 +426,7 @@ data Info =
487 }
426 }
488
427
489
428
490−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
429+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
491checkExport info name (A.At region export) =
430checkExport info name (A.At region export) =
492 case export of
431 case export of
493 Can.ExportValue ->
432 Can.ExportValue ->
@@ -528,23 +467,23 @@ checkExport info name (A.At region export) =
528 m { _values = Map.insert name (Value comment tipe) (_values m) }
467 m { _values = Map.insert name (Value comment tipe) (_values m) }
529
468
530
469
531−getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
470+getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
532getComment region name info =
471getComment region name info =
533 case Map.lookup name (_iComments info) of
472 case Map.lookup name (_iComments info) of
534 Nothing ->
473 Nothing ->
535 Result.throw (E.NoComment name region)
474 Result.throw (E.NoComment name region)
536
475
537− Just (Src.Comment snippet) ->
476+ Just comment ->
538− Result.ok (Json.fromComment snippet)
477+ Result.ok comment
539
478
540
479
541−getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
480+getType :: Name.Name -> Info -> Result i w Type.Type
542getType name info =
481getType name info =
543 case _iValues info ! name of
482 case _iValues info ! name of
544− Left region ->
483+ A.At defRegion Nothing ->
545− Result.throw (E.NoAnnotation name region)
484+ Result.throw (E.NoAnnotation name defRegion)
546
485
547− Right tipe ->
486+ A.At _ (Just tipe) ->
548 Result.ok (Extract.fromType tipe)
487 Result.ok (Extract.fromType tipe)
549
488
550
489
@@ -558,7 +497,7 @@ dector (Can.Ctor name _ _ args) =
558
497
559
498
560type Types =
499type Types =
561− Map.Map Name.Name (Either A.Region Can.Type)
500+ Map.Map Name.Name (A.Located (Maybe Can.Type))
562
501
563
502
564gatherTypes :: Can.Decls -> Types -> Types
503gatherTypes :: Can.Decls -> Types -> Types
@@ -567,8 +506,8 @@ gatherTypes decls types =
567 Can.Declare def subDecls ->
506 Can.Declare def subDecls ->
568 gatherTypes subDecls (addDef types def)
507 gatherTypes subDecls (addDef types def)
569
508
570− Can.DeclareRec def defs subDecls ->
509+ Can.DeclareRec defs subDecls ->
571− gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
510+ gatherTypes subDecls (List.foldl' addDef types defs)
572
511
573 Can.SaveTheEnvironment ->
512 Can.SaveTheEnvironment ->
574 types
513 types
@@ -578,10 +517,11 @@ addDef :: Types -> Can.Def -> Types
578addDef types def =
517addDef types def =
579 case def of
518 case def of
580 Can.Def (A.At region name) _ _ ->
519 Can.Def (A.At region name) _ _ ->
581− Map.insert name (Left region) types
520+ Map.insert name (A.At region Nothing) types
582
521
583− Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
522+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
584 let
523 let
524+ tipe =
585− tipe = foldr Can.TLambda resultType (map snd typedArgs)
525+ foldr Can.TLambda resultType (map snd typedArgs)
586 in
526 in
587− Map.insert name (Right tipe) types
527+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Elm/Float.hsdeleted−51
@@ -1,51 +0,0 @@
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− _ -> fail "binary encoding of Union was corrupted"
218+ _ -> error "binary encoding of Union was corrupted"
219
219
220
220
221instance Binary Alias where
221instance Binary Alias where
@@ -229,7 +229,7 @@ instance Binary Alias where
229 case n of
229 case n of
230 0 -> liftM PublicAlias get
230 0 -> liftM PublicAlias get
231 1 -> liftM PrivateAlias get
231 1 -> liftM PrivateAlias get
232− _ -> fail "binary encoding of Alias was corrupted"
232+ _ -> error "binary encoding of Alias was corrupted"
233
233
234
234
235instance Binary Binop where
235instance Binary Binop where
@@ -251,4 +251,4 @@ instance Binary DependencyInterface where
251 case n of
251 case n of
252 0 -> liftM Public get
252 0 -> liftM Public get
253 1 -> liftM3 Private get get get
253 1 -> liftM3 Private get get get
254− _ -> fail "binary encoding of DependencyInterface was corrupted"
254+ _ -> error "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+56−71
@@ -11,24 +11,25 @@ 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.Internal as B
14+import qualified Data.ByteString as BS
15+import Data.Coerce (coerce)
15import qualified Data.List as List
16import qualified Data.List as List
16import qualified Data.Map as Map
17import qualified Data.Map as Map
17import qualified Data.Name as Name
18import qualified Data.Name as Name
19+import qualified Data.Utf8 as Utf8
18−import Data.Word (Word8)
20+import Data.Word (Word8, Word16)
19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
21+import Foreign.Ptr (Ptr, plusPtr)
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
25import qualified Elm.Package as Pkg
25import qualified Elm.Package as Pkg
26import qualified Parse.Module as Module
26import qualified Parse.Module as Module
27−import qualified Parse.Space as Space
28import qualified Parse.Variable as Var
27import qualified Parse.Variable as Var
28+import Parse.Utils
29−import Parse.Primitives hiding (fromByteString)
29+import Parse.Primitives hiding (Parser, fromByteString)
30import qualified Parse.Primitives as P
30import qualified Parse.Primitives as P
31import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
32+import qualified Reporting.Error.Syntax as E
32
33
33
34
34
35
@@ -36,7 +37,7 @@ import qualified Reporting.Annotation as A
36
37
37
38
38data Chunk
39data Chunk
39− = JS B.ByteString
40+ = JS (Utf8.VeryLong UNCHECKED)
40 | ElmVar ModuleName.Canonical Name.Name
41 | ElmVar ModuleName.Canonical Name.Name
41 | JsVar Name.Name Name.Name
42 | JsVar Name.Name Name.Name
42 | ElmField Name.Name
43 | ElmField Name.Name
@@ -46,6 +47,9 @@ data Chunk
46 | Prod
47 | Prod
47
48
48
49
50+data UNCHECKED
51+
52+
49
53
50-- COUNT FIELDS
54-- COUNT FIELDS
51
55
@@ -80,58 +84,44 @@ type Foreigns =
80 Map.Map ModuleName.Raw Pkg.Name
84 Map.Map ModuleName.Raw Pkg.Name
81
85
82
86
83−fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content
87+fromByteString :: Pkg.Name -> Foreigns -> BS.ByteString -> Maybe Content
84fromByteString pkg foreigns bytes =
88fromByteString pkg foreigns bytes =
85− case P.fromByteString (parser pkg foreigns) toError bytes of
89+ case P.fromByteString (parser pkg foreigns) bytes of
86− Right content ->
87− Just content
90+ P.Ok content _ -> Just content
91+ P.Err _ _ _ _ -> Nothing
88
92
89− Left () ->
90− Nothing
91
93
92−
93−parser :: Pkg.Name -> Foreigns -> Parser () Content
94+parser :: Pkg.Name -> Foreigns -> Parser Content
94parser pkg foreigns =
95parser pkg foreigns =
95− do word2 0x2F 0x2A {-/*-} toError
96+ do word2 0x2F 0x2A {-/*-} E.XXX
96− Space.chomp ignoreError
97+ Module.freshLine
97− Space.checkFreshLine toError
98− imports <- specialize ignoreError (Module.chompImports [])
98+ imports <- Module.chompImports []
99− word2 0x2A 0x2F {-*/-} toError
99+ word2 0x2A 0x2F {-*/-} E.XXX
100 chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty
100 chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty
101 return (Content imports chunks)
101 return (Content imports chunks)
102
102
103
103
104−toError :: Row -> Col -> ()
105−toError _ _ =
106− ()
107−
108−
109−ignoreError :: a -> Row -> Col -> ()
110−ignoreError _ _ _ =
111− ()
112−
113−
114
104
115-- PARSE CHUNKS
105-- PARSE CHUNKS
116
106
117
107
118−parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
108+parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]
119parseChunks vtable enums fields =
109parseChunks vtable enums fields =
120− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
110+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr _ ->
121 let
111 let
122 (# chunks, newPos, newRow, newCol #) =
112 (# chunks, newPos, newRow, newCol #) =
123− chompChunks vtable enums fields src pos end row col pos []
113+ chompChunks vtable enums fields pos end row col pos []
124 in
114 in
125 if newPos == end then
115 if newPos == end then
126− cok chunks (P.State src newPos end indent newRow newCol)
116+ cok chunks (P.State newPos end indent newRow newCol ctx)
127 else
117 else
128− cerr row col toError
118+ cerr row col ctx E.XXX
129
119
130
120
131−chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
121+chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
132−chompChunks vs es fs src pos end row col lastPos revChunks =
122+chompChunks vs es fs pos end row col lastPos revChunks =
133 if pos >= end then
123 if pos >= end then
134− let !js = toByteString src lastPos end in
124+ let !js = Utf8.fromPtr lastPos end in
135 (# reverse (JS js : revChunks), pos, row, col #)
125 (# reverse (JS js : revChunks), pos, row, col #)
136
126
137 else
127 else
@@ -142,34 +132,24 @@ chompChunks vs es fs src pos end row col lastPos revChunks =
142 !pos3 = plusPtr pos 3
132 !pos3 = plusPtr pos 3
143 in
133 in
144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
134 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
145− let !js = toByteString src lastPos pos in
135+ let !js = Utf8.fromPtr lastPos pos in
146− chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
136+ chompTag vs es fs pos3 end row (col + 3) (JS js : revChunks)
147 else
137 else
148− chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
138+ chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
149
139
150 else if word == 0x0A {-\n-} then
140 else if word == 0x0A {-\n-} then
151− chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
141+ chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
152
142
153 else
143 else
154 let
144 let
155− !newPos = plusPtr pos (getCharWidth word)
145+ !newPos = plusPtr pos (getCharWidth pos end word)
156 in
146 in
157− chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
147+ chompChunks vs es fs 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−
168
148
169
149
170-- relies on external checks in chompChunks
150-- relies on external checks in chompChunks
171−chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
151+chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
172−chompTag vs es fs src pos end row col revChunks =
152+chompTag vs es fs pos end row col revChunks =
173 let
153 let
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
154 (# newPos, newCol #) = Var.chompInnerChars pos end col
175 !tagPos = plusPtr pos (-1)
155 !tagPos = plusPtr pos (-1)
@@ -179,7 +159,7 @@ chompTag vs es fs src pos end row col revChunks =
179 let
159 let
180 !name = Name.fromPtr pos newPos
160 !name = Name.fromPtr pos newPos
181 in
161 in
182− chompChunks vs es fs src newPos end row newCol newPos $
162+ chompChunks vs es fs newPos end row newCol newPos $
183 ElmField name : revChunks
163 ElmField name : revChunks
184 else
164 else
185 let
165 let
@@ -190,7 +170,7 @@ chompTag vs es fs src pos end row col revChunks =
190 (enum, newEnums) =
170 (enum, newEnums) =
191 lookupEnum (word - 0x30) name es
171 lookupEnum (word - 0x30) name es
192 in
172 in
193− chompChunks vs newEnums fs src newPos end row newCol newPos $
173+ chompChunks vs newEnums fs newPos end row newCol newPos $
194 JsEnum enum : revChunks
174 JsEnum enum : revChunks
195
175
196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
176 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
@@ -198,19 +178,19 @@ chompTag vs es fs src pos end row col revChunks =
198 (field, newFields) =
178 (field, newFields) =
199 lookupField name fs
179 lookupField name fs
200 in
180 in
201− chompChunks vs es newFields src newPos end row newCol newPos $
181+ chompChunks vs es newFields newPos end row newCol newPos $
202 JsField field : revChunks
182 JsField field : revChunks
203
183
204 else if name == "DEBUG" then
184 else if name == "DEBUG" then
205− chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
185+ chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
206
186
207 else if name == "PROD" then
187 else if name == "PROD" then
208− chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
188+ chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
209
189
210 else
190 else
211 case Map.lookup name vs of
191 case Map.lookup name vs of
212 Just chunk ->
192 Just chunk ->
213− chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
193+ chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
214
194
215 Nothing ->
195 Nothing ->
216 (# revChunks, pos, row, col #)
196 (# revChunks, pos, row, col #)
@@ -319,19 +299,19 @@ toNames exposing =
319 map toName exposedList
299 map toName exposedList
320
300
321
301
322−toName :: Src.Exposed -> Name.Name
302+toName :: A.Located Src.Exposed -> Name.Name
323−toName exposed =
303+toName (A.At _ exposed) =
324 case exposed of
304 case exposed of
325− Src.Lower (A.At _ name) ->
305+ Src.Lower name ->
326 name
306 name
327
307
328− Src.Upper (A.At _ name) Src.Private ->
308+ Src.Upper name Src.Private ->
329 name
309 name
330
310
331− Src.Upper _ (Src.Public _) ->
311+ Src.Upper _ Src.Public ->
332 error "cannot have Maybe(..) syntax in kernel code header"
312 error "cannot have Maybe(..) syntax in kernel code header"
333
313
334− Src.Operator _ _ ->
314+ Src.Operator _ ->
335 error "cannot use binops in kernel code"
315 error "cannot use binops in kernel code"
336
316
337
317
@@ -342,7 +322,7 @@ toName exposed =
342instance Binary Chunk where
322instance Binary Chunk where
343 put chunk =
323 put chunk =
344 case chunk of
324 case chunk of
345− JS a -> putWord8 0 >> put a
325+ JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
346 ElmVar a b -> putWord8 1 >> put a >> put b
326 ElmVar a b -> putWord8 1 >> put a >> put b
347 JsVar a b -> putWord8 2 >> put a >> put b
327 JsVar a b -> putWord8 2 >> put a >> put b
348 ElmField a -> putWord8 3 >> put a
328 ElmField a -> putWord8 3 >> put a
@@ -354,7 +334,7 @@ instance Binary Chunk where
354 get =
334 get =
355 do word <- getWord8
335 do word <- getWord8
356 case word of
336 case word of
357− 0 -> liftM JS get
337+ 0 -> liftM toJS get
358 1 -> liftM2 ElmVar get get
338 1 -> liftM2 ElmVar get get
359 2 -> liftM2 JsVar get get
339 2 -> liftM2 JsVar get get
360 3 -> liftM ElmField get
340 3 -> liftM ElmField get
@@ -363,3 +343,8 @@ instance Binary Chunk where
363 6 -> return Debug
343 6 -> return Debug
364 7 -> return Prod
344 7 -> return Prod
365 _ -> error "problem deserializing Elm.Kernel.Chunk"
345 _ -> error "problem deserializing Elm.Kernel.Chunk"
346+
347+
348+toJS :: Utf8.String -> Chunk
349+toJS str =
350+ JS (coerce str)
compiler/src/Elm/Licenses.hs+65−48
@@ -9,12 +9,14 @@ 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 ((!))
12import qualified Data.Map as Map
15import qualified Data.Map as Map
13import qualified Data.Utf8 as Utf8
16import qualified Data.Utf8 as Utf8
14
17
15import qualified Json.Decode as D
18import qualified Json.Decode as D
16import qualified Json.Encode as E
19import qualified Json.Encode as E
17−import qualified Json.String as Json
18import qualified Reporting.Suggest as Suggest
20import qualified Reporting.Suggest as Suggest
19
21
20
22
@@ -22,21 +24,25 @@ import qualified Reporting.Suggest as Suggest
22-- LICENCES
24-- LICENCES
23
25
24
26
25−newtype License =
27+data License =
26− License Json.String
28+ License
29+ { _name :: Utf8.String
30+ , _code :: Utf8.String
31+ }
32+ deriving (Eq, Ord)
27
33
28
34
29bsd3 :: License
35bsd3 :: License
30bsd3 =
36bsd3 =
31− License (Json.fromChars "BSD-3-Clause")
37+ osiApprovedSpdxLicenses ! "BSD-3-Clause"
32
38
33
39
34encode :: License -> E.Value
40encode :: License -> E.Value
35−encode (License code) =
41+encode (License _ code) =
36 E.string code
42 E.string code
37
43
38
44
39−decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
45+decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License
40decoder toError =
46decoder toError =
41 do str <- D.string
47 do str <- D.string
42 case check str of
48 case check str of
@@ -51,93 +57,97 @@ decoder toError =
51-- CHECK
57-- CHECK
52
58
53
59
54−check :: Json.String -> Either [Json.String] License
60+check :: Utf8.String -> Either [Utf8.String] License
55−check givenCode =
61+check rawName =
56− if Map.member givenCode osiApprovedSpdxLicenses then
62+ case Map.lookup rawName osiApprovedSpdxLicenses of
57− Right (License givenCode)
63+ Just license ->
64+ Right license
58
65
59− else
66+ Nothing ->
60− let
67+ let
61− pairs =
68+ toPairs (License name code) =
62− map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)
69+ [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]
63− ++
70+
71+ pairs =
64− Map.toList osiApprovedSpdxLicenses
72+ concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
65− in
73+ in
66− Left $ map fst $ take 4 $
74+ Left $ map snd $
67− Suggest.sort (Utf8.toChars givenCode) snd pairs
75+ Suggest.sort (Utf8.toChars rawName) fst pairs
68
76
69
77
70
78
71-- LIST OF LICENCES
79-- LIST OF LICENCES
72
80
73
81
74−(==>) :: [Char] -> [Char] -> (Json.String, [Char])
82+(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)
75−(==>) code fullName =
83+(==>) code name =
76− ( Json.fromChars code, fullName )
84+ ( code, License name code )
77
85
78
86
79--
87--
80-- OSI approved licenses in SPDX format.
88-- OSI approved licenses in SPDX format.
81-- <https://spdx.org/licenses/>
89-- <https://spdx.org/licenses/>
82--
90--
83−osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
91+osiApprovedSpdxLicenses :: Map.Map Utf8.String License
84osiApprovedSpdxLicenses =
92osiApprovedSpdxLicenses =
85 Map.fromList
93 Map.fromList
86− [ "0BSD" ==> "BSD Zero Clause License"
87− , "AAL" ==> "Attribution Assurance License"
88− , "AFL-1.1" ==> "Academic Free License v1.1"
94+ [ "AFL-1.1" ==> "Academic Free License v1.1"
89 , "AFL-1.2" ==> "Academic Free License v1.2"
95 , "AFL-1.2" ==> "Academic Free License v1.2"
90 , "AFL-2.0" ==> "Academic Free License v2.0"
96 , "AFL-2.0" ==> "Academic Free License v2.0"
91 , "AFL-2.1" ==> "Academic Free License v2.1"
97 , "AFL-2.1" ==> "Academic Free License v2.1"
92 , "AFL-3.0" ==> "Academic Free License v3.0"
98 , "AFL-3.0" ==> "Academic Free License v3.0"
93− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
99+ , "APL-1.0" ==> "Adaptive Public License 1.0"
94 , "Apache-1.1" ==> "Apache License 1.1"
100 , "Apache-1.1" ==> "Apache License 1.1"
95 , "Apache-2.0" ==> "Apache License 2.0"
101 , "Apache-2.0" ==> "Apache License 2.0"
96− , "APL-1.0" ==> "Adaptive Public License 1.0"
97 , "APSL-1.0" ==> "Apple Public Source License 1.0"
102 , "APSL-1.0" ==> "Apple Public Source License 1.0"
98 , "APSL-1.1" ==> "Apple Public Source License 1.1"
103 , "APSL-1.1" ==> "Apple Public Source License 1.1"
99 , "APSL-1.2" ==> "Apple Public Source License 1.2"
104 , "APSL-1.2" ==> "Apple Public Source License 1.2"
100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
105 , "APSL-2.0" ==> "Apple Public Source License 2.0"
101 , "Artistic-1.0" ==> "Artistic License 1.0"
106 , "Artistic-1.0" ==> "Artistic License 1.0"
102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
107 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
108+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
104 , "Artistic-2.0" ==> "Artistic License 2.0"
109 , "Artistic-2.0" ==> "Artistic License 2.0"
110+ , "AAL" ==> "Attribution Assurance License"
111+ , "BSL-1.0" ==> "Boost Software License 1.0"
105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
107− , "BSL-1.0" ==> "Boost Software License 1.0"
114+ , "0BSD" ==> "BSD Zero Clause License"
108− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
111 , "CNRI-Python" ==> "CNRI Python License"
116 , "CNRI-Python" ==> "CNRI Python License"
117+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
113 , "CPL-1.0" ==> "Common Public License 1.0"
119 , "CPL-1.0" ==> "Common Public License 1.0"
120+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
122+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
115 , "ECL-1.0" ==> "Educational Community License v1.0"
123 , "ECL-1.0" ==> "Educational Community License v1.0"
116 , "ECL-2.0" ==> "Educational Community License v2.0"
124 , "ECL-2.0" ==> "Educational Community License v2.0"
117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
119 , "Entessa" ==> "Entessa Public License v1.0"
127 , "Entessa" ==> "Entessa Public License v1.0"
120− , "EPL-1.0" ==> "Eclipse Public License 1.0"
121 , "EUDatagrid" ==> "EU DataGrid Software License"
128 , "EUDatagrid" ==> "EU DataGrid Software License"
122 , "EUPL-1.1" ==> "European Union Public License 1.1"
129 , "EUPL-1.1" ==> "European Union Public License 1.1"
123 , "Fair" ==> "Fair License"
130 , "Fair" ==> "Fair License"
124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
132+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
134 , "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"
127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
138 , "HPND" ==> "Historic Permission Notice and Disclaimer"
139+ , "IPL-1.0" ==> "IBM Public License v1.0"
128 , "Intel" ==> "Intel Open Source License"
140 , "Intel" ==> "Intel Open Source License"
129 , "IPA" ==> "IPA Font License"
141 , "IPA" ==> "IPA Font License"
130− , "IPL-1.0" ==> "IBM Public License v1.0"
131 , "ISC" ==> "ISC License"
142 , "ISC" ==> "ISC License"
132− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
143+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
133− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
144 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
136− , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
137 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
145 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
138− , "LPL-1.0" ==> "Lucent Public License Version 1.0"
146+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
139 , "LPL-1.02" ==> "Lucent Public License v1.02"
147 , "LPL-1.02" ==> "Lucent Public License v1.02"
148+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"
140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
149+ , "MS-PL" ==> "Microsoft Public License"
150+ , "MS-RL" ==> "Microsoft Reciprocal License"
141 , "MirOS" ==> "MirOS Licence"
151 , "MirOS" ==> "MirOS Licence"
142 , "MIT" ==> "MIT License"
152 , "MIT" ==> "MIT License"
143 , "Motosoto" ==> "Motosoto License"
153 , "Motosoto" ==> "Motosoto License"
@@ -145,41 +155,48 @@ osiApprovedSpdxLicenses =
145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
155 , "MPL-1.1" ==> "Mozilla Public License 1.1"
146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
156 , "MPL-2.0" ==> "Mozilla Public License 2.0"
147 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
157 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
148− , "MS-PL" ==> "Microsoft Public License"
149− , "MS-RL" ==> "Microsoft Reciprocal License"
150 , "Multics" ==> "Multics License"
158 , "Multics" ==> "Multics License"
151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
152 , "Naumen" ==> "Naumen Public License"
160 , "Naumen" ==> "Naumen Public License"
153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
154 , "NGPL" ==> "Nethack General Public License"
161 , "NGPL" ==> "Nethack General Public License"
155 , "Nokia" ==> "Nokia Open Source License"
162 , "Nokia" ==> "Nokia Open Source License"
156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
157 , "NTP" ==> "NTP License"
164 , "NTP" ==> "NTP License"
158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
165 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159− , "OFL-1.1" ==> "SIL Open Font License 1.1"
160 , "OGTSL" ==> "Open Group Test Suite License"
166 , "OGTSL" ==> "Open Group Test Suite License"
161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
162 , "OSL-1.0" ==> "Open Software License 1.0"
167 , "OSL-1.0" ==> "Open Software License 1.0"
163 , "OSL-2.0" ==> "Open Software License 2.0"
168 , "OSL-2.0" ==> "Open Software License 2.0"
164 , "OSL-2.1" ==> "Open Software License 2.1"
169 , "OSL-2.1" ==> "Open Software License 2.1"
165 , "OSL-3.0" ==> "Open Software License 3.0"
170 , "OSL-3.0" ==> "Open Software License 3.0"
171+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
166 , "PHP-3.0" ==> "PHP License v3.0"
172 , "PHP-3.0" ==> "PHP License v3.0"
167 , "PostgreSQL" ==> "PostgreSQL License"
173 , "PostgreSQL" ==> "PostgreSQL License"
168 , "Python-2.0" ==> "Python License 2.0"
174 , "Python-2.0" ==> "Python License 2.0"
169 , "QPL-1.0" ==> "Q Public License 1.0"
175 , "QPL-1.0" ==> "Q Public License 1.0"
176+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
178 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
173 , "RSCPL" ==> "Ricoh Source Code Public License"
179 , "RSCPL" ==> "Ricoh Source Code Public License"
180+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
174 , "SimPL-2.0" ==> "Simple Public License 2.0"
181 , "SimPL-2.0" ==> "Simple Public License 2.0"
175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176 , "Sleepycat" ==> "Sleepycat License"
182 , "Sleepycat" ==> "Sleepycat License"
183+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"
177 , "SPL-1.0" ==> "Sun Public License v1.0"
184 , "SPL-1.0" ==> "Sun Public License v1.0"
185+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
186 , "UPL-1.0" ==> "Universal Permissive License v1.0"
187+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
179 , "VSL-1.0" ==> "Vovida Software License v1.0"
188 , "VSL-1.0" ==> "Vovida Software License v1.0"
180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
189 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
182 , "Xnet" ==> "X.Net License"
190 , "Xnet" ==> "X.Net License"
183 , "Zlib" ==> "zlib License"
191 , "Zlib" ==> "zlib License"
184 , "ZPL-2.0" ==> "Zope Public License 2.0"
192 , "ZPL-2.0" ==> "Zope Public License 2.0"
185 ]
193 ]
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+39−65
@@ -1,19 +1,18 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}
1+{-# LANGUAGE OverloadedStrings #-}
2module Elm.ModuleName
2module Elm.ModuleName
3 ( Raw
3 ( Raw
4 , toChars
4 , toChars
5+ , toString
5 , toFilePath
6 , toFilePath
6 , toHyphenPath
7 , toHyphenPath
7− --
8+ , fromHyphenPath
8 , encode
9 , encode
9 , decoder
10 , decoder
10− , parser
11− --
12 , Canonical(..)
11 , Canonical(..)
13 , basics, char, string
12 , basics, char, string
14 , maybe, result, list, array, dict, tuple
13 , maybe, result, list, array, dict, tuple
15 , platform, cmd, sub
14 , platform, cmd, sub
16− , debug
15+ , debug, bitwise
17 , virtualDom
16 , virtualDom
18 , jsonDecode, jsonEncode
17 , jsonDecode, jsonEncode
19 , webgl, texture, vector2, vector3, vector4, matrix4
18 , webgl, texture, vector2, vector3, vector4, matrix4
@@ -23,19 +22,15 @@ module Elm.ModuleName
23
22
24import Control.Monad (liftM2)
23import Control.Monad (liftM2)
25import Data.Binary (Binary(..))
24import Data.Binary (Binary(..))
25+import qualified Data.Char as Char
26import qualified Data.Name as Name
26import qualified Data.Name as Name
27import qualified Data.Utf8 as Utf8
27import qualified Data.Utf8 as Utf8
28−import Data.Word (Word8)
29−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
30import Prelude hiding (maybe)
28import Prelude hiding (maybe)
31import qualified System.FilePath as FP
29import qualified System.FilePath as FP
32
30
33import qualified Elm.Package as Pkg
31import qualified Elm.Package as Pkg
34−import qualified Json.Decode as D
32+import qualified Json.Decode as Decode
35−import qualified Json.Encode as E
33+import qualified Json.Encode as Encode
36−import qualified Parse.Variable as Var
37−import qualified Parse.Primitives as P
38−import Parse.Primitives (Row, Col)
39
34
40
35
41
36
@@ -50,6 +45,11 @@ toChars =
50 Name.toChars
45 Name.toChars
51
46
52
47
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,68 +60,38 @@ 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+
63
74
64-- JSON
75-- JSON
65
76
66
77
67−encode :: Raw -> E.Value
78+encode :: Raw -> Encode.Value
68encode =
79encode =
69− E.name
80+ Encode.name
70
81
71
82
72−decoder :: D.Decoder (Row, Col) Raw
83+decoder :: Decode.Decoder Utf8.String Raw
73decoder =
84decoder =
74− D.customString parser (,)
85+ do str <- Decode.string
75−
86+ if all isGoodChunk (Utf8.split 0x2E {- . -} str)
76−
87+ then return (Name.fromUtf8 str)
77−
88+ else Decode.failure str
78−-- PARSER
79
89
80
90
81−parser :: P.Parser (Row, Col) Raw
91+isGoodChunk :: Utf8.String -> Bool
82−parser =
92+isGoodChunk chunk =
83− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
93+ Utf8.startsWithChar Char.isUpper chunk
84− let
94+ && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk
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)
125
95
126
96
127
97
@@ -135,7 +105,6 @@ data Canonical =
135 }
105 }
136
106
137
107
138−
139-- INSTANCES
108-- INSTANCES
140
109
141
110
@@ -226,6 +195,11 @@ debug :: Canonical
226debug = Canonical Pkg.core Name.debug
195debug = Canonical Pkg.core Name.debug
227
196
228
197
198+{-# NOINLINE bitwise #-}
199+bitwise :: Canonical
200+bitwise = Canonical Pkg.core Name.bitwise
201+
202+
229
203
230-- HTML
204-- HTML
231
205
compiler/src/Elm/Package.hs+83−205
@@ -1,52 +1,38 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}
2+{-# LANGUAGE OverloadedStrings #-}
3module Elm.Package
3module Elm.Package
4 ( Name(..)
4 ( Name(..)
5− , Author
6− , Project
7 , Canonical(..)
5 , Canonical(..)
8 , isKernel
6 , isKernel
7+ , toString
9 , toChars
8 , toChars
10 , toUrl
9 , toUrl
11 , toFilePath
10 , toFilePath
12− , toJsonString
11+ , BadName(..)
13− --
12+ , fromString
14 , dummyName, kernel, core
13 , dummyName, kernel, core
15 , browser, virtualDom, html
14 , browser, virtualDom, html
16 , json, http, url
15 , json, http, url
17 , webgl, linearAlgebra
16 , webgl, linearAlgebra
18− --
19 , suggestions
17 , suggestions
20− , nearbyNames
21− --
22 , decoder
18 , decoder
23 , encode
19 , encode
24− , keyDecoder
25− --
26− , parser
27 )
20 )
28 where
21 where
29
22
30
23
31import Control.Monad (liftM2)
24import Control.Monad (liftM2)
32import Data.Binary (Binary, get, put)
25import Data.Binary (Binary, get, put)
33−import qualified Data.Coerce as Coerce
26+import qualified Data.Char as Char
34−import qualified Data.List as List
35−import qualified Data.Map as Map
36import qualified Data.Name as Name
27import qualified Data.Name as Name
28+import qualified Data.Map as Map
37import Data.Monoid ((<>))
29import Data.Monoid ((<>))
38import qualified Data.Utf8 as Utf8
30import qualified Data.Utf8 as Utf8
39−import Data.Word (Word8)
40−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
41import System.FilePath ((</>))
31import System.FilePath ((</>))
42
32
43import qualified Elm.Version as V
33import qualified Elm.Version as V
44−import qualified Json.Decode as D
34+import qualified Json.Decode as Decode
45−import qualified Json.Encode as E
35+import qualified Json.Encode as Encode
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
50
36
51
37
52
38
@@ -55,17 +41,9 @@ import qualified Reporting.Suggest as Suggest
55
41
56data Name =
42data Name =
57 Name
43 Name
58− { _author :: !Author
44+ { _author :: !Name.Name
59− , _project :: !Project
45+ , _project :: !Name.Name
60 }
46 }
61− deriving (Ord)
62−
63−
64−type Author = Utf8.Utf8 AUTHOR
65−type Project = Utf8.Utf8 PROJECT
66−
67−data AUTHOR
68−data PROJECT
69
47
70
48
71data Canonical =
49data Canonical =
@@ -82,114 +60,127 @@ data Canonical =
82
60
83isKernel :: Name -> Bool
61isKernel :: Name -> Bool
84isKernel (Name author _) =
62isKernel (Name author _) =
85− author == elm || author == elm_explorations
63+ author == "elm" || author == "elm-explorations"
64+
65+
66+toString :: Name -> Utf8.String
67+toString (Name author project) =
68+ Utf8.join 0x2F [ Name.toUtf8 author, Name.toUtf8 project ]
86
69
87
70
88toChars :: Name -> String
71toChars :: Name -> String
89toChars (Name author project) =
72toChars (Name author project) =
90− Utf8.toChars author <> "/" <> Utf8.toChars project
73+ Name.toChars author <> "/" <> Name.toChars project
91
74
92
75
93toUrl :: Name -> String
76toUrl :: Name -> String
94toUrl (Name author project) =
77toUrl (Name author project) =
95− Utf8.toChars author ++ "/" ++ Utf8.toChars project
78+ Name.toChars author ++ "/" ++ Name.toChars project
96
79
97
80
98toFilePath :: Name -> FilePath
81toFilePath :: Name -> FilePath
99toFilePath (Name author project) =
82toFilePath (Name author project) =
100− Utf8.toChars author </> Utf8.toChars project
83+ Name.toChars author </> Name.toChars project
101
84
102
85
103−toJsonString :: Name -> Json.String
86+fromString :: Utf8.String -> Either BadName Name
104−toJsonString (Name author project) =
87+fromString str =
88+ case Utf8.split 0x2F {- / -} str of
105− Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
89+ [author, project]
90+ | Utf8.isEmpty author -> Left BadStructure
91+ | Utf8.isEmpty project -> Left BadStructure
92+ | Utf8.size project >= 256 -> Left TooLong
93+ | Utf8.containsDouble 0x2D {- - -} project -> Left HasDoubleDash
94+ | Utf8.contains 0x5F {- _ -} project -> Left HasUnderscore
95+ | Utf8.contains 0x2E {- . -} project -> Left HasDot
96+ | Utf8.any Char.isUpper project -> Left HasUppercase
97+ | Utf8.endsWithWord 0x2D {- - -} project -> Left HasDashEnd
98+ | Utf8.startsWithChar Char.isLower project -> Right (Name (Name.fromUtf8 author) (Name.fromUtf8 project))
99+ | True -> Left HasNonLowercaseStart
106
100
101+ _ ->
102+ Left BadStructure
107
103
108
104
109−-- COMMON PACKAGE NAMES
105+data BadName
106+ = BadStructure
107+ | TooLong
108+ | HasDoubleDash
109+ | HasUnderscore
110+ | HasDot
111+ | HasUppercase
112+ | HasDashEnd
113+ | HasNonLowercaseStart
114+
110
115
111
116
112−toName :: Author -> [Char] -> Name
117+-- COMMON PACKAGE NAMES
113−toName author project =
114− Name author (Utf8.fromChars project)
115
118
116
119
117{-# NOINLINE dummyName #-}
120{-# NOINLINE dummyName #-}
118dummyName :: Name
121dummyName :: Name
119dummyName =
122dummyName =
120− toName (Utf8.fromChars "author") "project"
123+ Name "author" "project"
121
124
122
125
123{-# NOINLINE kernel #-}
126{-# NOINLINE kernel #-}
124kernel :: Name
127kernel :: Name
125kernel =
128kernel =
126− toName elm "kernel"
129+ Name "elm" "kernel"
127
130
128
131
129{-# NOINLINE core #-}
132{-# NOINLINE core #-}
130core :: Name
133core :: Name
131core =
134core =
132− toName elm "core"
135+ Name "elm" "core"
133
136
134
137
135{-# NOINLINE browser #-}
138{-# NOINLINE browser #-}
136browser :: Name
139browser :: Name
137browser =
140browser =
138− toName elm "browser"
141+ Name "elm" "browser"
139
142
140
143
141{-# NOINLINE virtualDom #-}
144{-# NOINLINE virtualDom #-}
142virtualDom :: Name
145virtualDom :: Name
143virtualDom =
146virtualDom =
144− toName elm "virtual-dom"
147+ Name "elm" "virtual-dom"
145
148
146
149
147{-# NOINLINE html #-}
150{-# NOINLINE html #-}
148html :: Name
151html :: Name
149html =
152html =
150− toName elm "html"
153+ Name "elm" "html"
151
154
152
155
153{-# NOINLINE json #-}
156{-# NOINLINE json #-}
154json :: Name
157json :: Name
155json =
158json =
156− toName elm "json"
159+ Name "elm" "json"
157
160
158
161
159{-# NOINLINE http #-}
162{-# NOINLINE http #-}
160http :: Name
163http :: Name
161http =
164http =
162− toName elm "http"
165+ Name "elm" "http"
163
166
164
167
165{-# NOINLINE url #-}
168{-# NOINLINE url #-}
166url :: Name
169url :: Name
167url =
170url =
168− toName elm "url"
171+ Name "elm" "url"
169
172
170
173
171{-# NOINLINE webgl #-}
174{-# NOINLINE webgl #-}
172webgl :: Name
175webgl :: Name
173webgl =
176webgl =
174− toName elm_explorations "webgl"
177+ Name "elm-explorations" "webgl"
175
178
176
179
177{-# NOINLINE linearAlgebra #-}
180{-# NOINLINE linearAlgebra #-}
178linearAlgebra :: Name
181linearAlgebra :: Name
179linearAlgebra =
182linearAlgebra =
180− toName elm_explorations "linear-algebra"
183+ Name "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"
193
184
194
185
195
186
@@ -198,62 +189,17 @@ elm_explorations =
198
189
199suggestions :: Map.Map Name.Name Name
190suggestions :: Map.Map Name.Name Name
200suggestions =
191suggestions =
201− let
202− random = toName elm "random"
203− time = toName elm "time"
204− file = toName elm "file"
205− in
206 Map.fromList
192 Map.fromList
207− [ "Browser" ==> browser
193+ [ ("Browser", browser)
208− , "File" ==> file
209− , "File.Download" ==> file
210− , "File.Select" ==> file
211− , "Html" ==> html
194+ , ("Html", html)
212− , "Html.Attributes" ==> html
213− , "Html.Events" ==> html
214− , "Http" ==> http
195+ , ("Http", http)
215− , "Json.Decode" ==> json
196+ , ("Json.Decode", json)
216− , "Json.Encode" ==> json
197+ , ("Json.Encode", json)
217− , "Random" ==> random
218− , "Time" ==> time
219− , "Url.Parser" ==> url
198+ , ("Url.Parser", url)
220− , "Url" ==> url
199+ , ("Url", url)
221 ]
200 ]
222
201
223
202
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−
257
203
258-- INSTANCES
204-- INSTANCES
259
205
@@ -268,13 +214,17 @@ instance Eq Canonical where
268 version1 == version2 && package1 == package2
214 version1 == version2 && package1 == package2
269
215
270
216
271−
217+instance Ord Name where
272−-- BINARY
218+ compare (Name author1 project1) (Name author2 project2) =
219+ case compare project1 project2 of
220+ LT -> LT
221+ EQ -> compare author1 author2
222+ GT -> GT
273
223
274
224
275−instance Binary Name where -- PERF try storing as a Word16
225+instance Binary Name where
276− get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
226+ get = liftM2 Name get get
277− put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
227+ put (Name a b) = put a >> put b
278
228
279
229
280instance Binary Canonical where
230instance Binary Canonical where
@@ -286,89 +236,17 @@ instance Binary Canonical where
286-- JSON
236-- JSON
287
237
288
238
289−decoder :: D.Decoder (Row, Col) Name
239+decoder :: Decode.Decoder BadName Name
290decoder =
240decoder =
291− D.customString parser (,)
241+ do str <- Decode.string
242+ case fromString str of
243+ Right name ->
244+ return name
245+
246+ Left err ->
247+ Decode.failure err
292
248
293
249
294−encode :: Name -> E.Value
250+encode :: Name -> Encode.Value
295encode name =
251encode name =
296− E.chars (toChars name)
252+ Encode.string (toString 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.hsdeleted−133
@@ -1,133 +0,0 @@
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+43−73
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples #-}
3module Elm.Version
1module Elm.Version
4 ( Version(..)
2 ( Version(..)
5 , one
3 , one
@@ -9,11 +7,10 @@ module Elm.Version
9 , bumpMinor
7 , bumpMinor
10 , bumpMajor
8 , bumpMajor
11 , toChars
9 , toChars
12− --
10+ , toString
11+ , fromString
13 , decoder
12 , decoder
14 , encode
13 , encode
15− --
16− , parser
17 )
14 )
18 where
15 where
19
16
@@ -21,15 +18,13 @@ module Elm.Version
21import Prelude hiding (max)
18import Prelude hiding (max)
22import Control.Monad (liftM3)
19import Control.Monad (liftM3)
23import Data.Binary (Binary, get, put, getWord8, putWord8)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
21+import qualified Data.Utf8 as Utf8
24import qualified Data.Version as Version
22import qualified Data.Version as Version
25−import Data.Word (Word8, Word16)
23+import Data.Word (Word16)
26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27import qualified Paths_elm
24import qualified Paths_elm
28
25
29import qualified Json.Decode as D
26import qualified Json.Decode as D
30import qualified Json.Encode as E
27import qualified Json.Encode as E
31−import qualified Parse.Primitives as P
32−import Parse.Primitives (Row, Col)
33
28
34
29
35
30
@@ -91,26 +86,58 @@ bumpMajor (Version major _minor _patch) =
91
86
92
87
93
88
94−-- TO CHARS
89+-- TO STRING
95
90
96
91
97−toChars :: Version -> [Char]
92+toChars :: Version -> String
93+toChars vsn =
94+ Utf8.toChars (toString vsn)
95+
96+
97+toString :: Version -> Utf8.String
98−toChars (Version major minor patch) =
98+toString (Version major minor patch) =
99− show major ++ '.' : show minor ++ '.' : show patch
99+ Utf8.join 0x2E {- . -}
100+ [ Utf8.fromWord16 major
101+ , Utf8.fromWord16 minor
102+ , Utf8.fromWord16 patch
103+ ]
104+
105+
106+
107+-- FROM STRING
108+
109+
110+fromString :: Utf8.String -> Maybe Version
111+fromString str =
112+ case Utf8.split 0x2E {- . -} str of
113+ [major, minor, patch] ->
114+ Version
115+ <$> Utf8.toWord16 major
116+ <*> Utf8.toWord16 minor
117+ <*> Utf8.toWord16 patch
118+
119+ _ ->
120+ Nothing
100
121
101
122
102
123
103-- JSON
124-- JSON
104
125
105
126
106−decoder :: D.Decoder (Row, Col) Version
127+decoder :: D.Decoder Utf8.String Version
107decoder =
128decoder =
108− D.customString parser (,)
129+ do str <- D.string
130+ case fromString str of
131+ Just version ->
132+ return version
133+
134+ Nothing ->
135+ D.failure str
109
136
110
137
111encode :: Version -> E.Value
138encode :: Version -> E.Value
112encode version =
139encode version =
113− E.chars (toChars version)
140+ E.string (toString version)
114
141
115
142
116
143
@@ -137,60 +164,3 @@ instance Binary Version where
137 put major
164 put major
138 put minor
165 put minor
139 put patch
166 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+10−11
@@ -29,23 +29,22 @@ sandwich moduleName javascript =
29
29
30<body>
30<body>
31
31
32−<pre id="elm"></pre>
32+<pre id="elm">
33+This is a headless program, meaning there is nothing to show here.
34+
35+I started the program anyway though!
36+
37+You can access it as `app` in the developer console.
38+</pre>
33
39
34<script>
40<script>
35−try {
36|] <> javascript <> [r|
41|] <> javascript <> [r|
37
42
43+try {
38 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
44 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
39−}
40−catch (e)
45+} catch (e) {
41−{
42 // display initialization errors (e.g. bad flags, infinite recursion)
46 // display initialization errors (e.g. bad flags, infinite recursion)
43− var header = document.createElement("h1");
44− header.style.fontFamily = "monospace";
45− header.innerText = "Initialization Error";
46− var pre = document.getElementById("elm");
47+ document.getElementById("elm").innerText = e;
47− document.body.insertBefore(header, pre);
48− pre.innerText = e;
49 throw e;
48 throw e;
50}
49}
51</script>
50</script>
compiler/src/Generate/JavaScript.hs+55−76
@@ -2,7 +2,6 @@
2module Generate.JavaScript
2module Generate.JavaScript
3 ( generate
3 ( generate
4 , generateForRepl
4 , generateForRepl
5− , generateForReplEndpoint
6 )
5 )
7 where
6 where
8
7
@@ -86,9 +85,7 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _
86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
85 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
86 evalState = addGlobal mode graph debugState (Opt.Global home name)
88 in
87 in
89− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90− <> Functions.functions
91− <> stateToBuilder evalState
88+ stateToBuilder evalState
92 <> print ansi localizer home name tipe
89 <> print ansi localizer home name tipe
93
90
94
91
@@ -100,47 +97,14 @@ print ansi localizer home name tipe =
100 tipeDoc = RT.canToDoc localizer RT.None tipe
97 tipeDoc = RT.canToDoc localizer RT.None tipe
101 bool = if ansi then "true" else "false"
98 bool = if ansi then "true" else "false"
102 in
99 in
103− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
100+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
104− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
101+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
105− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
102+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
106− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
103+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
107− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
104+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
108− \} else {\n\
105+ \} else {\n\
109− \ _print(' : ' + _type);\n\
106+ \ _print(' : ' + _type);\n\
110− \}\n"
111−
112−
113−
114−-- GENERATE FOR REPL ENDPOINT
115−
116−
117−generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118−generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119− let
120− name = maybe Name.replValueToPrint id maybeName
121− mode = Mode.Dev Nothing
122− debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123− evalState = addGlobal mode graph debugState (Opt.Global home name)
124− in
125− Functions.functions
126− <> stateToBuilder evalState
127− <> postMessage localizer home maybeName tipe
128−
129−
130−postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131−postMessage localizer home maybeName tipe =
132− let
133− name = maybe Name.replValueToPrint id maybeName
134− value = JsName.toBuilder (JsName.fromGlobal home name)
135− toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136− tipeDoc = RT.canToDoc localizer RT.None tipe
137− toName n = "\"" <> Name.toBuilder n <> "\""
138− in
139− "self.postMessage({\n\
140− \ name: " <> maybe "null" toName maybeName <> ",\n\
141− \ value: " <> toString <> "(true, " <> value <> "),\n\
142− \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
143− \});\n"
107+ \}\n"
144
108
145
109
146
110
@@ -261,7 +225,7 @@ addKernel (State revKernels revBuilders seen) kernel =
261
225
262var :: Opt.Global -> Expr.Code -> JS.Stmt
226var :: Opt.Global -> Expr.Code -> JS.Stmt
263var (Opt.Global home name) code =
227var (Opt.Global home name) code =
264− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
228+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
265
229
266
230
267isDebugger :: Opt.Global -> Bool
231isDebugger :: Opt.Global -> Bool
@@ -292,7 +256,7 @@ generateCycle mode (Opt.Global home _) names values functions =
292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
256 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
293 <> drawCycle names
257 <> drawCycle names
294 <> "\\n\\nThese errors are very tricky, so read "
258 <> "\\n\\nThese errors are very tricky, so read "
295− <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
259+ <> B.stringUtf8 (D.makeNakedLink "halting-problem")
296 <> " to learn how to fix it!"
260 <> " to learn how to fix it!"
297 ]
261 ]
298
262
@@ -301,10 +265,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
301generateCycleFunc mode home def =
265generateCycleFunc mode home def =
302 case def of
266 case def of
303 Opt.Def name expr ->
267 Opt.Def name expr ->
304− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
268+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
305
269
306 Opt.TailDef name args expr ->
270 Opt.TailDef name args expr ->
307− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
271+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
308
272
309
273
310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
274generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
@@ -320,9 +284,9 @@ generateRealCycle home (name, _) =
320 realName = JsName.fromGlobal home name
284 realName = JsName.fromGlobal home name
321 in
285 in
322 JS.Block
286 JS.Block
323− [ JS.Var realName (JS.Call (JS.Ref safeName) [])
287+ [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
288 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
325− JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
289+ JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
326 ]
290 ]
327
291
328
292
@@ -350,7 +314,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
350addChunk mode chunk builder =
314addChunk mode chunk builder =
351 case chunk of
315 case chunk of
352 K.JS javascript ->
316 K.JS javascript ->
353− B.byteString javascript <> builder
317+ Utf8.toBuilder javascript <> builder
354
318
355 K.ElmVar home name ->
319 K.ElmVar home name ->
356 JsName.toBuilder (JsName.fromGlobal home name) <> builder
320 JsName.toBuilder (JsName.fromGlobal home name) <> builder
@@ -390,13 +354,16 @@ addChunk mode chunk builder =
390
354
391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
355generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
392generateEnum mode global@(Opt.Global home name) index =
356generateEnum mode global@(Opt.Global home name) index =
393− JS.Var (JsName.fromGlobal home name) $
357+ let
358+ definition =
394− case mode of
359+ case mode of
395− Mode.Dev _ ->
360+ Mode.Dev _ ->
396− Expr.codeToExpr (Expr.generateCtor mode global index 0)
361+ Expr.codeToExpr (Expr.generateCtor mode global index 0)
397
362
398− Mode.Prod _ ->
363+ Mode.Prod _ ->
399− JS.Int (Index.toMachine index)
364+ JS.Int (Index.toMachine index)
365+ in
366+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
400
367
401
368
402
369
@@ -405,13 +372,16 @@ generateEnum mode global@(Opt.Global home name) index =
405
372
406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
373generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
407generateBox mode global@(Opt.Global home name) =
374generateBox mode global@(Opt.Global home name) =
408− JS.Var (JsName.fromGlobal home name) $
375+ let
376+ definition =
409− case mode of
377+ case mode of
410− Mode.Dev _ ->
378+ Mode.Dev _ ->
411− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
379+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
412
380
413− Mode.Prod _ ->
381+ Mode.Prod _ ->
414− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
382+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
383+ in
384+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
415
385
416
386
417{-# NOINLINE identity #-}
387{-# NOINLINE identity #-}
@@ -426,11 +396,14 @@ identity =
426
396
427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
397generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
428generatePort mode (Opt.Global home name) makePort converter =
398generatePort mode (Opt.Global home name) makePort converter =
429− JS.Var (JsName.fromGlobal home name) $
399+ let
400+ definition =
430− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
401+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
431− [ JS.String (Name.toBuilder name)
402+ [ JS.String (Name.toBuilder name)
432− , Expr.codeToExpr (Expr.generate mode converter)
403+ , Expr.codeToExpr (Expr.generate mode converter)
433− ]
404+ ]
405+ in
406+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
434
407
435
408
436
409
@@ -458,9 +431,11 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)
458
431
459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
432generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
460generateLeaf home@(ModuleName.Canonical _ moduleName) name =
433generateLeaf home@(ModuleName.Canonical _ moduleName) name =
461− JS.Var (JsName.fromGlobal home name) $
434+ let
435+ definition =
462− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
436+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
463−
437+ in
438+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
464
439
465
440
466{-# NOINLINE leaf #-}
441{-# NOINLINE leaf #-}
@@ -534,7 +509,7 @@ generateExports mode (Trie maybeMain subs) =
534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
509 <> List.foldl' (addSubTrie mode) "}" otherSubTries
535
510
536
511
537−addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
512+addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
538addSubTrie mode end (name, trie) =
513addSubTrie mode end (name, trie) =
539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
514 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
540
515
@@ -546,7 +521,7 @@ addSubTrie mode end (name, trie) =
546data Trie =
521data Trie =
547 Trie
522 Trie
548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
523 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
549− , _subs :: Map.Map Name.Name Trie
524+ , _subs :: Map.Map Utf8.String Trie
550 }
525 }
551
526
552
527
@@ -557,10 +532,14 @@ emptyTrie =
557
532
558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
533addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
534addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
535+ let
536+ segments =
537+ Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
538+ in
560− merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
539+ merge trie $ segmentsToTrie home segments main
561
540
562
541
563−segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
542+segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
564segmentsToTrie home segments main =
543segmentsToTrie home segments main =
565 case segments of
544 case segments of
566 [] ->
545 [] ->
compiler/src/Generate/JavaScript/Builder.hs+217−207
@@ -16,7 +16,6 @@ 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
20import Data.ByteString.Builder as B
19import Data.ByteString.Builder as B
21import Data.Monoid ((<>))
20import Data.Monoid ((<>))
22import qualified Generate.JavaScript.Name as Name
21import qualified Generate.JavaScript.Name as Name
@@ -28,19 +27,6 @@ import qualified Json.Encode as Json
28-- EXPRESSIONS
27-- EXPRESSIONS
29
28
30
29
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−--
44data Expr
30data Expr
45 = String Builder
31 = String Builder
46 | Float Builder
32 | Float Builder
@@ -51,13 +37,13 @@ data Expr
51 | Array [Expr]
37 | Array [Expr]
52 | Object [(Name, Expr)]
38 | Object [(Name, Expr)]
53 | Ref Name
39 | Ref Name
54− | Access Expr Name -- foo.bar
40+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
55− | Index Expr Expr -- foo[bar]
41+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
56 | Prefix PrefixOp Expr
42 | Prefix PrefixOp Expr
57 | Infix InfixOp Expr Expr
43 | Infix InfixOp Expr Expr
58 | If Expr Expr Expr
44 | If Expr Expr Expr
59 | Assign LValue Expr
45 | Assign LValue Expr
60− | Call Expr [Expr]
46+ | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
61 | Function (Maybe Name) [Name] [Stmt]
47 | Function (Maybe Name) [Name] [Stmt]
62
48
63
49
@@ -72,21 +58,20 @@ data LValue
72
58
73
59
74data Stmt
60data Stmt
75− = Block [Stmt]
61+ = Block [Stmt] -- {stmts}
76− | EmptyStmt
62+ | EmptyStmt -- ;
77− | ExprStmt Expr
63+ | ExprStmt Expr -- expr;
78− | IfStmt Expr Stmt Stmt
64+ | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
79− | Switch Expr [Case]
65+ | Switch Expr [Case] -- switch (e) clauses
80− | While Expr Stmt
66+ | While Expr Stmt -- while (e) do stmt
81− | Break (Maybe Name)
67+ | Break (Maybe Name) -- break lab;
82− | Continue (Maybe Name)
68+ | Continue (Maybe Name) -- continue lab;
83− | Labelled Name Stmt
69+ | Labelled Name Stmt -- lab: stmt
84− | Try Stmt Name Stmt
70+ | Try Stmt Name Stmt -- try stmt catch (x) stmt
85− | Throw Expr
71+ | Throw Expr -- throw expr;
86− | Return Expr
72+ | Return (Maybe Expr) -- return expr;
87− | Var Name Expr
88− | Vars [(Name, Expr)]
73+ | Var [(Name, Maybe Expr)] -- var x, y=42;
89− | FunctionStmt Name [Name] [Stmt]
74+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
90
75
91
76
92data Case
77data Case
@@ -99,31 +84,37 @@ data Case
99
84
100
85
101data InfixOp
86data InfixOp
102− = OpAdd -- +
87+ = OpLT -- <
103− | OpSub -- -
88+ | OpLEq -- <=
89+ | OpGT -- >
90+ | OpGEq -- >=
91+ | OpIn -- in
92+ | OpInstanceof -- instanceof
93+ | OpEq -- ==
94+ | OpNEq -- !=
95+ | OpStrictEq -- ===
96+ | OpStrictNEq -- !==
97+ | OpLAnd -- &&
98+ | OpLOr -- ||
104 | OpMul -- *
99 | OpMul -- *
105 | OpDiv -- /
100 | OpDiv -- /
106 | OpMod -- %
101 | OpMod -- %
107− | OpEq -- ===
102+ | OpSub -- -
108− | OpNe -- !==
109− | OpLt -- <
110− | OpLe -- <=
111− | OpGt -- >
112− | OpGe -- >=
113− | OpAnd -- &&
114− | OpOr -- ||
115− | OpBitwiseAnd -- &
116− | OpBitwiseXor -- ^
117− | OpBitwiseOr -- |
118− | OpLShift -- <<
103+ | OpLShift -- <<
119− | OpSpRShift -- >>
104+ | OpSpRShift -- >>
120− | OpZfRShift -- >>>
105+ | OpZfRShift -- >>>
106+ | OpBAnd -- &
107+ | OpBXor -- ^
108+ | OpBOr -- |
109+ | OpAdd -- +
121
110
122
111
123data PrefixOp
112data PrefixOp
124− = PrefixNot -- !
113+ = PrefixLNot -- !
125− | PrefixNegate -- -
114+ | PrefixBNot -- ~
126− | PrefixComplement -- ~
115+ | PrefixPlus -- +
116+ | PrefixMinus -- -
117+ | PrefixTypeof -- typeof
127
118
128
119
129
120
@@ -132,40 +123,21 @@ data PrefixOp
132
123
133stmtToBuilder :: Stmt -> Builder
124stmtToBuilder :: Stmt -> Builder
134stmtToBuilder stmts =
125stmtToBuilder stmts =
135− fromStmt levelZero stmts
126+ fromStmt "" stmts
136
127
137
128
138exprToBuilder :: Expr -> Builder
129exprToBuilder :: Expr -> Builder
139exprToBuilder expr =
130exprToBuilder expr =
140− snd $ fromExpr levelZero Whatever expr
131+ snd $ fromExpr "" Whatever expr
141−
142−
143−
144−-- INDENT LEVEL
145−
146−
147−data Level =
148− Level Builder Level
149−
150
132
151−levelZero :: Level
152−levelZero =
153− Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
154
133
155
134
156−makeLevel :: Int -> BS.ByteString -> Level
135+-- HELPERS
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−
166
136
167
137
168−-- HELPERS
138+deeper :: Builder -> Builder
139+deeper indent =
140+ "\t" <> indent
169
141
170
142
171commaSep :: [Builder] -> Builder
143commaSep :: [Builder] -> Builder
@@ -173,52 +145,52 @@ commaSep builders =
173 mconcat (List.intersperse ", " builders)
145 mconcat (List.intersperse ", " builders)
174
146
175
147
176−commaNewlineSep :: Level -> [Builder] -> Builder
148+commaNewlineSep :: Builder -> [Builder] -> Builder
177−commaNewlineSep (Level _ (Level deeperIndent _)) builders =
149+commaNewlineSep indent builders =
178− mconcat (List.intersperse (",\n" <> deeperIndent) builders)
150+ mconcat (List.intersperse (",\n" <> deeper indent) builders)
179
151
180
152
181
153
182-- STATEMENTS
154-- STATEMENTS
183
155
184
156
185−fromStmtBlock :: Level -> [Stmt] -> Builder
157+fromStmtBlock :: Builder -> [Stmt] -> Builder
186−fromStmtBlock level stmts =
158+fromStmtBlock indent stmts =
187− mconcat (map (fromStmt level) stmts)
159+ mconcat (map (fromStmt indent) stmts)
188
160
189
161
190−fromStmt :: Level -> Stmt -> Builder
162+fromStmt :: Builder -> Stmt -> Builder
191−fromStmt level@(Level indent nextLevel) statement =
163+fromStmt indent statement =
192 case statement of
164 case statement of
193 Block stmts ->
165 Block stmts ->
194− fromStmtBlock level stmts
166+ fromStmtBlock indent stmts
195
167
196 EmptyStmt ->
168 EmptyStmt ->
197 mempty
169 mempty
198
170
199 ExprStmt expr ->
171 ExprStmt expr ->
200− indent <> snd (fromExpr level Whatever expr) <> ";\n"
172+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"
201
173
202 IfStmt condition thenStmt elseStmt ->
174 IfStmt condition thenStmt elseStmt ->
203 mconcat
175 mconcat
204− [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
176+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
205− , fromStmt nextLevel thenStmt
177+ , fromStmt (deeper indent) thenStmt
206 , indent, "} else {\n"
178 , indent, "} else {\n"
207− , fromStmt nextLevel elseStmt
179+ , fromStmt (deeper indent) elseStmt
208 , indent, "}\n"
180 , indent, "}\n"
209 ]
181 ]
210
182
211 Switch expr clauses ->
183 Switch expr clauses ->
212 mconcat
184 mconcat
213− [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
185+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
214− , mconcat (map (fromClause nextLevel) clauses)
186+ , mconcat (map (fromClause (deeper indent)) clauses)
215 , indent, "}\n"
187 , indent, "}\n"
216 ]
188 ]
217
189
218 While expr stmt ->
190 While expr stmt ->
219 mconcat
191 mconcat
220− [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
192+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
221− , fromStmt nextLevel stmt
193+ , fromStmt (deeper indent) stmt
222 , indent, "}\n"
194 , indent, "}\n"
223 ]
195 ]
224
196
@@ -237,37 +209,37 @@ fromStmt level@(Level indent nextLevel) statement =
237 Labelled label stmt ->
209 Labelled label stmt ->
238 mconcat
210 mconcat
239 [ indent, Name.toBuilder label, ":\n"
211 [ indent, Name.toBuilder label, ":\n"
240− , fromStmt level stmt
212+ , fromStmt indent stmt
241 ]
213 ]
242
214
243 Try tryStmt errorName catchStmt ->
215 Try tryStmt errorName catchStmt ->
244 mconcat
216 mconcat
245 [ indent, "try {\n"
217 [ indent, "try {\n"
246− , fromStmt nextLevel tryStmt
218+ , fromStmt (deeper indent) tryStmt
247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
248− , fromStmt nextLevel catchStmt
220+ , fromStmt (deeper indent) catchStmt
249 , indent, "}\n"
221 , indent, "}\n"
250 ]
222 ]
251
223
252 Throw expr ->
224 Throw expr ->
253− indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
225+ "throw " <> snd (fromExpr indent Whatever expr) <> ";"
254
226
255− Return expr ->
227+ Return Nothing ->
256− indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
228+ indent <> "return;\n"
257
229
258− Var name expr ->
230+ Return (Just expr) ->
259− indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
231+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
260
232
261− Vars [] ->
233+ Var [] ->
262 mempty
234 mempty
263
235
264− Vars vars ->
236+ Var vars ->
265− indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
237+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
266
238
267 FunctionStmt name args stmts ->
239 FunctionStmt name args stmts ->
268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
269 <>
241 <>
270− fromStmtBlock nextLevel stmts
242+ fromStmtBlock (deeper indent) stmts
271 <>
243 <>
272 indent <> "}\n"
244 indent <> "}\n"
273
245
@@ -276,25 +248,30 @@ fromStmt level@(Level indent nextLevel) statement =
276-- SWITCH CLAUSES
248-- SWITCH CLAUSES
277
249
278
250
279−fromClause :: Level -> Case -> Builder
251+fromClause :: Builder -> Case -> Builder
280−fromClause level@(Level indent nextLevel) clause =
252+fromClause indent clause =
281 case clause of
253 case clause of
282 Case expr stmts ->
254 Case expr stmts ->
283− indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
255+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
284− <> fromStmtBlock nextLevel stmts
256+ <> fromStmtBlock (deeper indent) stmts
285
257
286 Default stmts ->
258 Default stmts ->
287 indent <> "default:\n"
259 indent <> "default:\n"
288− <> fromStmtBlock nextLevel stmts
260+ <> fromStmtBlock (deeper indent) stmts
289
261
290
262
291
263
292-- VAR DECLS
264-- VAR DECLS
293
265
294
266
295−varToBuilder :: Level -> (Name, Expr) -> Builder
267+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
296−varToBuilder level (name, expr) =
268+varToBuilder indent (name, maybeExpr) =
269+ case maybeExpr of
270+ Nothing ->
271+ Name.toBuilder name
272+
273+ Just expr ->
297− Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
274+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
298
275
299
276
300
277
@@ -312,11 +289,12 @@ merge a b =
312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
313linesMap func xs =
290linesMap func xs =
314 let
291 let
292+ pairs =
315− pairs = map func xs
293+ map func xs
316 in
294 in
317− ( any ((==) Many . fst) pairs
295+ ( any ((==) Many . fst) pairs
318− , map snd pairs
296+ , map snd pairs
319− )
297+ )
320
298
321
299
322data Grouping = Atomic | Whatever
300data Grouping = Atomic | Whatever
@@ -332,23 +310,23 @@ parensFor grouping builder =
332 builder
310 builder
333
311
334
312
335−fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
313+fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
336−fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
314+fromExpr indent grouping expression =
337 case expression of
315 case expression of
338 String string ->
316 String string ->
339− ( One, "'" <> string <> "'" )
317+ (One, "'" <> string <> "'")
340
318
341 Float float ->
319 Float float ->
342− ( One, float )
320+ (One, float)
343
321
344 Int n ->
322 Int n ->
345− ( One, B.intDec n )
323+ (One, B.intDec n)
346
324
347 Bool bool ->
325 Bool bool ->
348− ( One, if bool then "true" else "false" )
326+ (One, if bool then "true" else "false")
349
327
350 Null ->
328 Null ->
351− ( One, "null" )
329+ (One, "null")
352
330
353 Json json ->
331 Json json ->
354 ( One, Json.encodeUgly json )
332 ( One, Json.encodeUgly json )
@@ -356,90 +334,111 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
356 Array exprs ->
334 Array exprs ->
357 (,) Many $
335 (,) Many $
358 let
336 let
337+ (anyMany, builders) =
359− (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
338+ linesMap (fromExpr indent Whatever) exprs
360 in
339 in
361− if anyMany then
340+ if anyMany then
362− "[\n"
341+ "[\n"
363− <> deeperIndent
342+ <> deeper indent
364− <> commaNewlineSep level builders
343+ <> commaNewlineSep indent builders
365− <> "\n" <> indent <> "]"
344+ <> "\n" <> indent <> "]"
345+
366− else
346+ else
367− "[" <> commaSep builders <> "]"
347+ "[" <> commaSep builders <> "]"
368
348
369 Object fields ->
349 Object fields ->
370 (,) Many $
350 (,) Many $
371 let
351 let
352+ deeperIndent =
353+ deeper indent
354+
355+ (anyMany, builders) =
372− (anyMany, builders) = linesMap (fromField nextLevel) fields
356+ linesMap (fromField deeperIndent) fields
373 in
357 in
374− if anyMany then
358+ if anyMany then
375− "{\n"
359+ "{\n"
376− <> deeperIndent
360+ <> deeperIndent
377− <> commaNewlineSep level builders
361+ <> commaNewlineSep indent builders
378− <> "\n" <> indent <> "}"
362+ <> "\n" <> indent <> "}"
363+
379− else
364+ else
380− "{" <> commaSep builders <> "}"
365+ "{" <> commaSep builders <> "}"
381
366
382 Ref name ->
367 Ref name ->
383− ( One, Name.toBuilder name )
368+ (One, Name.toBuilder name)
384
369
385 Access expr field ->
370 Access expr field ->
386− makeDot level expr field
371+ makeDot indent expr field
387
372
388 Index expr bracketedExpr ->
373 Index expr bracketedExpr ->
389− makeBracketed level expr bracketedExpr
374+ makeBracketed indent expr bracketedExpr
390
375
391 Prefix op expr ->
376 Prefix op expr ->
392 let
377 let
378+ (lines, builder) =
393− (lines, builder) = fromExpr level Atomic expr
379+ fromExpr indent Atomic expr
394 in
380 in
395− ( lines
381+ ( lines
396− , parensFor grouping (fromPrefix op <> builder)
382+ , parensFor grouping (fromPrefix op <> builder)
397− )
383+ )
398
384
399 Infix op leftExpr rightExpr ->
385 Infix op leftExpr rightExpr ->
400 let
386 let
387+ (leftLines, left) =
401− (leftLines , left ) = fromExpr level Atomic leftExpr
388+ fromExpr indent Atomic leftExpr
389+
390+ (rightLines, right) =
402− (rightLines, right) = fromExpr level Atomic rightExpr
391+ fromExpr indent Atomic rightExpr
403 in
392 in
404− ( merge leftLines rightLines
393+ ( merge leftLines rightLines
405− , parensFor grouping (left <> fromInfix op <> right)
394+ , parensFor grouping (left <> fromInfix op <> right)
406− )
395+ )
407
396
408 If condExpr thenExpr elseExpr ->
397 If condExpr thenExpr elseExpr ->
409 let
398 let
410− condB = snd (fromExpr level Atomic condExpr)
399+ condB = snd (fromExpr indent Atomic condExpr)
411− thenB = snd (fromExpr level Atomic thenExpr)
400+ thenB = snd (fromExpr indent Atomic thenExpr)
412− elseB = snd (fromExpr level Atomic elseExpr)
401+ elseB = snd (fromExpr indent Atomic elseExpr)
413 in
402 in
414− ( Many
403+ ( Many
415− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
404+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
416− )
405+ )
417
406
418 Assign lValue expr ->
407 Assign lValue expr ->
419 let
408 let
409+ (leftLines, left) =
420− (leftLines , left ) = fromLValue level lValue
410+ fromLValue indent lValue
411+
412+ (rightLines, right) =
421− (rightLines, right) = fromExpr level Whatever expr
413+ fromExpr indent Whatever expr
422 in
414 in
423− ( merge leftLines rightLines
415+ ( merge leftLines rightLines
424− , parensFor grouping (left <> " = " <> right)
416+ , parensFor grouping (left <> " = " <> right)
425− )
417+ )
426
418
427 Call function args ->
419 Call function args ->
428 (,) Many $
420 (,) Many $
429 let
421 let
422+ deeperIndent =
423+ deeper indent
424+
425+ funcB =
430− (_ , funcB) = fromExpr level Atomic function
426+ snd (fromExpr indent Atomic function)
427+
428+ (anyMany, argsB) =
431− (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
429+ linesMap (fromExpr deeperIndent Whatever) args
432 in
430 in
433− if anyMany then
431+ if anyMany then
434− funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
432+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
433+
435− else
434+ else
436− funcB <> "(" <> commaSep argsB <> ")"
435+ funcB <> "(" <> commaSep argsB <> ")"
437
436
438 Function maybeName args stmts ->
437 Function maybeName args stmts ->
439 (,) Many $
438 (,) Many $
440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
441 <>
440 <>
442− fromStmtBlock nextLevel stmts
441+ fromStmtBlock (deeper indent) stmts
443 <>
442 <>
444 indent <> "}"
443 indent <> "}"
445
444
@@ -448,50 +447,55 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
448-- FIELDS
447-- FIELDS
449
448
450
449
451−fromField :: Level -> (Name, Expr) -> (Lines, Builder)
450+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
452−fromField level (field, expr) =
451+fromField indent (field, expr) =
453 let
452 let
453+ (lines, builder) =
454− (lines, builder) = fromExpr level Whatever expr
454+ fromExpr indent 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 :: Level -> LValue -> (Lines, Builder)
465+fromLValue :: Builder -> LValue -> (Lines, Builder)
466−fromLValue level lValue =
466+fromLValue indent 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 level expr field
472+ makeDot indent expr field
473
473
474 LBracket expr bracketedExpr ->
474 LBracket expr bracketedExpr ->
475− makeBracketed level expr bracketedExpr
475+ makeBracketed indent expr bracketedExpr
476
476
477
477
478−makeDot :: Level -> Expr -> Name -> (Lines, Builder)
478+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
479−makeDot level expr field =
479+makeDot indent expr field =
480 let
480 let
481+ (lines, builder) =
481− (lines, builder) = fromExpr level Atomic expr
482+ fromExpr indent Atomic expr
482 in
483 in
483− (lines, builder <> "." <> Name.toBuilder field)
484+ (lines, builder <> "." <> Name.toBuilder field)
484
485
485
486
486−makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
487+makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
487−makeBracketed level expr bracketedExpr =
488+makeBracketed indent expr bracketedExpr =
488 let
489 let
490+ (lines, builder) =
489− (lines , builder ) = fromExpr level Atomic expr
491+ fromExpr indent Atomic expr
492+
490− (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
493+ (bracketedLines, bracketedBuilder) =
494+ fromExpr indent Whatever bracketedExpr
491 in
495 in
492− ( merge lines bracketedLines
496+ ( merge lines bracketedLines
493− , builder <> "[" <> bracketedBuilder <> "]"
497+ , builder <> "[" <> bracketedBuilder <> "]"
494− )
498+ )
495
499
496
500
497
501
@@ -501,30 +505,36 @@ makeBracketed level expr bracketedExpr =
501fromPrefix :: PrefixOp -> Builder
505fromPrefix :: PrefixOp -> Builder
502fromPrefix op =
506fromPrefix op =
503 case op of
507 case op of
504− PrefixNot -> "!"
508+ PrefixLNot -> "!"
505− PrefixNegate -> "-"
509+ PrefixBNot -> "~"
506− PrefixComplement -> "~"
510+ PrefixPlus -> "+"
511+ PrefixMinus -> "-"
512+ PrefixTypeof -> "typeof "
507
513
508
514
509fromInfix :: InfixOp -> Builder
515fromInfix :: InfixOp -> Builder
510fromInfix op =
516fromInfix op =
511 case op of
517 case op of
512− OpAdd -> " + "
518+ OpLT -> " < "
513− OpSub -> " - "
519+ OpLEq -> " <= "
520+ OpGT -> " > "
521+ OpGEq -> " >= "
522+ OpIn -> " in "
523+ OpInstanceof -> " instanceof "
524+ OpEq -> " == "
525+ OpNEq -> " != "
526+ OpStrictEq -> " === "
527+ OpStrictNEq -> " !== "
528+ OpLAnd -> " && "
529+ OpLOr -> " || "
514 OpMul -> " * "
530 OpMul -> " * "
515 OpDiv -> " / "
531 OpDiv -> " / "
516 OpMod -> " % "
532 OpMod -> " % "
517− OpEq -> " === "
533+ OpSub -> " - "
518− OpNe -> " !== "
519− OpLt -> " < "
520− OpLe -> " <= "
521− OpGt -> " > "
522− OpGe -> " >= "
523− OpAnd -> " && "
524− OpOr -> " || "
525− OpBitwiseAnd -> " & "
526− OpBitwiseXor -> " ^ "
527− OpBitwiseOr -> " | "
528 OpLShift -> " << "
534 OpLShift -> " << "
529 OpSpRShift -> " >> "
535 OpSpRShift -> " >> "
530 OpZfRShift -> " >>> "
536 OpZfRShift -> " >>> "
537+ OpBAnd -> " & "
538+ OpBXor -> " ^ "
539+ OpBOr -> " | "
540+ OpAdd -> " + "
compiler/src/Generate/JavaScript/Expression.hs+45−46
@@ -22,7 +22,6 @@ 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
26import qualified Data.Index as Index
25import qualified Data.Index as Index
27import qualified Elm.Compiler.Type as Type
26import qualified Elm.Compiler.Type as Type
28import qualified Elm.Compiler.Type.Extract as Extract
27import qualified Elm.Compiler.Type.Extract as Extract
@@ -33,7 +32,6 @@ import qualified Generate.JavaScript.Builder as JS
33import qualified Generate.JavaScript.Name as JsName
32import qualified Generate.JavaScript.Name as JsName
34import qualified Generate.Mode as Mode
33import qualified Generate.Mode as Mode
35import qualified Json.Encode as Encode
34import qualified Json.Encode as Encode
36−import Json.Encode ((==>))
37import qualified Optimize.DecisionTree as DT
35import qualified Optimize.DecisionTree as DT
38import qualified Reporting.Annotation as A
36import qualified Reporting.Annotation as A
39
37
@@ -130,7 +128,8 @@ generate mode expression =
130
128
131 Opt.Destruct (Opt.Destructor name path) body ->
129 Opt.Destruct (Opt.Destructor name path) body ->
132 let
130 let
131+ pathExpr = generatePath mode path
133− pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
132+ pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
134 in
133 in
135 JsBlock $ pathDef : codeToStmtList (generate mode body)
134 JsBlock $ pathDef : codeToStmtList (generate mode body)
136
135
@@ -139,7 +138,7 @@ generate mode expression =
139
138
140 Opt.Accessor field ->
139 Opt.Accessor field ->
141 JsExpr $ JS.Function Nothing [JsName.dollar]
140 JsExpr $ JS.Function Nothing [JsName.dollar]
142− [ JS.Return $
141+ [ JS.Return $ Just $
143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
144 ]
143 ]
145
144
@@ -191,7 +190,7 @@ generate mode expression =
191 JS.Object (map toTranlation (Set.toList fields))
190 JS.Object (map toTranlation (Set.toList fields))
192 in
191 in
193 JsExpr $ JS.Object $
192 JsExpr $ JS.Object $
194− [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
193+ [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
197 ]
196 ]
@@ -212,7 +211,7 @@ codeToExpr code =
212 JsExpr expr ->
211 JsExpr expr ->
213 expr
212 expr
214
213
215− JsBlock [ JS.Return expr ] ->
214+ JsBlock [ JS.Return (Just expr) ] ->
216 expr
215 expr
217
216
218 JsBlock stmts ->
217 JsBlock stmts ->
@@ -226,7 +225,7 @@ codeToStmtList code =
226 stmts
225 stmts
227
226
228 JsExpr expr ->
227 JsExpr expr ->
229− [ JS.Return expr ]
228+ [ JS.Return (Just expr) ]
230
229
231 JsBlock stmts ->
230 JsBlock stmts ->
232 stmts
231 stmts
@@ -239,7 +238,7 @@ codeToStmt code =
239 JS.Block stmts
238 JS.Block stmts
240
239
241 JsExpr expr ->
240 JsExpr expr ->
242− JS.Return expr
241+ JS.Return (Just expr)
243
242
244 JsBlock [stmt] ->
243 JsBlock [stmt] ->
245 stmt
244 stmt
@@ -483,17 +482,17 @@ generateBitwiseCall home name args =
483 case args of
482 case args of
484 [arg] ->
483 [arg] ->
485 case name of
484 case name of
486− "complement" -> JS.Prefix JS.PrefixComplement arg
485+ "complement" -> JS.Prefix JS.PrefixBNot arg
487 _ -> generateGlobalCall home name args
486 _ -> generateGlobalCall home name args
488
487
489 [left,right] ->
488 [left,right] ->
490 case name of
489 case name of
491− "and" -> JS.Infix JS.OpBitwiseAnd left right
490+ "and" -> JS.Infix JS.OpBAnd left right
492− "or" -> JS.Infix JS.OpBitwiseOr left right
491+ "or" -> JS.Infix JS.OpBOr left right
493− "xor" -> JS.Infix JS.OpBitwiseXor left right
492+ "xor" -> JS.Infix JS.OpBXor left right
494− "shiftLeftBy" -> JS.Infix JS.OpLShift right left
493+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left
495− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
494+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
496− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
495+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
497 _ -> generateGlobalCall home name args
496 _ -> generateGlobalCall home name args
498
497
499 _ ->
498 _ ->
@@ -506,10 +505,10 @@ generateBasicsCall mode home name args =
506 [elmArg] ->
505 [elmArg] ->
507 let arg = generateJsExpr mode elmArg in
506 let arg = generateJsExpr mode elmArg in
508 case name of
507 case name of
509− "not" -> JS.Prefix JS.PrefixNot arg
508+ "not" -> JS.Prefix JS.PrefixLNot arg
510− "negate" -> JS.Prefix JS.PrefixNegate arg
509+ "negate" -> JS.Prefix JS.PrefixMinus arg
511 "toFloat" -> arg
510 "toFloat" -> arg
512− "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
511+ "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
513 _ -> generateGlobalCall home name [arg]
512 _ -> generateGlobalCall home name [arg]
514
513
515 [elmLeft, elmRight] ->
514 [elmLeft, elmRight] ->
@@ -529,16 +528,16 @@ generateBasicsCall mode home name args =
529 "sub" -> JS.Infix JS.OpSub left right
528 "sub" -> JS.Infix JS.OpSub left right
530 "mul" -> JS.Infix JS.OpMul left right
529 "mul" -> JS.Infix JS.OpMul left right
531 "fdiv" -> JS.Infix JS.OpDiv left right
530 "fdiv" -> JS.Infix JS.OpDiv left right
532− "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
531+ "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
533 "eq" -> equal left right
532 "eq" -> equal left right
534 "neq" -> notEqual left right
533 "neq" -> notEqual left right
535− "lt" -> cmp JS.OpLt JS.OpLt 0 left right
534+ "lt" -> cmp JS.OpLT JS.OpLT 0 left right
536− "gt" -> cmp JS.OpGt JS.OpGt 0 left right
535+ "gt" -> cmp JS.OpGT JS.OpGT 0 left right
537− "le" -> cmp JS.OpLe JS.OpLt 1 left right
536+ "le" -> cmp JS.OpLEq JS.OpLT 1 left right
538− "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
537+ "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
539− "or" -> JS.Infix JS.OpOr left right
538+ "or" -> JS.Infix JS.OpLOr left right
540− "and" -> JS.Infix JS.OpAnd left right
539+ "and" -> JS.Infix JS.OpLAnd left right
541− "xor" -> JS.Infix JS.OpNe left right
540+ "xor" -> JS.Infix JS.OpStrictNEq left right
542 "remainderBy" -> JS.Infix JS.OpMod right left
541 "remainderBy" -> JS.Infix JS.OpMod right left
543 _ -> generateGlobalCall home name [left, right]
542 _ -> generateGlobalCall home name [left, right]
544
543
@@ -559,7 +558,7 @@ notEqual left right =
559 if isLiteral left || isLiteral right then
558 if isLiteral left || isLiteral right then
560 strictNEq left right
559 strictNEq left right
561 else
560 else
562− JS.Prefix JS.PrefixNot $
561+ JS.Prefix JS.PrefixLNot $
563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
564
563
565
564
@@ -648,42 +647,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr
648strictEq left right =
647strictEq left right =
649 case left of
648 case left of
650 JS.Int 0 ->
649 JS.Int 0 ->
651− JS.Prefix JS.PrefixNot right
650+ JS.Prefix JS.PrefixLNot right
652
651
653 JS.Bool bool ->
652 JS.Bool bool ->
654− if bool then right else JS.Prefix JS.PrefixNot right
653+ if bool then right else JS.Prefix JS.PrefixLNot right
655
654
656 _ ->
655 _ ->
657 case right of
656 case right of
658 JS.Int 0 ->
657 JS.Int 0 ->
659− JS.Prefix JS.PrefixNot left
658+ JS.Prefix JS.PrefixLNot left
660
659
661 JS.Bool bool ->
660 JS.Bool bool ->
662− if bool then left else JS.Prefix JS.PrefixNot left
661+ if bool then left else JS.Prefix JS.PrefixLNot left
663
662
664 _ ->
663 _ ->
665− JS.Infix JS.OpEq left right
664+ JS.Infix JS.OpStrictEq left right
666
665
667
666
668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
669strictNEq left right =
668strictNEq left right =
670 case left of
669 case left of
671 JS.Int 0 ->
670 JS.Int 0 ->
672− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
671+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
673
672
674 JS.Bool bool ->
673 JS.Bool bool ->
675− if bool then JS.Prefix JS.PrefixNot right else right
674+ if bool then JS.Prefix JS.PrefixLNot right else right
676
675
677 _ ->
676 _ ->
678 case right of
677 case right of
679 JS.Int 0 ->
678 JS.Int 0 ->
680− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
679+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
681
680
682 JS.Bool bool ->
681 JS.Bool bool ->
683− if bool then JS.Prefix JS.PrefixNot left else left
682+ if bool then JS.Prefix JS.PrefixLNot left else left
684
683
685 _ ->
684 _ ->
686− JS.Infix JS.OpNe left right
685+ JS.Infix JS.OpStrictNEq left right
687
686
688
687
689
688
@@ -696,13 +695,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm
696generateTailCall mode name args =
695generateTailCall mode name args =
697 let
696 let
698 toTempVars (argName, arg) =
697 toTempVars (argName, arg) =
699− ( JsName.makeTemp argName, generateJsExpr mode arg )
698+ ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
700
699
701 toRealVars (argName, _) =
700 toRealVars (argName, _) =
702 JS.ExprStmt $
701 JS.ExprStmt $
703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
704 in
703 in
705− JS.Vars (map toTempVars args)
704+ JS.Var (map toTempVars args)
706 : map toRealVars args
705 : map toRealVars args
707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
708
707
@@ -715,10 +714,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
715generateDef mode def =
714generateDef mode def =
716 case def of
715 case def of
717 Opt.Def name body ->
716 Opt.Def name body ->
718− JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
717+ JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
719
718
720 Opt.TailDef name argNames body ->
719 Opt.TailDef name argNames body ->
721− JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
720+ JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
722
721
723
722
724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
@@ -851,7 +850,7 @@ generateDecider mode label root decisionTree =
851
850
852 Opt.Chain testChain success failure ->
851 Opt.Chain testChain success failure ->
853 [ JS.IfStmt
852 [ JS.IfStmt
854− (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
853+ (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
855 (JS.Block $ generateDecider mode label root success)
854 (JS.Block $ generateDecider mode label root success)
856 (JS.Block $ generateDecider mode label root failure)
855 (JS.Block $ generateDecider mode label root failure)
857 ]
856 ]
@@ -893,7 +892,7 @@ generateIfTest mode root (path, test) =
893 value
892 value
894
893
895 DT.IsBool False ->
894 DT.IsBool False ->
896− JS.Prefix JS.PrefixNot value
895+ JS.Prefix JS.PrefixLNot value
897
896
898 DT.IsInt int ->
897 DT.IsInt int ->
899 strictEq value (JS.Int int)
898 strictEq value (JS.Int int)
@@ -911,7 +910,7 @@ generateIfTest mode root (path, test) =
911 JS.Access value (JsName.fromLocal "b")
910 JS.Access value (JsName.fromLocal "b")
912
911
913 DT.IsNil ->
912 DT.IsNil ->
914− JS.Prefix JS.PrefixNot $
913+ JS.Prefix JS.PrefixLNot $
915 JS.Access value (JsName.fromLocal "b")
914 JS.Access value (JsName.fromLocal "b")
916
915
917 DT.IsTuple ->
916 DT.IsTuple ->
@@ -1065,6 +1064,6 @@ toDebugMetadata mode msgType =
1065
1064
1066 Mode.Dev (Just interfaces) ->
1065 Mode.Dev (Just interfaces) ->
1067 JS.Json $ Encode.object $
1066 JS.Json $ Encode.object $
1068− [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1067+ [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1069− , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
1068+ , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
1070 ]
1069 ]
compiler/src/Generate/JavaScript/Name.hs+12−22
@@ -62,13 +62,19 @@ fromLocal name =
62
62
63
63
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
65−fromGlobal home name =
65+fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =
66+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
67+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
68+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
66− Name $ homeToBuilder home <> usd <> Name.toBuilder name
69+ <> "$" <> Name.toBuilder name
67
70
68
71
69fromCycle :: ModuleName.Canonical -> Name.Name -> Name
72fromCycle :: ModuleName.Canonical -> Name.Name -> Name
70−fromCycle home name =
73+fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =
74+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
75+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
76+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
71− Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name
77+ <> "$cyclic$" <> Name.toBuilder name
72
78
73
79
74fromKernel :: Name.Name -> Name.Name -> Name
80fromKernel :: Name.Name -> Name.Name -> Name
@@ -76,17 +82,6 @@ fromKernel home name =
76 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
82 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
77
83
78
84
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−
90
85
91-- TEMPORARY NAMES
86-- TEMPORARY NAMES
92
87
@@ -103,7 +98,7 @@ makeA n =
103
98
104makeLabel :: Name.Name -> Int -> Name
99makeLabel :: Name.Name -> Int -> Name
105makeLabel name index =
100makeLabel name index =
106− Name (Name.toBuilder name <> usd <> B.intDec index)
101+ Name (Name.toBuilder name <> "$" <> B.intDec index)
107
102
108
103
109makeTemp :: Name.Name -> Name
104makeTemp :: Name.Name -> Name
@@ -113,12 +108,7 @@ makeTemp name =
113
108
114dollar :: Name
109dollar :: Name
115dollar =
110dollar =
116− Name usd
117−
118−
119−usd :: B.Builder
120−usd =
121− Name.toBuilder Name.dollar
111+ Name (Name.toBuilder Name.dollar)
122
112
123
113
124
114
compiler/src/Generate/Mode.hs+1
@@ -49,6 +49,7 @@ shortenFieldNames (Opt.GlobalGraph _ frequencies) =
49
49
50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
51addToBuckets field frequency buckets =
51addToBuckets field frequency buckets =
52+ -- TODO try using an IntMap for buckets
52 Map.insertWith (++) frequency [field] buckets
53 Map.insertWith (++) frequency [field] buckets
53
54
54
55
compiler/src/Json/Decode.hs+177−329
@@ -4,110 +4,68 @@ module Json.Decode
4 ( fromByteString
4 ( fromByteString
5 , Decoder
5 , Decoder
6 , string
6 , string
7− , customString
8 , bool
7 , bool
9 , int
8 , int
10− , list
9+ , list, pair
11− , nonEmptyList
12− , pair
13− --
14− , KeyDecoder(..)
15− , dict
16− , pairs
10+ , dict, pairs, field
17− , field
18− --
19 , oneOf
11 , oneOf
20 , failure
12 , failure
21 , mapError
13 , mapError
22− --
23− , Error(..)
24− , Problem(..)
25− , DecodeExpectation(..)
26− , ParseError(..)
27− , StringProblem(..)
28 )
14 )
29 where
15 where
30
16
31
17
32−import qualified Data.ByteString.Internal as B
18+import qualified Data.ByteString as B
19+import qualified Data.List as List
33import qualified Data.Map as Map
20import qualified Data.Map as Map
34−import qualified Data.NonEmptyList as NE
21+import qualified Data.Utf8 as Utf8
35−import Data.Word (Word8)
22+import Data.Word (Word8, Word16)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
23import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
38
24
39−import qualified Json.String as Json
40import qualified Parse.Keyword as K
25import qualified Parse.Keyword as K
41import qualified Parse.Primitives as P
26import qualified Parse.Primitives as P
42−import Parse.Primitives (Row, Col)
43−import qualified Reporting.Annotation as A
27+import qualified Reporting.Error.Json as E
44
28
45
29
46
30
47-- RUNNERS
31-- RUNNERS
48
32
49
33
50−fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
34+fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
51−fromByteString (Decoder decode) src =
35+fromByteString decoder src =
52− case P.fromByteString pFile BadEnd src of
36+ fromAST decoder (P.fromByteString pFile src)
53− Right ast ->
54− decode ast Right (Left . DecodeProblem src)
55
37
56− Left problem ->
38+
39+fromAST :: Decoder e a -> P.Result E.ParseError AST -> Either (E.Error e) a
40+fromAST (Decoder decode) parserResult =
41+ case parserResult of
42+ P.Ok ast _ ->
43+ decode ast Right (Left . E.DecodeProblem)
44+
45+ P.Err err ->
57− Left (ParseProblem src problem)
46+ Left (E.ParseProblem err)
58
47
59
48
60
49
61-- DECODERS
50-- DECODERS
62
51
63
52
64−newtype Decoder x a =
53+newtype Decoder e a =
65 Decoder
54 Decoder
66 (
55 (
67 forall b.
56 forall b.
68 AST
57 AST
69 -> (a -> b)
58 -> (a -> b)
70− -> (Problem x -> b)
59+ -> (E.Problem e -> b)
71 -> b
60 -> b
72 )
61 )
73
62
74
63
75
64
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−
107-- INSTANCES
65-- INSTANCES
108
66
109
67
110−instance Functor (Decoder x) where
68+instance Functor (Decoder e) where
111 {-# INLINE fmap #-}
69 {-# INLINE fmap #-}
112 fmap func (Decoder decodeA) =
70 fmap func (Decoder decodeA) =
113 Decoder $ \ast ok err ->
71 Decoder $ \ast ok err ->
@@ -117,7 +75,7 @@ instance Functor (Decoder x) where
117 decodeA ast ok' err
75 decodeA ast ok' err
118
76
119
77
120−instance Applicative (Decoder x) where
78+instance Applicative (Decoder e) where
121 {-# INLINE pure #-}
79 {-# INLINE pure #-}
122 pure = return
80 pure = return
123
81
@@ -134,7 +92,7 @@ instance Applicative (Decoder x) where
134 decodeFunc ast okF err
92 decodeFunc ast okF err
135
93
136
94
137−instance Monad (Decoder x) where
95+instance Monad (Decoder e) where
138 {-# INLINE return #-}
96 {-# INLINE return #-}
139 return a =
97 return a =
140 Decoder $ \_ ok _ ->
98 Decoder $ \_ ok _ ->
@@ -155,37 +113,24 @@ instance Monad (Decoder x) where
155-- STRINGS
113-- STRINGS
156
114
157
115
158−string :: Decoder x Json.String
116+string :: Decoder e Utf8.String
159string =
117string =
160− Decoder $ \(A.At region ast) ok err ->
161− case ast of
162− String snippet ->
163− ok (Json.fromSnippet snippet)
164−
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 ->
118+ Decoder $ \ast ok err ->
172 case ast of
119 case ast of
173− String snippet ->
120+ String bits ->
174− case P.fromSnippet parser toBadEnd snippet of
121+ ok bits
175− Right a -> ok a
176− Left x -> err (Failure region x)
177
122
178 _ ->
123 _ ->
179− err (Expecting region TString)
124+ err (E.Expecting E.TString)
180
125
181
126
182
127
183-- BOOL
128-- BOOL
184
129
185
130
186−bool :: Decoder x Bool
131+bool :: Decoder e Bool
187bool =
132bool =
188− Decoder $ \(A.At region ast) ok err ->
133+ Decoder $ \ast ok err ->
189 case ast of
134 case ast of
190 TRUE ->
135 TRUE ->
191 ok True
136 ok True
@@ -194,40 +139,40 @@ bool =
194 ok False
139 ok False
195
140
196 _ ->
141 _ ->
197− err (Expecting region TBool)
142+ err (E.Expecting E.TBool)
198
143
199
144
200
145
201-- INT
146-- INT
202
147
203
148
204−int :: Decoder x Int
149+int :: Decoder e Int
205int =
150int =
206− Decoder $ \(A.At region ast) ok err ->
151+ Decoder $ \ast ok err ->
207 case ast of
152 case ast of
208 Int n ->
153 Int n ->
209 ok n
154 ok n
210
155
211 _ ->
156 _ ->
212− err (Expecting region TInt)
157+ err (E.Expecting E.TInt)
213
158
214
159
215
160
216−-- LISTS
161+-- ARRAYS
217
162
218
163
219−list :: Decoder x a -> Decoder x [a]
164+list :: Decoder e a -> Decoder e [a]
220list decoder =
165list decoder =
221− Decoder $ \(A.At region ast) ok err ->
166+ Decoder $ \ast ok err ->
222 case ast of
167 case ast of
223 Array asts ->
168 Array asts ->
224 listHelp decoder ok err 0 asts []
169 listHelp decoder ok err 0 asts []
225
170
226 _ ->
171 _ ->
227− err (Expecting region TArray)
172+ err (E.Expecting E.TArray)
228
173
229
174
230−listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
175+listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
231listHelp decoder@(Decoder decodeA) ok err !i asts revs =
176listHelp decoder@(Decoder decodeA) ok err !i asts revs =
232 case asts of
177 case asts of
233 [] ->
178 [] ->
@@ -235,40 +180,24 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
235
180
236 ast:asts ->
181 ast:asts ->
237 let
182 let
238− ok' value = listHelp decoder ok err (i+1) asts (value:revs)
183+ ok' a = listHelp decoder ok err (i+1) asts (a:revs)
239− err' prob = err (Index i prob)
184+ err' e = err (E.Index i e)
240 in
185 in
241 decodeA ast ok' err'
186 decodeA ast ok' err'
242
187
243
188
244−
245−-- NON-EMPTY LISTS
246−
247−
248−nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249−nonEmptyList decoder x =
250− do values <- list decoder
251− case values of
252− v:vs -> return (NE.List v vs)
253− [] -> failure x
254−
255−
256−
257−-- PAIR
258−
259−
260−pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
189+pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
261pair (Decoder decodeA) (Decoder decodeB) =
190pair (Decoder decodeA) (Decoder decodeB) =
262− Decoder $ \(A.At region ast) ok err ->
191+ Decoder $ \ast ok err ->
263 case ast of
192 case ast of
264 Array vs ->
193 Array vs ->
265 case vs of
194 case vs of
266 [astA,astB] ->
195 [astA,astB] ->
267 let
196 let
268− err0 e = err (Index 0 e)
197+ err0 e = err (E.Index 0 e)
269 ok0 a =
198 ok0 a =
270 let
199 let
271− err1 e = err (Index 1 e)
200+ err1 e = err (E.Index 1 e)
272 ok1 b = ok (a,b)
201 ok1 b = ok (a,b)
273 in
202 in
274 decodeB astB ok1 err1
203 decodeB astB ok1 err1
@@ -276,103 +205,70 @@ pair (Decoder decodeA) (Decoder decodeB) =
276 decodeA astA ok0 err0
205 decodeA astA ok0 err0
277
206
278 _ ->
207 _ ->
279− err (Expecting region (TArrayPair (length vs)))
208+ err (E.Expecting (E.TArrayPair (length vs)))
280
209
281 _ ->
210 _ ->
282− err (Expecting region TArray)
211+ err (E.Expecting E.TArray)
283−
284−
285
212
286−-- OBJECTS
287
213
288
214
289−data KeyDecoder x a =
215+-- OBJECT
290− KeyDecoder (P.Parser x a) (Row -> Col -> x)
291
216
292
217
293−dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
218+dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
294−dict keyDecoder valueDecoder =
219+dict decoder =
295− Map.fromList <$> pairs keyDecoder valueDecoder
220+ Map.fromList <$> pairs decoder
296
221
297
222
298−pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
223+pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
299−pairs keyDecoder valueDecoder =
224+pairs decoder =
300− Decoder $ \(A.At region ast) ok err ->
225+ Decoder $ \ast ok err ->
301 case ast of
226 case ast of
302 Object kvs ->
227 Object kvs ->
303− pairsHelp keyDecoder valueDecoder ok err kvs []
228+ pairsHelp decoder ok err kvs []
304
229
305 _ ->
230 _ ->
306− err (Expecting region TObject)
231+ err (E.Expecting E.TObject)
307
232
308
233
309−pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
234+pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
310−pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
235+pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
311 case kvs of
236 case kvs of
312 [] ->
237 [] ->
313 ok (reverse revs)
238 ok (reverse revs)
314
239
315− (snippet, ast) : kvs ->
240+ (key, ast) : kvs ->
316− case P.fromSnippet keyParser toBadEnd snippet of
317− Left x ->
318− err (Failure (snippetToRegion snippet) x)
319−
320− Right key ->
321− let
241+ let
322− ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
242+ ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
323− err' prob =
243+ err' e = err (E.Field key e)
324− let (P.Snippet fptr off len _ _) = snippet in
325− err (Field (B.PS fptr off len) prob)
326− in
244+ in
327− decodeA ast ok' err'
245+ decodeA ast ok' err'
328−
329−
330−snippetToRegion :: P.Snippet -> A.Region
331−snippetToRegion (P.Snippet _ _ len row col) =
332− A.Region (A.Position row col) (A.Position row (col + fromIntegral len))
333−
334−
335−
336−-- FIELDS
337
246
338
247
339−field :: B.ByteString -> Decoder x a -> Decoder x a
248+field :: Utf8.String -> Decoder e a -> Decoder e a
340field key (Decoder decodeA) =
249field key (Decoder decodeA) =
341− Decoder $ \(A.At region ast) ok err ->
250+ Decoder $ \ast ok err ->
342 case ast of
251 case ast of
343 Object kvs ->
252 Object kvs ->
344− case findField key kvs of
253+ case List.lookup key kvs of
345− Just value ->
254+ Just v ->
346 let
255 let
347− err' prob =
348− err (Field key prob)
256+ err' e = err (E.Field key e)
349 in
257 in
350− decodeA value ok err'
258+ decodeA v ok err'
351
259
352 Nothing ->
260 Nothing ->
353− err (Expecting region (TObjectWith key))
261+ err (E.Expecting (E.TObjectWith key))
354
262
355 _ ->
263 _ ->
356− err (Expecting region TObject)
264+ err (E.Expecting E.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
369
265
370
266
371
267
372-- ONE OF
268-- ONE OF
373
269
374
270
375−oneOf :: [Decoder x a] -> Decoder x a
271+oneOf :: [Decoder e a] -> Decoder e a
376oneOf decoders =
272oneOf decoders =
377 Decoder $ \ast ok err ->
273 Decoder $ \ast ok err ->
378 case decoders of
274 case decoders of
@@ -387,75 +283,71 @@ oneOf decoders =
387 error "Ran into (Json.Decode.oneOf [])"
283 error "Ran into (Json.Decode.oneOf [])"
388
284
389
285
390−oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
286+oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
391−oneOfHelp ast ok err decoders p ps =
287+oneOfHelp ast ok err decoders e es =
392 case decoders of
288 case decoders of
393 Decoder decodeA : decoders ->
289 Decoder decodeA : decoders ->
394 let
290 let
395− err' p' =
291+ err' e' =
396− oneOfHelp ast ok err decoders p' (p:ps)
292+ oneOfHelp ast ok err decoders e' (e:es)
397 in
293 in
398 decodeA ast ok err'
294 decodeA ast ok err'
399
295
400 [] ->
296 [] ->
401− err (oneOfError [] p ps)
297+ err (oneOfError [] e es)
402
298
403
299
404−oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
300+oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
405−oneOfError problems prob ps =
301+oneOfError errors err es =
406− case ps of
302+ case es of
407 [] ->
303 [] ->
408− OneOf prob problems
304+ E.OneOf err errors
409
305
410− p:ps ->
306+ e:es ->
411− oneOfError (prob:problems) p ps
307+ oneOfError (err:errors) e es
412
308
413
309
414
310
415-- FAILURE
311-- FAILURE
416
312
417
313
418−failure :: x -> Decoder x a
314+failure :: e -> Decoder e a
419−failure x =
315+failure e =
420− Decoder $ \(A.At region _) _ err ->
316+ Decoder $ \_ _ err ->
421− err (Failure region x)
317+ err (E.Failure e)
422
318
423
319
424
320
425-- ERRORS
321-- ERRORS
426
322
427
323
428−mapError :: (x -> y) -> Decoder x a -> Decoder y a
324+mapError :: (e -> e') -> Decoder e a -> Decoder e' a
429mapError func (Decoder decodeA) =
325mapError func (Decoder decodeA) =
430 Decoder $ \ast ok err ->
326 Decoder $ \ast ok err ->
431 let
327 let
432− err' prob = err (mapErrorHelp func prob)
328+ err' e = err (mapErrorHelp func e)
433 in
329 in
434 decodeA ast ok err'
330 decodeA ast ok err'
435
331
436
332
437−mapErrorHelp :: (x -> y) -> Problem x -> Problem y
333+mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
438−mapErrorHelp func problem =
334+mapErrorHelp func err =
439− case problem of
335+ case err of
440− Field k p -> Field k (mapErrorHelp func p)
336+ E.Field k e -> E.Field k (mapErrorHelp func e)
441− Index i p -> Index i (mapErrorHelp func p)
337+ E.Index i e -> E.Index i (mapErrorHelp func e)
442− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
338+ E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
443− Failure r x -> Failure r (func x)
339+ E.Failure e -> E.Failure (func e)
444− Expecting r e -> Expecting r e
340+ E.Expecting e -> E.Expecting e
445
341
446
342
447
343
448-- AST
344-- AST
449
345
450
346
451−type AST =
452− A.Located AST_
453−
454−
455−data AST_
347+data AST
456 = Array [AST]
348 = Array [AST]
457− | Object [(P.Snippet, AST)]
349+ | Object [(Utf8.String, AST)]
458− | String P.Snippet
350+ | String Utf8.String
459 | Int Int
351 | Int Int
460 | TRUE
352 | TRUE
461 | FALSE
353 | FALSE
@@ -467,33 +359,7 @@ data AST_
467
359
468
360
469type Parser a =
361type Parser a =
470− P.Parser ParseError a
362+ P.Parser E.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
497
363
498
364
499pFile :: Parser AST
365pFile :: Parser AST
@@ -501,60 +367,69 @@ pFile =
501 do spaces
367 do spaces
502 value <- pValue
368 value <- pValue
503 spaces
369 spaces
370+ endOfFile
504 return value
371 return value
505
372
506
373
507pValue :: Parser AST
374pValue :: Parser AST
508pValue =
375pValue =
509− P.addLocation $
510− P.oneOf Start
376+ P.oneOf E.Value
511− [ String <$> pString Start
377+ [ fmap String pString
512 , pObject
378 , pObject
513 , pArray
379 , pArray
514 , pInt
380 , pInt
515− , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
381+ , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
516− , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
382+ , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
517− , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
383+ , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
518 ]
384 ]
519
385
520
386
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+
521
396
522-- OBJECT
397-- OBJECT
523
398
524
399
525−pObject :: Parser AST_
400+pObject :: Parser AST
526pObject =
401pObject =
527− do P.word1 0x7B {- { -} Start
402+ do P.word1 0x7B {- { -} E.ObjectStart
528 spaces
403 spaces
529− P.oneOf ObjectField
404+ P.oneOf E.ObjectMore
530 [ do entry <- pField
405 [ do entry <- pField
531 spaces
406 spaces
532 pObjectHelp [entry]
407 pObjectHelp [entry]
533− , do P.word1 0x7D {-}-} ObjectEnd
408+ , do P.word1 0x7D {-}-} E.ObjectEnd
534 return (Object [])
409 return (Object [])
535 ]
410 ]
536
411
537
412
538−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
413+pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
539pObjectHelp revEntries =
414pObjectHelp revEntries =
540− P.oneOf ObjectEnd
415+ P.oneOf E.ObjectMore
541 [
416 [
542− do P.word1 0x2C {-,-} ObjectEnd
417+ do P.word1 0x2C {-,-} E.ObjectMore
543 spaces
418 spaces
544 entry <- pField
419 entry <- pField
545 spaces
420 spaces
546 pObjectHelp (entry:revEntries)
421 pObjectHelp (entry:revEntries)
547 ,
422 ,
548− do P.word1 0x7D {-}-} ObjectEnd
423+ do P.word1 0x7D {-}-} E.ObjectEnd
549 return (Object (reverse revEntries))
424 return (Object (reverse revEntries))
550 ]
425 ]
551
426
552
427
553−pField :: Parser (P.Snippet, AST)
428+pField :: Parser (Utf8.String, AST)
554pField =
429pField =
555− do key <- pString ObjectField
430+ do key <- pString
556 spaces
431 spaces
557− P.word1 0x3A {-:-} ObjectColon
432+ P.word1 0x3A {-:-} E.Colon
558 spaces
433 spaces
559 value <- pValue
434 value <- pValue
560 return (key, value)
435 return (key, value)
@@ -564,30 +439,30 @@ pField =
564-- ARRAY
439-- ARRAY
565
440
566
441
567−pArray :: Parser AST_
442+pArray :: Parser AST
568pArray =
443pArray =
569− do P.word1 0x5B {-[-} Start
444+ do P.word1 0x5B {-[-} E.ArrayStart
570 spaces
445 spaces
571− P.oneOf Start
446+ P.oneOf E.ArrayMore
572 [ do entry <- pValue
447 [ do entry <- pValue
573 spaces
448 spaces
574 pArrayHelp 1 [entry]
449 pArrayHelp 1 [entry]
575− , do P.word1 0x5D {-]-} ArrayEnd
450+ , do P.word1 0x5D {-]-} E.ArrayEnd
576 return (Array [])
451 return (Array [])
577 ]
452 ]
578
453
579
454
580−pArrayHelp :: Int -> [AST] -> Parser AST_
455+pArrayHelp :: Int -> [AST] -> Parser AST
581pArrayHelp !len revEntries =
456pArrayHelp !len revEntries =
582− P.oneOf ArrayEnd
457+ P.oneOf E.ArrayMore
583 [
458 [
584− do P.word1 0x2C {-,-} ArrayEnd
459+ do P.word1 0x2C {-,-} E.ArrayMore
585 spaces
460 spaces
586 entry <- pValue
461 entry <- pValue
587 spaces
462 spaces
588 pArrayHelp (len + 1) (entry:revEntries)
463 pArrayHelp (len + 1) (entry:revEntries)
589 ,
464 ,
590− do P.word1 0x5D {-]-} ArrayEnd
465+ do P.word1 0x5D {-]-} E.ArrayEnd
591 return (Array (reverse revEntries))
466 return (Array (reverse revEntries))
592 ]
467 ]
593
468
@@ -596,44 +471,41 @@ pArrayHelp !len revEntries =
596-- STRING
471-- STRING
597
472
598
473
599−pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
474+pString :: Parser Utf8.String
600−pString start =
475+pString =
601− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
476+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
477 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
603
478
604 let
479 let
605 !pos1 = plusPtr pos 1
480 !pos1 = plusPtr pos 1
606− !col1 = col + 1
607
481
608 (# status, newPos, newRow, newCol #) =
482 (# status, newPos, newRow, newCol #) =
609− pStringHelp pos1 end row col1
483+ pStringHelp pos1 end row (col + 1)
610 in
484 in
611 case status of
485 case status of
612 GoodString ->
486 GoodString ->
613 let
487 let
614− !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615− !len = minusPtr newPos pos1 - 1
616− !snp = P.Snippet src off len row col1
617− !newState = P.State src newPos end indent newRow newCol
488+ !newState = P.State newPos end indent newRow newCol
489+ !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
618 in
490 in
619− cok snp newState
491+ cok content newState
620
492
621− BadString problem ->
493+ BadStringEnd ->
622− cerr newRow newCol (StringProblem problem)
494+ cerr newRow newCol E.StringEnd
623
495
624 else
496 else
625− eerr row col start
497+ eerr row col E.StringStart
626
498
627
499
628data StringStatus
500data StringStatus
629 = GoodString
501 = GoodString
630− | BadString StringProblem
502+ | BadStringEnd
631
503
632
504
633−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
505+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
634pStringHelp pos end row col =
506pStringHelp pos end row col =
635 if pos >= end then
507 if pos >= end then
636− (# BadString BadStringEnd, pos, row, col #)
508+ (# BadStringEnd, pos, row, col #)
637
509
638 else
510 else
639 case P.unsafeIndex pos of
511 case P.unsafeIndex pos of
@@ -641,50 +513,26 @@ pStringHelp pos end row col =
641 (# GoodString, plusPtr pos 1, row, col + 1 #)
513 (# GoodString, plusPtr pos 1, row, col + 1 #)
642
514
643 0x0A {-\n-} ->
515 0x0A {-\n-} ->
644− (# BadString BadStringEnd, pos, row, col #)
516+ (# BadStringEnd, pos, row, col #)
645
517
646 0x5C {-\-} ->
518 0x5C {-\-} ->
519+ let
647− let !pos1 = plusPtr pos 1 in
520+ !pos1 = plusPtr pos 1
648− if pos1 >= end then
521+ in
649− (# BadString BadStringEnd, pos1, row + 1, col #)
650− else
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
522+ if pos1 < end then
668− pStringHelp pos6 end row (col + 6)
669− else
670− (# BadString BadStringEscapeHex, pos, row, col #)
671−
672− _ ->
673− (# BadString BadStringEscapeChar, pos, row, col #)
674
523
675− word ->
524+ let
676− if word < 0x20 then
525+ !word = P.unsafeIndex pos1
677− (# BadString BadStringControlChar, pos, row, col #)
678− else
679− let !newPos = plusPtr pos (P.getCharWidth word) in
526+ !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
527+ in
680− pStringHelp newPos end row (col + 1)
528+ pStringHelp newPos end row (col + 2)
681
529
530+ else
531+ (# BadStringEnd, pos1, row + 1, col #)
682
532
683−isHex :: Word8 -> Bool
533+ word ->
684−isHex word =
534+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
685− 0x30 {-0-} <= word && word <= 0x39 {-9-}
535+ pStringHelp newPos end row (col + 1)
686− || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687− || 0x41 {-A-} <= word && word <= 0x46 {-F-}
688
536
689
537
690
538
@@ -693,7 +541,7 @@ isHex word =
693
541
694spaces :: Parser ()
542spaces :: Parser ()
695spaces =
543spaces =
696− P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
544+ P.Parser $ \state@(P.State pos end indent row col) cok eok _ _ ->
697 let
545 let
698 (# newPos, newRow, newCol #) =
546 (# newPos, newRow, newCol #) =
699 eatSpaces pos end row col
547 eatSpaces pos end row col
@@ -703,12 +551,12 @@ spaces =
703 else
551 else
704 let
552 let
705 !newState =
553 !newState =
706− P.State src newPos end indent newRow newCol
554+ P.State newPos end indent newRow newCol
707 in
555 in
708 cok () newState
556 cok () newState
709
557
710
558
711−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
559+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
712eatSpaces pos end row col =
560eatSpaces pos end row col =
713 if pos >= end then
561 if pos >= end then
714 (# pos, row, col #)
562 (# pos, row, col #)
@@ -727,29 +575,29 @@ eatSpaces pos end row col =
727-- INTS
575-- INTS
728
576
729
577
730−pInt :: Parser AST_
578+pInt :: Parser AST
731pInt =
579pInt =
732− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
580+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
733 if pos >= end then
581 if pos >= end then
734− eerr row col Start
582+ eerr row col E.IntStart
735
583
736 else
584 else
737 let !word = P.unsafeIndex pos in
585 let !word = P.unsafeIndex pos in
738 if not (isDecimalDigit word) then
586 if not (isDecimalDigit word) then
739− eerr row col Start
587+ eerr row col E.IntStart
740
588
741 else if word == 0x30 {-0-} then
589 else if word == 0x30 {-0-} then
742
590
743 let
591 let
744 !pos1 = plusPtr pos 1
592 !pos1 = plusPtr pos 1
745− !newState = P.State src pos1 end indent row (col + 1)
593+ !newState = P.State pos1 end indent row (col + 1)
746 in
594 in
747 if pos1 < end then
595 if pos1 < end then
748 let !word1 = P.unsafeIndex pos1 in
596 let !word1 = P.unsafeIndex pos1 in
749 if isDecimalDigit word1 then
597 if isDecimalDigit word1 then
750− cerr row (col + 1) NoLeadingZeros
598+ cerr row (col + 1) E.NoLeadingZeros
751 else if word1 == 0x2E {-.-} then
599 else if word1 == 0x2E {-.-} then
752− cerr row (col + 1) NoFloats
600+ cerr row (col + 1) E.NoFloats
753 else
601 else
754 cok (Int 0) newState
602 cok (Int 0) newState
755 else
603 else
@@ -766,12 +614,12 @@ pInt =
766 GoodInt ->
614 GoodInt ->
767 let
615 let
768 !newState =
616 !newState =
769− P.State src newPos end indent row (col + len)
617+ P.State newPos end indent row (col + len)
770 in
618 in
771 cok (Int n) newState
619 cok (Int n) newState
772
620
773 BadIntEnd ->
621 BadIntEnd ->
774− cerr row (col + len) NoFloats
622+ cerr row (col + len) E.NoFloats
775
623
776
624
777data IntStatus = GoodInt | BadIntEnd
625data IntStatus = GoodInt | BadIntEnd
compiler/src/Json/Encode.hs+21−37
@@ -10,7 +10,6 @@ module Json.Encode
10 , object
10 , object
11 , string
11 , string
12 , name
12 , name
13− , chars
14 , bool
13 , bool
15 , int
14 , int
16 , number
15 , number
@@ -33,7 +32,6 @@ import qualified Data.Name as Name
33import qualified Data.Utf8 as Utf8
32import qualified Data.Utf8 as Utf8
34
33
35import qualified File
34import qualified File
36−import qualified Json.String as Json
37
35
38
36
39
37
@@ -42,7 +40,7 @@ import qualified Json.String as Json
42
40
43data Value
41data Value
44 = Array [Value]
42 = Array [Value]
45− | Object [(Json.String, Value)]
43+ | Object [(Utf8.String, Value)]
46 | String B.Builder
44 | String B.Builder
47 | Boolean Bool
45 | Boolean Bool
48 | Integer Int
46 | Integer Int
@@ -55,14 +53,14 @@ array =
55 Array
53 Array
56
54
57
55
58−object :: [(Json.String, Value)] -> Value
56+object :: [(Utf8.String,Value)] -> Value
59object =
57object =
60 Object
58 Object
61
59
62
60
63−string :: Json.String -> Value
61+string :: Utf8.String -> Value
64string str =
62string str =
65− String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')
63+ String (encodeUtf8 str)
66
64
67
65
68name :: Name.Name -> Value
66name :: Name.Name -> Value
@@ -90,7 +88,7 @@ null =
90 Null
88 Null
91
89
92
90
93−dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
91+dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value
94dict encodeKey encodeValue pairs =
92dict encodeKey encodeValue pairs =
95 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
93 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
96
94
@@ -101,35 +99,12 @@ list encodeEntry entries =
101
99
102
100
103
101
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−
127-- HELPERS
102-- HELPERS
128
103
129
104
130−(==>) :: [Char] -> value -> (Json.String, value)
105+(==>) :: a -> b -> (a, b)
131−(==>) key value =
106+(==>) a b =
132− (Json.fromChars key, value)
107+ (a, b)
133
108
134
109
135
110
@@ -169,7 +144,7 @@ encodeUgly value =
169 Object (first : rest) ->
144 Object (first : rest) ->
170 let
145 let
171 encodeEntry char (key, entry) =
146 encodeEntry char (key, entry) =
172− B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
147+ B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry
173 in
148 in
174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
149 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
175
150
@@ -230,6 +205,15 @@ encodeHelp indent value =
230
205
231
206
232
207
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+
233-- ENCODE ARRAY
217-- ENCODE ARRAY
234
218
235
219
@@ -252,7 +236,7 @@ arrayClose =
252-- ENCODE OBJECT
236-- ENCODE OBJECT
253
237
254
238
255−encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
239+encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder
256encodeObject =
240encodeObject =
257 encodeSequence objectOpen objectClose encodeField
241 encodeSequence objectOpen objectClose encodeField
258
242
@@ -267,9 +251,9 @@ objectClose =
267 B.char7 '}'
251 B.char7 '}'
268
252
269
253
270−encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
254+encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder
271encodeField indent (key, value) =
255encodeField indent (key, value) =
272− B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value
256+ encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value
273
257
274
258
275
259
compiler/src/Json/String.hsdeleted−192
@@ -1,192 +0,0 @@
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+7−8
@@ -21,12 +21,11 @@ import qualified Data.List as List
21import qualified Data.Map as Map
21import 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
24−import qualified Data.NonEmptyList as NE
24+import qualified Data.Utf8 as Utf8
25
25
26import qualified AST.Canonical as Can
26import qualified AST.Canonical as Can
27import qualified Data.Index as Index
27import qualified Data.Index as Index
28import qualified Elm.ModuleName as ModuleName
28import qualified Elm.ModuleName as ModuleName
29−import qualified Elm.String as ES
30import qualified Reporting.Annotation as A
29import qualified Reporting.Annotation as A
31
30
32
31
@@ -41,8 +40,8 @@ data Pattern
41
40
42
41
43data Literal
42data Literal
44− = Chr ES.String
43+ = Chr Utf8.String
45− | Str ES.String
44+ | Str Utf8.String
46 | Int Int
45 | Int Int
47 deriving (Eq)
46 deriving (Eq)
48
47
@@ -203,14 +202,14 @@ data Context
203-- CHECK
202-- CHECK
204
203
205
204
206−check :: Can.Module -> Either (NE.List Error) ()
205+check :: Can.Module -> Either [Error] ()
207−check (Can.Module _ _ _ decls _ _ _ _) =
206+check (Can.Module _ _ decls _ _ _ _) =
208 case checkDecls decls [] of
207 case checkDecls decls [] of
209 [] ->
208 [] ->
210 Right ()
209 Right ()
211
210
212− e:es ->
211+ errors ->
213− Left (NE.List e es)
212+ Left errors
214
213
215
214
216
215
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
30
31
31import qualified AST.Canonical as Can
32import qualified AST.Canonical as Can
32import qualified Data.Index as Index
33import qualified Data.Index as Index
33import qualified Elm.ModuleName as ModuleName
34import 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 ES.String
80+ | IsChr Utf8.String
81− | IsStr ES.String
81+ | IsStr Utf8.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− _ -> fail "problem getting DecisionTree.Test binary"
621+ _ -> error "problem getting DecisionTree.Test binary"
622
622
623
623
624instance Binary Path where
624instance Binary Path where
@@ -634,4 +634,4 @@ instance Binary Path where
634 0 -> liftM2 Index get get
634 0 -> liftM2 Index get get
635 1 -> liftM Unbox get
635 1 -> liftM Unbox get
636 2 -> pure Empty
636 2 -> pure Empty
637− _ -> fail "problem getting DecisionTree.Path binary"
637+ _ -> error "problem getting DecisionTree.Path binary"
compiler/src/Optimize/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 custom type"
61+ error "toEncoder: bad union type"
62
62
63 Can.TRecord _ (Just _) ->
63 Can.TRecord _ (Just _) ->
64 error "toEncoder: bad record"
64 error "toEncoder: bad record"
@@ -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.toElmString name)) value Nothing
71+ return $ Opt.Tuple (Opt.Str (Name.toUtf8 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.toElmString key), typeDecoder ]
312+ , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]
313 ]
313 ]
314
314
315
315
compiler/src/Parse/Declaration.hs+19−18
@@ -20,6 +20,7 @@ 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)
23import Parse.Primitives hiding (State)
24import Parse.Primitives hiding (State)
24import qualified Parse.Primitives as P
25import qualified Parse.Primitives as P
25import qualified Reporting.Annotation as A
26import qualified Reporting.Annotation as A
@@ -31,10 +32,10 @@ import qualified Reporting.Error.Syntax as E
31
32
32
33
33data Decl
34data Decl
34− = Value (Maybe Src.Comment) (A.Located Src.Value)
35+ = Value (Maybe DocComment) (A.Located Src.Value)
35− | Union (Maybe Src.Comment) (A.Located Src.Union)
36+ | Union (Maybe DocComment) (A.Located Src.Union)
36− | Alias (Maybe Src.Comment) (A.Located Src.Alias)
37+ | Alias (Maybe DocComment) (A.Located Src.Alias)
37− | Port (Maybe Src.Comment) Src.Port
38+ | Port (Maybe DocComment) Src.Port
38
39
39
40
40declaration :: Space.Parser E.Decl Decl
41declaration :: Space.Parser E.Decl Decl
@@ -52,7 +53,7 @@ declaration =
52-- DOC COMMENT
53-- DOC COMMENT
53
54
54
55
55−chompDocComment :: Parser E.Decl (Maybe Src.Comment)
56+chompDocComment :: Parser E.Decl (Maybe DocComment)
56chompDocComment =
57chompDocComment =
57 oneOfWithFallback
58 oneOfWithFallback
58 [
59 [
@@ -69,7 +70,7 @@ chompDocComment =
69
70
70
71
71{-# INLINE valueDecl #-}
72{-# INLINE valueDecl #-}
72−valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
73+valueDecl :: Maybe DocComment -> A.Position -> Space.Parser E.Decl Decl
73valueDecl maybeDocs start =
74valueDecl maybeDocs start =
74 do name <- Var.lower E.DeclStart
75 do name <- Var.lower E.DeclStart
75 end <- getPosition
76 end <- getPosition
@@ -80,7 +81,7 @@ valueDecl maybeDocs start =
80 do word1 0x3A {-:-} E.DeclDefEquals
81 do word1 0x3A {-:-} E.DeclDefEquals
81 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
82 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
82 (tipe, _) <- specialize E.DeclDefType Type.expression
83 (tipe, _) <- specialize E.DeclDefType Type.expression
83− Space.checkFreshLine E.DeclDefNameRepeat
84+ Space.checkFreshLine E.DeclDefFreshLineAfterType
84 defName <- chompMatchingName name
85 defName <- chompMatchingName name
85 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
86 Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
86 chompDefArgsAndBody maybeDocs start defName (Just tipe) []
87 chompDefArgsAndBody maybeDocs start defName (Just tipe) []
@@ -89,7 +90,7 @@ valueDecl maybeDocs start =
89 ]
90 ]
90
91
91
92
92−chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
93+chompDefArgsAndBody :: Maybe DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
93chompDefArgsAndBody maybeDocs start name tipe revArgs =
94chompDefArgsAndBody maybeDocs start name tipe revArgs =
94 oneOf E.DeclDefEquals
95 oneOf E.DeclDefEquals
95 [ do arg <- specialize E.DeclDefArg Pattern.term
96 [ do arg <- specialize E.DeclDefArg Pattern.term
@@ -107,19 +108,19 @@ chompDefArgsAndBody maybeDocs start name tipe revArgs =
107chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
108chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
108chompMatchingName expectedName =
109chompMatchingName expectedName =
109 let
110 let
110− (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
111+ (P.Parser parserL) = Var.lower (E.DeclDefNameRepeat expectedName)
111 in
112 in
112− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
113+ P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
113 let
114 let
114− cokL name newState@(P.State _ _ _ _ er ec) =
115+ cokL name newState@(P.State _ _ _ er ec) =
115 if expectedName == name
116 if expectedName == name
116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
117 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
117− else cerr sr sc (E.DeclDefNameMatch name)
118+ else cerr sr sc (E.DeclDefNameMatch expectedName name)
118
119
119− eokL name newState@(P.State _ _ _ _ er ec) =
120+ eokL name newState@(P.State _ _ _ er ec) =
120 if expectedName == name
121 if expectedName == name
121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
122 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
122− else eerr sr sc (E.DeclDefNameMatch name)
123+ else eerr sr sc (E.DeclDefNameMatch expectedName name)
123 in
124 in
124 parserL state cokL eokL cerr eerr
125 parserL state cokL eokL cerr eerr
125
126
@@ -129,7 +130,7 @@ chompMatchingName expectedName =
129
130
130
131
131{-# INLINE typeDecl #-}
132{-# INLINE typeDecl #-}
132−typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
133+typeDecl :: Maybe DocComment -> A.Position -> Space.Parser E.Decl Decl
133typeDecl maybeDocs start =
134typeDecl maybeDocs start =
134 inContext E.DeclType (Keyword.type_ E.DeclStart) $
135 inContext E.DeclType (Keyword.type_ E.DeclStart) $
135 do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
136 do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
@@ -214,7 +215,7 @@ chompVariants variants end =
214
215
215
216
216{-# INLINE portDecl #-}
217{-# INLINE portDecl #-}
217−portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
218+portDecl :: Maybe DocComment -> Space.Parser E.Decl Decl
218portDecl maybeDocs =
219portDecl maybeDocs =
219 inContext E.Port (Keyword.port_ E.DeclStart) $
220 inContext E.Port (Keyword.port_ E.DeclStart) $
220 do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
221 do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
@@ -235,7 +236,7 @@ portDecl maybeDocs =
235
236
236-- INVARIANT: always chomps to a freshline
237-- INVARIANT: always chomps to a freshline
237--
238--
238−infix_ :: Parser E.Module (A.Located Src.Infix)
239+infix_ :: Parser E.Module (A.Located Src.Binop)
239infix_ =
240infix_ =
240 let
241 let
241 err = E.Infix
242 err = E.Infix
@@ -263,4 +264,4 @@ infix_ =
263 end <- getPosition
264 end <- getPosition
264 Space.chomp _err
265 Space.chomp _err
265 Space.checkFreshLine err
266 Space.checkFreshLine err
266− return (A.at start end (Src.Infix op associativity precedence name))
267+ return (A.at start end (Src.Binop op associativity precedence name))
compiler/src/Parse/Docs.hsnew file+275
@@ -0,0 +1,275 @@
1+module Parse.Docs
2+ ( Docs(..)
3+ , parser
4+ )
5+ where
6+
7+
8+
9+-- DOCS
10+
11+
12+data Docs =
13+ Docs
14+ { _exposed :: [A.Located Name.Name]
15+ , _overview :: Utf8.String
16+ , _listed :: [A.Located Name.Name]
17+ , _comments :: Map.Map Name.Name Utf8.String
18+ }
19+
20+
21+
22+-- PARSER
23+
24+
25+parser :: Parser Docs
26+parser =
27+ error "TODO implement docs parser"
28+
29+
30+chompUntilDocs :: Parser Bool
31+chompUntilDocs =
32+ P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33+ let
34+ (# isStart, newOffset, newRow, newCol #) =
35+ eatDocs fp offset terminal row col
36+
37+ !newState =
38+ P.State fp newOffset terminal indent newRow newCol ctx
39+ in
40+ cok isStart newState
41+
42+
43+eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44+eatDocs fp offset terminal row col =
45+ if offset >= terminal then
46+ (# False, offset, row, col #)
47+
48+ else if isDocsStart fp offset terminal then
49+ (# True, offset + 5, row, col + 5 #)
50+
51+ else
52+ let !word = P.unsafeIndex fp offset in
53+ if word == 0x0A {- \n -} then
54+ eatDocs fp (offset + 1) terminal (row + 1) 1
55+
56+ else
57+ let !newOffset = offset + P.getCharWidth fp offset terminal word in
58+ eatDocs fp newOffset terminal row (col + 1)
59+
60+
61+isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62+isDocsStart =
63+ let (B.PS dfp doff dlen) = docsStart in
64+ P.isSubstring dfp doff dlen
65+
66+
67+{-# NOINLINE docsStart #-}
68+docsStart :: B.ByteString
69+docsStart =
70+ "@docs"
71+
72+
73+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74+chompOverview names =
75+ do isDocs <- chompUntilDocs
76+ if isDocs
77+ then chompOverviewHelp names
78+ else return names
79+
80+
81+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82+chompOverviewHelp names =
83+ do pos <- getPosition
84+ (SPos spos) <- whitespace
85+ if pos == spos
86+ then chompOverview names
87+ else chompOverview =<< chompDocs names
88+
89+
90+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91+chompDocs names =
92+ do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93+ spos <- whitespace
94+ oneOf SE.XXX
95+ [ do checkSpace spos
96+ word1 0x2C {-,-} SE.XXX
97+ spaces
98+ chompDocs (name:names)
99+ , return (name:names)
100+ ]
101+
102+
103+chompBinop :: Parser Name.Name
104+chompBinop =
105+ do word1 0x28 {-(-} SE.XXX
106+ name <- Symbol.binop
107+ word1 0x29 {-)-} SE.XXX
108+ return name
109+
110+
111+
112+
113+-- CHECK NAMES
114+
115+
116+type Result i w a =
117+ Result.Result i w E.Error a
118+
119+
120+type Dups =
121+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122+
123+
124+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125+checkNames exports names =
126+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127+ let overlap = Map.size (Map.intersection docs exports)
128+ if Map.size exports == overlap && overlap == Map.size docs
129+ then Result.ok ()
130+ else
131+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133+ Result.ok ()
134+
135+
136+addName :: Dups -> A.Located Name.Name -> Dups
137+addName dict (A.At region name) =
138+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139+
140+
141+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142+isUnique name regions =
143+ case regions of
144+ OneOrMore.One region ->
145+ Result.ok region
146+
147+ OneOrMore.More _ _ ->
148+ let (r1:r2:_) = OneOrMore.toList regions in
149+ Result.throw (E.Duplicate name r1 r2)
150+
151+
152+onlyInDocs :: Name.Name -> A.Region -> Result i w a
153+onlyInDocs name region =
154+ Result.throw $ E.OnlyInDocs name region
155+
156+
157+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158+onlyInExports name (A.At region _) =
159+ Result.throw $ E.OnlyInExports name region
160+
161+
162+
163+-- CHECK EXPORTS
164+
165+
166+data Info =
167+ Info
168+ { _iComments :: Map.Map Name.Name Comment
169+ , _iValues :: Types
170+ , _iUnions :: Map.Map Name.Name Can.Union
171+ , _iAliases :: Map.Map Name.Name Can.Alias
172+ , _iBinops :: Map.Map Name.Name Can.Binop
173+ , _iEffects :: Can.Effects
174+ }
175+
176+
177+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178+checkExport info name (A.At region export) =
179+ case export of
180+ Can.ExportValue ->
181+ do tipe <- getType name info
182+ comment <- getComment region name info
183+ Result.ok $ \m ->
184+ m { _values = Map.insert name (Value comment tipe) (_values m) }
185+
186+ Can.ExportBinop ->
187+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188+ tipe <- getType realName info
189+ comment <- getComment region realName info
190+ Result.ok $ \m ->
191+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192+
193+ Can.ExportAlias ->
194+ do let (Can.Alias tvars tipe) = _iAliases info ! name
195+ comment <- getComment region name info
196+ Result.ok $ \m ->
197+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198+
199+ Can.ExportUnionOpen ->
200+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201+ comment <- getComment region name info
202+ Result.ok $ \m ->
203+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204+
205+ Can.ExportUnionClosed ->
206+ do let (Can.Union tvars _ _ _) = _iUnions info ! name
207+ comment <- getComment region name info
208+ Result.ok $ \m ->
209+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210+
211+ Can.ExportPort ->
212+ do tipe <- getType name info
213+ comment <- getComment region name info
214+ Result.ok $ \m ->
215+ m { _values = Map.insert name (Value comment tipe) (_values m) }
216+
217+
218+getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219+getComment region name info =
220+ case Map.lookup name (_iComments info) of
221+ Nothing ->
222+ Result.throw (E.NoComment name region)
223+
224+ Just comment ->
225+ Result.ok comment
226+
227+
228+getType :: Name.Name -> Info -> Result i w Type.Type
229+getType name info =
230+ case _iValues info ! name of
231+ A.At defRegion Nothing ->
232+ Result.throw (E.NoAnnotation name defRegion)
233+
234+ A.At _ (Just tipe) ->
235+ Result.ok (Extract.fromType tipe)
236+
237+
238+dector :: Can.Ctor -> (Name.Name, [Type.Type])
239+dector (Can.Ctor name _ _ args) =
240+ ( name, map Extract.fromType args )
241+
242+
243+
244+-- GATHER TYPES
245+
246+
247+type Types =
248+ Map.Map Name.Name (A.Located (Maybe Can.Type))
249+
250+
251+gatherTypes :: Can.Decls -> Types -> Types
252+gatherTypes decls types =
253+ case decls of
254+ Can.Declare def subDecls ->
255+ gatherTypes subDecls (addDef types def)
256+
257+ Can.DeclareRec defs subDecls ->
258+ gatherTypes subDecls (List.foldl' addDef types defs)
259+
260+ Can.SaveTheEnvironment ->
261+ types
262+
263+
264+addDef :: Types -> Can.Def -> Types
265+addDef types def =
266+ case def of
267+ Can.Def (A.At region name) _ _ ->
268+ Map.insert name (A.At region Nothing) types
269+
270+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271+ let
272+ tipe =
273+ foldr Can.TLambda resultType (map snd typedArgs)
274+ in
275+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+45−57
@@ -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.String as String
19+import qualified Parse.Utf8 as Utf8
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 <- String.string E.Start E.String
49+ do str <- Utf8.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 <- String.character E.Start E.Char
55+ do chr <- Utf8.character E.Start E.Char
56 addEnd start (Src.Chr chr)
56 addEnd start (Src.Chr chr)
57
57
58
58
@@ -128,53 +128,42 @@ chompListEnd start entries =
128tuple :: A.Position -> Parser E.Expr Src.Expr
128tuple :: A.Position -> Parser E.Expr Src.Expr
129tuple start@(A.Position row col) =
129tuple start@(A.Position row col) =
130 inContext E.Tuple (word1 0x28 {-(-} E.Start) $
130 inContext E.Tuple (word1 0x28 {-(-} E.Start) $
131− do before <- getPosition
131+ oneOf E.TupleOpen
132− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
133− after <- getPosition
134− if before /= after
135− then
136− do (entry, end) <- specialize E.TupleExpr expression
137− Space.checkIndent end E.TupleIndentEnd
138− chompTupleEnd start entry []
139− else
140− oneOf E.TupleIndentExpr1
141− [
132+ [
142− do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
133+ do op <- Symbol.operator E.TupleOpen E.TupleOperatorReserved
143− if op == "-"
134+ if op == "-"
144− then
135+ then
145− oneOf E.TupleOperatorClose
136+ oneOf E.TupleOperatorClose
146− [
137+ [
147− do word1 0x29 {-)-} E.TupleOperatorClose
138+ do word1 0x29 {-)-} E.TupleOperatorClose
148− addEnd start (Src.Op op)
139+ addEnd start (Src.Op op)
149− ,
140+ ,
150− do (entry, end) <-
151− specialize E.TupleExpr $
141+ specialize E.TupleExpr $
152− do negatedExpr@(A.At (A.Region _ end) _) <- term
142+ do negatedExpr@(A.At (A.Region _ end) _) <- term
153− Space.chomp E.Space
143+ Space.chomp E.Space
154− let exprStart = A.Position row (col + 2)
144+ let exprStart = A.Position row (col + 2)
155− let expr = A.at exprStart end (Src.Negate negatedExpr)
145+ let expr = A.at exprStart end (Src.Negate negatedExpr)
156− chompExprEnd exprStart (State [] expr [] end)
146+ fst <$> chompExprEnd exprStart (State [] expr [] end)
157− Space.checkIndent end E.TupleIndentEnd
158− chompTupleEnd start entry []
159− ]
147+ ]
160− else
148+ else
161− do word1 0x29 {-)-} E.TupleOperatorClose
149+ do word1 0x29 {-)-} E.TupleOperatorClose
162− addEnd start (Src.Op op)
150+ addEnd start (Src.Op op)
163− ,
151+ ,
164− do word1 0x29 {-)-} E.TupleIndentExpr1
152+ do word1 0x29 {-)-} E.TupleOpen
165− addEnd start Src.Unit
153+ addEnd start Src.Unit
166− ,
154+ ,
155+ do Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr
167− do (entry, end) <- specialize E.TupleExpr expression
156+ (entry, end) <- specialize E.TupleExpr expression
168− Space.checkIndent end E.TupleIndentEnd
157+ Space.checkIndent end E.TupleIndentEnd
169− chompTupleEnd start entry []
158+ chompTupleEnd start entry []
170− ]
159+ ]
171
160
172
161
173chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
162chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
174chompTupleEnd start firstExpr revExprs =
163chompTupleEnd start firstExpr revExprs =
175 oneOf E.TupleEnd
164 oneOf E.TupleEnd
176 [ do word1 0x2C {-,-} E.TupleEnd
165 [ do word1 0x2C {-,-} E.TupleEnd
177− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN
166+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr
178 (entry, end) <- specialize E.TupleExpr expression
167 (entry, end) <- specialize E.TupleExpr expression
179 Space.checkIndent end E.TupleIndentEnd
168 Space.checkIndent end E.TupleIndentEnd
180 chompTupleEnd start firstExpr (entry : revExprs)
169 chompTupleEnd start firstExpr (entry : revExprs)
@@ -224,7 +213,7 @@ chompFields :: [Field] -> Parser E.Record [Field]
224chompFields fields =
213chompFields fields =
225 oneOf E.RecordEnd
214 oneOf E.RecordEnd
226 [ do word1 0x2C {-,-} E.RecordEnd
215 [ do word1 0x2C {-,-} E.RecordEnd
227− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
216+ Space.chompAndCheckIndent E.RecordSpace E.RecordField
228 f <- chompField
217 f <- chompField
229 chompFields (f : fields)
218 chompFields (f : fields)
230 , do word1 0x7D {-}-} E.RecordEnd
219 , do word1 0x7D {-}-} E.RecordEnd
@@ -275,16 +264,16 @@ chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
275chompExprEnd start (State ops expr args end) =
264chompExprEnd start (State ops expr args end) =
276 oneOfWithFallback
265 oneOfWithFallback
277 [ -- argument
266 [ -- argument
278− do Space.checkIndent end E.Start
267+ do Space.checkIndent end E.IndentMoreExpr
279 arg <- term
268 arg <- term
280 newEnd <- getPosition
269 newEnd <- getPosition
281 Space.chomp E.Space
270 Space.chomp E.Space
282 chompExprEnd start (State ops expr (arg:args) newEnd)
271 chompExprEnd start (State ops expr (arg:args) newEnd)
283
272
284 , -- operator
273 , -- operator
285− do Space.checkIndent end E.Start
274+ do Space.checkIndent end E.IndentMoreExpr
286 op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
275 op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
287− Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
276+ Space.chompAndCheckIndent E.Space E.IndentOperatorRight
288 newStart <- getPosition
277 newStart <- getPosition
289 if "-" == opName && end /= opStart && opEnd == newStart
278 if "-" == opName && end /= opStart && opEnd == newStart
290 then
279 then
@@ -295,8 +284,7 @@ chompExprEnd start (State ops expr args end) =
295 let arg = A.at opStart newEnd (Src.Negate negatedExpr)
284 let arg = A.at opStart newEnd (Src.Negate negatedExpr)
296 chompExprEnd start (State ops expr (arg:args) newEnd)
285 chompExprEnd start (State ops expr (arg:args) newEnd)
297 else
286 else
298− let err = E.OperatorRight opName in
287+ oneOf E.OperatorRight
299− oneOf err
300 [ -- term
288 [ -- term
301 do newExpr <- possiblyNegativeTerm newStart
289 do newExpr <- possiblyNegativeTerm newStart
302 newEnd <- getPosition
290 newEnd <- getPosition
@@ -306,7 +294,7 @@ chompExprEnd start (State ops expr args end) =
306
294
307 , -- final term
295 , -- final term
308 do (newLast, newEnd) <-
296 do (newLast, newEnd) <-
309− oneOf err
297+ oneOf E.OperatorRight
310 [ let_ newStart
298 [ let_ newStart
311 , case_ newStart
299 , case_ newStart
312 , if_ newStart
300 , if_ newStart
@@ -543,19 +531,19 @@ chompDefArgsAndBody start name tipe revArgs =
543chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
531chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
544chompMatchingName expectedName =
532chompMatchingName expectedName =
545 let
533 let
546− (P.Parser parserL) = Var.lower E.DefNameRepeat
534+ (P.Parser parserL) = Var.lower (E.DefNameRepeat expectedName)
547 in
535 in
548− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
536+ P.Parser $ \state@(P.State _ _ _ sr sc) cok eok cerr eerr ->
549 let
537 let
550− cokL name newState@(P.State _ _ _ _ er ec) =
538+ cokL name newState@(P.State _ _ _ er ec) =
551 if expectedName == name
539 if expectedName == name
552 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
540 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
553− else cerr sr sc (E.DefNameMatch name)
541+ else cerr sr sc (E.DefNameMatch expectedName name)
554
542
555− eokL name newState@(P.State _ _ _ _ er ec) =
543+ eokL name newState@(P.State _ _ _ er ec) =
556 if expectedName == name
544 if expectedName == name
557 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
545 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
558− else eerr sr sc (E.DefNameMatch name)
546+ else eerr sr sc (E.DefNameMatch expectedName name)
559 in
547 in
560 parserL state cokL eokL cerr eerr
548 parserL state cokL eokL cerr eerr
561
549
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 src pos end indent row col) cok _ _ eerr ->
123+ P.Parser $ \(P.State 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 src pos12 end indent row (col + 12) in cok () s
140+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
151+ P.Parser $ \(P.State 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 src pos2 end indent row (col + 2) in cok () s
158+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
165+ P.Parser $ \(P.State 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 src pos3 end indent row (col + 3) in cok () s
173+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
180+ P.Parser $ \(P.State 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 src pos4 end indent row (col + 4) in cok () s
189+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
196+ P.Parser $ \(P.State 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 src pos5 end indent row (col + 5) in cok () s
206+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
213+ P.Parser $ \(P.State 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 src pos6 end indent row (col + 6) in cok () s
224+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
231+ P.Parser $ \(P.State 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 src pos7 end indent row (col + 7) in cok () s
243+ let !s = P.State 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 src pos end indent row col) cok _ _ eerr ->
250+ P.Parser $ \(P.State 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 src pos8 end indent row (col + 8) in cok () s
263+ let !s = P.State 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+189−240
@@ -2,10 +2,9 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Module
3module Parse.Module
4 ( fromByteString
4 ( fromByteString
5− , ProjectType(..)
5+ , Header(..)
6− , isKernel
6+ , Effects(..)
7 , chompImports
7 , chompImports
8− , chompImport
9 )
8 )
10 where
9 where
11
10
@@ -31,111 +30,102 @@ import qualified Reporting.Error.Syntax as E
31-- FROM BYTE STRING
30-- FROM BYTE STRING
32
31
33
32
34−fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module
33+fromByteString :: Pkg.Name -> BS.ByteString -> Either E.Error Src.Module
35−fromByteString projectType source =
34+fromByteString pkg source =
35+ let
36+ parser
37+ | pkg == Pkg.core = core
38+ | Pkg.isKernel pkg = platform
39+ | otherwise = normal
40+ in
36− case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of
41+ case P.fromByteString parser source of
42+ P.Ok outcome _ ->
43+ case outcome of
37− Right modul -> checkModule projectType modul
44+ Right modul -> Right modul
38− Left err -> Left (E.ParseError err)
45+ Left err -> Left err
39−
40−
41−
42−-- PROJECT TYPE
43−
44−
45−data ProjectType
46− = Package Pkg.Name
47− | Application
48−
49
46
50−isCore :: ProjectType -> Bool
47+ P.Err err ->
51−isCore projectType =
48+ Left (E.ParseError err)
52− case projectType of
53− Package pkg -> pkg == Pkg.core
54− Application -> False
55
49
56
50
57−isKernel :: ProjectType -> Bool
58−isKernel projectType =
59− case projectType of
60− Package pkg -> Pkg.isKernel pkg
61− Application -> False
62
51
52+-- MODULE
63
53
64
54
65−-- MODULE
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)
66
64
67
65
68−data Module =
66+core :: Parser E.Module (Either E.Error Src.Module)
69− Module
67+core =
70− { _header :: Maybe Header
68+ do freshLine E.FreshLineModuleStart
71− , _imports :: [Src.Import]
69+ header <- chompHeader
72− , _infixes :: [A.Located Src.Infix]
70+ comment <- chompModuleDocComment
73− , _decls :: [Decl.Decl]
71+ imports <- chompImports []
74− }
72+ binops <- chompBinops []
73+ decls <- specialize E.Declarations $ chompDecls []
74+ endOfFile
75+ return (checkModule header comment imports binops decls)
75
76
76
77
77−chompModule :: ProjectType -> Parser E.Module Module
78+platform :: Parser E.Module (Either E.Error Src.Module)
78−chompModule projectType =
79+platform =
80+ do freshLine E.FreshLineModuleStart
79− do header <- chompHeader
81+ header <- chompHeader
82+ comment <- chompModuleDocComment
80− imports <- chompImports (if isCore projectType then [] else Imports.defaults)
83+ imports <- chompImports []
81− infixes <- if isKernel projectType then chompInfixes [] else return []
84+ binops <- chompBinops []
82 decls <- specialize E.Declarations $ chompDecls []
85 decls <- specialize E.Declarations $ chompDecls []
86+ endOfFile
83− return (Module header imports infixes decls)
87+ return (checkModule header comment (Imports.addDefaults imports) binops decls)
84
88
85
89
86
90
87-- CHECK MODULE
91-- CHECK MODULE
88
92
89
93
90−checkModule :: ProjectType -> Module -> Either E.Error Src.Module
94+checkModule :: Maybe Header -> Maybe Space.DocComment -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module
91−checkModule projectType (Module maybeHeader imports infixes decls) =
95+checkModule maybeHeader _maybeDocs imports binops decls =
92 let
96 let
93 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
97 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls
94 in
98 in
95 case maybeHeader of
99 case maybeHeader of
96− Just (Header name effects exports docs) ->
100+ Just (Header name effects exports) ->
97− Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes
101+ Src.Module (Just name) exports imports values unions aliases binops
98− <$> checkEffects projectType ports effects
102+ <$> checkEffects ports effects
99
103
100 Nothing ->
104 Nothing ->
101 Right $
105 Right $
102− Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $
106+ Src.Module Nothing (A.At A.one Src.Open) imports values unions aliases binops $
103 case ports of
107 case ports of
104 [] -> Src.NoEffects
108 [] -> Src.NoEffects
105 _:_ -> Src.Ports ports
109 _:_ -> Src.Ports ports
106
110
107
111
108−checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects
112+checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects
109−checkEffects projectType ports effects =
113+checkEffects ports effects =
110 case effects of
114 case effects of
111 NoEffects region ->
115 NoEffects region ->
112 case ports of
116 case ports of
113− [] ->
114− Right Src.NoEffects
117+ [] -> Right Src.NoEffects
115−
116− Src.Port name _ : _ ->
117− case projectType of
118− Package _ -> Left (E.NoPortsInPackage name)
119− Application -> Left (E.UnexpectedPort region)
118+ _:_ -> Left (E.UnexpectedPort region)
120
119
121 Ports region ->
120 Ports region ->
122− case projectType of
123− Package _ ->
124− Left (E.NoPortModulesInPackage region)
125−
126− Application ->
127− case ports of
121+ case ports of
128− [] -> Left (E.NoPorts region)
122+ [] -> Left (E.NoPorts region)
129− _:_ -> Right (Src.Ports ports)
123+ _:_ -> Right (Src.Ports ports)
130
124
131 Manager region manager ->
125 Manager region manager ->
132− if isKernel projectType then
133− case ports of
126+ case ports of
134− [] -> Right (Src.Manager region manager)
127+ [] -> Right (Src.Manager region manager)
135− _:_ -> Left (E.UnexpectedPort region)
128+ _:_ -> Left (E.UnexpectedPort region)
136− else
137− Left (E.NoEffectsOutsideKernel region)
138−
139
129
140
130
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] )
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] )
@@ -153,41 +143,6 @@ categorizeDecls values unions aliases ports decls =
153
143
154
144
155
145
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−
191-- FRESH LINES
146-- FRESH LINES
192
147
193
148
@@ -197,6 +152,15 @@ freshLine toFreshLineError =
197 Space.checkFreshLine toFreshLineError
152 Space.checkFreshLine toFreshLineError
198
153
199
154
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+
200
164
201-- CHOMP DECLARATIONS
165-- CHOMP DECLARATIONS
202
166
@@ -205,36 +169,35 @@ chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]
205chompDecls decls =
169chompDecls decls =
206 do (decl, _) <- Decl.declaration
170 do (decl, _) <- Decl.declaration
207 oneOfWithFallback
171 oneOfWithFallback
208− [ do Space.checkFreshLine E.DeclStart
172+ [ do Space.checkFreshLine E.DeclFreshLineStart
209 chompDecls (decl:decls)
173 chompDecls (decl:decls)
210 ]
174 ]
211 (reverse (decl:decls))
175 (reverse (decl:decls))
212
176
213
177
214−chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]
178+chompBinops :: [A.Located Src.Binop] -> Parser E.Module [A.Located Src.Binop]
215−chompInfixes infixes =
179+chompBinops binops =
216 oneOfWithFallback
180 oneOfWithFallback
217 [ do binop <- Decl.infix_
181 [ do binop <- Decl.infix_
218− chompInfixes (binop:infixes)
182+ chompBinops (binop:binops)
219 ]
183 ]
220− infixes
184+ binops
221
185
222
186
223
187
224-- MODULE DOC COMMENT
188-- MODULE DOC COMMENT
225
189
226
190
227−chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment)
191+chompModuleDocComment :: Parser E.Module (Maybe Space.DocComment)
228−chompModuleDocCommentSpace =
192+chompModuleDocComment =
229− do (A.At region ()) <- addLocation (freshLine E.FreshLine)
230− oneOfWithFallback
193+ oneOfWithFallback
231− [
194+ [
232− do docComment <- Space.docComment E.ImportStart E.ModuleSpace
195+ do docComment <- Space.docComment E.ImportStart E.ModuleSpace
233− Space.chomp E.ModuleSpace
196+ Space.chomp E.ModuleSpace
234− Space.checkFreshLine E.FreshLine
197+ Space.checkFreshLine E.FreshLineAfterDocComment
235− return (Right docComment)
198+ return (Just docComment)
236− ]
199+ ]
237− (Left region)
200+ Nothing
238
201
239
202
240
203
@@ -242,7 +205,7 @@ chompModuleDocCommentSpace =
242
205
243
206
244data Header =
207data Header =
245− Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment)
208+ Header Name.Name Effects (A.Located Src.Exposing)
246
209
247
210
248data Effects
211data Effects
@@ -253,56 +216,52 @@ data Effects
253
216
254chompHeader :: Parser E.Module (Maybe Header)
217chompHeader :: Parser E.Module (Maybe Header)
255chompHeader =
218chompHeader =
256− do freshLine E.FreshLine
257− start <- getPosition
219+ do start <- getPosition
258 oneOfWithFallback
220 oneOfWithFallback
259 [
221 [
260 -- module MyThing exposing (..)
222 -- module MyThing exposing (..)
261− do Keyword.module_ E.ModuleProblem
223+ do Keyword.module_ E.Module
262− effectEnd <- getPosition
224+ end <- getPosition
263− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
225+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentName
264− name <- addLocation (Var.moduleName E.ModuleName)
226+ name <- Var.moduleName E.ModuleName
265− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
227+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
266− Keyword.exposing_ E.ModuleProblem
228+ Keyword.exposing_ E.ModuleExposing
267− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem
229+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
268− exports <- addLocation (specialize E.ModuleExposing exposing)
230+ exports <- addLocation (specialize E.ModuleExposingList exposing)
269− comment <- chompModuleDocCommentSpace
231+ freshLine E.FreshLineAfterModuleLine
270− return $ Just $
271− Header name (NoEffects (A.Region start effectEnd)) exports comment
232+ return (Just (Header name (NoEffects (A.Region start end)) exports))
272 ,
233 ,
273 -- port module MyThing exposing (..)
234 -- port module MyThing exposing (..)
274− do Keyword.port_ E.PortModuleProblem
235+ do Keyword.port_ E.Module
275− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
236+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentPortModule
276− Keyword.module_ E.PortModuleProblem
237+ Keyword.module_ E.ModulePortModule
277− effectEnd <- getPosition
238+ end <- getPosition
278− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
239+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentName
279− name <- addLocation (Var.moduleName E.PortModuleName)
240+ name <- Var.moduleName E.ModuleName
280− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
241+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
281− Keyword.exposing_ E.PortModuleProblem
242+ Keyword.exposing_ E.ModuleExposing
282− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem
243+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
283− exports <- addLocation (specialize E.PortModuleExposing exposing)
244+ exports <- addLocation (specialize E.ModuleExposingList exposing)
284− comment <- chompModuleDocCommentSpace
245+ freshLine E.FreshLineAfterModuleLine
285− return $ Just $
286− Header name (Ports (A.Region start effectEnd)) exports comment
246+ return (Just (Header name (Ports (A.Region start end)) exports))
287 ,
247 ,
288 -- effect module MyThing where { command = MyCmd } exposing (..)
248 -- effect module MyThing where { command = MyCmd } exposing (..)
289− do Keyword.effect_ E.Effect
249+ do Keyword.effect_ E.Module
290− Space.chompAndCheckIndent E.ModuleSpace E.Effect
250+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
291− Keyword.module_ E.Effect
251+ Keyword.module_ E.ModuleEffect
292− effectEnd <- getPosition
252+ end <- getPosition
293− Space.chompAndCheckIndent E.ModuleSpace E.Effect
253+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
294− name <- addLocation (Var.moduleName E.ModuleName)
254+ name <- Var.moduleName E.ModuleName
295− Space.chompAndCheckIndent E.ModuleSpace E.Effect
255+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
296− Keyword.where_ E.Effect
256+ Keyword.where_ E.ModuleEffect
297− Space.chompAndCheckIndent E.ModuleSpace E.Effect
257+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
298 manager <- chompManager
258 manager <- chompManager
299− Space.chompAndCheckIndent E.ModuleSpace E.Effect
259+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposing
300− Keyword.exposing_ E.Effect
260+ Keyword.exposing_ E.ModuleExposing
301− Space.chompAndCheckIndent E.ModuleSpace E.Effect
261+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleIndentExposingList
302− exports <- addLocation (specialize (const E.Effect) exposing)
262+ exports <- addLocation (specialize E.ModuleExposingList exposing)
303− comment <- chompModuleDocCommentSpace
263+ freshLine E.FreshLineAfterModuleLine
304− return $ Just $
305− Header name (Manager (A.Region start effectEnd) manager) exports comment
264+ return (Just (Header name (Manager (A.Region start end) manager) exports))
306 ]
265 ]
307 -- default header
266 -- default header
308 Nothing
267 Nothing
@@ -310,34 +269,34 @@ chompHeader =
310
269
311chompManager :: Parser E.Module Src.Manager
270chompManager :: Parser E.Module Src.Manager
312chompManager =
271chompManager =
313− do word1 0x7B {- { -} E.Effect
272+ do word1 0x7B {- { -} E.ModuleEffect
314 spaces_em
273 spaces_em
315− oneOf E.Effect
274+ oneOf E.ModuleEffect
316 [ do cmd <- chompCommand
275 [ do cmd <- chompCommand
317 spaces_em
276 spaces_em
318− oneOf E.Effect
277+ oneOf E.ModuleEffect
319− [ do word1 0x7D {-}-} E.Effect
278+ [ do word1 0x7D {-}-} E.ModuleEffect
320 spaces_em
279 spaces_em
321 return (Src.Cmd cmd)
280 return (Src.Cmd cmd)
322− , do word1 0x2C {-,-} E.Effect
281+ , do word1 0x2C {-,-} E.ModuleEffect
323 spaces_em
282 spaces_em
324 sub <- chompSubscription
283 sub <- chompSubscription
325 spaces_em
284 spaces_em
326− word1 0x7D {-}-} E.Effect
285+ word1 0x7D {-}-} E.ModuleEffect
327 spaces_em
286 spaces_em
328 return (Src.Fx cmd sub)
287 return (Src.Fx cmd sub)
329 ]
288 ]
330 , do sub <- chompSubscription
289 , do sub <- chompSubscription
331 spaces_em
290 spaces_em
332− oneOf E.Effect
291+ oneOf E.ModuleEffect
333− [ do word1 0x7D {-}-} E.Effect
292+ [ do word1 0x7D {-}-} E.ModuleEffect
334 spaces_em
293 spaces_em
335 return (Src.Sub sub)
294 return (Src.Sub sub)
336− , do word1 0x2C {-,-} E.Effect
295+ , do word1 0x2C {-,-} E.ModuleEffect
337 spaces_em
296 spaces_em
338 cmd <- chompCommand
297 cmd <- chompCommand
339 spaces_em
298 spaces_em
340− word1 0x7D {-}-} E.Effect
299+ word1 0x7D {-}-} E.ModuleEffect
341 spaces_em
300 spaces_em
342 return (Src.Fx cmd sub)
301 return (Src.Fx cmd sub)
343 ]
302 ]
@@ -346,25 +305,25 @@ chompManager =
346
305
347chompCommand :: Parser E.Module (A.Located Name.Name)
306chompCommand :: Parser E.Module (A.Located Name.Name)
348chompCommand =
307chompCommand =
349− do Keyword.command_ E.Effect
308+ do Keyword.command_ E.ModuleEffect
350 spaces_em
309 spaces_em
351− word1 0x3D {-=-} E.Effect
310+ word1 0x3D {-=-} E.ModuleEffect
352 spaces_em
311 spaces_em
353− addLocation (Var.upper E.Effect)
312+ addLocation (Var.upper E.ModuleEffect)
354
313
355
314
356chompSubscription :: Parser E.Module (A.Located Name.Name)
315chompSubscription :: Parser E.Module (A.Located Name.Name)
357chompSubscription =
316chompSubscription =
358− do Keyword.subscription_ E.Effect
317+ do Keyword.subscription_ E.ModuleEffect
359 spaces_em
318 spaces_em
360− word1 0x3D {-=-} E.Effect
319+ word1 0x3D {-=-} E.ModuleEffect
361 spaces_em
320 spaces_em
362− addLocation (Var.upper E.Effect)
321+ addLocation (Var.upper E.ModuleEffect)
363
322
364
323
365spaces_em :: Parser E.Module ()
324spaces_em :: Parser E.Module ()
366spaces_em =
325spaces_em =
367− Space.chompAndCheckIndent E.ModuleSpace E.Effect
326+ Space.chompAndCheckIndent E.ModuleSpace E.ModuleEffect
368
327
369
328
370
329
@@ -372,33 +331,28 @@ spaces_em =
372
331
373
332
374chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
333chompImports :: [Src.Import] -> Parser E.Module [Src.Import]
375−chompImports is =
334+chompImports imports =
376 oneOfWithFallback
335 oneOfWithFallback
377− [ do i <- chompImport
336+ [ do Keyword.import_ E.ImportStart
337+ Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
338+ name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
339+ Space.chomp E.ModuleSpace
340+ oneOf E.ImportEnd
341+ [ do Space.checkFreshLine E.ImportEnd
378− chompImports (i:is)
342+ chompImports $
343+ Src.Import name Nothing (Src.Explicit []) : imports
344+ , do Space.checkIndent end E.ImportIndentAs
345+ oneOf E.ImportAs
346+ [ chompAs name imports
347+ , chompExposing name Nothing imports
348+ ]
349+ ]
379 ]
350 ]
380− (reverse is)
351+ (reverse imports)
381
352
382
353
383−chompImport :: Parser E.Module Src.Import
384−chompImport =
385− do Keyword.import_ E.ImportStart
386− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName
387− name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)
388− Space.chomp E.ModuleSpace
389− oneOf E.ImportEnd
390− [ do Space.checkFreshLine E.ImportEnd
391− return $ Src.Import name Nothing (Src.Explicit [])
392− , do Space.checkIndent end E.ImportEnd
393− oneOf E.ImportAs
394− [ chompAs name
395− , chompExposing name Nothing
396− ]
397− ]
398−
399−
400−chompAs :: A.Located Name.Name -> Parser E.Module Src.Import
354+chompAs :: A.Located Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
401−chompAs name =
355+chompAs name imports =
402 do Keyword.as_ E.ImportAs
356 do Keyword.as_ E.ImportAs
403 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
357 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias
404 alias <- Var.upper E.ImportAlias
358 alias <- Var.upper E.ImportAlias
@@ -406,19 +360,21 @@ chompAs name =
406 Space.chomp E.ModuleSpace
360 Space.chomp E.ModuleSpace
407 oneOf E.ImportEnd
361 oneOf E.ImportEnd
408 [ do Space.checkFreshLine E.ImportEnd
362 [ do Space.checkFreshLine E.ImportEnd
363+ chompImports $
409− return $ Src.Import name (Just alias) (Src.Explicit [])
364+ Src.Import name (Just alias) (Src.Explicit []) : imports
410− , do Space.checkIndent end E.ImportEnd
365+ , do Space.checkIndent end E.ImportIndentExposing
411− chompExposing name (Just alias)
366+ chompExposing name (Just alias) imports
412 ]
367 ]
413
368
414
369
415−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import
370+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser E.Module [Src.Import]
416−chompExposing name maybeAlias =
371+chompExposing name maybeAlias imports =
417 do Keyword.exposing_ E.ImportExposing
372 do Keyword.exposing_ E.ImportExposing
418 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
373 Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList
419 exposed <- specialize E.ImportExposingList exposing
374 exposed <- specialize E.ImportExposingList exposing
420 freshLine E.ImportEnd
375 freshLine E.ImportEnd
376+ chompImports $
421− return $ Src.Import name maybeAlias exposed
377+ Src.Import name maybeAlias exposed : imports
422
378
423
379
424
380
@@ -429,24 +385,24 @@ exposing :: Parser E.Exposing Src.Exposing
429exposing =
385exposing =
430 do word1 0x28 {-(-} E.ExposingStart
386 do word1 0x28 {-(-} E.ExposingStart
431 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
387 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
432− oneOf E.ExposingValue
388+ oneOf E.ExposingIndentValue
433− [ do word2 0x2E 0x2E {-..-} E.ExposingValue
389+ [ do word2 0x2E 0x2E {-..-} E.ExposingIndentValue
434 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
390 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
435 word1 0x29 {-)-} E.ExposingEnd
391 word1 0x29 {-)-} E.ExposingEnd
436 return Src.Open
392 return Src.Open
437− , do exposed <- chompExposed
393+ , do exposed <- addLocation chompExposed
438 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
394 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
439 exposingHelp [exposed]
395 exposingHelp [exposed]
440 ]
396 ]
441
397
442
398
443−exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing
399+exposingHelp :: [A.Located Src.Exposed] -> Parser E.Exposing Src.Exposing
444exposingHelp revExposed =
400exposingHelp revExposed =
445 oneOf E.ExposingEnd
401 oneOf E.ExposingEnd
446 [ do word1 0x2C {-,-} E.ExposingEnd
402 [ do word1 0x2C {-,-} E.ExposingEnd
447 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
403 Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue
448− exposed <- chompExposed
404+ exposed <- addLocation chompExposed
449− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
405+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValueEnd
450 exposingHelp (exposed:revExposed)
406 exposingHelp (exposed:revExposed)
451 , do word1 0x29 {-)-} E.ExposingEnd
407 , do word1 0x29 {-)-} E.ExposingEnd
452 return (Src.Explicit (reverse revExposed))
408 return (Src.Explicit (reverse revExposed))
@@ -455,33 +411,26 @@ exposingHelp revExposed =
455
411
456chompExposed :: Parser E.Exposing Src.Exposed
412chompExposed :: Parser E.Exposing Src.Exposed
457chompExposed =
413chompExposed =
458− do start <- getPosition
459− oneOf E.ExposingValue
414+ oneOf E.ExposingValue
460− [ do name <- Var.lower E.ExposingValue
415+ [ Src.Lower <$> Var.lower E.ExposingValue
461− end <- getPosition
462− return $ Src.Lower $ A.at start end name
463− , do word1 0x28 {-(-} E.ExposingValue
416+ , do word1 0x28 {-(-} E.ExposingValue
464− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
417+ op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved
465− word1 0x29 {-)-} E.ExposingOperatorRightParen
418+ word1 0x29 {-)-} E.ExposingOperatorRightParen
466− end <- getPosition
467− return $ Src.Operator (A.Region start end) op
419+ return (Src.Operator op)
468− , do name <- Var.upper E.ExposingValue
420+ , do name <- Var.upper E.ExposingValue
469− end <- getPosition
470− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd
421+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacy
471− Src.Upper (A.at start end name) <$> privacy
422+ Src.Upper name <$> privacy
472− ]
423+ ]
473
424
474
425
475privacy :: Parser E.Exposing Src.Privacy
426privacy :: Parser E.Exposing Src.Privacy
476privacy =
427privacy =
477 oneOfWithFallback
428 oneOfWithFallback
478 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
429 [ do word1 0x28 {-(-} E.ExposingTypePrivacy
479− Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
430+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyDots
480− start <- getPosition
481− word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy
431+ word2 0x2E 0x2E {-..-} E.ExposingTypePrivacyDots
482− end <- getPosition
483− Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy
432+ Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentTypePrivacyEnd
484− word1 0x29 {-)-} E.ExposingTypePrivacy
433+ word1 0x29 {-)-} E.ExposingTypePrivacyEnd
485− return $ Src.Public (A.Region start end)
434+ return Src.Public
486 ]
435 ]
487 Src.Private
436 Src.Private
compiler/src/Parse/Number.hs+13−16
@@ -11,11 +11,11 @@ module Parse.Number
11 where
11 where
12
12
13
13
14+import qualified Data.Utf8 as Utf8
14import Data.Word (Word8)
15import Data.Word (Word8)
15import Foreign.Ptr (Ptr, plusPtr, minusPtr)
16import Foreign.Ptr (Ptr, plusPtr, minusPtr)
16
17
17import qualified AST.Utils.Binop as Binop
18import 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 EF.Float
46+ | Float (Utf8.Under256 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 src pos end indent row col) cok _ cerr eerr ->
51+ P.Parser $ \(P.State 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 src newPos end indent row newCol
79+ !newState = P.State 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 = EF.fromPtr pos newPos
86+ !copy = Utf8.fromPtr pos newPos
87 !float = Float copy
87 !float = Float copy
88− !newState = P.State src newPos end indent row newCol
88+ !newState = P.State 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 pos end n
124+ chompFraction (plusPtr pos 1) 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,14 +139,11 @@ 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
145− if pos1 >= end then
142+ if pos >= end then
146 Err pos (E.NumberDot n)
143 Err pos (E.NumberDot n)
147
144
148− else if isDecimalDigit (P.unsafeIndex pos1) then
145+ else if isDecimalDigit (P.unsafeIndex pos) then
149− chompFractionHelp (plusPtr pos1 1) end
146+ chompFractionHelp (plusPtr pos 1) end
150
147
151 else
148 else
152 Err pos (E.NumberDot n)
149 Err pos (E.NumberDot n)
@@ -225,7 +222,7 @@ chompZero pos end =
225 chompHexInt (plusPtr pos 1) end
222 chompHexInt (plusPtr pos 1) end
226
223
227 else if word == 0x2E {-.-} then
224 else if word == 0x2E {-.-} then
228− chompFraction pos end 0
225+ chompFraction (plusPtr pos 1) end 0
229
226
230 else if isDecimalDigit word then
227 else if isDecimalDigit word then
231 Err pos E.NumberNoLeadingZero
228 Err pos E.NumberNoLeadingZero
@@ -290,7 +287,7 @@ stepHex pos end word acc
290
287
291precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
288precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence
292precedence toExpectation =
289precedence toExpectation =
293− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
290+ P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
294 if pos >= end then
291 if pos >= end then
295 eerr row col toExpectation
292 eerr row col toExpectation
296
293
@@ -299,7 +296,7 @@ precedence toExpectation =
299 if isDecimalDigit word then
296 if isDecimalDigit word then
300 cok
297 cok
301 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
298 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))
302− (P.State src (plusPtr pos 1) end indent row (col + 1))
299+ (P.State (plusPtr pos 1) end indent row (col + 1))
303
300
304 else
301 else
305 eerr row col toExpectation
302 eerr row col toExpectation
compiler/src/Parse/Pattern.hs+21−46
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
2+{-# LANGUAGE 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)
14
13
15import qualified AST.Source as Src
14import qualified AST.Source as Src
16import qualified Parse.Keyword as Keyword
15import qualified Parse.Keyword as Keyword
17import qualified Parse.Number as Number
16import qualified Parse.Number as Number
18import qualified Parse.Space as Space
17import qualified Parse.Space as Space
19−import qualified Parse.String as String
18+import qualified Parse.Symbol as Symbol
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 wildcard
46+ do Symbol.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,43 +67,18 @@ 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
72− width = fromIntegral (Utf8.size float)
71+ cerr row col (E.PFloat (Utf8.size float))
73− in
74− cerr row (col - width) (E.PFloat width)
75 ,
72 ,
76− do str <- String.string E.PStart E.PString
73+ do str <- Utf8.string E.PStart E.PString
77 addEnd start (Src.PStr str)
74 addEnd start (Src.PStr str)
78 ,
75 ,
79− do chr <- String.character E.PStart E.PChar
76+ do chr <- Utf8.character E.PStart E.PChar
80 addEnd start (Src.PChr chr)
77 addEnd start (Src.PChr chr)
81 ]
78 ]
82
79
83
80
84
81
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−
107-- RECORDS
82-- RECORDS
108
83
109
84
@@ -129,7 +104,7 @@ recordHelp start vars =
129 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
104 Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
130 recordHelp start (var:vars)
105 recordHelp start (var:vars)
131 , do word1 0x7D {-}-} E.PRecordEnd
106 , do word1 0x7D {-}-} E.PRecordEnd
132− addEnd start (Src.PRecord (reverse vars))
107+ addEnd start (Src.PRecord vars)
133 ]
108 ]
134
109
135
110
@@ -140,7 +115,7 @@ recordHelp start vars =
140tuple :: A.Position -> Parser E.Pattern Src.Pattern
115tuple :: A.Position -> Parser E.Pattern Src.Pattern
141tuple start =
116tuple start =
142 inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
117 inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
143− do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1
118+ do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentOpen
144 oneOf E.PTupleOpen
119 oneOf E.PTupleOpen
145 [ do (pattern, end) <- P.specialize E.PTupleExpr expression
120 [ do (pattern, end) <- P.specialize E.PTupleExpr expression
146 Space.checkIndent end E.PTupleIndentEnd
121 Space.checkIndent end E.PTupleIndentEnd
@@ -154,7 +129,7 @@ tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.P
154tupleHelp start firstPattern revPatterns =
129tupleHelp start firstPattern revPatterns =
155 oneOf E.PTupleEnd
130 oneOf E.PTupleEnd
156 [ do word1 0x2C {-,-} E.PTupleEnd
131 [ do word1 0x2C {-,-} E.PTupleEnd
157− Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN
132+ Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr
158 (pattern, end) <- P.specialize E.PTupleExpr expression
133 (pattern, end) <- P.specialize E.PTupleExpr expression
159 Space.checkIndent end E.PTupleIndentEnd
134 Space.checkIndent end E.PTupleIndentEnd
160 tupleHelp start firstPattern (pattern : revPatterns)
135 tupleHelp start firstPattern (pattern : revPatterns)
@@ -205,18 +180,18 @@ listHelp start patterns =
205expression :: Space.Parser E.Pattern Src.Pattern
180expression :: Space.Parser E.Pattern Src.Pattern
206expression =
181expression =
207 do start <- getPosition
182 do start <- getPosition
208− ePart <- exprPart
183+ cTerm <- exprTerm
209− exprHelp start [] ePart
184+ exprHelp start [] cTerm
210
185
211
186
212exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
187exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
213−exprHelp start revPatterns (pattern, end) =
188+exprHelp start patterns (pattern, end) =
214 oneOfWithFallback
189 oneOfWithFallback
215 [ do Space.checkIndent end E.PIndentStart
190 [ do Space.checkIndent end E.PIndentStart
216 word2 0x3A 0x3A {-::-} E.PStart
191 word2 0x3A 0x3A {-::-} E.PStart
217 Space.chompAndCheckIndent E.PSpace E.PIndentStart
192 Space.chompAndCheckIndent E.PSpace E.PIndentStart
218− ePart <- exprPart
193+ cTerm <- exprTerm
219− exprHelp start (pattern:revPatterns) ePart
194+ exprHelp start (pattern:patterns) cTerm
220 , do Space.checkIndent end E.PIndentStart
195 , do Space.checkIndent end E.PIndentStart
221 Keyword.as_ E.PStart
196 Keyword.as_ E.PStart
222 Space.chompAndCheckIndent E.PSpace E.PIndentAlias
197 Space.chompAndCheckIndent E.PSpace E.PIndentAlias
@@ -226,11 +201,11 @@ exprHelp start revPatterns (pattern, end) =
226 Space.chomp E.PSpace
201 Space.chomp E.PSpace
227 let alias = A.at nameStart newEnd name
202 let alias = A.at nameStart newEnd name
228 return
203 return
229− ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)
204+ ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)
230 , newEnd
205 , newEnd
231 )
206 )
232 ]
207 ]
233− ( List.foldl' cons pattern revPatterns
208+ ( List.foldl' cons pattern patterns
234 , end
209 , end
235 )
210 )
236
211
@@ -241,11 +216,11 @@ cons tl hd =
241
216
242
217
243
218
244−-- EXPRESSION PART
219+-- EXPRESSION TERM
245
220
246
221
247−exprPart :: Space.Parser E.Pattern Src.Pattern
222+exprTerm :: Space.Parser E.Pattern Src.Pattern
248−exprPart =
223+exprTerm =
249 oneOf E.PStart
224 oneOf E.PStart
250 [
225 [
251 do start <- getPosition
226 do start <- getPosition
compiler/src/Parse/Primitives.hs+47−95
@@ -1,7 +1,8 @@
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 #-}
2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}
3module Parse.Primitives
3module Parse.Primitives
4+ ( Result(..)
4− ( fromByteString
5+ , fromByteString
5 , Parser(..)
6 , Parser(..)
6 , State(..)
7 , State(..)
7 , Row
8 , Row
@@ -12,20 +13,18 @@ module Parse.Primitives
12 , getIndent, setIndent, withIndent, withBacksetIndent
13 , getIndent, setIndent, withIndent, withBacksetIndent
13 , word1, word2
14 , word1, word2
14 , unsafeIndex, isWord, getCharWidth
15 , unsafeIndex, isWord, getCharWidth
15− , Snippet(..)
16− , fromSnippet
17 )
16 )
18 where
17 where
19
18
20
19
21import Prelude hiding (length)
20import Prelude hiding (length)
22import qualified Control.Applicative as Applicative (Applicative(..))
21import 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 Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
27+import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)
28−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
29
28
30import qualified Reporting.Annotation as A
29import qualified Reporting.Annotation as A
31
30
@@ -46,10 +45,9 @@ newtype Parser x a =
46 )
45 )
47
46
48
47
49−data State = -- PERF try taking some out to avoid allocation
48+data State = -- TODO try adding UNPACK to everything
50 State
49 State
51− { _src :: ForeignPtr Word8
52− , _pos :: !(Ptr Word8)
50+ { _pos :: !(Ptr Word8)
53 , _end :: !(Ptr Word8)
51 , _end :: !(Ptr Word8)
54 , _indent :: !Word16
52 , _indent :: !Word16
55 , _row :: !Row
53 , _row :: !Row
@@ -85,23 +83,7 @@ instance Applicative.Applicative (Parser x) where
85 pure = return
83 pure = return
86
84
87 {-# INLINE (<*>) #-}
85 {-# INLINE (<*>) #-}
88− (<*>) (Parser parserFunc) (Parser parserArg) =
86+ (<*>) = ap
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
105
87
106
88
107
89
@@ -135,7 +117,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
135
117
136 [] ->
118 [] ->
137 let
119 let
138− (State _ _ _ _ row col) = state
120+ (State _ _ _ row col) = state
139 in
121 in
140 eerr row col toError
122 eerr row col toError
141
123
@@ -145,7 +127,7 @@ oneOfHelp state cok eok cerr eerr toError parsers =
145
127
146
128
147{-# INLINE oneOfWithFallback #-}
129{-# INLINE oneOfWithFallback #-}
148−oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.
130+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values.
149oneOfWithFallback parsers fallback =
131oneOfWithFallback parsers fallback =
150 Parser $ \state cok eok cerr _ ->
132 Parser $ \state cok eok cerr _ ->
151 oowfHelp state cok eok cerr parsers fallback
133 oowfHelp state cok eok cerr parsers fallback
@@ -201,56 +183,26 @@ instance Monad (Parser x) where
201-- FROM BYTESTRING
183-- FROM BYTESTRING
202
184
203
185
186+data Result x a
187+ = Ok !a State
188+ | Err x
189+
190+
204−fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a
191+fromByteString :: Parser x a -> B.ByteString -> Result x a
205−fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) =
192+fromByteString (Parser parser) (B.PS fp offset length) =
206 B.accursedUnutterablePerformIO $
193 B.accursedUnutterablePerformIO $
207 let
194 let
208− toOk' = toOk toBadEnd
209− !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset
195+ !pos = plusPtr (unsafeForeignPtrToPtr fp) offset
210 !end = plusPtr pos length
196 !end = plusPtr pos length
211− !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr
197+ !result = parser (State pos end 0 1 1) Ok Ok toErr toErr
212 in
198 in
213− do touchForeignPtr fptr
199+ do touchForeignPtr fp
214 return result
200 return result
215
201
216
202
217−toOk :: (Row -> Col -> x) -> a -> State -> Either x a
218−toOk toBadEnd !a (State _ pos end _ row col) =
219− if pos == end
220− then Right a
221− else Left (toBadEnd row col)
222−
223−
224−toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a
203+toErr :: Row -> Col -> (Row -> Col -> x) -> Result x a
225toErr row col toError =
204toErr row col toError =
226− Left (toError row col)
205+ Err (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
254
206
255
207
256
208
@@ -259,30 +211,30 @@ fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =
259
211
260getCol :: Parser x Word16
212getCol :: Parser x Word16
261getCol =
213getCol =
262− Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ ->
214+ Parser $ \state@(State _ _ _ _ col) _ eok _ _ ->
263 eok col state
215 eok col state
264
216
265
217
266{-# INLINE getPosition #-}
218{-# INLINE getPosition #-}
267getPosition :: Parser x A.Position
219getPosition :: Parser x A.Position
268getPosition =
220getPosition =
269− Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
221+ Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
270 eok (A.Position row col) state
222 eok (A.Position row col) state
271
223
272
224
273addLocation :: Parser x a -> Parser x (A.Located a)
225addLocation :: Parser x a -> Parser x (A.Located a)
274addLocation (Parser parser) =
226addLocation (Parser parser) =
275− Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr ->
227+ Parser $ \state@(State _ _ _ sr sc) cok eok cerr eerr ->
276 let
228 let
277− cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
229+ cok' a s@(State _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
278− eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
230+ eok' a s@(State _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s
279 in
231 in
280 parser state cok' eok' cerr eerr
232 parser state cok' eok' cerr eerr
281
233
282
234
283addEnd :: A.Position -> a -> Parser x (A.Located a)
235addEnd :: A.Position -> a -> Parser x (A.Located a)
284addEnd start value =
236addEnd start value =
285− Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->
237+ Parser $ \state@(State _ _ _ row col) _ eok _ _ ->
286 eok (A.at start (A.Position row col) value) state
238 eok (A.at start (A.Position row col) value) state
287
239
288
240
@@ -292,37 +244,37 @@ addEnd start value =
292
244
293getIndent :: Parser x Word16
245getIndent :: Parser x Word16
294getIndent =
246getIndent =
295− Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ ->
247+ Parser $ \state@(State _ _ indent _ _) _ eok _ _ ->
296 eok indent state
248 eok indent state
297
249
298
250
299setIndent :: Word16 -> Parser x ()
251setIndent :: Word16 -> Parser x ()
300setIndent indent =
252setIndent indent =
301− Parser $ \(State src pos end _ row col) _ eok _ _ ->
253+ Parser $ \(State pos end _ row col) _ eok _ _ ->
302 let
254 let
303− !newState = State src pos end indent row col
255+ !newState = State pos end indent row col
304 in
256 in
305 eok () newState
257 eok () newState
306
258
307
259
308withIndent :: Parser x a -> Parser x a
260withIndent :: Parser x a -> Parser x a
309withIndent (Parser parser) =
261withIndent (Parser parser) =
310− Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
262+ Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
311 let
263 let
312− cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
264+ cok' a (State p e _ r c) = cok 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)
265+ eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
314 in
266 in
315− parser (State src pos end col row col) cok' eok' cerr eerr
267+ parser (State pos end col row col) cok' eok' cerr eerr
316
268
317
269
318withBacksetIndent :: Word16 -> Parser x a -> Parser x a
270withBacksetIndent :: Word16 -> Parser x a -> Parser x a
319withBacksetIndent backset (Parser parser) =
271withBacksetIndent backset (Parser parser) =
320− Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->
272+ Parser $ \(State pos end oldIndent row col) cok eok cerr eerr ->
321 let
273 let
322− cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)
274+ cok' a (State p e _ r c) = cok 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)
275+ eok' a (State p e _ r c) = eok a (State p e oldIndent r c)
324 in
276 in
325− parser (State src pos end (col - backset) row col) cok' eok' cerr eerr
277+ parser (State pos end (col - backset) row col) cok' eok' cerr eerr
326
278
327
279
328
280
@@ -331,7 +283,7 @@ withBacksetIndent backset (Parser parser) =
331
283
332inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
284inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a
333inContext addContext (Parser parserStart) (Parser parserA) =
285inContext addContext (Parser parserStart) (Parser parserA) =
334− Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
286+ Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
335 let
287 let
336 cerrA r c tx = cerr row col (addContext (tx r c))
288 cerrA r c tx = cerr row col (addContext (tx r c))
337 eerrA r c tx = eerr row col (addContext (tx r c))
289 eerrA r c tx = eerr row col (addContext (tx r c))
@@ -344,7 +296,7 @@ inContext addContext (Parser parserStart) (Parser parserA) =
344
296
345specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
297specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a
346specialize addContext (Parser parser) =
298specialize addContext (Parser parser) =
347− Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->
299+ Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->
348 let
300 let
349 cerr' r c tx = cerr row col (addContext (tx r c))
301 cerr' r c tx = cerr row col (addContext (tx r c))
350 eerr' r c tx = eerr row col (addContext (tx r c))
302 eerr' r c tx = eerr row col (addContext (tx r c))
@@ -358,9 +310,9 @@ specialize addContext (Parser parser) =
358
310
359word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
311word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()
360word1 word toError =
312word1 word toError =
361− Parser $ \(State src pos end indent row col) cok _ _ eerr ->
313+ Parser $ \(State pos end indent row col) cok _ _ eerr ->
362 if pos < end && unsafeIndex pos == word then
314 if pos < end && unsafeIndex pos == word then
363− let !newState = State src (plusPtr pos 1) end indent row (col + 1) in
315+ let !newState = State (plusPtr pos 1) end indent row (col + 1) in
364 cok () newState
316 cok () newState
365 else
317 else
366 eerr row col toError
318 eerr row col toError
@@ -368,12 +320,12 @@ word1 word toError =
368
320
369word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
321word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
370word2 w1 w2 toError =
322word2 w1 w2 toError =
371− Parser $ \(State src pos end indent row col) cok _ _ eerr ->
323+ Parser $ \(State pos end indent row col) cok _ _ eerr ->
372 let
324 let
373 !pos1 = plusPtr pos 1
325 !pos1 = plusPtr pos 1
374 in
326 in
375 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
327 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then
376− let !newState = State src (plusPtr pos 2) end indent row (col + 2) in
328+ let !newState = State (plusPtr pos 2) end indent row (col + 2) in
377 cok () newState
329 cok () newState
378 else
330 else
379 eerr row col toError
331 eerr row col toError
@@ -394,8 +346,8 @@ isWord pos end word =
394 pos < end && unsafeIndex pos == word
346 pos < end && unsafeIndex pos == word
395
347
396
348
397−getCharWidth :: Word8 -> Int
349+getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
398−getCharWidth word
350+getCharWidth _pos _end word
399 | word < 0x80 = 1
351 | word < 0x80 = 1
400 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
352 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."
401 | word < 0xe0 = 2
353 | word < 0xe0 = 2
compiler/src/Parse/Repl.hsnew file+117
@@ -0,0 +1,117 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Parse.Repl
4+ ( Entry(..)
5+ , parseEntry
6+ )
7+ where
8+
9+
10+import qualified Data.ByteString.UTF8 as BS_UTF8
11+import Data.Name (Name)
12+
13+import qualified AST.Source as Src
14+import qualified Parse.Primitives as P
15+import Parse.Utils
16+
17+
18+
19+-- ENTRY
20+
21+
22+data Entry
23+ = Import Name (Maybe Name) Src.Exposing String
24+ | Type Name String
25+ | Def (Maybe Name) String
26+ | Other String
27+ | Annotation
28+ | Port
29+
30+
31+
32+-- PARSE
33+
34+
35+parseEntry :: String -> Entry
36+parseEntry source =
37+ case P.fromByteString parser (BS_UTF8.fromString source) of
38+ P.Ok entry _ ->
39+ entry
40+
41+ P.Err _ _ _ _ ->
42+ Other source
43+
44+
45+parser :: Parser Entry
46+parser =
47+ error "TODO parse the REPL stuff"
48+
49+{-
50+ oneOf
51+ [
52+ do Keyword.import_
53+ spaces
54+ name <- Var.moduleName
55+ alias <- tryAlias
56+ exposing <-
57+ oneOf
58+ [ do spaces
59+ Keyword.exposing_
60+ spaces
61+ Module.exposing
62+ , return (Src.Explicit [])
63+ ]
64+ return (Import name alias exposing source)
65+ ,
66+ do Keyword.port_
67+ return Port
68+ ,
69+ do Keyword.type_
70+ spaces
71+ oneOf
72+ [ do Keyword.alias_
73+ spaces
74+ , return ()
75+ ]
76+ name <- Var.upper
77+ return (Type name source)
78+ ,
79+ do root <- Pattern.term
80+ spaces
81+ case A.toValue root of
82+ Src.PVar name ->
83+ oneOf
84+ [ do word1 0x3A {-:-} E.XXX
85+ return Annotation
86+ , do chompArgs
87+ return (Def (Just name) source)
88+ ]
89+
90+ _ ->
91+ do word1 0x3D {-=-} E.XXX
92+ return (Def Nothing source)
93+ ]
94+
95+
96+chompArgs :: Parser ()
97+chompArgs =
98+ oneOf
99+ [ do Pattern.term
100+ spaces
101+ chompArgs
102+ , do word1 0x3D {-=-} E.XXX
103+ return ()
104+ ]
105+
106+
107+tryAlias :: Parser (Maybe Name)
108+tryAlias =
109+ oneOf
110+ [ try $
111+ do spaces
112+ Keyword.as_
113+ spaces
114+ Just <$> Var.upper
115+ , return Nothing
116+ ]
117+-}
compiler/src/Parse/Shader.hs+19−20
@@ -6,13 +6,12 @@ module Parse.Shader
6 where
6 where
7
7
8
8
9−import qualified Data.ByteString.Internal as B
9+import qualified Data.List as List
10−import qualified Data.ByteString.UTF8 as BS_UTF8
11import qualified Data.Map as Map
10import qualified Data.Map as Map
12import qualified Data.Name as Name
11import 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, minusPtr)
14+import Foreign.Ptr (Ptr, plusPtr)
15−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
16import qualified Language.GLSL.Parser as GLP
15import qualified Language.GLSL.Parser as GLP
17import qualified Language.GLSL.Syntax as GLS
16import qualified Language.GLSL.Syntax as GLS
18import qualified Text.Parsec as Parsec
17import qualified Text.Parsec as Parsec
@@ -35,16 +34,17 @@ shader start@(A.Position row col) =
35 do block <- parseBlock
34 do block <- parseBlock
36 shdr <- parseGlsl row col block
35 shdr <- parseGlsl row col block
37 end <- P.getPosition
36 end <- P.getPosition
37+ let src = List.intercalate "\\n" (lines block)
38− return (A.at start end (Src.Shader (Shader.fromChars block) shdr))
38+ return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))
39
39
40
40
41
41
42-- BLOCK
42-- BLOCK
43
43
44
44
45−parseBlock :: Parser E.Expr [Char]
45+parseBlock :: Parser E.Expr String
46parseBlock =
46parseBlock =
47− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
47+ P.Parser $ \(P.State 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,17 +58,16 @@ 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 + 6)
61+ eatShader pos6 end row col
62 in
62 in
63 case status of
63 case status of
64 Good ->
64 Good ->
65 let
65 let
66− !off = minusPtr pos6 (unsafeForeignPtrToPtr src)
66+ !block = Utf8.fromPtr pos newPos
67− !len = minusPtr newPos pos6
67+ !source = Utf8.toChars block
68− !block = BS_UTF8.toString (B.PS src off len)
69− !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)
68+ !newState = P.State (plusPtr newPos 2) end indent newRow newCol
70 in
69 in
71− cok block newState
70+ cok source newState
72
71
73 Unending ->
72 Unending ->
74 cerr row col E.EndlessShader
73 cerr row col E.EndlessShader
@@ -90,13 +89,13 @@ eatShader pos end row col =
90 else
89 else
91 let !word = P.unsafeIndex pos in
90 let !word = P.unsafeIndex pos in
92 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
91 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
93− (# Good, pos, row, col #)
92+ (# Good, pos, row, col + 2 #)
94
93
95 else if word == 0x0A {- \n -} then
94 else if word == 0x0A {- \n -} then
96 eatShader (plusPtr pos 1) end (row + 1) 1
95 eatShader (plusPtr pos 1) end (row + 1) 1
97
96
98 else
97 else
99− let !newPos = plusPtr pos (P.getCharWidth word) in
98+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
100 eatShader newPos end row (col + 1)
99 eatShader newPos end row (col + 1)
101
100
102
101
@@ -104,7 +103,7 @@ eatShader pos end row col =
104-- GLSL
103-- GLSL
105
104
106
105
107−parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types
106+parseGlsl :: Row -> Col -> String -> Parser E.Expr Shader.Types
108parseGlsl startRow startCol src =
107parseGlsl startRow startCol src =
109 case GLP.parse src of
108 case GLP.parse src of
110 Right (GLS.TranslationUnit decls) ->
109 Right (GLS.TranslationUnit decls) ->
@@ -129,9 +128,9 @@ parseGlsl startRow startCol src =
129 else failure (startRow + row - 1) col msg
128 else failure (startRow + row - 1) col msg
130
129
131
130
132−failure :: Row -> Col -> [Char] -> Parser E.Expr a
131+failure :: Row -> Col -> String -> Parser E.Expr a
133failure row col msg =
132failure row col msg =
134− P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->
133+ P.Parser $ \(P.State _ _ _ _ _) _ _ cerr _ ->
135 cerr row col (E.ShaderProblem msg)
134 cerr row col (E.ShaderProblem msg)
136
135
137
136
@@ -144,7 +143,7 @@ emptyTypes =
144 Shader.Types Map.empty Map.empty Map.empty
143 Shader.Types Map.empty Map.empty Map.empty
145
144
146
145
147−addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types
146+addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types
148addInput (qual, tipe, name) glDecls =
147addInput (qual, tipe, name) glDecls =
149 case qual of
148 case qual of
150 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
149 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
@@ -153,7 +152,7 @@ addInput (qual, tipe, name) glDecls =
153 _ -> error "Should never happen due to `extractInputs` function"
152 _ -> error "Should never happen due to `extractInputs` function"
154
153
155
154
156−extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]
155+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)]
157extractInputs decl =
156extractInputs decl =
158 case decl of
157 case decl of
159 GLS.Declaration
158 GLS.Declaration
compiler/src/Parse/Space.hs+29−25
@@ -10,16 +10,15 @@ module Parse.Space
10 , checkAligned
10 , checkAligned
11 , checkFreshLine
11 , checkFreshLine
12 --
12 --
13+ , DocComment(..)
13 , docComment
14 , docComment
14 )
15 )
15 where
16 where
16
17
17
18
18import Data.Word (Word8, Word16)
19import Data.Word (Word8, Word16)
19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.Ptr (Ptr, plusPtr)
20−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
21
21
22−import qualified AST.Source as Src
23import Parse.Primitives (Row, Col)
22import Parse.Primitives (Row, Col)
24import qualified Parse.Primitives as P
23import qualified Parse.Primitives as P
25import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
@@ -40,19 +39,20 @@ type Parser x a =
40
39
41chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
40chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
42chomp toError =
41chomp toError =
43− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
42+ P.Parser $ \(P.State pos end indent row col) cok _ cerr _ ->
44 let
43 let
45 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
44 (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
46 in
45 in
47 case status of
46 case status of
48 Good ->
47 Good ->
49 let
48 let
50− !newState = P.State src newPos end indent newRow newCol
49+ !newState = P.State newPos end indent newRow newCol
51 in
50 in
52 cok () newState
51 cok () newState
53
52
54 HasTab -> cerr newRow newCol (toError E.HasTab)
53 HasTab -> cerr newRow newCol (toError E.HasTab)
55 EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment)
54 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 src pos end indent row col) cok _ cerr _ ->
92+ P.Parser $ \(P.State 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 src newPos end indent newRow newCol
102+ !newState = P.State newPos end indent newRow newCol
103 in
103 in
104 cok () newState
104 cok () newState
105
105
@@ -108,6 +108,7 @@ 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)
111
112
112
113
113
114
@@ -118,6 +119,7 @@ data Status
118 = Good
119 = Good
119 | HasTab
120 | HasTab
120 | EndlessMultiComment
121 | EndlessMultiComment
122+ | UnexpectedDocComment
121
123
122
124
123eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
125eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
@@ -157,7 +159,7 @@ eatSpaces pos end row col =
157-- LINE COMMENTS
159-- LINE COMMENTS
158
160
159
161
160−eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
162+eatLineComment :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)
161eatLineComment pos end row col =
163eatLineComment pos end row col =
162 if pos >= end then
164 if pos >= end then
163 (# Good, pos, row, col #)
165 (# Good, pos, row, col #)
@@ -167,7 +169,7 @@ eatLineComment pos end row col =
167 if word == 0x0A {- \n -} then
169 if word == 0x0A {- \n -} then
168 eatSpaces (plusPtr pos 1) end (row + 1) 1
170 eatSpaces (plusPtr pos 1) end (row + 1) 1
169 else
171 else
170− let !newPos = plusPtr pos (P.getCharWidth word) in
172+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
171 eatLineComment newPos end row (col + 1)
173 eatLineComment newPos end row (col + 1)
172
174
173
175
@@ -187,7 +189,7 @@ eatMultiComment pos end row col =
187 else if P.unsafeIndex pos1 == 0x2D {- - -} then
189 else if P.unsafeIndex pos1 == 0x2D {- - -} then
188
190
189 if P.unsafeIndex pos2 == 0x7C {- | -} then
191 if P.unsafeIndex pos2 == 0x7C {- | -} then
190− (# Good, pos, row, col #)
192+ (# UnexpectedDocComment, pos, row, col #)
191 else
193 else
192 let
194 let
193 (# status, newPos, newRow, newCol #) =
195 (# status, newPos, newRow, newCol #) =
@@ -208,7 +210,7 @@ data MultiStatus
208 | MultiEndless
210 | MultiEndless
209
211
210
212
211−eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
213+eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Word16, Word16 #)
212eatMultiCommentHelp pos end row col openComments =
214eatMultiCommentHelp pos end row col openComments =
213 if pos >= end then
215 if pos >= end then
214 (# MultiEndless, pos, row, col #)
216 (# MultiEndless, pos, row, col #)
@@ -231,7 +233,7 @@ eatMultiCommentHelp pos end row col openComments =
231 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
233 eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
232
234
233 else
235 else
234− let !newPos = plusPtr pos (P.getCharWidth word) in
236+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
235 eatMultiCommentHelp newPos end row (col + 1) openComments
237 eatMultiCommentHelp newPos end row (col + 1) openComments
236
238
237
239
@@ -239,9 +241,16 @@ eatMultiCommentHelp pos end row col openComments =
239-- DOCUMENTATION COMMENT
241-- DOCUMENTATION COMMENT
240
242
241
243
244+data DocComment =
245+ DocComment
246+ { _start :: Ptr Word8
247+ , _end :: Ptr Word8
248+ }
249+
250+
242−docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment
251+docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x DocComment
243docComment toExpectation toSpaceError =
252docComment toExpectation toSpaceError =
244− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
253+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
245 let
254 let
246 !pos3 = plusPtr pos 3
255 !pos3 = plusPtr pos 3
247 in
256 in
@@ -251,19 +260,14 @@ docComment toExpectation toSpaceError =
251 && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
260 && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
252 then
261 then
253 let
262 let
254− !col3 = col + 3
255−
256 (# status, newPos, newRow, newCol #) =
263 (# status, newPos, newRow, newCol #) =
257− eatMultiCommentHelp pos3 end row col3 1
264+ eatMultiCommentHelp pos3 end row (col + 3) 1
258 in
265 in
259 case status of
266 case status of
260 MultiGood ->
267 MultiGood ->
261 let
268 let
262− !off = minusPtr pos3 (unsafeForeignPtrToPtr src)
269+ !comment = DocComment pos3 (plusPtr newPos (-2))
263− !len = minusPtr newPos pos3 - 2
264− !snippet = P.Snippet src off len row col3
265− !comment = Src.Comment snippet
266− !newState = P.State src newPos end indent newRow newCol
270+ !newState = P.State newPos end indent newRow newCol
267 in
271 in
268 cok comment newState
272 cok comment newState
269
273
compiler/src/Parse/Symbol.hs+34−19
@@ -1,9 +1,8 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3module Parse.Symbol
3module Parse.Symbol
4+ ( wildcard
4− ( operator
5+ , operator
5− , BadOperator(..)
6− , binopCharSet
7 )
6 )
8 where
7 where
9
8
@@ -16,39 +15,55 @@ import Foreign.Ptr (Ptr, plusPtr, minusPtr)
16import GHC.Word (Word8)
15import GHC.Word (Word8)
17
16
18import Parse.Primitives (Parser, Row, Col)
17import 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
20
21
21
22
22
23
23−-- OPERATOR
24+-- UNDERSCORE
25+
26+
27+wildcard :: Parser E.Pattern ()
28+wildcard =
29+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
30+ if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
31+ eerr row col E.PStart
32+ else
33+ let
34+ !newPos = plusPtr pos 1
35+ !newCol = col + 1
36+ in
37+ if Var.getInnerWidth newPos end > 0 then
38+ let (# _, badCol #) = Var.chompInnerChars newPos end newCol in
39+ cerr row col (E.PWildcardNotVar (fromIntegral (badCol - col)))
40+ else
41+ let !newState = P.State newPos end indent row newCol in
42+ cok () newState
43+
24
44
25
45
26−data BadOperator
46+-- OPERATOR
27− = BadDot
28− | BadPipe
29− | BadArrow
30− | BadEquals
31− | BadHasType
32
47
33
48
34−operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name
49+operator :: (Row -> Col -> x) -> (E.Operator -> Row -> Col -> x) -> Parser x Name.Name
35operator toExpectation toError =
50operator toExpectation toError =
36− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
51+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
37 let !newPos = chompOps pos end in
52 let !newPos = chompOps pos end in
38 if pos == newPos then
53 if pos == newPos then
39 eerr row col toExpectation
54 eerr row col toExpectation
40
55
41 else
56 else
42 case Name.fromPtr pos newPos of
57 case Name.fromPtr pos newPos of
43− "." -> eerr row col (toError BadDot)
58+ "." -> cerr row col (toError E.OpDot)
44− "|" -> cerr row col (toError BadPipe)
59+ "|" -> cerr row col (toError E.OpPipe)
45− "->" -> cerr row col (toError BadArrow)
60+ "->" -> cerr row col (toError E.OpArrow)
46− "=" -> cerr row col (toError BadEquals)
61+ "=" -> cerr row col (toError E.OpEquals)
47− ":" -> cerr row col (toError BadHasType)
62+ ":" -> cerr row col (toError E.OpHasType)
48 op ->
63 op ->
49 let
64 let
50 !newCol = col + fromIntegral (minusPtr newPos pos)
65 !newCol = col + fromIntegral (minusPtr newPos pos)
51− !newState = P.State src newPos end indent row newCol
66+ !newState = P.State newPos end indent row newCol
52 in
67 in
53 cok op newState
68 cok op newState
54
69
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.TTupleIndentType1
50+ , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType
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.TStart -- could just be another type instead
98+ word2 0x2D 0x3E {-->-} E.TArrow
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.TTupleIndentTypeN
150+ Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType
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/String.hs → compiler/src/Parse/Utf8.hsrenamed+66−64
@@ -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.String
3+module Parse.Utf8
4 ( string
4 ( string
5 , character
5 , character
6 )
6 )
@@ -11,7 +11,6 @@ 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
15import Parse.Primitives (Parser, Row, Col)
14import Parse.Primitives (Parser, Row, Col)
16import qualified Parse.Number as Number
15import qualified Parse.Number as Number
17import qualified Parse.Primitives as P
16import qualified Parse.Primitives as P
@@ -22,39 +21,39 @@ import qualified Reporting.Error.Syntax as E
22-- CHARACTER
21-- CHARACTER
23
22
24
23
25−character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x ES.String
24+character :: (Row -> Col -> x) -> (E.Char -> Row -> Col -> x) -> Parser x Utf8.String
26character toExpectation toError =
25character toExpectation toError =
27− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
26+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
28 if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
27 if pos >= end || P.unsafeIndex pos /= 0x27 {- ' -} then
29 eerr row col toExpectation
28 eerr row col toExpectation
30
29
31 else
30 else
32− case chompChar (plusPtr pos 1) end row (col + 1) 0 placeholder of
31+ case chompChar (plusPtr pos 1) end (col + 1) 0 placeholder of
33 Good newPos newCol numChars mostRecent ->
32 Good newPos newCol numChars mostRecent ->
34 if numChars /= 1 then
33 if numChars /= 1 then
35 cerr row col (toError (E.CharNotString (fromIntegral (newCol - col))))
34 cerr row col (toError (E.CharNotString (fromIntegral (newCol - col))))
36 else
35 else
37 let
36 let
38− !newState = P.State src newPos end indent row newCol
37+ !newState = P.State newPos end indent row newCol
39− !char = ES.fromChunks [mostRecent]
38+ !char = Utf8.fromChunks [mostRecent]
40 in
39 in
41 cok char newState
40 cok char newState
42
41
43 CharEndless newCol ->
42 CharEndless newCol ->
44 cerr row newCol (toError E.CharEndless)
43 cerr row newCol (toError E.CharEndless)
45
44
46− CharEscape r c escape ->
45+ CharEscape newCol escape ->
47− cerr r c (toError (E.CharEscape escape))
46+ cerr row newCol (toError (E.CharEscape escape))
48
47
49
48
50data CharResult
49data CharResult
51− = Good (Ptr Word8) Col Word16 ES.Chunk
50+ = Good (Ptr Word8) Col Word16 Utf8.Chunk
52 | CharEndless Col
51 | CharEndless Col
53− | CharEscape Row Col E.Escape
52+ | CharEscape Col E.Escape
54
53
55
54
56−chompChar :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> ES.Chunk -> CharResult
55+chompChar :: Ptr Word8 -> Ptr Word8 -> Col -> Word16 -> Utf8.Chunk -> CharResult
57−chompChar pos end row col numChars mostRecent =
56+chompChar pos end col numChars mostRecent =
58 if pos >= end then
57 if pos >= end then
59 CharEndless col
58 CharEndless col
60
59
@@ -69,37 +68,37 @@ chompChar pos end row col numChars mostRecent =
69 CharEndless col
68 CharEndless col
70
69
71 else if word == 0x22 {- " -} then
70 else if word == 0x22 {- " -} then
72− chompChar (plusPtr pos 1) end row (col + 1) (numChars + 1) doubleQuote
71+ chompChar (plusPtr pos 1) end (col + 1) (numChars + 1) doubleQuote
73
72
74 else if word == 0x5C {- \ -} then
73 else if word == 0x5C {- \ -} then
75− case eatEscape (plusPtr pos 1) end row col of
74+ case eatEscape (plusPtr pos 1) end col of
76 EscapeNormal ->
75 EscapeNormal ->
77− chompChar (plusPtr pos 2) end row (col + 2) (numChars + 1) (ES.Slice pos 2)
76+ chompChar (plusPtr pos 2) end (col + 2) (numChars + 1) (Utf8.Slice pos 2)
78
77
79 EscapeUnicode delta code ->
78 EscapeUnicode delta code ->
80− chompChar (plusPtr pos delta) end row (col + fromIntegral delta) (numChars + 1) (ES.CodePoint code)
79+ chompChar (plusPtr pos delta) end (col + fromIntegral delta) (numChars + 1) (Utf8.CodePoint code)
81
80
82− EscapeProblem r c badEscape ->
81+ EscapeProblem badEscape ->
83− CharEscape r c badEscape
82+ CharEscape col badEscape
84
83
85 EscapeEndOfFile ->
84 EscapeEndOfFile ->
86 CharEndless col
85 CharEndless col
87
86
88 else
87 else
89 let
88 let
90− !width = P.getCharWidth word
89+ !width = P.getCharWidth pos end word
91 !newPos = plusPtr pos width
90 !newPos = plusPtr pos width
92 in
91 in
93− chompChar newPos end row (col + 1) (numChars + 1) (ES.Slice pos width)
92+ chompChar newPos end (col + 1) (numChars + 1) (Utf8.Slice pos width)
94
93
95
94
96
95
97-- STRINGS
96-- STRINGS
98
97
99
98
100−string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x ES.String
99+string :: (Row -> Col -> x) -> (E.String -> Row -> Col -> x) -> Parser x Utf8.String
101string toExpectation toError =
100string toExpectation toError =
102− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
101+ P.Parser $ \(P.State pos end indent row col) cok _ cerr eerr ->
103 if isDoubleQuote pos end then
102 if isDoubleQuote pos end then
104
103
105 let
104 let
@@ -122,7 +121,7 @@ string toExpectation toError =
122 Ok newPos newRow newCol utf8 ->
121 Ok newPos newRow newCol utf8 ->
123 let
122 let
124 !newState =
123 !newState =
125− P.State src newPos end indent newRow newCol
124+ P.State newPos end indent newRow newCol
126 in
125 in
127 cok utf8 newState
126 cok utf8 newState
128
127
@@ -140,32 +139,32 @@ isDoubleQuote pos end =
140
139
141
140
142data StringResult
141data StringResult
143− = Ok (Ptr Word8) Row Col !ES.String
142+ = Ok (Ptr Word8) Row Col !Utf8.String
144 | Err Row Col E.String
143 | Err Row Col E.String
145
144
146
145
147−finalize :: Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> ES.String
146+finalize :: Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> Utf8.String
148finalize start end revChunks =
147finalize start end revChunks =
149− ES.fromChunks $ reverse $
148+ Utf8.fromChunks $ reverse $
150 if start == end then
149 if start == end then
151 revChunks
150 revChunks
152 else
151 else
153− ES.Slice start (minusPtr end start) : revChunks
152+ Utf8.Slice start (minusPtr end start) : revChunks
154
153
155
154
156−addEscape :: ES.Chunk -> Ptr Word8 -> Ptr Word8 -> [ES.Chunk] -> [ES.Chunk]
155+addEscape :: Utf8.Chunk -> Ptr Word8 -> Ptr Word8 -> [Utf8.Chunk] -> [Utf8.Chunk]
157addEscape chunk start end revChunks =
156addEscape chunk start end revChunks =
158 if start == end then
157 if start == end then
159 chunk : revChunks
158 chunk : revChunks
160 else
159 else
161− chunk : ES.Slice start (minusPtr end start) : revChunks
160+ chunk : Utf8.Slice start (minusPtr end start) : revChunks
162
161
163
162
164
163
165-- SINGLE STRINGS
164-- SINGLE STRINGS
166
165
167
166
168−singleString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [ES.Chunk] -> StringResult
167+singleString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Utf8.Chunk] -> StringResult
169singleString pos end row col initialPos revChunks =
168singleString pos end row col initialPos revChunks =
170 if pos >= end then
169 if pos >= end then
171 Err row col E.StringEndless_Single
170 Err row col E.StringEndless_Single
@@ -187,23 +186,23 @@ singleString pos end row col initialPos revChunks =
187 addEscape singleQuote initialPos pos revChunks
186 addEscape singleQuote initialPos pos revChunks
188
187
189 else if word == 0x5C {- \ -} then
188 else if word == 0x5C {- \ -} then
190− case eatEscape (plusPtr pos 1) end row col of
189+ case eatEscape (plusPtr pos 1) end col of
191 EscapeNormal ->
190 EscapeNormal ->
192 singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks
191 singleString (plusPtr pos 2) end row (col + 2) initialPos revChunks
193
192
194 EscapeUnicode delta code ->
193 EscapeUnicode delta code ->
195 let !newPos = plusPtr pos delta in
194 let !newPos = plusPtr pos delta in
196 singleString newPos end row (col + fromIntegral delta) newPos $
195 singleString newPos end row (col + fromIntegral delta) newPos $
197− addEscape (ES.CodePoint code) initialPos pos revChunks
196+ addEscape (Utf8.CodePoint code) initialPos pos revChunks
198
197
199− EscapeProblem r c x ->
198+ EscapeProblem x ->
200− Err r c (E.StringEscape x)
199+ Err row col (E.StringEscape x)
201
200
202 EscapeEndOfFile ->
201 EscapeEndOfFile ->
203 Err row (col + 1) E.StringEndless_Single
202 Err row (col + 1) E.StringEndless_Single
204
203
205 else
204 else
206− let !newPos = plusPtr pos (P.getCharWidth word) in
205+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
207 singleString newPos end row (col + 1) initialPos revChunks
206 singleString newPos end row (col + 1) initialPos revChunks
208
207
209
208
@@ -211,7 +210,7 @@ singleString pos end row col initialPos revChunks =
211-- MULTI STRINGS
210-- MULTI STRINGS
212
211
213
212
214−multiString :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> Row -> Col -> [ES.Chunk] -> StringResult
213+multiString :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> Word16 -> Word16 -> [Utf8.Chunk] -> StringResult
215multiString pos end row col initialPos sr sc revChunks =
214multiString pos end row col initialPos sr sc revChunks =
216 if pos >= end then
215 if pos >= end then
217 Err sr sc E.StringEndless_Multi
216 Err sr sc E.StringEndless_Multi
@@ -238,23 +237,23 @@ multiString pos end row col initialPos sr sc revChunks =
238 addEscape carriageReturn initialPos pos revChunks
237 addEscape carriageReturn initialPos pos revChunks
239
238
240 else if word == 0x5C {- \ -} then
239 else if word == 0x5C {- \ -} then
241− case eatEscape (plusPtr pos 1) end row col of
240+ case eatEscape (plusPtr pos 1) end col of
242 EscapeNormal ->
241 EscapeNormal ->
243 multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks
242 multiString (plusPtr pos 2) end row (col + 2) initialPos sr sc revChunks
244
243
245 EscapeUnicode delta code ->
244 EscapeUnicode delta code ->
246 let !newPos = plusPtr pos delta in
245 let !newPos = plusPtr pos delta in
247 multiString newPos end row (col + fromIntegral delta) newPos sr sc $
246 multiString newPos end row (col + fromIntegral delta) newPos sr sc $
248− addEscape (ES.CodePoint code) initialPos pos revChunks
247+ addEscape (Utf8.CodePoint code) initialPos pos revChunks
249
248
250− EscapeProblem r c x ->
249+ EscapeProblem x ->
251− Err r c (E.StringEscape x)
250+ Err row col (E.StringEscape x)
252
251
253 EscapeEndOfFile ->
252 EscapeEndOfFile ->
254 Err sr sc E.StringEndless_Multi
253 Err sr sc E.StringEndless_Multi
255
254
256 else
255 else
257− let !newPos = plusPtr pos (P.getCharWidth word) in
256+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
258 multiString newPos end row (col + 1) initialPos sr sc revChunks
257 multiString newPos end row (col + 1) initialPos sr sc revChunks
259
258
260
259
@@ -266,11 +265,11 @@ data Escape
266 = EscapeNormal
265 = EscapeNormal
267 | EscapeUnicode !Int !Int
266 | EscapeUnicode !Int !Int
268 | EscapeEndOfFile
267 | EscapeEndOfFile
269− | EscapeProblem Row Col E.Escape
268+ | EscapeProblem E.Escape
270
269
271
270
272−eatEscape :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
271+eatEscape :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
273−eatEscape pos end row col =
272+eatEscape pos end startCol =
274 if pos >= end then
273 if pos >= end then
275 EscapeEndOfFile
274 EscapeEndOfFile
276
275
@@ -282,14 +281,14 @@ eatEscape pos end row col =
282 0x22 {- " -} -> EscapeNormal
281 0x22 {- " -} -> EscapeNormal
283 0x27 {- ' -} -> EscapeNormal
282 0x27 {- ' -} -> EscapeNormal
284 0x5C {- \ -} -> EscapeNormal
283 0x5C {- \ -} -> EscapeNormal
285− 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end row col
284+ 0x75 {- u -} -> eatUnicode (plusPtr pos 1) end startCol
286− _ -> EscapeProblem row col E.EscapeUnknown
285+ _ -> EscapeProblem (E.EscapeUnknown startCol (startCol + 1))
287
286
288
287
289−eatUnicode :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Escape
288+eatUnicode :: Ptr Word8 -> Ptr Word8 -> Word16 -> Escape
290−eatUnicode pos end row col =
289+eatUnicode pos end startCol =
291 if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
290 if pos >= end || P.unsafeIndex pos /= 0x7B {- { -} then
292− EscapeProblem row col (E.BadUnicodeFormat 2)
291+ EscapeProblem $ E.BadUnicodeFormat startCol (startCol + 1)
293 else
292 else
294 let
293 let
295 !digitPos = plusPtr pos 1
294 !digitPos = plusPtr pos 1
@@ -297,15 +296,18 @@ eatUnicode pos end row col =
297 !numDigits = minusPtr newPos digitPos
296 !numDigits = minusPtr newPos digitPos
298 in
297 in
299 if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
298 if newPos >= end || P.unsafeIndex newPos /= 0x7D {- } -} then
300− EscapeProblem row col $ E.BadUnicodeFormat (2 + fromIntegral (minusPtr newPos pos))
299+ EscapeProblem $ E.BadUnicodeFormat startCol $
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 row col $ E.BadUnicodeCode (3 + fromIntegral (minusPtr newPos pos))
303+ EscapeProblem $ E.BadUnicodeCode startCol $
304+ startCol + fromIntegral (minusPtr newPos pos) + 1
304
305
305 else if numDigits < 4 || 6 < numDigits then
306 else if numDigits < 4 || 6 < numDigits then
306− EscapeProblem row col $
307+ EscapeProblem $
307 E.BadUnicodeLength
308 E.BadUnicodeLength
309+ startCol
308− (3 + fromIntegral (minusPtr newPos pos))
310+ (startCol + fromIntegral (minusPtr newPos pos) + 1)
309 numDigits
311 numDigits
310 code
312 code
311
313
@@ -314,30 +316,30 @@ eatUnicode pos end row col =
314
316
315
317
316{-# NOINLINE singleQuote #-}
318{-# NOINLINE singleQuote #-}
317−singleQuote :: ES.Chunk
319+singleQuote :: Utf8.Chunk
318singleQuote =
320singleQuote =
319− ES.Escape 0x27 {-'-}
321+ Utf8.Escape 0x27 {- ' -}
320
322
321
323
322{-# NOINLINE doubleQuote #-}
324{-# NOINLINE doubleQuote #-}
323−doubleQuote :: ES.Chunk
325+doubleQuote :: Utf8.Chunk
324doubleQuote =
326doubleQuote =
325− ES.Escape 0x22 {-"-}
327+ Utf8.Escape 0x22 {- " -}
326
328
327
329
328{-# NOINLINE newline #-}
330{-# NOINLINE newline #-}
329−newline :: ES.Chunk
331+newline :: Utf8.Chunk
330newline =
332newline =
331− ES.Escape 0x6E {-n-}
333+ Utf8.Escape 0x6E {- n -}
332
334
333
335
334{-# NOINLINE carriageReturn #-}
336{-# NOINLINE carriageReturn #-}
335−carriageReturn :: ES.Chunk
337+carriageReturn :: Utf8.Chunk
336carriageReturn =
338carriageReturn =
337− ES.Escape 0x72 {-r-}
339+ Utf8.Escape 0x72 {- \r -}
338
340
339
341
340{-# NOINLINE placeholder #-}
342{-# NOINLINE placeholder #-}
341−placeholder :: ES.Chunk
343+placeholder :: Utf8.Chunk
342placeholder =
344placeholder =
343− ES.CodePoint 0xFFFD {-replacement character-}
345+ Utf8.CodePoint 0xFFFD {- replacement character -}
compiler/src/Parse/Variable.hs+23−30
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, OverloadedStrings #-}
3module Parse.Variable
3module Parse.Variable
4 ( lower
4 ( lower
5 , upper
5 , upper
@@ -8,10 +8,8 @@ module Parse.Variable
8 , foreignUpper
8 , foreignUpper
9 , foreignAlpha
9 , foreignAlpha
10 , chompInnerChars
10 , chompInnerChars
11− , getUpperWidth
12 , getInnerWidth
11 , getInnerWidth
13 , getInnerWidthHelp
12 , getInnerWidthHelp
14− , reservedWords
15 )
13 )
16 where
14 where
17
15
@@ -35,13 +33,13 @@ import qualified Parse.Primitives as P
35
33
36upper :: (Row -> Col -> x) -> Parser x Name.Name
34upper :: (Row -> Col -> x) -> Parser x Name.Name
37upper toError =
35upper toError =
38− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
36+ P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
39 let (# newPos, newCol #) = chompUpper pos end col in
37 let (# newPos, newCol #) = chompUpper pos end col in
40 if pos == newPos then
38 if pos == newPos then
41 eerr row col toError
39 eerr row col toError
42 else
40 else
43 let !name = Name.fromPtr pos newPos in
41 let !name = Name.fromPtr pos newPos in
44− cok name (P.State src newPos end indent row newCol)
42+ cok name (P.State newPos end indent row newCol)
45
43
46
44
47
45
@@ -50,7 +48,7 @@ upper toError =
50
48
51lower :: (Row -> Col -> x) -> Parser x Name.Name
49lower :: (Row -> Col -> x) -> Parser x Name.Name
52lower toError =
50lower toError =
53− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
51+ P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
54 let (# newPos, newCol #) = chompLower pos end col in
52 let (# newPos, newCol #) = chompLower pos end col in
55 if pos == newPos then
53 if pos == newPos then
56 eerr row col toError
54 eerr row col toError
@@ -61,13 +59,13 @@ lower toError =
61 else
59 else
62 let
60 let
63 !newState =
61 !newState =
64− P.State src newPos end indent row newCol
62+ P.State newPos end indent row newCol
65 in
63 in
66 cok name newState
64 cok name newState
67
65
68
66
69{-# NOINLINE reservedWords #-}
67{-# NOINLINE reservedWords #-}
70−reservedWords :: Set.Set Name.Name -- PERF try using a trie instead
68+reservedWords :: Set.Set Name.Name -- TODO try using a trie instead
71reservedWords =
69reservedWords =
72 Set.fromList
70 Set.fromList
73 [ "if", "then", "else"
71 [ "if", "then", "else"
@@ -87,26 +85,21 @@ reservedWords =
87
85
88moduleName :: (Row -> Col -> x) -> Parser x Name.Name
86moduleName :: (Row -> Col -> x) -> Parser x Name.Name
89moduleName toError =
87moduleName toError =
90− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
88+ P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
91 let
89 let
92 (# pos1, col1 #) = chompUpper pos end col
90 (# pos1, col1 #) = chompUpper pos end col
91+ (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
93 in
92 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
100− case status of
93+ case status of
101− Good ->
94+ Good ->
102− let
95+ let
103− !name = Name.fromPtr pos newPos
96+ !name = Name.fromPtr pos newPos
104− !newState = P.State src newPos end indent row newCol
97+ !newState = P.State newPos end indent row newCol
105− in
98+ in
106− cok name newState
99+ cok name newState
107
100
108− Bad ->
101+ Bad ->
109− cerr row newCol toError
102+ eerr row newCol toError
110
103
111
104
112data ModuleNameStatus
105data ModuleNameStatus
@@ -141,22 +134,22 @@ data Upper
141
134
142foreignUpper :: (Row -> Col -> x) -> Parser x Upper
135foreignUpper :: (Row -> Col -> x) -> Parser x Upper
143foreignUpper toError =
136foreignUpper toError =
144− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
137+ P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
145 let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
138 let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
146 if upperStart == upperEnd then
139 if upperStart == upperEnd then
147 eerr row newCol toError
140 eerr row newCol toError
148 else
141 else
149 let
142 let
150− !newState = P.State src upperEnd end indent row newCol
143+ !newState = P.State upperEnd end indent row newCol
151 !name = Name.fromPtr upperStart upperEnd
144 !name = Name.fromPtr upperStart upperEnd
152− !upperName =
145+ !foreign =
153 if upperStart == pos then
146 if upperStart == pos then
154 Unqualified name
147 Unqualified name
155 else
148 else
156 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
149 let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
157 Qualified home name
150 Qualified home name
158 in
151 in
159− cok upperName newState
152+ cok foreign newState
160
153
161
154
162foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
155foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Col -> (# Ptr Word8, Ptr Word8, Col #)
@@ -180,13 +173,13 @@ foreignUpperHelp pos end col =
180
173
181foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
174foreignAlpha :: (Row -> Col -> x) -> Parser x Src.Expr_
182foreignAlpha toError =
175foreignAlpha toError =
183− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
176+ P.Parser $ \(P.State pos end indent row col) cok _ _ eerr ->
184 let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
177 let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
185 if alphaStart == alphaEnd then
178 if alphaStart == alphaEnd then
186 eerr row newCol toError
179 eerr row newCol toError
187 else
180 else
188 let
181 let
189− !newState = P.State src alphaEnd end indent row newCol
182+ !newState = P.State alphaEnd end indent row newCol
190 !name = Name.fromPtr alphaStart alphaEnd
183 !name = Name.fromPtr alphaStart alphaEnd
191 in
184 in
192 if alphaStart == pos then
185 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 -- PERF see if unpacking region is helpful
29+ At Region a -- TODO see if unpacking region is helpful
30
30
31
31
32instance Functor Located where
32instance Functor Located where
compiler/src/Reporting/Doc.hs+47−79
@@ -7,38 +7,16 @@ 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
11+ , fromChars, fromName, fromInt, fromUtf8
12− , fromName
13− , fromVersion
14− , fromPackage
15− , fromInt
16− --
17− , toAnsi
18− , toString
12+ , toAnsi, toString, toLine
19− , toLine
20− --
21 , encode
13 , encode
22− --
14+
23− , stack
24− , reflow
25− , commaSep
15+ , stack, reflow, commaSep
26− --
27− , toSimpleNote
16+ , toSimpleNote, toSimpleHint, toFancyHint
28− , toFancyNote
29− , toSimpleHint
30− , toFancyHint
31− --
32− , link
33− , fancyLink
34− , reflowLink
35− , makeLink
36− , makeNakedLink
17+ , link, fancyLink, reflowLink, makeLink, makeNakedLink
37− --
38− , args
39− , moreArgs
18+ , args, moreArgs
40− , ordinal
41− , intToOrdinal
19+ , ordinal, intToOrdinal
42 , cycle
20 , cycle
43 )
21 )
44 where
22 where
@@ -48,17 +26,14 @@ import Prelude hiding (cycle)
48import qualified Data.List as List
26import qualified Data.List as List
49import Data.Monoid ((<>))
27import Data.Monoid ((<>))
50import qualified Data.Name as Name
28import qualified Data.Name as Name
29+import qualified Data.Utf8 as Utf8
51import qualified System.Console.ANSI.Types as Ansi
30import qualified System.Console.ANSI.Types as Ansi
52import qualified System.Info as Info
31import qualified System.Info as Info
53import System.IO (Handle)
32import System.IO (Handle)
54import qualified Text.PrettyPrint.ANSI.Leijen as P
33import qualified Text.PrettyPrint.ANSI.Leijen as P
55
34
56import qualified Data.Index as Index
35import qualified Data.Index as Index
57−import qualified Elm.Package as Pkg
58−import qualified Elm.Version as V
59−import Json.Encode ((==>))
60import qualified Json.Encode as E
36import qualified Json.Encode as E
61−import qualified Json.String as Json
62
37
63
38
64
39
@@ -75,21 +50,16 @@ fromName name =
75 P.text (Name.toChars name)
50 P.text (Name.toChars name)
76
51
77
52
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−
88fromInt :: Int -> P.Doc
53fromInt :: Int -> P.Doc
89fromInt n =
54fromInt n =
90 P.text (show n)
55 P.text (show n)
91
56
92
57
58+fromUtf8 :: Utf8.String -> P.Doc
59+fromUtf8 utf8 =
60+ P.text (Utf8.toChars utf8)
61+
62+
93
63
94-- TO STRING
64-- TO STRING
95
65
@@ -141,21 +111,12 @@ commaSep conjunction addStyle names =
141
111
142
112
143
113
144−-- NOTES
114+-- HINTS
145
115
146
116
147toSimpleNote :: String -> P.Doc
117toSimpleNote :: String -> P.Doc
148toSimpleNote message =
118toSimpleNote message =
149− toFancyNote (map P.text (words message))
119+ P.fillSep ((P.underline "Note" <> ":") : map P.text (words message))
150−
151−
152−toFancyNote :: [P.Doc] -> P.Doc
153−toFancyNote chunks =
154− P.fillSep (P.underline "Note" <> ":" : chunks)
155−
156−
157−
158−-- HINTS
159
120
160
121
161toSimpleHint :: String -> P.Doc
122toSimpleHint :: String -> P.Doc
@@ -172,32 +133,32 @@ toFancyHint chunks =
172-- LINKS
133-- LINKS
173
134
174
135
175−link :: String -> String -> String -> String -> P.Doc
136+link :: P.Doc -> String -> String -> String -> P.Doc
176link word before fileName after =
137link word before fileName after =
177 P.fillSep $
138 P.fillSep $
178− (P.underline (P.text word) <> ":")
139+ (P.underline word <> ":")
179 : map P.text (words before)
140 : map P.text (words before)
180 ++ P.text (makeLink fileName)
141 ++ P.text (makeLink fileName)
181 : map P.text (words after)
142 : map P.text (words after)
182
143
183
144
184−fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
145+fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc
185fancyLink word before fileName after =
146fancyLink word before fileName after =
186 P.fillSep $
147 P.fillSep $
187− (P.underline (P.text word) <> ":") : before ++ P.text (makeLink fileName) : after
148+ (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after
188
149
189
150
190−makeLink :: [Char] -> [Char]
151+makeLink :: String -> String
191makeLink fileName =
152makeLink fileName =
192− "<https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName <> ">"
153+ "<https://elm-lang.org/" <> error "TODO V.toString V.compiler" <> "/" <> fileName <> ">"
193
154
194
155
195−makeNakedLink :: [Char] -> [Char]
156+makeNakedLink :: String -> String
196makeNakedLink fileName =
157makeNakedLink fileName =
197− "https://elm-lang.org/" <> V.toChars V.compiler <> "/" <> fileName
158+ "https://elm-lang.org/" <> error "TODO V.toString V.compiler" <> "/" <> fileName
198
159
199
160
200−reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
161+reflowLink :: String -> String -> String -> P.Doc
201reflowLink before fileName after =
162reflowLink before fileName after =
202 P.fillSep $
163 P.fillSep $
203 map P.text (words before)
164 map P.text (words before)
@@ -306,8 +267,10 @@ data Color
306 | WHITE
267 | WHITE
307
268
308
269
309−toJsonHelp :: Style -> [String] -> P.SimpleDoc -> [E.Value]
270+toJsonHelp :: Style -> [a] -> P.SimpleDoc -> [E.Value]
310toJsonHelp style revChunks simpleDoc =
271toJsonHelp style revChunks simpleDoc =
272+ error "TODO generate json on errors" style revChunks simpleDoc sgrToStyle encodeColor
273+{-
311 case simpleDoc of
274 case simpleDoc of
312 P.SFail ->
275 P.SFail ->
313 error $
276 error $
@@ -318,18 +281,23 @@ toJsonHelp style revChunks simpleDoc =
318 [ encodeChunks style revChunks ]
281 [ encodeChunks style revChunks ]
319
282
320 P.SChar char rest ->
283 P.SChar char rest ->
321− toJsonHelp style ([char] : revChunks) rest
284+ toJsonHelp style (TB.singleton char : revChunks) rest
322
285
323 P.SText _ string rest ->
286 P.SText _ string rest ->
324− toJsonHelp style (string : revChunks) rest
287+ toJsonHelp style (TB.fromString string : revChunks) rest
325
288
326 P.SLine indent rest ->
289 P.SLine indent rest ->
327− toJsonHelp style (replicate indent ' ' : "\n" : revChunks) rest
290+ toJsonHelp style (spaces indent : "\n" : revChunks) rest
328
291
329 P.SSGR sgrs rest ->
292 P.SSGR sgrs rest ->
330 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
293 encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest
331
294
332
295
296+spaces :: Int -> TB.Builder
297+spaces n =
298+ TB.fromText (Text.replicate n " ")
299+-}
300+
333sgrToStyle :: [Ansi.SGR] -> Style -> Style
301sgrToStyle :: [Ansi.SGR] -> Style -> Style
334sgrToStyle sgrs style@(Style bold underline color) =
302sgrToStyle sgrs style@(Style bold underline color) =
335 case sgrs of
303 case sgrs of
@@ -390,28 +358,28 @@ toColor layer intensity color =
390 Ansi.White -> pick White WHITE
358 Ansi.White -> pick White WHITE
391 Ansi.Black -> pick Black BLACK
359 Ansi.Black -> pick Black BLACK
392
360
393−
361+{-
394−encodeChunks :: Style -> [String] -> E.Value
362+encodeChunks :: Style -> [TB.Builder] -> E.Value
395encodeChunks (Style bold underline color) revChunks =
363encodeChunks (Style bold underline color) revChunks =
396 let
364 let
397− chars = concat (reverse revChunks)
365+ !str = Utf8.concat (reverse revChunks)
398 in
366 in
399 case color of
367 case color of
400 Nothing | not bold && not underline ->
368 Nothing | not bold && not underline ->
401− E.chars chars
369+ E.string str
402
370
403 _ ->
371 _ ->
404 E.object
372 E.object
405− [ "bold" ==> E.bool bold
373+ [ ("bold", E.bool bold)
406− , "underline" ==> E.bool underline
374+ , ("underline", E.bool underline)
407− , "color" ==> maybe E.null encodeColor color
375+ , ("color", maybe E.null encodeColor color)
408− , "string" ==> E.chars chars
376+ , ("string", E.string str)
409 ]
377 ]
410−
378+-}
411
379
412encodeColor :: Color -> E.Value
380encodeColor :: Color -> E.Value
413encodeColor color =
381encodeColor color =
414− E.string $ Json.fromChars $
382+ E.string $
415 case color of
383 case color of
416 Red -> "red"
384 Red -> "red"
417 RED -> "RED"
385 RED -> "RED"
compiler/src/Reporting/Error.hs+22−175
@@ -1,28 +1,14 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error
3module Reporting.Error
4− ( Module(..)
5− , Error(..)
4+ ( Error(..)
6− , toDoc
5+ , toReports
7− , toJson
8 )
6 )
9 where
7 where
10
8
11
9
12−import qualified Data.ByteString as B
13−import qualified Data.NonEmptyList as NE
14−import qualified Data.OneOrMore as OneOrMore
15−import qualified System.FilePath as FP
16−
17−import qualified Elm.ModuleName as ModuleName
18−import qualified File
19−import qualified Json.Encode as E
20−import Json.Encode ((==>))
21−import qualified Reporting.Annotation as A
22−import qualified Reporting.Doc as D
23import qualified Reporting.Error.Canonicalize as Canonicalize
10import qualified Reporting.Error.Canonicalize as Canonicalize
24import qualified Reporting.Error.Docs as Docs
11import qualified Reporting.Error.Docs as Docs
25−import qualified Reporting.Error.Import as Import
26import qualified Reporting.Error.Main as Main
12import qualified Reporting.Error.Main as Main
27import qualified Reporting.Error.Pattern as Pattern
13import qualified Reporting.Error.Pattern as Pattern
28import qualified Reporting.Error.Syntax as Syntax
14import qualified Reporting.Error.Syntax as Syntax
@@ -33,178 +19,39 @@ import qualified Reporting.Report as Report
33
19
34
20
35
21
36−-- MODULE
37−
38−
39−data Module =
40− Module
41− { _name :: ModuleName.Raw
42− , _absolutePath :: FilePath
43− , _modificationTime :: File.Time
44− , _source :: B.ByteString
45− , _error :: Error
46− }
47−
48−
49−
50−-- ERRORS
22+-- ALL POSSIBLE ERRORS
51
23
52
24
53data Error
25data Error
54− = BadSyntax Syntax.Error
26+ = Syntax Syntax.Error
55− | BadImports (NE.List Import.Error)
56− | BadNames (OneOrMore.OneOrMore Canonicalize.Error)
27+ | Canonicalize Canonicalize.Error
57− | BadTypes L.Localizer (NE.List Type.Error)
28+ | Type L.Localizer [Type.Error]
58− | BadMains L.Localizer (OneOrMore.OneOrMore Main.Error)
29+ | Main L.Localizer Main.Error
59− | BadPatterns (NE.List Pattern.Error)
30+ | Pattern [Pattern.Error]
60− | BadDocs Docs.Error
31+ | Docs Docs.Error
61
32
62
33
63
34
64-- TO REPORT
35-- TO REPORT
65
36
66
37
67−toReports :: Code.Source -> Error -> NE.List Report.Report
38+toReports :: Code.Source -> Error -> [Report.Report]
68toReports source err =
39toReports source err =
69 case err of
40 case err of
70− BadSyntax syntaxError ->
41+ Syntax syntaxError ->
71− NE.List (Syntax.toReport source syntaxError) []
42+ [Syntax.toReport source syntaxError]
72−
73− BadImports errs ->
74− fmap (Import.toReport source) errs
75−
76− BadNames errs ->
77− fmap (Canonicalize.toReport source) (OneOrMore.destruct NE.List errs)
78−
79− BadTypes localizer errs ->
80− fmap (Type.toReport source localizer) errs
81−
82− BadMains localizer errs ->
83− fmap (Main.toReport localizer source) (OneOrMore.destruct NE.List errs)
84−
85− BadPatterns errs ->
86− fmap (Pattern.toReport source) errs
87−
88− BadDocs docsErr ->
89− Docs.toReports source docsErr
90−
91−
92−
93−-- TO DOC
94−
95−
96−toDoc :: FilePath -> Module -> [Module] -> D.Doc
97−toDoc root err errs =
98− let
99− (NE.List m ms) = NE.sortBy _modificationTime (NE.List err errs)
100− in
101− D.vcat (toDocHelp root m ms)
102−
103−
104−toDocHelp :: FilePath -> Module -> [Module] -> [D.Doc]
105−toDocHelp root module1 modules =
106− case modules of
107− [] ->
108− [moduleToDoc root module1
109− ,""
110− ]
111−
112− module2 : otherModules ->
113− moduleToDoc root module1
114− : toSeparator module1 module2
115− : toDocHelp root module2 otherModules
116−
117−
118−toSeparator :: Module -> Module -> D.Doc
119−toSeparator beforeModule afterModule =
120− let
121− before = ModuleName.toChars (_name beforeModule) ++ " ↑ "
122− after = " ↓ " ++ ModuleName.toChars (_name afterModule)
123− in
124− D.dullred $ D.vcat $
125− [ D.indent (80 - length before) (D.fromChars before)
126− , "====o======================================================================o===="
127− , D.fromChars after
128− , ""
129− , ""
130− ]
131−
132−
133−
134−-- MODULE TO DOC
135−
136−
137−moduleToDoc :: FilePath -> Module -> D.Doc
138−moduleToDoc root (Module _ absolutePath _ source err) =
139− let
140− reports =
141− toReports (Code.toSource source) err
142−
143− relativePath =
144− FP.makeRelative root absolutePath
145− in
146− D.vcat $ map (reportToDoc relativePath) (NE.toList reports)
147−
148−
149−reportToDoc :: FilePath -> Report.Report -> D.Doc
150−reportToDoc relativePath (Report.Report title _ _ message) =
151− D.vcat
152− [ toMessageBar title relativePath
153− , ""
154− , message
155− , ""
156− ]
157−
158−
159−toMessageBar :: String -> FilePath -> D.Doc
160−toMessageBar title filePath =
161− let
162− usedSpace =
163− 4 + length title + 1 + length filePath
164− in
165− D.dullcyan $ D.fromChars $
166− "-- " ++ title
167− ++ " " ++ replicate (max 1 (80 - usedSpace)) '-'
168− ++ " " ++ filePath
169
43
44+ Canonicalize canonicalizeError ->
45+ [Canonicalize.toReport source canonicalizeError]
170
46
47+ Type localizer typeErrors ->
48+ map (Type.toReport source localizer) typeErrors
171
49
172−-- TO JSON
50+ Main localizer mainError ->
51+ [Main.toReport localizer source mainError]
173
52
53+ Pattern patternErrors ->
54+ map (Pattern.toReport source) patternErrors
174
55
175−toJson :: Module -> E.Value
56+ Docs docsError ->
176−toJson (Module name path _ source err) =
57+ [Docs.toReport source docsError]
177− let
178− reports =
179− toReports (Code.toSource source) err
180− in
181− E.object
182− [ "path" ==> E.chars path
183− , "name" ==> E.name name
184− , "problems" ==> E.array (map reportToJson (NE.toList reports))
185− ]
186−
187−
188−reportToJson :: Report.Report -> E.Value
189−reportToJson (Report.Report title region _sgstns message) =
190− E.object
191− [ "title" ==> E.chars title
192− , "region" ==> encodeRegion region
193− , "message" ==> D.encode message
194− ]
195−
196−
197−encodeRegion :: A.Region -> E.Value
198−encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
199− E.object
200− [ "start" ==>
201− E.object
202− [ "line" ==> E.int (fromIntegral sr)
203− , "column" ==> E.int (fromIntegral sc)
204− ]
205− , "end" ==>
206− E.object
207− [ "line" ==> E.int (fromIntegral er)
208− , "column" ==> E.int (fromIntegral ec)
209− ]
210− ]
compiler/src/Reporting/Error/Canonicalize.hs+73−74
@@ -14,10 +14,8 @@ module Reporting.Error.Canonicalize
14
14
15
15
16import qualified Data.Char as Char
16import qualified Data.Char as Char
17−import qualified Data.List as List
18import qualified Data.Map as Map
17import qualified Data.Map as Map
19import qualified Data.Name as Name
18import qualified Data.Name as Name
20−import qualified Data.OneOrMore as OneOrMore
21import qualified Data.Set as Set
19import qualified Data.Set as Set
22
20
23import qualified AST.Canonical as Can
21import qualified AST.Canonical as Can
@@ -39,10 +37,10 @@ import qualified Reporting.Suggest as Suggest
39
37
40data Error
38data Error
41 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
39 = AnnotationTooShort A.Region Name.Name Index.ZeroBased Int
42− | AmbiguousVar A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
40+ | AmbiguousVar A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
43− | AmbiguousType A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
41+ | AmbiguousType A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
44− | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
42+ | AmbiguousVariant A.Region (Maybe Name.Name) Name.Name [ModuleName.Canonical]
45− | AmbiguousBinop A.Region Name.Name ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
43+ | AmbiguousBinop A.Region Name.Name [ModuleName.Canonical]
46 | BadArity A.Region BadArityContext Name.Name Int Int
44 | BadArity A.Region BadArityContext Name.Name Int Int
47 | Binop A.Region Name.Name Name.Name
45 | Binop A.Region Name.Name Name.Name
48 | DuplicateDecl Name.Name A.Region A.Region
46 | DuplicateDecl Name.Name A.Region A.Region
@@ -153,7 +151,7 @@ toReport source err =
153 numDefArgs = numTypeArgs + leftovers
151 numDefArgs = numTypeArgs + leftovers
154 in
152 in
155 Report.Report "BAD TYPE ANNOTATION" region [] $
153 Report.Report "BAD TYPE ANNOTATION" region [] $
156− Code.toSnippet source region Nothing
154+ Report.toCodeSnippet source region Nothing
157 (
155 (
158 D.reflow $
156 D.reflow $
159 "The type annotation for `" <> Name.toChars name <> "` says it can accept "
157 "The type annotation for `" <> Name.toChars name <> "` says it can accept "
@@ -166,17 +164,17 @@ toReport source err =
166 <> " be deleted? Maybe some parentheses are missing?"
164 <> " be deleted? Maybe some parentheses are missing?"
167 )
165 )
168
166
169− AmbiguousVar region maybePrefix name h hs ->
167+ AmbiguousVar region maybePrefix name possibleHomes ->
170− ambiguousName source region maybePrefix name h hs "variable"
168+ ambiguousName source region maybePrefix name possibleHomes "variable"
171
169
172− AmbiguousType region maybePrefix name h hs ->
170+ AmbiguousType region maybePrefix name possibleHomes ->
173− ambiguousName source region maybePrefix name h hs "type"
171+ ambiguousName source region maybePrefix name possibleHomes "type"
174
172
175− AmbiguousVariant region maybePrefix name h hs ->
173+ AmbiguousVariant region maybePrefix name possibleHomes ->
176− ambiguousName source region maybePrefix name h hs "variant"
174+ ambiguousName source region maybePrefix name possibleHomes "variant"
177
175
178− AmbiguousBinop region name h hs ->
176+ AmbiguousBinop region name possibleHomes ->
179− ambiguousName source region Nothing name h hs "operator"
177+ ambiguousName source region Nothing name possibleHomes "operator"
180
178
181 BadArity region badArityContext name expected actual ->
179 BadArity region badArityContext name expected actual ->
182 let
180 let
@@ -187,7 +185,7 @@ toReport source err =
187 in
185 in
188 if actual < expected then
186 if actual < expected then
189 Report.Report "TOO FEW ARGS" region [] $
187 Report.Report "TOO FEW ARGS" region [] $
190− Code.toSnippet source region Nothing
188+ Report.toCodeSnippet source region Nothing
191 (
189 (
192 D.reflow $
190 D.reflow $
193 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
191 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
@@ -199,7 +197,7 @@ toReport source err =
199
197
200 else
198 else
201 Report.Report "TOO MANY ARGS" region [] $
199 Report.Report "TOO MANY ARGS" region [] $
202− Code.toSnippet source region Nothing
200+ Report.toCodeSnippet source region Nothing
203 (
201 (
204 D.reflow $
202 D.reflow $
205 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
203 "The `" <> Name.toChars name <> "` " <> thing <> " needs "
@@ -213,7 +211,7 @@ toReport source err =
213
211
214 Binop region op1 op2 ->
212 Binop region op1 op2 ->
215 Report.Report "INFIX PROBLEM" region [] $
213 Report.Report "INFIX PROBLEM" region [] $
216− Code.toSnippet source region Nothing
214+ Report.toCodeSnippet source region Nothing
217 (
215 (
218 D.reflow $
216 D.reflow $
219 "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses."
217 "You cannot mix (" <> Name.toChars op1 <> ") and (" <> Name.toChars op2 <> ") without parentheses."
@@ -244,11 +242,11 @@ toReport source err =
244
242
245 DuplicateAliasArg typeName name r1 r2 ->
243 DuplicateAliasArg typeName name r1 r2 ->
246 nameClash source r1 r2 $
244 nameClash source r1 r2 $
247− "The `" <> Name.toChars typeName <> "` type alias has multiple `" <> Name.toChars name <> "` type variables."
245+ "The `" <> Name.toChars typeName <> "` type alias has multilpe `" <> Name.toChars name <> "` type variables."
248
246
249 DuplicateUnionArg typeName name r1 r2 ->
247 DuplicateUnionArg typeName name r1 r2 ->
250 nameClash source r1 r2 $
248 nameClash source r1 r2 $
251− "The `" <> Name.toChars typeName <> "` type has multiple `" <> Name.toChars name <> "` type variables."
249+ "The `" <> Name.toChars typeName <> "` type has multilpe `" <> Name.toChars name <> "` type variables."
252
250
253 DuplicatePattern context name r1 r2 ->
251 DuplicatePattern context name r1 r2 ->
254 nameClash source r1 r2 $
252 nameClash source r1 r2 $
@@ -270,18 +268,18 @@ toReport source err =
270
268
271 EffectNotFound region name ->
269 EffectNotFound region name ->
272 Report.Report "EFFECT PROBLEM" region [] $
270 Report.Report "EFFECT PROBLEM" region [] $
273− Code.toSnippet source region Nothing
271+ Report.toCodeSnippet source region Nothing
274 (
272 (
275 D.reflow $
273 D.reflow $
276 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
274 "You have declared that `" ++ Name.toChars name ++ "` is an effect type:"
277 ,
275 ,
278 D.reflow $
276 D.reflow $
279− "But I cannot find a custom type named `" ++ Name.toChars name ++ "` in this file!"
277+ "But I cannot find a union type named `" ++ Name.toChars name ++ "` in this file!"
280 )
278 )
281
279
282 EffectFunctionNotFound region name ->
280 EffectFunctionNotFound region name ->
283 Report.Report "EFFECT PROBLEM" region [] $
281 Report.Report "EFFECT PROBLEM" region [] $
284− Code.toSnippet source region Nothing
282+ Report.toCodeSnippet source region Nothing
285 (
283 (
286 D.reflow $
284 D.reflow $
287 "This kind of effect module must define a `" ++ Name.toChars name ++ "` function."
285 "This kind of effect module must define a `" ++ Name.toChars name ++ "` function."
@@ -297,7 +295,7 @@ toReport source err =
297 "You are trying to expose `" <> Name.toChars name <> "` multiple times!"
295 "You are trying to expose `" <> Name.toChars name <> "` multiple times!"
298 in
296 in
299 Report.Report "REDUNDANT EXPORT" r2 [] $
297 Report.Report "REDUNDANT EXPORT" r2 [] $
300− Code.toPair source r1 r2
298+ Report.toCodePair source r1 r2
301 (
299 (
302 D.reflow messageThatEndsWithPunctuation
300 D.reflow messageThatEndsWithPunctuation
303 ,
301 ,
@@ -341,10 +339,10 @@ toReport source err =
341
339
342 ExportOpenAlias region name ->
340 ExportOpenAlias region name ->
343 Report.Report "BAD EXPORT" region [] $
341 Report.Report "BAD EXPORT" region [] $
344− Code.toSnippet source region Nothing
342+ Report.toCodeSnippet source region Nothing
345 (
343 (
346 D.reflow $
344 D.reflow $
347− "The (..) syntax is for exposing variants of a custom type. It cannot be used with a type alias like `"
345+ "The (..) syntax is for exposing union type constructors. It cannot be used with a type alias like `"
348 ++ Name.toChars name ++ "` though."
346 ++ Name.toChars name ++ "` though."
349 ,
347 ,
350 D.reflow $
348 D.reflow $
@@ -353,16 +351,16 @@ toReport source err =
353
351
354 ImportCtorByName region ctor tipe ->
352 ImportCtorByName region ctor tipe ->
355 Report.Report "BAD IMPORT" region [] $
353 Report.Report "BAD IMPORT" region [] $
356− Code.toSnippet source region Nothing
354+ Report.toCodeSnippet source region Nothing
357 (
355 (
358 D.reflow $
356 D.reflow $
359 "You are trying to import the `" <> Name.toChars ctor
357 "You are trying to import the `" <> Name.toChars ctor
360− <> "` variant by name:"
358+ <> "` type constructor by name:"
361 ,
359 ,
362 D.fillSep
360 D.fillSep
363 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
361 ["Try","importing",D.green (D.fromName tipe <> "(..)"),"instead."
364 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
362 ,"The","dots","mean","“expose","the",D.fromName tipe,"type","and"
365− ,"all","its","variants","so","it","gives","you","access","to"
363+ ,"all","its","constructors”","so","it","gives","you","access","to"
366 , D.fromName ctor <> "."
364 , D.fromName ctor <> "."
367 ]
365 ]
368 )
366 )
@@ -373,7 +371,7 @@ toReport source err =
373 -- So this error should never actually get printed out.
371 -- So this error should never actually get printed out.
374 --
372 --
375 Report.Report "UNKNOWN IMPORT" region [] $
373 Report.Report "UNKNOWN IMPORT" region [] $
376− Code.toSnippet source region Nothing
374+ Report.toCodeSnippet source region Nothing
377 (
375 (
378 D.reflow $
376 D.reflow $
379 "I could not find a `" <> Name.toChars name <> "` module to import!"
377 "I could not find a `" <> Name.toChars name <> "` module to import!"
@@ -383,13 +381,18 @@ toReport source err =
383
381
384 ImportOpenAlias region name ->
382 ImportOpenAlias region name ->
385 Report.Report "BAD IMPORT" region [] $
383 Report.Report "BAD IMPORT" region [] $
386− Code.toSnippet source region Nothing
384+ Report.toCodeSnippet source region Nothing
387 (
385 (
388 D.reflow $
386 D.reflow $
389 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
387 "The `" <> Name.toChars name <> "` type alias cannot be followed by (..) like this:"
390 ,
388 ,
391− D.reflow $
389+ D.stack
392− "Remove the (..) and it should work."
390+ [ "Remove the (..) and it should work."
391+ , D.link "Hint"
392+ "The distinction between `type` and `type alias` is important here. Read"
393+ "types-vs-type-aliases"
394+ "to learn more."
395+ ]
393 )
396 )
394
397
395 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
398 ImportExposingNotFound region (ModuleName.Canonical _ home) value possibleNames ->
@@ -399,7 +402,7 @@ toReport source err =
399 Suggest.sort (Name.toChars home) Name.toChars possibleNames
402 Suggest.sort (Name.toChars home) Name.toChars possibleNames
400 in
403 in
401 Report.Report "BAD IMPORT" region suggestions $
404 Report.Report "BAD IMPORT" region suggestions $
402− Code.toSnippet source region Nothing
405+ Report.toCodeSnippet source region Nothing
403 (
406 (
404 D.reflow $
407 D.reflow $
405 "The `" <> Name.toChars home
408 "The `" <> Name.toChars home
@@ -432,7 +435,7 @@ toReport source err =
432 NotFoundBinop region op locals ->
435 NotFoundBinop region op locals ->
433 if op == "===" then
436 if op == "===" then
434 Report.Report "UNKNOWN OPERATOR" region ["=="] $
437 Report.Report "UNKNOWN OPERATOR" region ["=="] $
435− Code.toSnippet source region Nothing
438+ Report.toCodeSnippet source region Nothing
436 (
439 (
437 "Elm does not have a (===) operator like JavaScript."
440 "Elm does not have a (===) operator like JavaScript."
438 ,
441 ,
@@ -441,7 +444,7 @@ toReport source err =
441
444
442 else if op == "!=" || op == "!==" then
445 else if op == "!=" || op == "!==" then
443 Report.Report "UNKNOWN OPERATOR" region ["/="] $
446 Report.Report "UNKNOWN OPERATOR" region ["/="] $
444− Code.toSnippet source region Nothing
447+ Report.toCodeSnippet source region Nothing
445 (
448 (
446 D.reflow $
449 D.reflow $
447 "Elm uses a different name for the “not equal” operator:"
450 "Elm uses a different name for the “not equal” operator:"
@@ -456,7 +459,7 @@ toReport source err =
456
459
457 else if op == "**" then
460 else if op == "**" then
458 Report.Report "UNKNOWN OPERATOR" region ["^","*"] $
461 Report.Report "UNKNOWN OPERATOR" region ["^","*"] $
459− Code.toSnippet source region Nothing
462+ Report.toCodeSnippet source region Nothing
460 (
463 (
461 D.reflow $
464 D.reflow $
462 "I do not recognize the (**) operator:"
465 "I do not recognize the (**) operator:"
@@ -467,7 +470,7 @@ toReport source err =
467
470
468 else if op == "%" then
471 else if op == "%" then
469 Report.Report "UNKNOWN OPERATOR" region [] $
472 Report.Report "UNKNOWN OPERATOR" region [] $
470− Code.toSnippet source region Nothing
473+ Report.toCodeSnippet source region Nothing
471 (
474 (
472 D.reflow $
475 D.reflow $
473 "Elm does not use (%) as the remainder operator:"
476 "Elm does not use (%) as the remainder operator:"
@@ -494,7 +497,7 @@ toReport source err =
494 D.green $ "(" <> altOp <> ")"
497 D.green $ "(" <> altOp <> ")"
495 in
498 in
496 Report.Report "UNKNOWN OPERATOR" region suggestions $
499 Report.Report "UNKNOWN OPERATOR" region suggestions $
497− Code.toSnippet source region Nothing
500+ Report.toCodeSnippet source region Nothing
498 (
501 (
499 D.reflow $
502 D.reflow $
500 "I do not recognize the (" ++ Name.toChars op ++ ") operator."
503 "I do not recognize the (" ++ Name.toChars op ++ ") operator."
@@ -512,21 +515,21 @@ toReport source err =
512
515
513 PatternHasRecordCtor region name ->
516 PatternHasRecordCtor region name ->
514 Report.Report "BAD PATTERN" region [] $
517 Report.Report "BAD PATTERN" region [] $
515− Code.toSnippet source region Nothing
518+ Report.toCodeSnippet source region Nothing
516 (
519 (
517 D.reflow $
520 D.reflow $
518 "You can construct records by using `" <> Name.toChars name
521 "You can construct records by using `" <> Name.toChars name
519 <> "` as a function, but it is not available in pattern matching like this:"
522 <> "` as a function, but it is not available in pattern matching like this:"
520 ,
523 ,
521 D.reflow $
524 D.reflow $
522− "I recommend matching the record as a variable and unpacking it later."
525+ "I recommend matching matching the record as a variable and unpacking it later."
523 )
526 )
524
527
525 PortPayloadInvalid region portName _badType invalidPayload ->
528 PortPayloadInvalid region portName _badType invalidPayload ->
526 let
529 let
527 formatDetails (aBadKindOfThing, elaboration) =
530 formatDetails (aBadKindOfThing, elaboration) =
528 Report.Report "PORT ERROR" region [] $
531 Report.Report "PORT ERROR" region [] $
529− Code.toSnippet source region Nothing
532+ Report.toCodeSnippet source region Nothing
530 (
533 (
531 D.reflow $
534 D.reflow $
532 "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":"
535 "The `" <> Name.toChars portName <> "` port is trying to transmit " <> aBadKindOfThing <> ":"
@@ -592,7 +595,7 @@ toReport source err =
592 let
595 let
593 formatDetails (before, after) =
596 formatDetails (before, after) =
594 Report.Report "BAD PORT" region [] $
597 Report.Report "BAD PORT" region [] $
595− Code.toSnippet source region Nothing $
598+ Report.toCodeSnippet source region Nothing $
596 (
599 (
597 D.reflow before
600 D.reflow before
598 ,
601 ,
@@ -671,7 +674,7 @@ toReport source err =
671 D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
674 D.fillSep $ map (D.dullyellow . D.fromChars) (words question) ++ map D.fromChars (words details)
672 in
675 in
673 Report.Report "CYCLIC DEFINITION" region [] $
676 Report.Report "CYCLIC DEFINITION" region [] $
674− Code.toSnippet source region Nothing $
677+ Report.toCodeSnippet source region Nothing $
675 case names of
678 case names of
676 [] ->
679 [] ->
677 (
680 (
@@ -679,7 +682,7 @@ toReport source err =
679 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
682 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
680 ,
683 ,
681 D.stack
684 D.stack
682− [ makeTheory "Are you trying to mutate a variable?" $
685+ [ makeTheory "Are you are trying to mutate a variable?" $
683 "Elm does not have mutation, so when I see " ++ Name.toChars name
686 "Elm does not have mutation, so when I see " ++ Name.toChars name
684 ++ " defined in terms of " ++ Name.toChars name
687 ++ " defined in terms of " ++ Name.toChars name
685 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
688 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -713,7 +716,7 @@ toReport source err =
713
716
714 RecursiveLet (A.At region name) names ->
717 RecursiveLet (A.At region name) names ->
715 Report.Report "CYCLIC VALUE" region [] $
718 Report.Report "CYCLIC VALUE" region [] $
716− Code.toSnippet source region Nothing $
719+ Report.toCodeSnippet source region Nothing $
717 case names of
720 case names of
718 [] ->
721 [] ->
719 let
722 let
@@ -725,7 +728,7 @@ toReport source err =
725 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
728 "The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop."
726 ,
729 ,
727 D.stack
730 D.stack
728− [ makeTheory "Are you trying to mutate a variable?" $
731+ [ makeTheory "Are you are trying to mutate a variable?" $
729 "Elm does not have mutation, so when I see " ++ Name.toChars name
732 "Elm does not have mutation, so when I see " ++ Name.toChars name
730 ++ " defined in terms of " ++ Name.toChars name
733 ++ " defined in terms of " ++ Name.toChars name
731 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
734 ++ ", I treat it as a recursive definition. Try giving the new value a new name!"
@@ -759,7 +762,7 @@ toReport source err =
759
762
760 Shadowing name r1 r2 ->
763 Shadowing name r1 r2 ->
761 Report.Report "SHADOWING" r2 [] $
764 Report.Report "SHADOWING" r2 [] $
762− Code.toPair source r1 r2
765+ Report.toCodePair source r1 r2
763 ( "These variables cannot have the same name:"
766 ( "These variables cannot have the same name:"
764 , advice
767 , advice
765 )
768 )
@@ -780,7 +783,7 @@ toReport source err =
780
783
781 TupleLargerThanThree region ->
784 TupleLargerThanThree region ->
782 Report.Report "BAD TUPLE" region [] $
785 Report.Report "BAD TUPLE" region [] $
783− Code.toSnippet source region Nothing
786+ Report.toCodeSnippet source region Nothing
784 (
787 (
785 "I only accept tuples with two or three items. This has too many:"
788 "I only accept tuples with two or three items. This has too many:"
786 ,
789 ,
@@ -829,7 +832,7 @@ toReport source err =
829 )
832 )
830 in
833 in
831 Report.Report title aliasRegion [] $
834 Report.Report title aliasRegion [] $
832− Code.toSnippet source aliasRegion subRegion
835+ Report.toCodeSnippet source aliasRegion subRegion
833 (
836 (
834 D.fillSep overview
837 D.fillSep overview
835 ,
838 ,
@@ -882,7 +885,7 @@ toReport source err =
882
885
883 in
886 in
884 Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $
887 Report.Report "TYPE VARIABLE PROBLEMS" aliasRegion [] $
885− Code.toSnippet source aliasRegion Nothing
888+ Report.toCodeSnippet source aliasRegion Nothing
886 (
889 (
887 D.reflow $
890 D.reflow $
888 "Type alias `" <> Name.toChars typeName <> "` has some type variable problems."
891 "Type alias `" <> Name.toChars typeName <> "` has some type variable problems."
@@ -929,7 +932,7 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
929 )
932 )
930 in
933 in
931 Report.Report title declRegion [] $
934 Report.Report title declRegion [] $
932− Code.toSnippet source declRegion subRegion
935+ Report.toCodeSnippet source declRegion subRegion
933 (
936 (
934 D.fillSep overview
937 D.fillSep overview
935 ,
938 ,
@@ -957,7 +960,7 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
957nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report
960nameClash :: Code.Source -> A.Region -> A.Region -> String -> Report.Report
958nameClash source r1 r2 messageThatEndsWithPunctuation =
961nameClash source r1 r2 messageThatEndsWithPunctuation =
959 Report.Report "NAME CLASH" r2 [] $
962 Report.Report "NAME CLASH" r2 [] $
960− Code.toPair source r1 r2
963+ Report.toCodePair source r1 r2
961 (
964 (
962 D.reflow messageThatEndsWithPunctuation
965 D.reflow messageThatEndsWithPunctuation
963 ,
966 ,
@@ -976,32 +979,28 @@ nameClash source r1 r2 messageThatEndsWithPunctuation =
976-- AMBIGUOUS NAME
979-- AMBIGUOUS NAME
977
980
978
981
979−ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> ModuleName.Canonical -> OneOrMore.OneOrMore ModuleName.Canonical -> String -> Report.Report
982+ambiguousName :: Code.Source -> A.Region -> Maybe Name.Name -> Name.Name -> [ModuleName.Canonical] -> String -> Report.Report
980−ambiguousName source region maybePrefix name h hs thing =
983+ambiguousName source region maybePrefix name possibleHomes thing =
981− let
982− possibleHomes = List.sort (h : OneOrMore.destruct (:) hs)
983− in
984 Report.Report "AMBIGUOUS NAME" region [] $
984 Report.Report "AMBIGUOUS NAME" region [] $
985− Code.toSnippet source region Nothing $
985+ Report.toCodeSnippet source region Nothing $
986 case maybePrefix of
986 case maybePrefix of
987 Nothing ->
987 Nothing ->
988 let
988 let
989 homeToYellowDoc (ModuleName.Canonical _ home) =
989 homeToYellowDoc (ModuleName.Canonical _ home) =
990− D.dullyellow (D.fromName home <> "." <> D.fromName name)
990+ D.dullyellow (D.fromName home)
991+
992+ bothOrAll =
993+ if length possibleHomes == 2 then "both" else "all"
991 in
994 in
992 (
995 (
993− D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:"
996+ D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous."
994 ,
997 ,
995 D.stack
998 D.stack
996 [ D.reflow $
999 [ D.reflow $
997− "This name is exposed by " ++ show (length possibleHomes) ++ " of your imports, so I am not\
1000+ "Check your imports. The following modules " ++ bothOrAll
998− \ sure which one to use:"
1001+ ++ " expose a `" ++ Name.toChars name ++ "` " ++ thing ++ ":"
999 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
1002 , D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes
1000− , D.reflow $
1003+ , D.reflowLink "Read" "imports" "to learn how to clarify which one you want."
1001− "I recommend using qualified names for imported values. I also recommend having\
1002− \ at most one `exposing (..)` per file to make name clashes like this less common\
1003− \ in the long run."
1004− , D.link "Note" "Check out" "imports" "for more info on the import syntax."
1005 ]
1004 ]
1006 )
1005 )
1007
1006
@@ -1009,9 +1008,9 @@ ambiguousName source region maybePrefix name h hs thing =
1009 let
1008 let
1010 homeToYellowDoc (ModuleName.Canonical _ home) =
1009 homeToYellowDoc (ModuleName.Canonical _ home) =
1011 if prefix == home then
1010 if prefix == home then
1012− D.cyan "import" <+> D.fromName home
1011+ D.blue "import" <+> D.dullyellow (D.fromName home)
1013 else
1012 else
1014− D.cyan "import" <+> D.fromName home <+> D.cyan "as" <+> D.fromName prefix
1013+ D.blue "import" <+> D.dullyellow (D.fromName home) <+> D.blue "as" <+> D.dullyellow (D.fromName prefix)
1015
1014
1016 eitherOrAny =
1015 eitherOrAny =
1017 if length possibleHomes == 2 then "either" else "any"
1016 if length possibleHomes == 2 then "either" else "any"
@@ -1066,7 +1065,7 @@ notFound source region maybePrefix name thing (PossibleNames locals quals) =
1066
1065
1067 in
1066 in
1068 Report.Report "NAMING ERROR" region nearbyNames $
1067 Report.Report "NAMING ERROR" region nearbyNames $
1069− Code.toSnippet source region Nothing
1068+ Report.toCodeSnippet source region Nothing
1070 (
1069 (
1071 D.reflow $
1070 D.reflow $
1072 "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":"
1071 "I cannot find a `" ++ givenName ++ "` " ++ thing ++ ":"
@@ -1196,7 +1195,7 @@ _argMismatchReport source region kind name expected actual =
1196 <> " arguments"
1195 <> " arguments"
1197 in
1196 in
1198 Report.Report (map Char.toUpper numArgs) region [] $
1197 Report.Report (map Char.toUpper numArgs) region [] $
1199− Code.toSnippet source region Nothing
1198+ Report.toCodeSnippet source region Nothing
1200 (
1199 (
1201 D.reflow $
1200 D.reflow $
1202 kind <> " " <> Name.toChars name <> " has " <> numArgs <> "."
1201 kind <> " " <> Name.toChars name <> " has " <> numArgs <> "."
@@ -1215,7 +1214,7 @@ aliasRecursionReport source region name args tipe others =
1215 case others of
1214 case others of
1216 [] ->
1215 [] ->
1217 Report.Report "ALIAS PROBLEM" region [] $
1216 Report.Report "ALIAS PROBLEM" region [] $
1218− Code.toSnippet source region Nothing
1217+ Report.toCodeSnippet source region Nothing
1219 (
1218 (
1220 "This type alias is recursive, forming an infinite type!"
1219 "This type alias is recursive, forming an infinite type!"
1221 ,
1220 ,
@@ -1234,7 +1233,7 @@ aliasRecursionReport source region name args tipe others =
1234
1233
1235 _ ->
1234 _ ->
1236 Report.Report "ALIAS PROBLEM" region [] $
1235 Report.Report "ALIAS PROBLEM" region [] $
1237− Code.toSnippet source region Nothing
1236+ Report.toCodeSnippet source region Nothing
1238 (
1237 (
1239 "This type alias is part of a mutually recursive set of type aliases."
1238 "This type alias is part of a mutually recursive set of type aliases."
1240 ,
1239 ,
compiler/src/Reporting/Error/Docs.hs+23−132
@@ -2,24 +2,17 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Docs
3module Reporting.Error.Docs
4 ( Error(..)
4 ( Error(..)
5− , SyntaxProblem(..)
5+ , toReport
6− , NameProblem(..)
7− , DefProblem(..)
8− , toReports
9 )
6 )
10 where
7 where
11
8
12
9
13import qualified Data.Name as Name
10import qualified Data.Name as Name
14−import qualified Data.NonEmptyList as NE
15
11
16−import Parse.Primitives (Row, Col)
17−import Parse.Symbol (BadOperator(..))
18import qualified Reporting.Annotation as A
12import qualified Reporting.Annotation as A
19import Reporting.Doc ((<>))
13import Reporting.Doc ((<>))
20import qualified Reporting.Doc as D
14import qualified Reporting.Doc as D
21import qualified Reporting.Render.Code as Code
15import qualified Reporting.Render.Code as Code
22−import qualified Reporting.Error.Syntax as E
23import qualified Reporting.Report as Report
16import qualified Reporting.Report as Report
24
17
25
18
@@ -27,56 +20,36 @@ import qualified Reporting.Report as Report
27data Error
20data Error
28 = NoDocs A.Region
21 = NoDocs A.Region
29 | ImplicitExposing A.Region
22 | 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
45− = NameDuplicate Name.Name A.Region A.Region
23+ | Duplicate Name.Name A.Region A.Region
46− | NameOnlyInDocs Name.Name A.Region
24+ | OnlyInDocs Name.Name A.Region
47− | NameOnlyInExports Name.Name A.Region
25+ | OnlyInExports Name.Name A.Region
48−
49−
50−data DefProblem
51− = NoComment Name.Name A.Region
26+ | NoComment Name.Name A.Region
52 | NoAnnotation Name.Name A.Region
27 | NoAnnotation Name.Name A.Region
53
28
54
29
55
30
56−-- TO REPORTS
31+-- TO REPORT
57
32
58
33
59−toReports :: Code.Source -> Error -> NE.List Report.Report
34+toReport :: Code.Source -> Error -> Report.Report
60−toReports source err =
35+toReport source err =
61 case err of
36 case err of
62 NoDocs region ->
37 NoDocs region ->
63− NE.singleton $
64 Report.Report "NO DOCS" region [] $
38 Report.Report "NO DOCS" region [] $
65− Code.toSnippet source region Nothing
39+ D.stack
66− (
40+ [
67 D.reflow $
41 D.reflow $
68 "You must have a documentation comment between the module\
42 "You must have a documentation comment between the module\
69 \ declaration and the imports."
43 \ declaration and the imports."
70 ,
44 ,
71 D.reflow
45 D.reflow
72− "Learn more at <https://package.elm-lang.org/help/documentation-format>"
46+ "Learn more at <http://package.elm-lang.org/help/documentation-format>"
73− )
47+ ]
74
48
75 ImplicitExposing region ->
49 ImplicitExposing region ->
76− NE.singleton $
77 Report.Report "IMPLICIT EXPOSING" region [] $
50 Report.Report "IMPLICIT EXPOSING" region [] $
78− Code.toSnippet source region Nothing
51+ D.stack
79− (
52+ [
80 D.reflow $
53 D.reflow $
81 "I need you to be explicit about what this module exposes:"
54 "I need you to be explicit about what this module exposes:"
82 ,
55 ,
@@ -86,85 +59,11 @@ toReports source err =
86 \ to be explicit about this is a way of adding another quality check before\
59 \ to be explicit about this is a way of adding another quality check before\
87 \ code gets published. So as you write out the public API, ask yourself if\
60 \ code gets published. So as you write out the public API, ask yourself if\
88 \ it will be easy to understand as people read the documentation!"
61 \ it will be easy to understand as people read the documentation!"
89− )
62+ ]
90−
91− SyntaxProblem problem ->
92− NE.singleton $
93− toSyntaxProblemReport source problem
94−
95− NameProblems problems ->
96− fmap (toNameProblemReport source) problems
97−
98− DefProblems problems ->
99− fmap (toDefProblemReport source) problems
100−
101
63
102−
64+ Duplicate name r1 r2 ->
103−-- SYNTAX PROBLEM
104−
105−
106−toSyntaxProblemReport :: Code.Source -> SyntaxProblem -> Report.Report
107−toSyntaxProblemReport source problem =
108− let
109− toSyntaxReport row col details =
110− let
111− region = toRegion row col
112− in
113− Report.Report "PROBLEM IN DOCS" region [] $
114− Code.toSnippet source region Nothing
115− ( D.reflow "I was partway through parsing your module documentation, but I got stuck here:"
116− , D.stack $
117− [ D.reflow details
118− , D.toSimpleHint $
119− "Read through <https://package.elm-lang.org/help/documentation-format> for\
120− \ tips on how to write module documentation!"
121− ]
122− )
123− in
124− case problem of
125− Op row col ->
126− toSyntaxReport row col $
127− "I am trying to parse an operator like (+) or (*) but something is going wrong."
128−
129− OpBad _ row col ->
130− toSyntaxReport row col $
131− "I am trying to parse an operator like (+) or (*) but it looks like you are using\
132− \ a reserved symbol in this case."
133−
134− Name row col ->
135− toSyntaxReport row col $
136− "I was expecting to see the name of another exposed value from this module."
137−
138− Space space row col ->
139− E.toSpaceReport source space row col
140−
141− Comma row col ->
142− toSyntaxReport row col $
143− "I was expecting to see a comma next."
144−
145− BadEnd row col ->
146− toSyntaxReport row col $
147− "I am not really sure what I am getting stuck on though."
148−
149−
150−toRegion :: Row -> Col -> A.Region
151−toRegion row col =
152− let
153− pos = A.Position row col
154− in
155− A.Region pos pos
156−
157−
158−
159−-- NAME PROBLEM
160−
161−
162−toNameProblemReport :: Code.Source -> NameProblem -> Report.Report
163−toNameProblemReport source problem =
164− case problem of
165− NameDuplicate name r1 r2 ->
166 Report.Report "DUPLICATE DOCS" r2 [] $
65 Report.Report "DUPLICATE DOCS" r2 [] $
167− Code.toPair source r1 r2
66+ Report.toCodePair source r1 r2
168 (
67 (
169 D.reflow $
68 D.reflow $
170 "There can only be one `" <> Name.toChars name
69 "There can only be one `" <> Name.toChars name
@@ -182,9 +81,9 @@ toNameProblemReport source problem =
182 "Remove one of them!"
81 "Remove one of them!"
183 )
82 )
184
83
185− NameOnlyInDocs name region ->
84+ OnlyInDocs name region ->
186 Report.Report "DOCS MISTAKE" region [] $
85 Report.Report "DOCS MISTAKE" region [] $
187− Code.toSnippet source region Nothing
86+ Report.toCodeSnippet source region Nothing
188 (
87 (
189 D.reflow $
88 D.reflow $
190 "I do not see `" <> Name.toChars name
89 "I do not see `" <> Name.toChars name
@@ -195,9 +94,9 @@ toNameProblemReport source problem =
195 <> Name.toChars name <> "` and forgot to delete it here?"
94 <> Name.toChars name <> "` and forgot to delete it here?"
196 )
95 )
197
96
198− NameOnlyInExports name region ->
97+ OnlyInExports name region ->
199 Report.Report "DOCS MISTAKE" region [] $
98 Report.Report "DOCS MISTAKE" region [] $
200− Code.toSnippet source region Nothing
99+ Report.toCodeSnippet source region Nothing
201 (
100 (
202 D.reflow $
101 D.reflow $
203 "I do not see `" <> Name.toChars name
102 "I do not see `" <> Name.toChars name
@@ -211,17 +110,9 @@ toNameProblemReport source problem =
211 ]
110 ]
212 )
111 )
213
112
214−
215−
216−-- DEF PROBLEM
217−
218−
219−toDefProblemReport :: Code.Source -> DefProblem -> Report.Report
220−toDefProblemReport source problem =
221− case problem of
222 NoComment name region ->
113 NoComment name region ->
223 Report.Report "NO DOCS" region [] $
114 Report.Report "NO DOCS" region [] $
224− Code.toSnippet source region Nothing
115+ Report.toCodeSnippet source region Nothing
225 (
116 (
226 D.reflow $
117 D.reflow $
227 "The `" <> Name.toChars name <> "` definition does not have a documentation comment."
118 "The `" <> Name.toChars name <> "` definition does not have a documentation comment."
@@ -235,7 +126,7 @@ toDefProblemReport source problem =
235
126
236 NoAnnotation name region ->
127 NoAnnotation name region ->
237 Report.Report "NO TYPE ANNOTATION" region [] $
128 Report.Report "NO TYPE ANNOTATION" region [] $
238− Code.toSnippet source region Nothing
129+ Report.toCodeSnippet source region Nothing
239 (
130 (
240 D.reflow $
131 D.reflow $
241 "The `" <> Name.toChars name <> "` definition does not have a type annotation."
132 "The `" <> Name.toChars name <> "` definition does not have a type annotation."
compiler/src/Reporting/Error/Import.hsdeleted−162
@@ -1,162 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Error.Import
3− ( Error(..)
4− , Problem(..)
5− , toReport
6− )
7− where
8−
9−
10−import qualified Data.Map as Map
11−import qualified Data.Set as Set
12−
13−import qualified Elm.ModuleName as ModuleName
14−import qualified Elm.Package as Pkg
15−import qualified Reporting.Doc as D
16−import qualified Reporting.Render.Code as Code
17−import qualified Reporting.Report as Report
18−import qualified Reporting.Suggest as Suggest
19−import qualified Reporting.Annotation as A
20−
21−
22−
23−-- ERROR
24−
25−
26−data Error =
27− Error
28− { _region :: A.Region
29− , _import :: ModuleName.Raw
30− , _unimported :: Set.Set ModuleName.Raw
31− , _problem :: Problem
32− }
33−
34−
35−data Problem
36− = NotFound
37− | Ambiguous FilePath [FilePath] Pkg.Name [Pkg.Name]
38− | AmbiguousLocal FilePath FilePath [FilePath]
39− | AmbiguousForeign Pkg.Name Pkg.Name [Pkg.Name]
40−
41−
42−
43−-- TO REPORT
44−
45−
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+270−280
@@ -1,344 +1,334 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Json
3module Reporting.Error.Json
4− ( toReport
4+ ( Error(..)
5− , FailureToReport(..)
5+ , Problem(..)
6+ , DecodeExpectation(..)
7+ , ParseExpectation(..)
6 , Context(..)
8 , Context(..)
7− , Reason(..)
9+ , toReport
8 )
10 )
9 where
11 where
10
12
11
13
12−import qualified Data.ByteString as BS
14+import qualified Data.Utf8 as Utf8
13−import qualified Data.ByteString.UTF8 as BS_UTF8
15+import Data.Word (Word16)
14−import qualified Data.NonEmptyList as NE
15
16
16−import Json.Decode (Error(..), Problem(..), DecodeExpectation(..), ParseError(..), StringProblem(..))
17+import qualified Parse.Primitives as P
17−import qualified Reporting.Annotation as A
18+import qualified Reporting.Report as Report
18−import qualified Reporting.Doc as D
19−import qualified Reporting.Exit.Help as Help
20−import qualified Reporting.Render.Code as Code
21
19
22
20
23
21
24−-- TO REPORT
22+-- ERROR
25
23
26
24
27−toReport :: FilePath -> FailureToReport x -> Error x -> Reason -> Help.Report
25+data Error e
28−toReport path ftr err reason =
26+ = DecodeProblem (Problem e)
29− case err of
27+ | ParseProblem Word16 Word16 (P.Context Context) ParseExpectation
30− DecodeProblem bytes problem ->
31− problemToReport path ftr (Code.toSource bytes) CRoot problem reason
32
28
33− ParseProblem bytes parseError ->
34− parseErrorToReport path (Code.toSource bytes) parseError reason
35
29
36
30
37−newtype Reason =
31+-- DECODE PROBLEMS
38− ExplicitReason String
39
32
40
33
41−because :: Reason -> String -> String
34+data Problem e
42−because (ExplicitReason iNeedThings) problem =
35+ = Field Utf8.String (Problem e)
43− iNeedThings ++ " " ++ problem
36+ | Index Int (Problem e)
37+ | OneOf (Problem e) [Problem e]
38+ | Failure e
39+ | Expecting DecodeExpectation
44
40
45
41
42+data DecodeExpectation
43+ = TObject
44+ | TArray
45+ | TString
46+ | TBool
47+ | TInt
48+ | TObjectWith Utf8.String
49+ | TArrayPair Int
46
50
47−-- PARSE ERROR TO REPORT
48
51
49
52
50−parseErrorToReport :: FilePath -> Code.Source -> ParseError -> Reason -> Help.Report
53+-- PARSE EXPECTATION
51−parseErrorToReport path source parseError reason =
52− let
53− toSnippet title row col (problem, details) =
54− let
55− pos = A.Position row col
56− surroundings = A.Region (A.Position (max 1 (row - 2)) 1) pos
57− region = A.Region pos pos
58− in
59− Help.jsonReport title (Just path) $
60− Code.toSnippet source surroundings (Just region)
61− ( D.reflow (because reason problem)
62− , details
63− )
64− in
65− case parseError of
66− Start row col ->
67− toSnippet "EXPECTING A VALUE" row col
68− (
69− "I was expecting to see a JSON value next:"
70− ,
71− D.stack
72− [ D.fillSep
73− ["Try","something","like",D.dullyellow "\"this\"","or"
74− ,D.dullyellow "42","to","move","on","to","better","hints!"
75− ]
76− , D.toSimpleNote $
77− "The JSON specification does not allow trailing commas, so you can sometimes\
78− \ get this error in arrays that have an extra comma at the end. In that case,\
79− \ remove that last comma or add another array entry after it!"
80− ]
81− )
82
54
83− ObjectField row col ->
84− toSnippet "EXTRA COMMA" row col
85− (
86− "I was partway through parsing a JSON object when I got stuck here:"
87− ,
88− D.stack
89− [ D.fillSep
90− ["I","saw","a","comma","right","before","I","got","stuck","here,"
91− ,"so","I","was","expecting","to","see","a","field","name","like"
92− ,D.dullyellow "\"type\"","or",D.dullyellow "\"dependencies\"","next."
93− ]
94− , D.reflow $
95− "This error is commonly caused by trailing commas in JSON objects. Those are\
96− \ actually disallowed by <https://json.org> so check the previous line for a\
97− \ trailing comma that may need to be deleted."
98− , objectNote
99− ]
100− )
101
55
102− ObjectColon row col ->
56+data ParseExpectation
103− toSnippet "EXPECTING COLON" row col
57+ = ObjectStart
104− (
58+ | ObjectMore
105− "I was partway through parsing a JSON object when I got stuck here:"
59+ | ObjectEnd
106− ,
60+ | ArrayStart
107− D.stack
61+ | ArrayMore
108− [ D.reflow $ "I was expecting to see a colon next."
62+ | ArrayEnd
109− , objectNote
63+ | StringStart
110− ]
64+ | StringEnd
111− )
65+ | IntStart
66+ | NoLeadingZeros
67+ | NoFloats
68+ | Bool
69+ | Null
70+ | Value
71+ | Colon
72+ | EndOfFile
112
73
113− ObjectEnd row col ->
74+
114− toSnippet "UNFINISHED OBJECT" row col
75+
115− (
76+data Context
116− "I was partway through parsing a JSON object when I got stuck here:"
77+ = CIndex Int
117− ,
78+ | CField Utf8.String
118− D.stack
79+
80+
81+
82+-- TO REPORT
83+
84+
85+toReport :: Error e -> Report.Report
86+toReport err =
87+ error "TODO Reporting.Error.Json.toReport" err
88+
89+
90+{-
91+
92+-- ERROR
93+
94+
95+data Error e
96+ = BadJson Syntax.Error
97+ | BadContent (Json.Error e)
98+
99+
100+
101+-- TO DOC
102+
103+
104+toDoc :: String -> Code.Source -> (e -> [D.Doc]) -> Error e -> D.Doc
105+toDoc rootName source userErrorToDocs err =
106+ case err of
107+ BadJson syntaxError ->
108+ case Syntax.toReport source syntaxError of
109+ Report.Report _ _ _ doc ->
110+ doc
111+
112+ BadContent jsonError ->
113+ case flatten jsonError of
114+ [] ->
115+ D.reflow
116+ "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\
117+ \ and share it at <https://github.com/elm/compiler/issues> so I can\
118+ \ provide a helpful hint here!"
119+
120+ [flatError] ->
121+ flatErrorToDoc rootName [] userErrorToDocs flatError
122+
123+ flatErrors ->
124+ let
125+ toNumberedDoc index flatErr =
126+ D.dullcyan ("(" <> D.fromInt index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr
127+ in
128+ D.stack $
119 [ D.reflow $
129 [ D.reflow $
120− "I was expecting to see a comma or a closing curly brace next."
130+ "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"
121− , D.reflow $
122− "Is a comma missing on the previous line? Is an array missing a closing square\
123− \ bracket? It is often something tricky like that!"
124− , objectNote
125 ]
131 ]
126− )
132+ ++ zipWith toNumberedDoc [1..] flatErrors
133+
134+
127
135
128− ArrayEnd row col ->
136+-- FLAT ERROR TO DOC
129− toSnippet "UNFINISHED ARRAY" row col
137+
130− (
138+
131− "I was partway through parsing a JSON array when I got stuck here:"
139+flatErrorToDoc :: String -> [D.Doc] -> (e -> [D.Doc]) -> FlatError e -> D.Doc
132− ,
140+flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =
141+ case theories of
142+ [] ->
143+ let
144+ explanation =
145+ case theory of
146+ Failure userError ->
147+ userErrorToDocs userError
148+
149+ Expecting tipe ->
150+ ["I","was","expecting"] ++ anExpectedThing tipe
151+ in
152+ case accesses of
153+ [] ->
154+ D.fillSep (starter ++ explanation)
155+
156+ _ ->
133 D.stack
157 D.stack
134− [ D.reflow $ "I was expecting to see a comma or a closing square bracket next."
158+ [ D.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]
135− , D.reflow $
159+ , D.fillSep explanation
136− "Is a comma missing on the previous line? It is often something like that!"
137 ]
160 ]
138− )
161+
139−
162+ _:_ ->
140− StringProblem stringProblem row col ->
163+ let
141− case stringProblem of
164+ introduction =
142− BadStringEnd ->
165+ case accesses of
143− toSnippet "ENDLESS STRING" row col
166+ [] ->
144− (
167+ ["I","am","having","trouble","with","the"]
145− "I got to the end of the line without seeing the closing double quote:"
168+ ++ actualThing json
146− ,
169+ ++ ["here","because:"]
147− D.fillSep $
170+
148− ["Strings","look","like",D.green "\"this\"","with","double"
171+ _ ->
149− ,"quotes","on","each","end.","Is","the","closing","double"
172+ ["I","am","having","trouble","with","the"]
150− ,"quote","missing","in","your","code?"
173+ ++ actualThing json
151− ]
174+ ++ ["at",accessToDoc rootName accesses,"because:"]
152− )
175+ in
153−
176+ D.stack
154− BadStringControlChar ->
177+ [ D.fillSep (starter ++ introduction)
155− toSnippet "UNEXPECTED CONTROL CHARACTER" row col
178+ , D.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)
156− (
179+ , D.reflow "I accept any of these things."
157− "I ran into a control character unexpectedly:"
158− ,
159− D.reflow $
160− "These are characters that represent tabs, backspaces, newlines, and\
161− \ a bunch of other invisible characters. They all come before 20 in the\
162− \ ASCII range, and they are disallowed by the JSON specificaiton. Maybe\
163− \ a copy/paste added one of these invisible characters to your JSON?"
164− )
165−
166− BadStringEscapeChar ->
167− toSnippet "UNKNOWN ESCAPE" row col
168− (
169− "Backslashes always start escaped characters, but I do not recognize this one:"
170− ,
171− D.stack
172− [ D.reflow $
173− "Valid escape characters include:"
174− , D.dullyellow $ D.indent 4 $ D.vcat $
175− ["\\\"","\\\\","\\/","\\b","\\f","\\n","\\r","\\t","\\u003D"]
176− , D.reflow $
177− "Do you want one of those instead? Maybe you need \\\\ to escape a backslash?"
178− ]
179− )
180−
181− BadStringEscapeHex ->
182− toSnippet "BAD HEX ESCAPE" row col
183− (
184− "This is not a valid hex escape:"
185− ,
186− D.fillSep $
187− ["Valid","hex","escapes","in","JSON","are","between"
188− ,D.green "\\u0000","and",D.green "\\uFFFF"
189− ,"and","always","have","exactly","four","digits."
190− ]
191− )
192−
193− NoLeadingZeros row col ->
194− toSnippet "BAD NUMBER" row col
195− (
196− "Numbers cannot start with zeros like this:"
197− ,
198− D.reflow $ "Try deleting the leading zeros?"
199− )
200−
201− NoFloats row col ->
202− toSnippet "UNEXPECTED NUMBER" row col
203− (
204− "I got stuck while trying to parse this number:"
205− ,
206− D.reflow $
207− "I do not accept floating point numbers like 3.1415 right now. That kind\
208− \ of JSON value is not needed for any of the uses that Elm has for now."
209− )
210−
211− BadEnd row col ->
212− toSnippet "JSON PROBLEM" row col
213− (
214− "I was partway through parsing some JSON when I got stuck here:"
215− ,
216− D.reflow $
217− "I am not really sure what is wrong. This sometimes means there is extra\
218− \ stuff after a valid JSON value?"
219− )
220−
221−
222−objectNote :: D.Doc
223−objectNote =
224− D.stack
225− [ D.toSimpleNote $ "Here is an example of a valid JSON object for reference:"
226− , D.vcat
227− [ D.indent 4 $ "{"
228− , D.indent 6 $ D.dullyellow "\"name\"" <> ": " <> D.dullyellow "\"Tom\"" <> ","
229− , D.indent 6 $ D.dullyellow "\"age\"" <> ": " <> D.dullyellow "42"
230− , D.indent 4 $ "}"
231 ]
180 ]
232− , D.reflow $
233− "Notice that (1) the field names are in double quotes and (2) there is no\
234− \ trailing comma after the last entry. Both are strict requirements in JSON!"
235− ]
236
181
237
182
183+accessToDoc :: String -> [String] -> D.Doc
184+accessToDoc rootName accesses =
185+ D.dullyellow (D.fromString (rootName ++ concat accesses))
238
186
239−-- PROBLEM TO REPORT
240
187
188+actualThing :: E.Value -> [D.Doc]
189+actualThing json =
190+ case json of
191+ E.Array _ -> [D.red "array"]
192+ E.Object _ -> [D.red "object"]
193+ E.String _ -> [D.red "string"]
194+ E.Boolean b -> [D.red (if b then "true" else "false"),"value"]
195+ E.Integer n -> ["number",D.red (D.fromInt n)]
196+ E.Number _ -> [D.red "number"]
197+ E.Null -> [D.red "null","value"]
241
198
242−data Context
243− = CRoot
244− | CField BS.ByteString Context
245− | CIndex Int Context
246
199
200+anExpectedThing :: Json.Type -> [D.Doc]
201+anExpectedThing tipe =
202+ case tipe of
203+ Json.TObject -> ["an", D.green "OBJECT" <> "."]
204+ Json.TArray -> ["an", D.green "ARRAY" <> "."]
205+ Json.TString -> ["a", D.green "STRING" <> "."]
206+ Json.TBool -> ["a", D.green "BOOLEAN" <> "."]
207+ Json.TInt -> ["an", D.green "INT" <> "."]
208+ Json.TObjectWith field -> ["an",D.green "OBJECT","with","a",D.green ("\"" <> D.fromString (Text.unpack field) <> "\""),"field."]
209+ Json.TArrayPair len ->
210+ ["an",D.green "ARRAY","with",D.green "TWO","entries."
211+ ,"This","array","has",D.fromInt len, if len == 1 then "element." else "elements."
212+ ]
247
213
248−problemToReport :: FilePath -> FailureToReport x -> Code.Source -> Context -> Problem x -> Reason -> Help.Report
249−problemToReport path ftr source context problem reason =
250− case problem of
251− Field field prob ->
252− problemToReport path ftr source (CField field context) prob reason
253
214
254− Index index prob ->
215+toBullet :: [D.Doc] -> (e -> [D.Doc]) -> Theory e -> D.Doc
255− problemToReport path ftr source (CIndex index context) prob reason
216+toBullet intro userErrorToDocs theory =
217+ D.indent 4 $ D.fillSep $ (++) intro $
218+ case theory of
219+ Failure userError ->
220+ userErrorToDocs userError
256
221
257− OneOf p ps ->
222+ Expecting tipe ->
258− -- NOTE: only displays the deepest problem. This works well for the kind
223+ ["I","was","expecting"] ++ anExpectedThing tipe
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
264
224
265− Failure region x ->
266− _failureToReport ftr path source context region x
267
225
268− Expecting region expectation ->
269− expectationToReport path source context region expectation reason
270
226
227+-- TO FLAT ERRORS
271
228
272−getMaxDepth :: Problem x -> Int
273−getMaxDepth problem =
274− case problem of
275− Field _ prob -> 1 + getMaxDepth prob
276− Index _ prob -> 1 + getMaxDepth prob
277− OneOf p ps -> maximum (getMaxDepth p : map getMaxDepth ps)
278− Failure _ _ -> 0
279− Expecting _ _ -> 0
280
229
230+data FlatError e =
231+ FlatError [String] E.Value (Theory e) [Theory e]
281
232
282−newtype FailureToReport x =
283− FailureToReport { _failureToReport :: FilePath -> Code.Source -> Context -> A.Region -> x -> Help.Report }
284
233
234+data Theory e
235+ = Failure e
236+ | Expecting Json.Type
285
237
286−expectationToReport :: FilePath -> Code.Source -> Context -> A.Region -> DecodeExpectation -> Reason -> Help.Report
238+
287−expectationToReport path source context (A.Region start end) expectation reason =
239+flatten :: Json.Error e -> [FlatError e]
240+flatten jsonError =
288 let
241 let
289− (A.Position sr _) = start
242+ depth (FlatError accesses _ _ _) =
290− (A.Position er _) = end
243+ length accesses
244+ in
245+ List.sortOn depth $ flattenTree (toErrorTree jsonError)
291
246
292− region =
293− if sr == er then region else A.Region start start
294
247
295− introduction =
248+flattenTree :: ErrorTree e -> [FlatError e]
296− case context of
249+flattenTree (ErrorTree theories subTrees) =
297− CRoot ->
250+ let
298− "I ran into some trouble here:"
251+ addAccess access (FlatError accesses json t ts) =
252+ FlatError (access:accesses) json t ts
253+
254+ toFlats (name, tree) =
255+ map (addAccess name) (flattenTree tree)
256+
257+ subErrors =
258+ concatMap toFlats (Map.toList subTrees)
259+ in
260+ case theories of
261+ [] ->
262+ subErrors
299
263
300− CField field _ ->
264+ (json, theory) : rest ->
301− "I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"
265+ FlatError [] json theory (map snd rest) : subErrors
302
266
303− CIndex index (CField field _) ->
304− "When looking at the \"" ++ BS_UTF8.toString field ++ "\" field, I ran into trouble with the "
305− ++ D.intToOrdinal index ++ " entry:"
306
267
307− CIndex index _ ->
308− "I ran into trouble with the " ++ D.intToOrdinal index ++ " index of this array:"
309
268
310− toSnippet title aThing =
269+-- TO ERROR TREE
311− Help.jsonReport title (Just path) $
270+
312− Code.toSnippet source region Nothing
271+
313− ( D.reflow (because reason introduction)
272+data ErrorTree e =
314− , D.fillSep $ ["I","was","expecting","to","run","into"] ++ aThing
273+ ErrorTree
315− )
274+ { _theories :: [(E.Value, Theory e)]
275+ , _subErrors :: Map.Map String (ErrorTree e)
276+ }
277+
278+
279+toErrorTree :: Json.Error e -> ErrorTree e
280+toErrorTree jsonError =
281+ add jsonError empty
282+
283+
284+empty :: ErrorTree e
285+empty =
286+ ErrorTree [] Map.empty
287+
288+
289+add :: Json.Error e -> ErrorTree e -> ErrorTree e
290+add jsonError tree@(ErrorTree theories subErrors) =
291+ case jsonError of
292+ Json.Field field subErr ->
293+ ErrorTree theories (addName (fieldToName field) subErr subErrors)
294+
295+ Json.Index index subErr ->
296+ ErrorTree theories (addName (indexToName index) subErr subErrors)
297+
298+ Json.OneOf errors ->
299+ foldr add tree errors
300+
301+ Json.Expecting json tipe ->
302+ ErrorTree ((json, Expecting tipe) : theories) subErrors
303+
304+ Json.Failure json err ->
305+ ErrorTree ((json, Failure err) : theories) subErrors
306+
307+
308+addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)
309+addName name err subErrors =
310+ let
311+ subAdd maybeCrush =
312+ Just (add err (maybe empty id maybeCrush))
316 in
313 in
317− case expectation of
314+ Map.alter subAdd name subErrors
318− TObject ->
319− toSnippet "EXPECTING OBJECT" ["an", D.green "OBJECT" <> "."]
320
315
321− TArray ->
322− toSnippet "EXPECTING ARRAY" ["an", D.green "ARRAY" <> "."]
323
316
324− TString ->
317+fieldToName :: Text.Text -> String
325− toSnippet "EXPECTING STRING" ["a", D.green "STRING" <> "."]
318+fieldToName field =
319+ case Text.unpack field of
320+ [] ->
321+ "['']"
326
322
327− TBool ->
323+ string@(char : rest) ->
328− toSnippet "EXPECTING BOOL" ["a", D.green "BOOLEAN" <> "."]
324+ if Char.isAlpha char && all Char.isAlphaNum rest then
325+ '.' : string
326+ else
327+ "['" ++ string ++ "']"
329
328
330− TInt ->
331− toSnippet "EXPECTING INT" ["an", D.green "INT" <> "."]
332
329
333− TObjectWith field ->
330+indexToName :: Int -> String
334− toSnippet "MISSING FIELD"
331+indexToName index =
335− ["an",D.green "OBJECT","with","a"
332+ "[" ++ show index ++ "]"
336− ,D.green ("\"" <> D.fromChars (BS_UTF8.toString field) <> "\"")
337− ,"field."
338− ]
339
333
340− TArrayPair len ->
334+-}
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− Code.toSnippet source region Nothing
41+ Report.toCodeSnippet 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− Code.toSnippet source region Nothing
56+ Report.toCodeSnippet 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− Code.toSnippet source region Nothing
72+ Report.toCodeSnippet 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+8−9
@@ -8,7 +8,6 @@ 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
12import qualified Nitpick.PatternMatches as P
11import qualified Nitpick.PatternMatches as P
13import Reporting.Doc ((<>))
12import Reporting.Doc ((<>))
14import qualified Reporting.Doc as D
13import qualified Reporting.Doc as D
@@ -25,7 +24,7 @@ toReport source err =
25 case err of
24 case err of
26 P.Redundant caseRegion patternRegion index ->
25 P.Redundant caseRegion patternRegion index ->
27 Report.Report "REDUNDANT PATTERN" patternRegion [] $
26 Report.Report "REDUNDANT PATTERN" patternRegion [] $
28− Code.toSnippet source caseRegion (Just patternRegion)
27+ Report.toCodeSnippet source caseRegion (Just patternRegion)
29 (
28 (
30 D.reflow $
29 D.reflow $
31 "The " <> D.intToOrdinal index <> " pattern is redundant:"
30 "The " <> D.intToOrdinal index <> " pattern is redundant:"
@@ -39,9 +38,9 @@ toReport source err =
39 case context of
38 case context of
40 P.BadArg ->
39 P.BadArg ->
41 Report.Report "UNSAFE PATTERN" region [] $
40 Report.Report "UNSAFE PATTERN" region [] $
42− Code.toSnippet source region Nothing
41+ Report.toCodeSnippet source region Nothing
43 (
42 (
44− "This pattern does not cover all possibilities:"
43+ "This pattern does not cover all possiblities:"
45 ,
44 ,
46 D.stack
45 D.stack
47 [ "Other possibilities include:"
46 [ "Other possibilities include:"
@@ -55,7 +54,7 @@ toReport source err =
55
54
56 P.BadDestruct ->
55 P.BadDestruct ->
57 Report.Report "UNSAFE PATTERN" region [] $
56 Report.Report "UNSAFE PATTERN" region [] $
58− Code.toSnippet source region Nothing
57+ Report.toCodeSnippet source region Nothing
59 (
58 (
60 "This pattern does not cover all possible values:"
59 "This pattern does not cover all possible values:"
61 ,
60 ,
@@ -64,7 +63,7 @@ toReport source err =
64 , unhandledPatternsToDocBlock unhandled
63 , unhandledPatternsToDocBlock unhandled
65 , D.reflow $
64 , D.reflow $
66 "I would have to crash if I saw one of those! You can use\
65 "I would have to crash if I saw one of those! You can use\
67− \ `let` to deconstruct values only if there is ONE possibility.\
66+ \ `let` to deconstruct values only if there is ONE possiblity.\
68 \ Switch to a `case` expression to account for all possibilities."
67 \ Switch to a `case` expression to account for all possibilities."
69 , D.toSimpleHint $
68 , D.toSimpleHint $
70 "Are you calling a function that definitely returns values\
69 "Are you calling a function that definitely returns values\
@@ -75,7 +74,7 @@ toReport source err =
75
74
76 P.BadCase ->
75 P.BadCase ->
77 Report.Report "MISSING PATTERNS" region [] $
76 Report.Report "MISSING PATTERNS" region [] $
78− Code.toSnippet source region Nothing
77+ Report.toCodeSnippet source region Nothing
79 (
78 (
80 "This `case` does not have branches for all possibilities:"
79 "This `case` does not have branches for all possibilities:"
81 ,
80 ,
@@ -118,10 +117,10 @@ patternToDoc context pattern =
118 NonList (P.Literal literal) ->
117 NonList (P.Literal literal) ->
119 case literal of
118 case literal of
120 P.Chr chr ->
119 P.Chr chr ->
121− "'" <> D.fromChars (ES.toChars chr) <> "'"
120+ "'" <> D.fromUtf8 chr <> "'"
122
121
123 P.Str str ->
122 P.Str str ->
124− "\"" <> D.fromChars (ES.toChars str) <> "\""
123+ "\"" <> D.fromUtf8 str <> "\""
125
124
126 P.Int int ->
125 P.Int int ->
127 D.fromInt int
126 D.fromInt int
compiler/src/Reporting/Error/Syntax.hs+908−5184

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+10−154

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Report.hs+63

This diff is too big to show here.

compiler/src/Reporting/Result.hs+2−12

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+123−14

This diff is too big to show here.

compiler/src/Type/Solve.hs+3−11

This diff is too big to show here.

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

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.

docs/upgrade-instructions/0.19.1.mddeleted−60

This diff is too big to show here.

elm.cabal+16−34

This diff is too big to show here.

hints/bad-recursion.mddeleted−133

This diff is too big to show here.

hints/comparing-custom-types.mddeleted−98

This diff is too big to show here.

hints/comparing-records.mddeleted−85

This diff is too big to show here.

hints/implicit-casts.mddeleted−50

This diff is too big to show here.

hints/import-cycles.mddeleted−184

This diff is too big to show here.

hints/imports.mddeleted−126

This diff is too big to show here.

hints/infinite-type.mddeleted−42

This diff is too big to show here.

hints/init.mddeleted−55

This diff is too big to show here.

hints/missing-patterns.mddeleted−139

This diff is too big to show here.

hints/optimize.mddeleted−59

This diff is too big to show here.

hints/port-modules.mddeleted−32

This diff is too big to show here.

hints/recursive-alias.mddeleted−162

This diff is too big to show here.

hints/repl.mddeleted−73

This diff is too big to show here.

hints/shadowing.mddeleted−70

This diff is too big to show here.

hints/tuples.mddeleted−19

This diff is too big to show here.

hints/type-annotations.mddeleted−60

This diff is too big to show here.

installers/README.mddeleted−32

This diff is too big to show here.

installers/linux/Dockerfiledeleted−39

This diff is too big to show here.

installers/linux/README.mddeleted−93

This diff is too big to show here.

installers/mac/Distribution.xml+3−5

This diff is too big to show here.

installers/mac/README.mddeleted−93

This diff is too big to show here.

installers/mac/Resources/en.lproj/background.pngnew file

Binary file not shown.

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

This diff is too big to show here.

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

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+3−30

This diff is too big to show here.

installers/npm/PUBLISHING.md+141−29

This diff is too big to show here.

installers/npm/README.md+23−30

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/download.jsdeleted−114

This diff is too big to show here.

installers/npm/index.jsnew file+21

This diff is too big to show here.

installers/npm/install.jsdeleted−4

This diff is too big to show here.

installers/npm/package.json+15−13

This diff is too big to show here.

installers/npm/troubleshooting.mddeleted−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+3−18

This diff is too big to show here.

installers/win/file.iconew file

Binary file not shown.

installers/win/inst.dat+2−1

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+2−1

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifnew file

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+15−20

This diff is too big to show here.

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

This diff is too big to show here.

roadmap.mddeleted−29

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsdeleted−148

This diff is too big to show here.

terminal/src/Bump.hs+8−158

This diff is too big to show here.

terminal/src/Develop.hs+77−70

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hs+6−348

This diff is too big to show here.

terminal/src/Init.hs+1−2

This diff is too big to show here.

terminal/src/Install.hs+31−16

This diff is too big to show here.

terminal/src/Main.hs+36−32

This diff is too big to show here.

terminal/src/Make.hs+268−113

This diff is too big to show here.

terminal/src/Publish.hs+8−529

This diff is too big to show here.

terminal/src/Repl.hs+197−522

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Terminal/Args/Helpers.hsnew file+125

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

worker/elm.cabaldeleted−210

This diff is too big to show here.

worker/elm.jsondeleted−26

This diff is too big to show here.

worker/nginx.confdeleted−22

This diff is too big to show here.

worker/outlines/compile/elm.jsondeleted−32

This diff is too big to show here.

worker/outlines/repl/elm.jsondeleted−19

This diff is too big to show here.

worker/src/Artifacts.hsdeleted−155

This diff is too big to show here.

worker/src/Cors.hsdeleted−48

This diff is too big to show here.

worker/src/Endpoint/Compile.hsdeleted−323

This diff is too big to show here.

worker/src/Endpoint/Quotes.hsdeleted−114

This diff is too big to show here.

worker/src/Endpoint/Repl.hsdeleted−244

This diff is too big to show here.

worker/src/Errors.elmdeleted−217

This diff is too big to show here.

worker/src/Main.hsdeleted−73

This diff is too big to show here.