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

Binary file not shown.

LICENSE+6−25
@@ -1,30 +1,11 @@
1−Copyright (c) 2012-present, Evan Czaplicki
1+Copyright 2012-present Evan Czaplicki
2
2
3−All rights reserved.
3+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
4
4
5−Redistribution and use in source and binary forms, with or without
5+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
6−modification, are permitted provided that the following conditions are met:
7
6
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
7+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
10
8
11− * Redistributions in binary form must reproduce the above
9+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15
10
16− * Neither the name of Evan Czaplicki nor the names of other
11+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+10−5
@@ -1,17 +1,22 @@
1−# The Elm Compiler
1+# Elm
2
2
3−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
3+A delightful language for reliable webapps.
4
4
5+Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6+
7+
8+<br>
5
9
6## Install
10## Install
7
11
8−Follow [these instructions][installer]!
12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
9
13
10− [installer]: https://guide.elm-lang.org/install.html
14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
11
15
16+<br>
12
17
13## Help
18## Help
14
19
15If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
20If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
16
21
17−[slack]: http://elmlang.herokuapp.com/
22+[slack]: http://elmlang.herokuapp.com/
builder/src/BackgroundWriter.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE BangPatterns #-}
2+module BackgroundWriter
3+ ( Scope
4+ , withScope
5+ , writeBinary
6+ )
7+ where
8+
9+
10+import Control.Concurrent (forkIO)
11+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12+import qualified Data.Binary as Binary
13+import Data.Foldable (traverse_)
14+
15+import qualified File
16+
17+
18+
19+-- BACKGROUND WRITER
20+
21+
22+newtype Scope =
23+ Scope (MVar [MVar ()])
24+
25+
26+withScope :: (Scope -> IO a) -> IO a
27+withScope callback =
28+ do workList <- newMVar []
29+ result <- callback (Scope workList)
30+ mvars <- takeMVar workList
31+ traverse_ takeMVar mvars
32+ return result
33+
34+
35+writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36+writeBinary (Scope workList) path value =
37+ do mvar <- newEmptyMVar
38+ _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39+ oldWork <- takeMVar workList
40+ let !newWork = mvar:oldWork
41+ putMVar workList newWork
42+
builder/src/Build.hsnew file+1251
@@ -0,0 +1,1251 @@
1+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3+module Build
4+ ( fromExposed
5+ , fromPaths
6+ , fromRepl
7+ , Artifacts(..)
8+ , Root(..)
9+ , Module(..)
10+ , CachedInterface(..)
11+ , ReplArtifacts(..)
12+ , DocsGoal(..)
13+ , getRootNames
14+ )
15+ where
16+
17+
18+import Control.Concurrent (forkIO)
19+import Control.Concurrent.MVar
20+import Control.Monad (filterM, mapM_, sequence_)
21+import qualified Data.ByteString as B
22+import qualified Data.Char as Char
23+import qualified Data.Graph as Graph
24+import qualified Data.List as List
25+import qualified Data.Map.Utils as Map
26+import qualified Data.Map.Strict as Map
27+import Data.Map.Strict ((!))
28+import qualified Data.Maybe as Maybe
29+import qualified Data.Name as Name
30+import qualified Data.NonEmptyList as NE
31+import qualified Data.OneOrMore as OneOrMore
32+import qualified Data.Set as Set
33+import qualified System.Directory as Dir
34+import qualified System.FilePath as FP
35+import System.FilePath ((</>), (<.>))
36+
37+import qualified AST.Canonical as Can
38+import qualified AST.Source as Src
39+import qualified AST.Optimized as Opt
40+import qualified Compile
41+import qualified Elm.Details as Details
42+import qualified Elm.Docs as Docs
43+import qualified Elm.Interface as I
44+import qualified Elm.ModuleName as ModuleName
45+import qualified Elm.Outline as Outline
46+import qualified Elm.Package as Pkg
47+import qualified File
48+import qualified Json.Encode as E
49+import qualified Parse.Module as Parse
50+import qualified Reporting
51+import 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
56+import qualified Reporting.Exit as Exit
57+import qualified Reporting.Render.Type.Localizer as L
58+import qualified Stuff
59+
60+
61+
62+-- ENVIRONMENT
63+
64+
65+data Env =
66+ Env
67+ { _key :: Reporting.BKey
68+ , _root :: FilePath
69+ , _project :: Parse.ProjectType
70+ , _srcDirs :: [AbsoluteSrcDir]
71+ , _buildID :: Details.BuildID
72+ , _locals :: Map.Map ModuleName.Raw Details.Local
73+ , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
74+ }
75+
76+
77+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
78+makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
79+ case validOutline of
80+ Details.ValidApp givenSrcDirs ->
81+ do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82+ return $ Env key root Parse.Application srcDirs buildID locals foreigns
83+
84+ Details.ValidPkg pkg _ _ ->
85+ do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
86+ return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
87+
88+
89+
90+-- SOURCE DIRECTORY
91+
92+
93+newtype AbsoluteSrcDir =
94+ AbsoluteSrcDir FilePath
95+
96+
97+toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98+toAbsoluteSrcDir root srcDir =
99+ AbsoluteSrcDir <$> Dir.canonicalizePath
100+ (
101+ case srcDir of
102+ Outline.AbsoluteSrcDir dir -> dir
103+ Outline.RelativeSrcDir dir -> root </> dir
104+ )
105+
106+
107+addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108+addRelative (AbsoluteSrcDir srcDir) path =
109+ srcDir </> path
110+
111+
112+
113+-- FORK
114+
115+
116+-- PERF try using IORef semephore on file crawl phase?
117+-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
118+-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
119+--
120+fork :: IO a -> IO (MVar a)
121+fork work =
122+ do mvar <- newEmptyMVar
123+ _ <- forkIO $ putMVar mvar =<< work
124+ return mvar
125+
126+
127+{-# INLINE forkWithKey #-}
128+forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
129+forkWithKey func dict =
130+ Map.traverseWithKey (\k v -> fork (func k v)) dict
131+
132+
133+
134+-- FROM EXPOSED
135+
136+
137+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
138+fromExposed style root details docsGoal exposed@(NE.List e es) =
139+ Reporting.trackBuild style $ \key ->
140+ do env <- makeEnv key root details
141+ dmvar <- Details.loadInterfaces root details
142+
143+ -- crawl
144+ mvar <- newEmptyMVar
145+ let docsNeed = toDocsNeed docsGoal
146+ roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
147+ putMVar mvar roots
148+ mapM_ readMVar roots
149+ statuses <- traverse readMVar =<< readMVar mvar
150+
151+ -- compile
152+ midpoint <- checkMidpoint dmvar statuses
153+ case midpoint of
154+ Left problem ->
155+ return (Left (Exit.BuildProjectProblem problem))
156+
157+ Right foreigns ->
158+ do rmvar <- newEmptyMVar
159+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
160+ putMVar rmvar resultMVars
161+ results <- traverse readMVar resultMVars
162+ writeDetails root details results
163+ finalizeExposed root docsGoal exposed results
164+
165+
166+
167+-- FROM PATHS
168+
169+
170+data Artifacts =
171+ Artifacts
172+ { _name :: Pkg.Name
173+ , _deps :: Dependencies
174+ , _roots :: NE.List Root
175+ , _modules :: [Module]
176+ }
177+
178+
179+data Module
180+ = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
181+ | Cached ModuleName.Raw Bool (MVar CachedInterface)
182+
183+
184+type Dependencies =
185+ Map.Map ModuleName.Canonical I.DependencyInterface
186+
187+
188+fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189+fromPaths style root details paths =
190+ Reporting.trackBuild style $ \key ->
191+ do env <- makeEnv key root details
192+
193+ elroots <- findRoots env paths
194+ case elroots of
195+ Left problem ->
196+ return (Left (Exit.BuildProjectProblem problem))
197+
198+ Right lroots ->
199+ do -- crawl
200+ dmvar <- Details.loadInterfaces root details
201+ smvar <- newMVar Map.empty
202+ srootMVars <- traverse (fork . crawlRoot env smvar) lroots
203+ sroots <- traverse readMVar srootMVars
204+ statuses <- traverse readMVar =<< readMVar smvar
205+
206+ midpoint <- checkMidpointAndRoots dmvar statuses sroots
207+ case midpoint of
208+ Left problem ->
209+ return (Left (Exit.BuildProjectProblem problem))
210+
211+ Right foreigns ->
212+ do -- compile
213+ rmvar <- newEmptyMVar
214+ resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
215+ putMVar rmvar resultsMVars
216+ rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
217+ results <- traverse readMVar resultsMVars
218+ writeDetails root details results
219+ toArtifacts env foreigns results <$> traverse readMVar rrootMVars
220+
221+
222+
223+-- GET ROOT NAMES
224+
225+
226+getRootNames :: Artifacts -> NE.List ModuleName.Raw
227+getRootNames (Artifacts _ _ roots _) =
228+ fmap getRootName roots
229+
230+
231+getRootName :: Root -> ModuleName.Raw
232+getRootName root =
233+ case root of
234+ Inside name -> name
235+ Outside name _ _ -> name
236+
237+
238+
239+-- CRAWL
240+
241+
242+type StatusDict =
243+ Map.Map ModuleName.Raw (MVar Status)
244+
245+
246+data Status
247+ = SCached Details.Local
248+ | SChanged Details.Local B.ByteString Src.Module DocsNeed
249+ | SBadImport Import.Problem
250+ | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
251+ | SForeign Pkg.Name
252+ | SKernel
253+
254+
255+crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
256+crawlDeps env mvar deps blockedValue =
257+ do statusDict <- takeMVar mvar
258+ let depsDict = Map.fromKeys (\_ -> ()) deps
259+ let newsDict = Map.difference depsDict statusDict
260+ statuses <- Map.traverseWithKey crawlNew newsDict
261+ putMVar mvar (Map.union statuses statusDict)
262+ mapM_ readMVar statuses
263+ return blockedValue
264+ where
265+ crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
266+
267+
268+crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
269+crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
270+ do let fileName = ModuleName.toFilePath name <.> "elm"
271+
272+ paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
273+
274+ case paths of
275+ [path] ->
276+ case Map.lookup name foreigns of
277+ Just (Details.Foreign dep deps) ->
278+ return $ SBadImport $ Import.Ambiguous path [] dep deps
279+
280+ Nothing ->
281+ do newTime <- File.getTime path
282+ case Map.lookup name locals of
283+ Nothing ->
284+ crawlFile env mvar docsNeed name path newTime buildID
285+
286+ Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
287+ if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
288+ then crawlFile env mvar docsNeed name path newTime lastChange
289+ else crawlDeps env mvar deps (SCached local)
290+
291+ p1:p2:ps ->
292+ return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
293+
294+ [] ->
295+ case Map.lookup name foreigns of
296+ Just (Details.Foreign dep deps) ->
297+ case deps of
298+ [] ->
299+ return $ SForeign dep
300+
301+ d:ds ->
302+ return $ SBadImport $ Import.AmbiguousForeign dep d ds
303+
304+ Nothing ->
305+ if Name.isKernel name && Parse.isKernel projectType then
306+ do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
307+ return $ if exists then SKernel else SBadImport Import.NotFound
308+ else
309+ return $ SBadImport Import.NotFound
310+
311+
312+crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
313+crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
314+ do source <- File.readUtf8 (root </> path)
315+
316+ case Parse.fromByteString projectType source of
317+ Left err ->
318+ return $ SBadSyntax path time source err
319+
320+ Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
321+ case maybeActualName of
322+ Nothing ->
323+ return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
324+
325+ Just name@(A.At _ actualName) ->
326+ if expectedName == actualName then
327+ let
328+ deps = map Src.getImportName imports
329+ local = Details.Local path time deps (any isMain values) lastChange buildID
330+ in
331+ crawlDeps env mvar deps (SChanged local source modul docsNeed)
332+ else
333+ return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
334+
335+
336+isMain :: A.Located Src.Value -> Bool
337+isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
338+ name == Name._main
339+
340+
341+
342+-- CHECK MODULE
343+
344+
345+type ResultDict =
346+ Map.Map ModuleName.Raw (MVar Result)
347+
348+
349+data Result
350+ = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
351+ | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
352+ | RCached Bool Details.BuildID (MVar CachedInterface)
353+ | RNotFound Import.Problem
354+ | RProblem Error.Module
355+ | RBlocked
356+ | RForeign I.Interface
357+ | RKernel
358+
359+
360+data CachedInterface
361+ = Unneeded
362+ | Loaded I.Interface
363+ | Corrupted
364+
365+
366+checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
367+checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
368+ case status of
369+ SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
370+ do results <- readMVar resultsMVar
371+ depsStatus <- checkDeps root results deps lastCompile
372+ case depsStatus of
373+ DepsChange ifaces ->
374+ do source <- File.readUtf8 path
375+ case Parse.fromByteString projectType source of
376+ Right modul -> compile env (DocsNeed False) local source ifaces modul
377+ Left err ->
378+ return $ RProblem $
379+ Error.Module name path time source (Error.BadSyntax err)
380+
381+ DepsSame _ _ ->
382+ do mvar <- newMVar Unneeded
383+ return (RCached hasMain lastChange mvar)
384+
385+ DepsBlock ->
386+ return RBlocked
387+
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 ->
399+ do results <- readMVar resultsMVar
400+ depsStatus <- checkDeps root results deps lastCompile
401+ case depsStatus of
402+ DepsChange ifaces ->
403+ compile env docsNeed local source ifaces modul
404+
405+ DepsSame same cached ->
406+ do maybeLoaded <- loadInterfaces root same cached
407+ case maybeLoaded of
408+ Nothing -> return RBlocked
409+ Just ifaces -> compile env docsNeed local source ifaces modul
410+
411+ DepsBlock ->
412+ return RBlocked
413+
414+ DepsNotFound problems ->
415+ return $ RProblem $ Error.Module name path time source $
416+ Error.BadImports (toImportErrors env results imports problems)
417+
418+ SBadImport importProblem ->
419+ return (RNotFound importProblem)
420+
421+ SBadSyntax path time source err ->
422+ return $ RProblem $ Error.Module name path time source $
423+ Error.BadSyntax err
424+
425+ SForeign home ->
426+ case foreigns ! ModuleName.Canonical home name of
427+ I.Public iface -> return (RForeign iface)
428+ I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
429+
430+ SKernel ->
431+ return RKernel
432+
433+
434+
435+-- CHECK DEPS
436+
437+
438+data DepsStatus
439+ = DepsChange (Map.Map ModuleName.Raw I.Interface)
440+ | DepsSame [Dep] [CDep]
441+ | DepsBlock
442+ | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
443+
444+
445+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
446+checkDeps root results deps lastCompile =
447+ checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
448+
449+
450+type Dep = (ModuleName.Raw, I.Interface)
451+type CDep = (ModuleName.Raw, MVar CachedInterface)
452+
453+
454+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
455+checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
456+ case deps of
457+ dep:otherDeps ->
458+ do result <- readMVar (results ! dep)
459+ case result of
460+ RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
461+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
462+
463+ RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
464+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
465+
466+ RCached _ lastChange mvar ->
467+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
468+
469+ RNotFound prob ->
470+ checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471+
472+ RProblem _ ->
473+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
474+
475+ RBlocked ->
476+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
477+
478+ RForeign iface ->
479+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
480+
481+ RKernel ->
482+ checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
483+
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+
529+
530+
531+-- LOAD CACHED INTERFACES
532+
533+
534+loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535+loadInterfaces root same cached =
536+ do loading <- traverse (fork . loadInterface root) cached
537+ maybeLoaded <- traverse readMVar loading
538+ case sequence maybeLoaded of
539+ Nothing ->
540+ return Nothing
541+
542+ Just loaded ->
543+ return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
544+
545+
546+loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
547+loadInterface root (name, ciMvar) =
548+ do cachedInterface <- takeMVar ciMvar
549+ case cachedInterface of
550+ Corrupted ->
551+ do putMVar ciMvar cachedInterface
552+ return Nothing
553+
554+ Loaded iface ->
555+ do putMVar ciMvar cachedInterface
556+ return (Just (name, iface))
557+
558+ Unneeded ->
559+ do maybeIface <- File.readBinary (Stuff.elmi root name)
560+ case maybeIface of
561+ Nothing ->
562+ do putMVar ciMvar Corrupted
563+ return Nothing
564+
565+ Just iface ->
566+ do putMVar ciMvar (Loaded iface)
567+ return (Just (name, iface))
568+
569+
570+
571+-- CHECK PROJECT
572+
573+
574+checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575+checkMidpoint dmvar statuses =
576+ case checkForCycles statuses of
577+ Nothing ->
578+ do maybeForeigns <- readMVar dmvar
579+ case maybeForeigns of
580+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)
581+ Just fs -> return (Right fs)
582+
583+ Just (NE.List name names) ->
584+ do _ <- readMVar dmvar
585+ return (Left (Exit.BP_Cycle name names))
586+
587+
588+checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589+checkMidpointAndRoots dmvar statuses sroots =
590+ case checkForCycles statuses of
591+ Nothing ->
592+ case checkUniqueRoots statuses sroots of
593+ Nothing ->
594+ do maybeForeigns <- readMVar dmvar
595+ case maybeForeigns of
596+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)
597+ Just fs -> return (Right fs)
598+
599+ Just problem ->
600+ do _ <- readMVar dmvar
601+ return (Left problem)
602+
603+ Just (NE.List name names) ->
604+ do _ <- readMVar dmvar
605+ return (Left (Exit.BP_Cycle name names))
606+
607+
608+
609+-- CHECK FOR CYCLES
610+
611+
612+checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
613+checkForCycles modules =
614+ let
615+ !graph = Map.foldrWithKey addToGraph [] modules
616+ !sccs = Graph.stronglyConnComp graph
617+ in
618+ checkForCyclesHelp sccs
619+
620+
621+checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
622+checkForCyclesHelp sccs =
623+ case sccs of
624+ [] ->
625+ Nothing
626+
627+ scc:otherSccs ->
628+ case scc of
629+ Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
630+ Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
631+ Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
632+
633+
634+type Node =
635+ ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
636+
637+
638+addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
639+addToGraph name status graph =
640+ let
641+ dependencies =
642+ case status of
643+ SCached (Details.Local _ _ deps _ _ _) -> deps
644+ SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
645+ SBadImport _ -> []
646+ SBadSyntax _ _ _ _ -> []
647+ SForeign _ -> []
648+ SKernel -> []
649+ in
650+ (name, name, dependencies) : graph
651+
652+
653+
654+-- CHECK UNIQUE ROOTS
655+
656+
657+checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
658+checkUniqueRoots insides sroots =
659+ let
660+ outsidesDict =
661+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
662+ in
663+ case Map.traverseWithKey checkOutside outsidesDict of
664+ Left problem ->
665+ Just problem
666+
667+ Right outsides ->
668+ case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
669+ Right () -> Nothing
670+ Left problem -> Just problem
671+
672+
673+rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
674+rootStatusToNamePathPair sroot =
675+ case sroot of
676+ SInside _ -> Nothing
677+ SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
678+ SOutsideErr _ -> Nothing
679+
680+
681+checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
682+checkOutside name paths =
683+ case OneOrMore.destruct NE.List paths of
684+ NE.List p [] -> Right p
685+ NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
686+
687+
688+checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
689+checkInside name p1 status =
690+ case status of
691+ SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
692+ SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
693+ SBadImport _ -> Right ()
694+ SBadSyntax _ _ _ _ -> Right ()
695+ SForeign _ -> Right ()
696+ SKernel -> Right ()
697+
698+
699+
700+-- COMPILE MODULE
701+
702+
703+compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
704+compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
705+ let
706+ pkg = projectTypeToPkg projectType
707+ in
708+ case Compile.compile pkg ifaces modul of
709+ Right (Compile.Artifacts canonical annotations objects) ->
710+ case makeDocs docsNeed canonical of
711+ Left err ->
712+ return $ RProblem $
713+ Error.Module (Src.getName modul) path time source (Error.BadDocs err)
714+
715+ Right docs ->
716+ do let name = Src.getName modul
717+ let iface = I.fromModule pkg canonical annotations
718+ let elmi = Stuff.elmi root name
719+ File.writeBinary (Stuff.elmo root name) objects
720+ maybeOldi <- File.readBinary elmi
721+ case maybeOldi of
722+ Just oldi | oldi == iface ->
723+ do -- iface should be fully forced by equality check
724+ Reporting.report key Reporting.BDone
725+ let local = Details.Local path time deps main lastChange buildID
726+ return (RSame local iface objects docs)
727+
728+ _ ->
729+ do -- iface may be lazy still
730+ File.writeBinary elmi iface
731+ Reporting.report key Reporting.BDone
732+ let local = Details.Local path time deps main buildID buildID
733+ return (RNew local iface objects docs)
734+
735+ Left err ->
736+ return $ RProblem $
737+ Error.Module (Src.getName modul) path time source err
738+
739+
740+projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741+projectTypeToPkg projectType =
742+ case projectType of
743+ Parse.Package pkg -> pkg
744+ Parse.Application -> Pkg.dummyName
745+
746+
747+
748+-- WRITE DETAILS
749+
750+
751+writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
752+writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
753+ File.writeBinary (Stuff.details root) $
754+ Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
755+
756+
757+addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
758+addNewLocal name result locals =
759+ case result of
760+ RNew local _ _ _ -> Map.insert name local locals
761+ RSame local _ _ _ -> Map.insert name local locals
762+ RCached _ _ _ -> locals
763+ RNotFound _ -> locals
764+ RProblem _ -> locals
765+ RBlocked -> locals
766+ RForeign _ -> locals
767+ RKernel -> locals
768+
769+
770+
771+-- FINALIZE EXPOSED
772+
773+
774+finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
775+finalizeExposed root docsGoal exposed results =
776+ case foldr (addImportProblems results) [] (NE.toList exposed) of
777+ p:ps ->
778+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
779+
780+ [] ->
781+ case Map.foldr addErrors [] results of
782+ [] -> Right <$> finalizeDocs docsGoal results
783+ e:es -> return $ Left $ Exit.BuildBadModules root e es
784+
785+
786+addErrors :: Result -> [Error.Module] -> [Error.Module]
787+addErrors result errors =
788+ case result of
789+ RNew _ _ _ _ -> errors
790+ RSame _ _ _ _ -> errors
791+ RCached _ _ _ -> errors
792+ RNotFound _ -> errors
793+ RProblem e -> e:errors
794+ RBlocked -> errors
795+ RForeign _ -> errors
796+ RKernel -> errors
797+
798+
799+addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
800+addImportProblems results name problems =
801+ case results ! name of
802+ RNew _ _ _ _ -> problems
803+ RSame _ _ _ _ -> problems
804+ RCached _ _ _ -> problems
805+ RNotFound p -> (name, p) : problems
806+ RProblem _ -> problems
807+ RBlocked -> problems
808+ RForeign _ -> problems
809+ RKernel -> problems
810+
811+
812+
813+-- DOCS
814+
815+
816+data DocsGoal a where
817+ KeepDocs :: DocsGoal Docs.Documentation
818+ WriteDocs :: FilePath -> DocsGoal ()
819+ IgnoreDocs :: DocsGoal ()
820+
821+
822+newtype DocsNeed =
823+ DocsNeed { needsDocs :: Bool }
824+
825+
826+toDocsNeed :: DocsGoal a -> DocsNeed
827+toDocsNeed goal =
828+ case goal of
829+ IgnoreDocs -> DocsNeed False
830+ WriteDocs _ -> DocsNeed True
831+ KeepDocs -> DocsNeed True
832+
833+
834+makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
835+makeDocs (DocsNeed isNeeded) modul =
836+ if isNeeded then
837+ case Docs.fromModule modul of
838+ Right docs -> Right (Just docs)
839+ Left err -> Left err
840+ else
841+ Right Nothing
842+
843+
844+finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
845+finalizeDocs goal results =
846+ case goal of
847+ KeepDocs ->
848+ return $ Map.mapMaybe toDocs results
849+
850+ WriteDocs path ->
851+ E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
852+
853+ IgnoreDocs ->
854+ return ()
855+
856+
857+toDocs :: Result -> Maybe Docs.Module
858+toDocs result =
859+ case result of
860+ RNew _ _ _ d -> d
861+ RSame _ _ _ d -> d
862+ RCached _ _ _ -> Nothing
863+ RNotFound _ -> Nothing
864+ RProblem _ -> Nothing
865+ RBlocked -> Nothing
866+ RForeign _ -> Nothing
867+ RKernel -> Nothing
868+
869+
870+
871+--------------------------------------------------------------------------------
872+------ NOW FOR SOME REPL STUFF -------------------------------------------------
873+--------------------------------------------------------------------------------
874+
875+
876+-- FROM REPL
877+
878+
879+data ReplArtifacts =
880+ ReplArtifacts
881+ { _repl_home :: ModuleName.Canonical
882+ , _repl_modules :: [Module]
883+ , _repl_localizer :: L.Localizer
884+ , _repl_annotations :: Map.Map Name.Name Can.Annotation
885+ }
886+
887+
888+fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
889+fromRepl root details source =
890+ do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
891+ case Parse.fromByteString projectType source of
892+ Left syntaxError ->
893+ return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
894+
895+ Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
896+ do dmvar <- Details.loadInterfaces root details
897+
898+ let deps = map Src.getImportName imports
899+ mvar <- newMVar Map.empty
900+ crawlDeps env mvar deps ()
901+
902+ statuses <- traverse readMVar =<< readMVar mvar
903+ midpoint <- checkMidpoint dmvar statuses
904+
905+ case midpoint of
906+ Left problem ->
907+ return $ Left $ Exit.ReplProjectProblem problem
908+
909+ Right foreigns ->
910+ do rmvar <- newEmptyMVar
911+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
912+ putMVar rmvar resultMVars
913+ results <- traverse readMVar resultMVars
914+ writeDetails root details results
915+ depsStatus <- checkDeps root resultMVars deps 0
916+ finalizeReplArtifacts env source modul depsStatus resultMVars results
917+
918+
919+finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
920+finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
921+ let
922+ pkg =
923+ projectTypeToPkg projectType
924+
925+ compileInput ifaces =
926+ case Compile.compile pkg ifaces modul of
927+ Right (Compile.Artifacts canonical annotations objects) ->
928+ let
929+ h = Can._name canonical
930+ m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
931+ ms = Map.foldrWithKey addInside [] results
932+ in
933+ return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
934+
935+ Left errors ->
936+ return $ Left $ Exit.ReplBadInput source errors
937+ in
938+ case depsStatus of
939+ DepsChange ifaces ->
940+ compileInput ifaces
941+
942+ DepsSame same cached ->
943+ do maybeLoaded <- loadInterfaces root same cached
944+ case maybeLoaded of
945+ Just ifaces -> compileInput ifaces
946+ Nothing -> return $ Left $ Exit.ReplBadCache
947+
948+ DepsBlock ->
949+ case Map.foldr addErrors [] results of
950+ [] -> return $ Left $ Exit.ReplBlocked
951+ e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
952+
953+ DepsNotFound problems ->
954+ return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
955+ toImportErrors env resultMVars imports problems
956+
957+
958+
959+--------------------------------------------------------------------------------
960+--------------------------------------------------------------------------------
961+------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
962+--------------------------------------------------------------------------------
963+--------------------------------------------------------------------------------
964+
965+
966+
967+-- FIND ROOT
968+
969+
970+data RootLocation
971+ = LInside ModuleName.Raw
972+ | LOutside FilePath
973+
974+
975+findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
976+findRoots env paths =
977+ do mvars <- traverse (fork . getRootInfo env) paths
978+ einfos <- traverse readMVar mvars
979+ return $ checkRoots =<< sequence einfos
980+
981+
982+checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
983+checkRoots infos =
984+ let
985+ toOneOrMore loc@(RootInfo absolute _ _) =
986+ (absolute, OneOrMore.one loc)
987+
988+ fromOneOrMore loc locs =
989+ case locs of
990+ [] -> Right ()
991+ loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
992+ in
993+ fmap (\_ -> fmap _location infos) $
994+ traverse (OneOrMore.destruct fromOneOrMore) $
995+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
996+
997+
998+
999+-- ROOT INFO
1000+
1001+
1002+data RootInfo =
1003+ RootInfo
1004+ { _absolute :: FilePath
1005+ , _relative :: FilePath
1006+ , _location :: RootLocation
1007+ }
1008+
1009+
1010+getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1011+getRootInfo env path =
1012+ do exists <- File.exists path
1013+ if exists
1014+ then getRootInfoHelp env path =<< Dir.canonicalizePath path
1015+ else return (Left (Exit.BP_PathUnknown path))
1016+
1017+
1018+getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1019+getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
1020+ let
1021+ (dirs, file) = FP.splitFileName absolutePath
1022+ (final, ext) = FP.splitExtension file
1023+ in
1024+ if ext /= ".elm"
1025+ then
1026+ return $ Left $ Exit.BP_WithBadExtension path
1027+ else
1028+ let
1029+ absoluteSegments = FP.splitDirectories dirs ++ [final]
1030+ in
1031+ case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
1032+ [] ->
1033+ return $ Right $ RootInfo absolutePath path (LOutside path)
1034+
1035+ [(_, Right names)] ->
1036+ do let name = Name.fromChars (List.intercalate "." names)
1037+ matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
1038+ case matchingDirs of
1039+ d1:d2:_ ->
1040+ do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
1041+ let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042+ return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043+
1044+ _ ->
1045+ return $ Right $ RootInfo absolutePath path (LInside name)
1046+
1047+ [(s, Left names)] ->
1048+ return $ Left $ Exit.BP_RootNameInvalid path s names
1049+
1050+ (s1,_):(s2,_):_ ->
1051+ return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1052+
1053+
1054+
1055+isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
1056+isInsideSrcDirByName names srcDir =
1057+ File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1058+
1059+
1060+isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061+isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1062+ case dropPrefix (FP.splitDirectories srcDir) segments of
1063+ Nothing ->
1064+ Nothing
1065+
1066+ Just names ->
1067+ if all isGoodName names
1068+ then Just (srcDir, Right names)
1069+ else Just (srcDir, Left names)
1070+
1071+
1072+isGoodName :: [Char] -> Bool
1073+isGoodName name =
1074+ case name of
1075+ [] ->
1076+ False
1077+
1078+ char:chars ->
1079+ Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1080+
1081+
1082+-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083+--
1084+dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1085+dropPrefix roots paths =
1086+ case roots of
1087+ [] ->
1088+ Just paths
1089+
1090+ r:rs ->
1091+ case paths of
1092+ [] -> Nothing
1093+ p:ps -> if r == p then dropPrefix rs ps else Nothing
1094+
1095+
1096+
1097+-- CRAWL ROOTS
1098+
1099+
1100+data RootStatus
1101+ = SInside ModuleName.Raw
1102+ | SOutsideOk Details.Local B.ByteString Src.Module
1103+ | SOutsideErr Error.Module
1104+
1105+
1106+crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
1107+crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1108+ case root of
1109+ LInside name ->
1110+ do statusMVar <- newEmptyMVar
1111+ statusDict <- takeMVar mvar
1112+ putMVar mvar (Map.insert name statusMVar statusDict)
1113+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1114+ return (SInside name)
1115+
1116+ LOutside path ->
1117+ do time <- File.getTime path
1118+ source <- File.readUtf8 path
1119+ case Parse.fromByteString projectType source of
1120+ Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1121+ do let deps = map Src.getImportName imports
1122+ let local = Details.Local path time deps (any isMain values) buildID buildID
1123+ crawlDeps env mvar deps (SOutsideOk local source modul)
1124+
1125+ Left syntaxError ->
1126+ return $ SOutsideErr $
1127+ Error.Module "???" path time source (Error.BadSyntax syntaxError)
1128+
1129+
1130+
1131+-- CHECK ROOTS
1132+
1133+
1134+data RootResult
1135+ = RInside ModuleName.Raw
1136+ | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1137+ | ROutsideErr Error.Module
1138+ | ROutsideBlocked
1139+
1140+
1141+checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
1142+checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1143+ case rootStatus of
1144+ SInside name ->
1145+ return (RInside name)
1146+
1147+ SOutsideErr err ->
1148+ return (ROutsideErr err)
1149+
1150+ SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1151+ do depsStatus <- checkDeps root results deps lastCompile
1152+ case depsStatus of
1153+ DepsChange ifaces ->
1154+ compileOutside env local source ifaces modul
1155+
1156+ DepsSame same cached ->
1157+ do maybeLoaded <- loadInterfaces root same cached
1158+ case maybeLoaded of
1159+ Nothing -> return ROutsideBlocked
1160+ Just ifaces -> compileOutside env local source ifaces modul
1161+
1162+ DepsBlock ->
1163+ return ROutsideBlocked
1164+
1165+ DepsNotFound problems ->
1166+ return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1167+ Error.BadImports (toImportErrors env results imports problems)
1168+
1169+
1170+compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
1171+compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1172+ let
1173+ pkg = projectTypeToPkg projectType
1174+ name = Src.getName modul
1175+ in
1176+ case Compile.compile pkg ifaces modul of
1177+ Right (Compile.Artifacts canonical annotations objects) ->
1178+ do Reporting.report key Reporting.BDone
1179+ return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1180+
1181+ Left errors ->
1182+ return $ ROutsideErr $ Error.Module name path time source errors
1183+
1184+
1185+
1186+-- TO ARTIFACTS
1187+
1188+
1189+data Root
1190+ = Inside ModuleName.Raw
1191+ | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1192+
1193+
1194+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
1195+toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
1196+ case gatherProblemsOrMains results rootResults of
1197+ Left (NE.List e es) ->
1198+ Left (Exit.BuildBadModules root e es)
1199+
1200+ Right roots ->
1201+ Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
1202+ Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
1203+
1204+
1205+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
1206+gatherProblemsOrMains results (NE.List rootResult rootResults) =
1207+ let
1208+ addResult result (es, roots) =
1209+ case result of
1210+ RInside n -> ( es, Inside n : roots)
1211+ ROutsideOk n i o -> ( es, Outside n i o : roots)
1212+ ROutsideErr e -> (e:es, roots)
1213+ ROutsideBlocked -> ( es, roots)
1214+
1215+ errors = Map.foldr addErrors [] results
1216+ in
1217+ case (rootResult, foldr addResult (errors, []) rootResults) of
1218+ (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1219+ (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1220+ (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1221+ (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1222+ (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1223+ (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1224+ (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1225+
1226+
1227+addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1228+addInside name result modules =
1229+ case result of
1230+ RNew _ iface objs _ -> Fresh name iface objs : modules
1231+ RSame _ iface objs _ -> Fresh name iface objs : modules
1232+ RCached main _ mvar -> Cached name main mvar : modules
1233+ RNotFound _ -> error (badInside name)
1234+ RProblem _ -> error (badInside name)
1235+ RBlocked -> error (badInside name)
1236+ RForeign _ -> modules
1237+ RKernel -> modules
1238+
1239+
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]
1246+addOutside root modules =
1247+ case root of
1248+ RInside _ -> modules
1249+ ROutsideOk name iface objs -> Fresh name iface objs : modules
1250+ ROutsideErr _ -> modules
1251+ ROutsideBlocked -> modules
builder/src/Deps/Bump.hsnew file+37
@@ -0,0 +1,37 @@
1+module Deps.Bump
2+ ( getPossibilities
3+ )
4+ where
5+
6+
7+import qualified Data.List as List
8+
9+import qualified Deps.Registry as Registry
10+import qualified Elm.Magnitude as M
11+import qualified Elm.Version as V
12+
13+
14+
15+-- GET POSSIBILITIES
16+
17+
18+getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]
19+getPossibilities (Registry.KnownVersions latest previous) =
20+ let
21+ allVersions = reverse (latest:previous)
22+ minorPoints = map last (List.groupBy sameMajor allVersions)
23+ patchPoints = map last (List.groupBy sameMinor allVersions)
24+ in
25+ (latest, V.bumpMajor latest, M.MAJOR)
26+ : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
27+ ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
28+
29+
30+sameMajor :: V.Version -> V.Version -> Bool
31+sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =
32+ major1 == major2
33+
34+
35+sameMinor :: V.Version -> V.Version -> Bool
36+sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =
37+ major1 == major2 && minor1 == minor2
builder/src/Deps/Diff.hs+10−8
@@ -18,7 +18,7 @@ import qualified Data.List as List
18import qualified Data.Map as Map
18import qualified Data.Map as Map
19import qualified Data.Name as Name
19import qualified Data.Name as Name
20import qualified Data.Set as Set
20import qualified Data.Set as Set
21−import qualified Data.Utf8 as Utf8
21+import qualified System.Directory as Dir
22import System.FilePath ((</>))
22import System.FilePath ((</>))
23
23
24import qualified Deps.Website as Website
24import qualified Deps.Website as Website
@@ -204,7 +204,7 @@ isSameName :: Name.Name -> Name.Name -> Bool
204isSameName oldFullName newFullName =
204isSameName oldFullName newFullName =
205 let
205 let
206 dedot name =
206 dedot name =
207− reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))
207+ reverse (Name.splitDots name)
208 in
208 in
209 case ( dedot oldFullName, dedot newFullName ) of
209 case ( dedot oldFullName, dedot newFullName ) of
210 (oldName:[], newName:_) ->
210 (oldName:[], newName:_) ->
@@ -357,12 +357,13 @@ changeMagnitude (Changes added changed removed) =
357
357
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359getDocs cache manager name version =
359getDocs cache manager name version =
360− do let path = Stuff.package cache name version </> "docs.json"
360+ do let home = Stuff.package cache name version
361+ let path = home </> "docs.json"
361 exists <- File.exists path
362 exists <- File.exists path
362 if exists
363 if exists
363 then
364 then
364− do result <- D.fromFile Docs.decoder path
365+ do bytes <- File.readUtf8 path
365− case result of
366+ case D.fromByteString Docs.decoder bytes of
366 Right docs ->
367 Right docs ->
367 return $ Right docs
368 return $ Right docs
368
369
@@ -371,11 +372,12 @@ getDocs cache manager name version =
371 return $ Left Exit.DP_Cache
372 return $ Left Exit.DP_Cache
372 else
373 else
373 do let url = Website.metadata name version "docs.json"
374 do let url = Website.metadata name version "docs.json"
374− Http.post manager url [] Exit.DP_Http $ \body ->
375+ Http.get manager url [] Exit.DP_Http $ \body ->
375 case D.fromByteString Docs.decoder body of
376 case D.fromByteString Docs.decoder body of
376 Right docs ->
377 Right docs ->
378+ do Dir.createDirectoryIfMissing True home
377− do File.writeUtf8 path body
379+ File.writeUtf8 path body
378 return $ Right docs
380 return $ Right docs
379
381
380 Left _ ->
382 Left _ ->
381− return $ Left Exit.DP_Data
383+ return $ Left $ Exit.DP_Data url body
builder/src/Deps/Plan.hsdeleted−64
@@ -1,64 +0,0 @@
1−module Install.Plan where
2−
3−import qualified Data.Map as Map
4−
5−import qualified Elm.Package.Solution as S
6−import qualified Elm.Package as Package
7−
8−
9−data Plan =
10− Plan
11− { installs :: Map.Map Package.Name Package.Version
12− , upgrades :: Map.Map Package.Name (Package.Version, Package.Version)
13− , removals :: Map.Map Package.Name Package.Version
14− }
15−
16−
17−create :: S.Solution -> S.Solution -> Plan
18−create old new =
19− Plan
20− { installs = Map.difference new old
21− , upgrades = discardNoOps (Map.intersectionWith (,) old new)
22− , removals = Map.difference old new
23− }
24− where
25− discardNoOps updates =
26− Map.mapMaybe isChanged updates
27−
28− isChanged upgrade@(oldVersion,newVersion) =
29− if oldVersion == newVersion
30− then Nothing
31− else Just upgrade
32−
33−
34−isEmpty :: Plan -> Bool
35−isEmpty (Plan installs upgrades removals) =
36− Map.null installs
37− && Map.null upgrades
38− && Map.null removals
39−
40−
41−-- DISPLAY
42−
43−display :: Plan -> String
44−display (Plan installs upgrades removals) =
45− "\n"
46− ++ displayCategory "Install" displayInstall installs
47− ++ displayCategory "Upgrade" displayUpgrade upgrades
48− ++ displayCategory "Remove" displayRemove removals
49− where
50− displayCategory name render category =
51− if Map.null category then "" else
52− " " ++ name ++ ":"
53− ++ concatMap (\entry -> "\n " ++ render entry) (Map.toList category)
54− ++ "\n"
55−
56− displayInstall (name, version) =
57− Package.toString name ++ " " ++ Package.versionToString version
58−
59− displayUpgrade (name, (old, new)) =
60− Package.toString name ++ " ("
61− ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")"
62−
63− displayRemove (name, _version) =
64− Package.toString name
builder/src/Deps/Registry.hs+40−73
@@ -16,11 +16,8 @@ module Deps.Registry
16import Prelude hiding (read)
16import Prelude hiding (read)
17import Control.Monad (liftM2)
17import Control.Monad (liftM2)
18import Data.Binary (Binary, get, put)
18import Data.Binary (Binary, get, put)
19−import Data.Function (on)
20import qualified Data.List as List
19import qualified Data.List as List
21import qualified Data.Map.Strict as Map
20import qualified Data.Map.Strict as Map
22−import qualified Data.Name as Name
23−import qualified Data.Utf8 as Utf8
24
21
25import qualified Deps.Website as Website
22import qualified Deps.Website as Website
26import qualified Elm.Package as Pkg
23import qualified Elm.Package as Pkg
@@ -28,8 +25,8 @@ import qualified Elm.Version as V
28import qualified File
25import qualified File
29import qualified Http
26import qualified Http
30import qualified Json.Decode as D
27import qualified Json.Decode as D
31−import qualified Reporting.Exit as E
28+import qualified Parse.Primitives as P
32−import qualified Reporting.Suggest as Suggest
29+import qualified Reporting.Exit as Exit
33import qualified Stuff
30import qualified Stuff
34
31
35
32
@@ -57,18 +54,14 @@ data KnownVersions =
57
54
58read :: Stuff.PackageCache -> IO (Maybe Registry)
55read :: Stuff.PackageCache -> IO (Maybe Registry)
59read cache =
56read cache =
60− do let path = Stuff.registry cache
57+ File.readBinary (Stuff.registry cache)
61− exists <- File.exists path
62− if exists
63− then File.readBinary path
64− else return Nothing
65
58
66
59
67
60
68-- FETCH
61-- FETCH
69
62
70
63
71−fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
64+fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
72fetch manager cache =
65fetch manager cache =
73 post manager "/all-packages" allPkgsDecoder $
66 post manager "/all-packages" allPkgsDecoder $
74 \versions ->
67 \versions ->
@@ -86,33 +79,26 @@ addEntry (KnownVersions _ vs) count =
86
79
87allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
80allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
88allPkgsDecoder =
81allPkgsDecoder =
89− do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
82+ let
90− checkKeys pairs Map.empty
83+ keyDecoder =
91− where
84+ Pkg.keyDecoder bail
92− checkKeys pairs pkgs =
93− case pairs of
94− [] ->
95− return pkgs
96−
97− (key, versions) : rest ->
98− case Pkg.fromString key of
99− Right pkg ->
100− case List.sortBy (flip compare) versions of
101− [] ->
102− D.failure ()
103
85
104− v:vs ->
86+ versionsDecoder =
105− checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
87+ D.list (D.mapError (\_ -> ()) V.decoder)
106
88
107− Left _ ->
89+ toKnownVersions versions =
90+ case List.sortBy (flip compare) versions of
91+ v:vs -> return (KnownVersions v vs)
108− D.failure ()
92+ [] -> D.failure ()
93+ in
94+ D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
109
95
110
96
111
97
112-- UPDATE
98-- UPDATE
113
99
114
100
115−update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either E.RegistryProblem Registry)
101+update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
116update manager cache oldRegistry@(Registry size packages) =
102update manager cache oldRegistry@(Registry size packages) =
117 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
103 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
118 \news ->
104 \news ->
@@ -144,29 +130,33 @@ addNew (name, version) versions =
144 Map.alter (Just . add) name versions
130 Map.alter (Just . add) name versions
145
131
146
132
133+
134+-- NEW PACKAGE DECODER
135+
136+
147newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
148newPkgDecoder =
138newPkgDecoder =
149− do str <- D.string
139+ D.customString newPkgParser bail
150− case Utf8.split 0x40 {-@-} str of
140+
151− [key, value] ->
152− case Pkg.fromString key of
153− Right pkg ->
154− case V.fromString value of
155− Just vsn -> return (pkg, vsn)
156− Nothing -> D.failure ()
157
141
158− Left _ ->
142+newPkgParser :: P.Parser () (Pkg.Name, V.Version)
159− D.failure ()
143+newPkgParser =
144+ do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
145+ P.word1 0x40 {-@-} bail
146+ vsn <- P.specialize (\_ _ _ -> ()) V.parser
147+ return (pkg, vsn)
160
148
161− _ ->
149+
162− D.failure ()
150+bail :: row -> col -> ()
151+bail _ _ =
152+ ()
163
153
164
154
165
155
166-- LATEST
156-- LATEST
167
157
168
158
169−latest :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
159+latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
170latest manager cache =
160latest manager cache =
171 do maybeOldRegistry <- read cache
161 do maybeOldRegistry <- read cache
172 case maybeOldRegistry of
162 case maybeOldRegistry of
@@ -190,46 +180,23 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
190getVersions' name (Registry _ versions) =
180getVersions' name (Registry _ versions) =
191 case Map.lookup name versions of
181 case Map.lookup name versions of
192 Just kvs -> Right kvs
182 Just kvs -> Right kvs
193− Nothing -> Left $ nearbyNames name (Map.keys versions)
183+ Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
194−
195−
196−nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197−nearbyNames (Pkg.Name author1 project1) possibleNames =
198− let
199− authorDist = authorDistance (Name.toChars author1)
200− projectDist = projectDistance (Name.toChars project1)
201−
202− addDistance name@(Pkg.Name author2 project2) =
203− ( authorDist author2 + projectDist project2, name )
204− in
205− map snd $ take 4 $
206− List.sortBy (compare `on` fst) $
207− map addDistance possibleNames
208−
209−
210−authorDistance :: String -> Name.Name -> Int
211−authorDistance bad possibility =
212− abs (Suggest.distance bad (Name.toChars possibility))
213−
214−
215−projectDistance :: String -> Name.Name -> Int
216−projectDistance bad possibility =
217− if possibility == "elm" || possibility == "elm-explorations"
218− then 0
219− else abs (Suggest.distance bad (Name.toChars possibility))
220
184
221
185
222
186
223-- POST
187-- POST
224
188
225
189
226−post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either E.RegistryProblem b)
190+post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
227post manager path decoder callback =
191post manager path decoder callback =
192+ let
228− Http.post manager (Website.route path []) [] E.RP_Http $
193+ url = Website.route path []
194+ in
195+ Http.post manager url [] Exit.RP_Http $
229 \body ->
196 \body ->
230 case D.fromByteString decoder body of
197 case D.fromByteString decoder body of
231 Right a -> Right <$> callback a
198 Right a -> Right <$> callback a
232− Left _ -> return $ Left E.RP_Data
199+ Left _ -> return $ Left $ Exit.RP_Data url body
233
200
234
201
235
202
builder/src/Deps/Solver.hs+258−149
@@ -1,14 +1,25 @@
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Deps.Solver
2module Deps.Solver
3− ( online
3+ ( Solver
4− , offline
4+ , Result(..)
5+ , Connection(..)
6+ --
5 , Details(..)
7 , Details(..)
8+ , verify
9+ --
10+ , AppSolution(..)
11+ , addToApp
12+ --
13+ , Env(..)
14+ , initEnv
6 )
15 )
7 where
16 where
8
17
9
18
10import Control.Monad (foldM)
19import Control.Monad (foldM)
20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
11import qualified Data.Map as Map
21import qualified Data.Map as Map
22+import Data.Map ((!))
12import qualified System.Directory as Dir
23import qualified System.Directory as Dir
13import System.FilePath ((</>))
24import System.FilePath ((</>))
14
25
@@ -21,52 +32,11 @@ import qualified Elm.Version as V
21import qualified File
32import qualified File
22import qualified Http
33import qualified Http
23import qualified Json.Decode as D
34import qualified Json.Decode as D
35+import qualified Reporting.Exit as Exit
24import qualified Stuff
36import qualified Stuff
25
37
26
38
27
39
28−-- ONLINE / OFFLINE
29−
30−
31−online :: Stuff.PackageCache -> Http.Manager -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
32−online cache manager registry constraints =
33− solve cache (Online manager) registry constraints
34−
35−
36−offline :: Stuff.PackageCache -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
37−offline cache registry constraints =
38− solve cache Offline registry constraints
39−
40−
41−
42−-- SOLVE
43−
44−
45−data Details =
46− Details V.Version (Map.Map Pkg.Name C.Constraint)
47−
48−
49−solve :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
50−solve cache connection registry constraints =
51− let
52− (Solver solver) = exploreGoals (Goals constraints Map.empty)
53− in
54− solver (State cache connection registry Map.empty [])
55− (\(State _ _ _ cs _) vs _ -> return $ Right $ Map.mapWithKey (toDetails cs) vs)
56− (\(State _ _ _ _ ps) -> return $ Left ps)
57−
58−
59−toDetails :: Map.Map (Pkg.Name, V.Version) Constraints -> Pkg.Name -> V.Version -> Details
60−toDetails constraints name vsn =
61− case Map.lookup (name, vsn) constraints of
62− Just (Constraints _ deps) ->
63− Details vsn deps
64−
65− Nothing ->
66− error "compiler bug in Deps.Solver manifesting in toDetails"
67−
68−
69−
70-- SOLVER
40-- SOLVER
71
41
72
42
@@ -77,21 +47,17 @@ newtype Solver a =
77 State
47 State
78 -> (State -> a -> (State -> IO b) -> IO b)
48 -> (State -> a -> (State -> IO b) -> IO b)
79 -> (State -> IO b)
49 -> (State -> IO b)
50+ -> (Exit.Solver -> IO b)
80 -> IO b
51 -> IO b
81 )
52 )
82
53
83
54
84−
85−-- STATE
86−
87−
88data State =
55data State =
89 State
56 State
90 { _cache :: Stuff.PackageCache
57 { _cache :: Stuff.PackageCache
91− , _internet :: Connection
58+ , _connection :: Connection
92 , _registry :: Registry.Registry
59 , _registry :: Registry.Registry
93 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
60 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
94− , _problems :: [Problem]
95 }
61 }
96
62
97
63
@@ -107,13 +73,126 @@ data Connection
107 | Offline
73 | Offline
108
74
109
75
110−data Problem
76+
111− = BadCacheData Pkg.Name V.Version
77+-- RESULT
112− | BadHttpData Pkg.Name V.Version
78+
113− | BadHttp Http.Error
79+
114− | UnknownPackage [Pkg.Name]
80+data Result a
115− | ImpossibleConstraint Pkg.Name C.Constraint
81+ = Ok a
116− | UnavailableOffline Pkg.Name V.Version
82+ | NoSolution
83+ | NoOfflineSolution
84+ | Err Exit.Solver
85+
86+
87+
88+-- VERIFY -- used by Elm.Details
89+
90+
91+data Details =
92+ Details V.Version (Map.Map Pkg.Name C.Constraint)
93+
94+
95+verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96+verify cache connection registry constraints =
97+ Stuff.withRegistryLock cache $
98+ case try constraints of
99+ Solver solver ->
100+ solver (State cache connection registry Map.empty)
101+ (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
102+ (\_ -> return $ noSolution connection)
103+ (\e -> return $ Err e)
104+
105+
106+addDeps :: State -> Pkg.Name -> V.Version -> Details
107+addDeps (State _ _ _ constraints) name vsn =
108+ case Map.lookup (name, vsn) constraints of
109+ Just (Constraints _ deps) -> Details vsn deps
110+ Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
111+
112+
113+noSolution :: Connection -> Result a
114+noSolution connection =
115+ case connection of
116+ Online _ -> NoSolution
117+ Offline -> NoOfflineSolution
118+
119+
120+
121+-- ADD TO APP - used in Install
122+
123+
124+data AppSolution =
125+ AppSolution
126+ { _old :: Map.Map Pkg.Name V.Version
127+ , _new :: Map.Map Pkg.Name V.Version
128+ , _app :: Outline.AppOutline
129+ }
130+
131+
132+addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
133+addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134+ Stuff.withRegistryLock cache $
135+ let
136+ allIndirects = Map.union indirect testIndirect
137+ allDirects = Map.union direct testDirect
138+ allDeps = Map.union allDirects allIndirects
139+
140+ attempt toConstraint deps =
141+ try (Map.insert pkg C.anything (Map.map toConstraint deps))
142+ in
143+ case
144+ oneOf
145+ ( attempt C.exactly allDeps )
146+ [ attempt C.exactly allDirects
147+ , attempt C.untilNextMinor allDirects
148+ , attempt C.untilNextMajor allDirects
149+ , attempt (\_ -> C.anything) allDirects
150+ ]
151+ of
152+ Solver solver ->
153+ solver (State cache connection registry Map.empty)
154+ (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
155+ (\_ -> return $ noSolution connection)
156+ (\e -> return $ Err e)
157+
158+
159+toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
160+toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
161+ let
162+ d = Map.intersection new (Map.insert pkg V.one direct)
163+ i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
164+ td = Map.intersection new (Map.delete pkg testDirect)
165+ ti = Map.difference new (Map.unions [d,i,td])
166+ in
167+ AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
168+
169+
170+getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
171+getTransitive constraints solution unvisited visited =
172+ case unvisited of
173+ [] ->
174+ visited
175+
176+ info@(pkg,vsn) : infos ->
177+ if Map.member pkg visited
178+ then getTransitive constraints solution infos visited
179+ else
180+ let
181+ newDeps = _deps (constraints ! info)
182+ newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
183+ newVisited = Map.insert pkg vsn visited
184+ in
185+ getTransitive constraints solution infos $
186+ getTransitive constraints solution newUnvisited newVisited
187+
188+
189+
190+-- TRY
191+
192+
193+try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
194+try constraints =
195+ exploreGoals (Goals constraints Map.empty)
117
196
118
197
119
198
@@ -149,7 +228,7 @@ addVersion (Goals pending solved) name version =
149 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
228 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
150 return (Goals newPending (Map.insert name version solved))
229 return (Goals newPending (Map.insert name version solved))
151 else
230 else
152− deadend
231+ backtrack
153
232
154
233
155addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
234addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
@@ -158,7 +237,7 @@ addConstraint solved unsolved (name, newConstraint) =
158 Just version ->
237 Just version ->
159 if C.satisfies newConstraint version
238 if C.satisfies newConstraint version
160 then return unsolved
239 then return unsolved
161− else deadend
240+ else backtrack
162
241
163 Nothing ->
242 Nothing ->
164 case Map.lookup name unsolved of
243 case Map.lookup name unsolved of
@@ -168,7 +247,7 @@ addConstraint solved unsolved (name, newConstraint) =
168 Just oldConstraint ->
247 Just oldConstraint ->
169 case C.intersect oldConstraint newConstraint of
248 case C.intersect oldConstraint newConstraint of
170 Nothing ->
249 Nothing ->
171− deadend
250+ backtrack
172
251
173 Just mergedConstraint ->
252 Just mergedConstraint ->
174 if oldConstraint == mergedConstraint
253 if oldConstraint == mergedConstraint
@@ -182,18 +261,15 @@ addConstraint solved unsolved (name, newConstraint) =
182
261
183getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
262getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
184getRelevantVersions name constraint =
263getRelevantVersions name constraint =
185− Solver $ \state@(State _ _ registry _ _) ok err ->
264+ Solver $ \state@(State _ _ registry _) ok back _ ->
186− case Registry.getVersions' name registry of
265+ case Registry.getVersions name registry of
187− Right (Registry.KnownVersions newest previous) ->
266+ Just (Registry.KnownVersions newest previous) ->
188 case filter (C.satisfies constraint) (newest:previous) of
267 case filter (C.satisfies constraint) (newest:previous) of
189− [] ->
268+ [] -> back state
190− err (addProblem (ImpossibleConstraint name constraint) state)
191−
192− v:vs ->
193− ok state (v,vs) err
269+ v:vs -> ok state (v,vs) back
194
270
195− Left suggestions ->
271+ Nothing ->
196− err (addProblem (UnknownPackage suggestions) state)
272+ back state
197
273
198
274
199
275
@@ -201,59 +277,57 @@ getRelevantVersions name constraint =
201
277
202
278
203getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
279getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
204−getConstraints name version =
280+getConstraints pkg vsn =
205− Solver $ \state@(State cache connection registry cDict ps) ok err ->
281+ Solver $ \state@(State cache connection registry cDict) ok back err ->
206− do let key = (name, version)
282+ do let key = (pkg, vsn)
207 case Map.lookup key cDict of
283 case Map.lookup key cDict of
208 Just cs ->
284 Just cs ->
209− ok state cs err
285+ ok state cs back
210
286
211 Nothing ->
287 Nothing ->
212− do result <- getConstraintsHelp cache connection name version
213− case result of
214− Right cs ->
215− ok (State cache connection registry (Map.insert key cs cDict) ps) cs err
288+ do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
216−
289+ let home = Stuff.package cache pkg vsn
217− Left p ->
218− err (State cache connection registry cDict (p:ps))
219−
220−
221−getConstraintsHelp :: Stuff.PackageCache -> Connection -> Pkg.Name -> V.Version -> IO (Either Problem Constraints)
222−getConstraintsHelp cache connection name version =
223− do let path = Stuff.package cache name version </> "elm.json"
290+ let path = home </> "elm.json"
224− outlineExists <- File.exists path
291+ outlineExists <- File.exists path
225− if outlineExists
292+ if outlineExists
226− then
293+ then
227− do result <- D.fromFile constraintsDecoder path
294+ do bytes <- File.readUtf8 path
228− case result of
295+ case D.fromByteString constraintsDecoder bytes of
229− Right cs ->
296+ Right cs ->
230− case connection of
297+ case connection of
231− Online _ ->
298+ Online _ ->
232− return $ Right cs
299+ ok (toNewState cs) cs back
233−
300+
234− Offline ->
301+ Offline ->
235− do srcExists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
302+ do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
236− if srcExists
303+ if srcExists
237− then return $ Right cs
304+ then ok (toNewState cs) cs back
238− else return $ Left (UnavailableOffline name version)
305+ else back state
239−
306+
240− Left _ ->
307+ Left _ ->
241− do File.remove path
308+ do File.remove path
242− return $ Left (BadCacheData name version)
309+ err (Exit.SolverBadCacheData pkg vsn)
243− else
310+ else
244− case connection of
311+ case connection of
245− Offline ->
312+ Offline ->
246− return (Left (UnavailableOffline name version))
313+ back state
247−
314+
248− Online manager ->
315+ Online manager ->
249− Http.post manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->
316+ do let url = Website.metadata pkg vsn "elm.json"
317+ result <- Http.get manager url [] id (return . Right)
318+ case result of
319+ Left httpProblem ->
320+ err (Exit.SolverBadHttp pkg vsn httpProblem)
321+
322+ Right body ->
250− case D.fromByteString constraintsDecoder body of
323+ case D.fromByteString constraintsDecoder body of
251− Right cs ->
324+ Right cs ->
325+ do Dir.createDirectoryIfMissing True home
252− do File.writeUtf8 path body
326+ File.writeUtf8 path body
253− return $ Right cs
327+ ok (toNewState cs) cs back
254−
328+
255− Left _ ->
329+ Left _ ->
256− return $ Left (BadHttpData name version)
330+ err (Exit.SolverBadHttpData pkg vsn url)
257
331
258
332
259constraintsDecoder :: D.Decoder () Constraints
333constraintsDecoder :: D.Decoder () Constraints
@@ -268,46 +342,83 @@ constraintsDecoder =
268
342
269
343
270
344
345+-- ENVIRONMENT
346+
347+
348+data Env =
349+ Env Stuff.PackageCache Http.Manager Connection Registry.Registry
350+
351+
352+initEnv :: IO (Either Exit.RegistryProblem Env)
353+initEnv =
354+ do mvar <- newEmptyMVar
355+ _ <- forkIO $ putMVar mvar =<< Http.getManager
356+ cache <- Stuff.getPackageCache
357+ Stuff.withRegistryLock cache $
358+ do maybeRegistry <- Registry.read cache
359+ manager <- readMVar mvar
360+
361+ case maybeRegistry of
362+ Nothing ->
363+ do eitherRegistry <- Registry.fetch manager cache
364+ case eitherRegistry of
365+ Right latestRegistry ->
366+ return $ Right $ Env cache manager (Online manager) latestRegistry
367+
368+ Left problem ->
369+ return $ Left $ problem
370+
371+ Just cachedRegistry ->
372+ do eitherRegistry <- Registry.update manager cache cachedRegistry
373+ case eitherRegistry of
374+ Right latestRegistry ->
375+ return $ Right $ Env cache manager (Online manager) latestRegistry
376+
377+ Left _ ->
378+ return $ Right $ Env cache manager Offline cachedRegistry
379+
380+
381+
271-- INSTANCES
382-- INSTANCES
272
383
273
384
274instance Functor Solver where
385instance Functor Solver where
275 fmap func (Solver solver) =
386 fmap func (Solver solver) =
276− Solver $ \state ok err ->
387+ Solver $ \state ok back err ->
277 let
388 let
278− okA stateA arg errA = ok stateA (func arg) errA
389+ okA stateA arg backA = ok stateA (func arg) backA
279 in
390 in
280− solver state okA err
391+ solver state okA back err
281
392
282
393
283instance Applicative Solver where
394instance Applicative Solver where
284 pure a =
395 pure a =
285− Solver $ \state ok err -> ok state a err
396+ Solver $ \state ok back _ -> ok state a back
286
397
287 (<*>) (Solver solverFunc) (Solver solverArg) =
398 (<*>) (Solver solverFunc) (Solver solverArg) =
288− Solver $ \state ok err ->
399+ Solver $ \state ok back err ->
289 let
400 let
290− okF stateF func errF =
401+ okF stateF func backF =
291 let
402 let
292− okA stateA arg errA = ok stateA (func arg) errA
403+ okA stateA arg backA = ok stateA (func arg) backA
293 in
404 in
294− solverArg stateF okA errF
405+ solverArg stateF okA backF err
295 in
406 in
296− solverFunc state okF err
407+ solverFunc state okF back err
297
408
298
409
299instance Monad Solver where
410instance Monad Solver where
300 return a =
411 return a =
301− Solver $ \state ok err -> ok state a err
412+ Solver $ \state ok back _ -> ok state a back
302
413
303 (>>=) (Solver solverA) callback =
414 (>>=) (Solver solverA) callback =
304− Solver $ \state ok err ->
415+ Solver $ \state ok back err ->
305 let
416 let
306− okA stateA a errA =
417+ okA stateA a backA =
307 case callback a of
418 case callback a of
308− Solver solverB -> solverB stateA ok errA
419+ Solver solverB -> solverB stateA ok backA err
309 in
420 in
310− solverA state okA err
421+ solverA state okA back err
311
422
312
423
313oneOf :: Solver a -> [Solver a] -> Solver a
424oneOf :: Solver a -> [Solver a] -> Solver a
@@ -317,19 +428,17 @@ oneOf solver@(Solver solverHead) solvers =
317 solver
428 solver
318
429
319 s:ss ->
430 s:ss ->
320− Solver $ \state0 ok err ->
431+ Solver $ \state0 ok back err ->
321− solverHead state0 ok $ \state1 ->
432+ let
433+ tryTail state1 =
322− let
434+ let
323− (Solver solverTail) = oneOf s ss
435+ (Solver solverTail) = oneOf s ss
324− in
436+ in
325− solverTail state1 ok err
437+ solverTail state1 ok back err
326−
438+ in
327−
439+ solverHead state0 ok tryTail err
440+
441+
328−deadend :: Solver a
442+backtrack :: Solver a
329−deadend =
443+backtrack =
330− Solver $ \state _ err -> err state
444+ Solver $ \state _ back _ -> back state
331−
332−
333−addProblem :: Problem -> State -> State
334−addProblem problem (State cache registry cDict maybeManager problems) =
335− State cache registry cDict maybeManager (problem:problems)
builder/src/Elm/Bump.hsdeleted−137
@@ -1,137 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Bump
3− ( bump
4− , toPossibleBumps
5− )
6− where
7−
8−
9−import Control.Monad.Trans (liftIO)
10−import qualified Data.List as List
11−
12−import qualified Deps.Cache as Cache
13−import qualified Deps.Diff as Diff
14−import qualified Elm.Project.Json as Project
15−import qualified Elm.Project.Summary as Summary
16−import qualified Elm.Version as V
17−import Reporting.Doc ((<>), (<+>))
18−import qualified Reporting.Doc as D
19−import qualified Reporting.Exit as Exit
20−import qualified Reporting.Exit.Bump as E
21−import qualified Reporting.Exit.Help as Help
22−import qualified Reporting.Progress.Terminal as Terminal
23−import qualified Reporting.Task as Task
24−
25−
26−
27−-- BUMP
28−
29−
30−bump :: Summary.Summary -> Task.Task ()
31−bump summary@(Summary.Summary root project _ _ _) =
32− case project of
33− Project.App _ ->
34− Task.throw (Exit.Bump E.Application)
35−
36− Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
37− do registry <- Cache.mandatoryUpdate
38− case Cache.getVersions name registry of
39− Left _suggestions ->
40− checkNewPackage root info
41−
42− Right publishedVersions ->
43− let
44− bumpableVersions =
45− map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
46− in
47− if elem version bumpableVersions then
48− suggestVersion summary info
49− else
50− Task.throw $ Exit.Bump $ E.Unbumpable version $
51− map head (List.group (List.sort bumpableVersions))
52−
53−
54−
55−-- VALID BUMPS
56−
57−
58−toPossibleBumps :: [V.Version] -> [(V.Version, V.Version, Diff.Magnitude)]
59−toPossibleBumps publishedVersions =
60− case publishedVersions of
61− [] ->
62− []
63−
64− _ ->
65− let
66− patchPoints =
67− V.filterLatest V.majorAndMinor publishedVersions
68−
69− minorPoints =
70− V.filterLatest V._major publishedVersions
71−
72− majorPoint =
73− maximum publishedVersions
74− in
75− (majorPoint, V.bumpMajor majorPoint, Diff.MAJOR)
76− : map (\v -> (v, V.bumpMinor v, Diff.MINOR)) minorPoints
77− ++ map (\v -> (v, V.bumpPatch v, Diff.PATCH)) patchPoints
78−
79−
80−
81−-- CHECK NEW PACKAGE
82−
83−
84−checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
85−checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
86− do liftIO $ putStrLn Terminal.newPackageOverview
87− if version == V.one
88− then
89− liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
90− else
91− changeVersion root info V.one $
92− "It looks like the version in elm.json has been changed though!\n\
93− \Would you like me to change it back to "
94− <> D.fromUtf8 (V.toString V.one) <> "? [Y/n] "
95−
96−
97−
98−-- SUGGEST VERSION
99−
100−
101−suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
102−suggestVersion (Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
103− do oldDocs <- Cache.getDocs name version
104− newDocs <- Task.silently (error "TODO Project.generateDocs summary")
105− let changes = Diff.diff oldDocs newDocs
106− let newVersion = Diff.bump changes version
107− changeVersion root info newVersion $
108− let
109− old = D.fromUtf8 $ V.toString version
110− new = D.fromUtf8 $ V.toString newVersion
111− mag = D.fromChars $ Diff.magnitudeToString (Diff.toMagnitude changes)
112− in
113− "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
114− <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
115− <> "\n"
116− <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
117−
118−
119−
120−-- CHANGE VERSION
121−
122−
123−changeVersion :: FilePath -> Project.PkgInfo -> V.Version -> D.Doc -> Task.Task ()
124−changeVersion root info targetVersion explanation =
125− do approved <- Task.getApproval explanation
126− if not approved
127− then
128− liftIO $ putStrLn "Okay, I did not change anything!"
129−
130− else
131− do liftIO $ Project.write root $ Project.Pkg $
132− info { Project._pkg_version = targetVersion }
133−
134− liftIO $ Help.toStdout $
135− "Version changed to "
136− <> D.green (D.fromUtf8 (V.toString targetVersion))
137− <> "!\n"
builder/src/Elm/Details.hs+479−223
@@ -2,35 +2,48 @@
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Elm.Details
3module Elm.Details
4 ( Details(..)
4 ( Details(..)
5+ , BuildID
5 , ValidOutline(..)
6 , ValidOutline(..)
6 , Local(..)
7 , Local(..)
7 , Foreign(..)
8 , Foreign(..)
8− , verify
9+ , load
10+ , loadObjects
11+ , loadInterfaces
12+ , verifyInstall
9 )
13 )
10 where
14 where
11
15
12
16
13import Control.Concurrent (forkIO)
17import Control.Concurrent (forkIO)
14import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
18import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
15−import Control.Monad (liftM, liftM2, liftM3, liftM4)
19+import Control.Monad (liftM, liftM2, liftM3)
16import Data.Binary (Binary, get, put, getWord8, putWord8)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
17−import Data.Foldable (traverse_)
21+import qualified Data.Either as Either
18import qualified Data.Map as Map
22import qualified Data.Map as Map
23+import qualified Data.Map.Utils as Map
19import qualified Data.Map.Merge.Strict as Map
24import qualified Data.Map.Merge.Strict as Map
25+import qualified Data.Maybe as Maybe
26+import qualified Data.Name as Name
27+import qualified Data.NonEmptyList as NE
20import qualified Data.OneOrMore as OneOrMore
28import qualified Data.OneOrMore as OneOrMore
21import qualified Data.Set as Set
29import qualified Data.Set as Set
22import qualified Data.Utf8 as Utf8
30import qualified Data.Utf8 as Utf8
31+import Data.Word (Word64)
23import qualified System.Directory as Dir
32import qualified System.Directory as Dir
24import System.FilePath ((</>), (<.>))
33import System.FilePath ((</>), (<.>))
25
34
35+import qualified AST.Canonical as Can
26import qualified AST.Source as Src
36import qualified AST.Source as Src
27import qualified AST.Optimized as Opt
37import qualified AST.Optimized as Opt
38+import qualified BackgroundWriter as BW
28import qualified Compile
39import qualified Compile
29import qualified Deps.Registry as Registry
40import qualified Deps.Registry as Registry
30import qualified Deps.Solver as Solver
41import qualified Deps.Solver as Solver
31import qualified Deps.Website as Website
42import qualified Deps.Website as Website
32import qualified Elm.Constraint as Con
43import qualified Elm.Constraint as Con
44+import qualified Elm.Docs as Docs
33import qualified Elm.Interface as I
45import qualified Elm.Interface as I
46+import qualified Elm.Kernel as Kernel
34import qualified Elm.ModuleName as ModuleName
47import qualified Elm.ModuleName as ModuleName
35import qualified Elm.Outline as Outline
48import qualified Elm.Outline as Outline
36import qualified Elm.Package as Pkg
49import qualified Elm.Package as Pkg
@@ -38,7 +51,10 @@ import qualified Elm.Version as V
38import qualified File
51import qualified File
39import qualified Http
52import qualified Http
40import qualified Json.Decode as D
53import qualified Json.Decode as D
54+import qualified Json.Encode as E
41import qualified Parse.Module as Parse
55import qualified Parse.Module as Parse
56+import qualified Reporting
57+import qualified Reporting.Annotation as A
42import qualified Reporting.Exit as Exit
58import qualified Reporting.Exit as Exit
43import qualified Reporting.Task as Task
59import qualified Reporting.Task as Task
44import qualified Stuff
60import qualified Stuff
@@ -52,21 +68,42 @@ data Details =
52 Details
68 Details
53 { _outlineTime :: File.Time
69 { _outlineTime :: File.Time
54 , _outline :: ValidOutline
70 , _outline :: ValidOutline
71+ , _buildID :: BuildID
55 , _locals :: Map.Map ModuleName.Raw Local
72 , _locals :: Map.Map ModuleName.Raw Local
56 , _foreigns :: Map.Map ModuleName.Raw Foreign
73 , _foreigns :: Map.Map ModuleName.Raw Foreign
74+ , _extras :: Extras
57 }
75 }
58
76
59
77
60−data ValidOutline
78+type BuildID = Word64
61− = ValidApp Outline.AppOutline
62− | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)
63
79
64
80
81+data ValidOutline
82+ = ValidApp (NE.List Outline.SrcDir)
83+ | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
84+
85+
86+-- NOTE: we need two ways to detect if a file must be recompiled:
87+--
88+-- (1) _time is the modification time from the last time we compiled the file.
89+-- By checking EQUALITY with the current modification time, we can detect file
90+-- saves and `git checkout` of previous versions. Both need a recompile.
91+--
92+-- (2) _lastChange is the BuildID from the last time a new interface file was
93+-- generated, and _lastCompile is the BuildID from the last time the file was
94+-- compiled. These may be different if a file is recompiled but the interface
95+-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
96+-- imports, we need to recompile. This can happen when a project has multiple
97+-- entrypoints and some modules are compiled less often than their imports.
98+--
65data Local =
99data Local =
66 Local
100 Local
67 { _path :: FilePath
101 { _path :: FilePath
68 , _time :: File.Time
102 , _time :: File.Time
69 , _deps :: [ModuleName.Raw]
103 , _deps :: [ModuleName.Raw]
104+ , _main :: Bool
105+ , _lastChange :: BuildID
106+ , _lastCompile :: BuildID
70 }
107 }
71
108
72
109
@@ -74,117 +111,150 @@ data Foreign =
74 Foreign Pkg.Name [Pkg.Name]
111 Foreign Pkg.Name [Pkg.Name]
75
112
76
113
114+data Extras
115+ = ArtifactsCached
116+ | ArtifactsFresh Interfaces Opt.GlobalGraph
117+
118+
119+type Interfaces =
120+ Map.Map ModuleName.Canonical I.DependencyInterface
121+
122+
123+
124+-- LOAD ARTIFACTS
125+
126+
127+loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
128+loadObjects root (Details _ _ _ _ _ extras) =
129+ case extras of
130+ ArtifactsFresh _ o -> newMVar (Just o)
131+ ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
132+
133+
134+loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
135+loadInterfaces root (Details _ _ _ _ _ extras) =
136+ case extras of
137+ ArtifactsFresh i _ -> newMVar (Just i)
138+ ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
139+
140+
77
141
78−-- VERIFY
142+-- VERIFY INSTALL -- used by Install
79
143
80
144
81−verify :: FilePath -> Task.Task Details
145+verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
82−verify root =
146+verifyInstall scope root (Solver.Env cache manager connection registry) outline =
147+ do time <- File.getTime (root </> "elm.json")
148+ let key = Reporting.ignorer
149+ let env = Env key scope root cache manager connection registry
150+ case outline of
151+ Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
152+ Outline.App app -> Task.run (verifyApp env time app >> return ())
153+
154+
155+
156+-- LOAD -- used by Make, Repl, Reactor
157+
158+
159+load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
160+load style scope root =
83− do newTime <- Task.io $ File.getTime (root </> "elm.json")
161+ do newTime <- File.getTime (root </> "elm.json")
84− maybeDetails <- Task.io $ File.readBinary (root </> Stuff.details)
162+ maybeDetails <- File.readBinary (Stuff.details root)
85 case maybeDetails of
163 case maybeDetails of
86 Nothing ->
164 Nothing ->
87− rebuild root newTime
165+ generate style scope root newTime
88
166
89− Just details@(Details oldTime _ _ _) ->
167+ Just details@(Details oldTime _ buildID _ _ _) ->
90 if oldTime == newTime
168 if oldTime == newTime
91− then return details
169+ then return (Right details { _buildID = buildID + 1 })
92− else rebuild root newTime
170+ else generate style scope root newTime
93
171
94
172
95
173
96−-- REBUILD
174+-- GENERATE
97
175
98
176
99−rebuild :: FilePath -> File.Time -> Task.Task Details
177+generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
100−rebuild root time =
178+generate style scope root time =
101− do (outline, info) <- rebuildHelp root
179+ Reporting.trackDetails style $ \key ->
180+ do result <- initEnv key scope root
102− case outline of
181+ case result of
103− Outline.Pkg pkg -> solvePkg info time pkg
182+ Left exit ->
104− Outline.App app -> solveApp info time app
183+ return (Left exit)
105
184
185+ Right (env, outline) ->
186+ case outline of
187+ Outline.Pkg pkg -> Task.run (verifyPkg env time pkg)
188+ Outline.App app -> Task.run (verifyApp env time app)
106
189
107−data Info =
108− Info Stuff.PackageCache Http.Manager Connection Registry.Registry
109
190
110
191
111−data Connection
192+-- ENV
112− = Online
113− | Offline
114
193
115
194
116−rebuildHelp :: FilePath -> Task.Task (Outline.Outline, Info)
195+data Env =
117−rebuildHelp root =
196+ Env
118− Task.eio id $
197+ { _key :: Reporting.DKey
119− do cacheMVar <- fork Stuff.getPackageCache
198+ , _scope :: BW.Scope
120− managerMVar <- fork Http.getManager
199+ , _root :: FilePath
121− registryMVar <- fork (Registry.read =<< readMVar cacheMVar)
200+ , _cache :: Stuff.PackageCache
201+ , _manager :: Http.Manager
202+ , _connection :: Solver.Connection
203+ , _registry :: Registry.Registry
204+ }
205+
206+
207+initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
208+initEnv key scope root =
209+ do mvar <- fork Solver.initEnv
122 eitherOutline <- Outline.read root
210 eitherOutline <- Outline.read root
123− cache <- readMVar cacheMVar
124− manager <- readMVar managerMVar
125− maybeRegistry <- readMVar registryMVar
126 case eitherOutline of
211 case eitherOutline of
127 Left problem ->
212 Left problem ->
128 return $ Left $ Exit.DetailsBadOutline problem
213 return $ Left $ Exit.DetailsBadOutline problem
129
214
130 Right outline ->
215 Right outline ->
131− case maybeRegistry of
216+ do maybeEnv <- readMVar mvar
132− Nothing ->
217+ case maybeEnv of
133− do eitherRegistry <- Registry.fetch manager cache
218+ Left problem ->
134− case eitherRegistry of
219+ return $ Left $ Exit.DetailsCannotGetRegistry problem
135− Right latestRegistry ->
136− return $ Right (outline, Info cache manager Online latestRegistry)
137
220
138− Left problem ->
221+ Right (Solver.Env cache manager connection registry) ->
139− return $ Left $ Exit.DetailsCannotGetRegistry problem
222+ return $ Right (Env key scope root cache manager connection registry, outline)
140
223
141− Just cachedRegistry ->
142− do eitherRegistry <- Registry.update manager cache cachedRegistry
143− case eitherRegistry of
144− Right latestRegistry ->
145− return $ Right (outline, Info cache manager Online latestRegistry)
146
224
147− Left _ ->
148− return $ Right (outline, Info cache manager Offline cachedRegistry)
149
225
226+-- VERIFY PROJECT
150
227
151
228
152−-- SOLVE PKG
229+type Task a = Task.Task Exit.Details a
153
230
154
231
155−solvePkg :: Info -> File.Time -> Outline.PkgOutline -> Task.Task Details
232+verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
156−solvePkg info time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
233+verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
157 if Con.goodElm elm
234 if Con.goodElm elm
158 then
235 then
159− do solution <- solve info =<< union noDups direct testDirect
236+ do solution <- verifyConstraints env =<< union noDups direct testDirect
160− foreigns <- verifyDependencies info solution direct
237+ let exposedList = Outline.flattenExposed exposed
161− let vsns = Map.map (\(Solver.Details v _) -> v) solution
238+ let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
162− return $ Details time (ValidPkg outline vsns) Map.empty foreigns
239+ verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
163 else
240 else
164 Task.throw $ Exit.DetailsBadElmInPkg elm
241 Task.throw $ Exit.DetailsBadElmInPkg elm
165
242
166
243
167−
168−-- SOLVE APP
169−
170−
171−solveApp :: Info -> File.Time -> Outline.AppOutline -> Task.Task Details
244+verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
172−solveApp info time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
245+verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
173 if elmVersion == V.compiler
246 if elmVersion == V.compiler
174 then
247 then
175 do stated <- checkAppDeps outline
248 do stated <- checkAppDeps outline
176− actual <- solve info (Map.map Con.exactly stated)
249+ actual <- verifyConstraints env (Map.map Con.exactly stated)
177 if Map.size stated == Map.size actual
250 if Map.size stated == Map.size actual
178− then
251+ then verifyDependencies env time (ValidApp srcDirs) actual direct
179− do foreigns <- verifyDependencies info actual direct
252+ else Task.throw $ Exit.DetailsHandEditedDependencies
180− return $ Details time (ValidApp outline) Map.empty foreigns
181− else
182− Task.throw $ error "TODO solveApp"
183 else
253 else
184− Task.throw $ Exit.DetailsBadElmInApp elmVersion
254+ Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
185
255
186
256
187−checkAppDeps :: Outline.AppOutline -> Task.Task (Map.Map Pkg.Name V.Version)
257+checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
188checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
258checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
189 do x <- union allowEqualDups indirect testDirect
259 do x <- union allowEqualDups indirect testDirect
190 y <- union noDups direct testIndirect
260 y <- union noDups direct testIndirect
@@ -192,32 +262,34 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
192
262
193
263
194
264
195−-- SOLVE
265+-- VERIFY CONSTRAINTS
196
266
197
267
198−solve :: Info -> Map.Map Pkg.Name Con.Constraint -> Task.Task (Map.Map Pkg.Name Solver.Details)
268+verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
199−solve (Info cache manager connection registry) constraints =
269+verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
200− Task.eio (error "TODO solve problem") $
270+ do result <- Task.io $ Solver.verify cache connection registry constraints
201− case connection of
271+ case result of
202− Online -> Solver.online cache manager registry constraints
272+ Solver.Ok details -> return details
203− Offline -> Solver.offline cache registry constraints
273+ Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
274+ Solver.NoOfflineSolution -> Task.throw $ Exit.DetailsNoOfflineSolution
275+ Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit
204
276
205
277
206
278
207-- UNION
279-- UNION
208
280
209
281
210−union :: (Ord k) => (k -> v -> v -> Task.Task v) -> Map.Map k v -> Map.Map k v -> Task.Task (Map.Map k v)
282+union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v)
211union tieBreaker deps1 deps2 =
283union tieBreaker deps1 deps2 =
212 Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
284 Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
213
285
214
286
215−noDups :: k -> v -> v -> Task.Task v
287+noDups :: k -> v -> v -> Task v
216noDups _ _ _ =
288noDups _ _ _ =
217 Task.throw Exit.DetailsHandEditedDependencies
289 Task.throw Exit.DetailsHandEditedDependencies
218
290
219
291
220−allowEqualDups :: (Eq v) => k -> v -> v -> Task.Task v
292+allowEqualDups :: (Eq v) => k -> v -> v -> Task v
221allowEqualDups _ v1 v2 =
293allowEqualDups _ v1 v2 =
222 if v1 == v2
294 if v1 == v2
223 then return v1
295 then return v1
@@ -239,36 +311,42 @@ fork work =
239-- VERIFY DEPENDENCIES
311-- VERIFY DEPENDENCIES
240
312
241
313
242−verifyDependencies :: Info -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task.Task (Map.Map ModuleName.Raw Foreign)
314+verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
243−verifyDependencies info solution directDeps =
315+verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
244− Task.eio (error "TODO verifyDependencies") $
316+ Task.eio id $
317+ do Reporting.report key (Reporting.DStart (Map.size solution))
245− do mvar <- newEmptyMVar
318+ mvar <- newEmptyMVar
319+ mvars <- Stuff.withRegistryLock cache $
246− mvars <- Map.traverseWithKey (\k v -> fork (verifyDep info mvar solution k v)) solution
320+ Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
247 putMVar mvar mvars
321 putMVar mvar mvars
248− results <- traverse readMVar mvars
322+ deps <- traverse readMVar mvars
249− case sequence results of
323+ case sequence deps of
250 Left _ ->
324 Left _ ->
251− return (Left (error "TODO one of the dependencies did not build"))
325+ do home <- Stuff.getElmHome
326+ return $ Left $ Exit.DetailsBadDeps home $
327+ Maybe.catMaybes $ Either.lefts $ Map.elems deps
252
328
253 Right artifacts ->
329 Right artifacts ->
254 let
330 let
255− objs = Map.foldr gatherObjects Opt.empty artifacts
331+ objs = Map.foldr addObjects Opt.empty artifacts
256− ifaces = Map.foldrWithKey (gatherInterfaces directDeps) Map.empty artifacts
332+ ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
257− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
333+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps
334+ details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)
258 in
335 in
259− do File.writeBinary Stuff.objects objs
336+ do BW.writeBinary scope (Stuff.objects root) objs
260− File.writeBinary Stuff.interfaces ifaces
337+ BW.writeBinary scope (Stuff.interfaces root) ifaces
338+ BW.writeBinary scope (Stuff.details root) details
261− return (Right foreigns)
339+ return (Right details)
262
340
263
341
264−gatherObjects :: Artifacts -> Opt.Graph -> Opt.Graph
342+addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph
265−gatherObjects (Artifacts _ objs) graph =
343+addObjects (Artifacts _ objs) graph =
266− Opt.union objs graph
344+ Opt.addGlobalGraph objs graph
267
345
268
346
269−gatherInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Canonical I.DependencyInterface
347+addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces
270−gatherInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
348+addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
271− Map.union dependencyInterfaces $ Map.mapKeys (ModuleName.Canonical pkg) $
349+ Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $
272 if Map.member pkg directDeps
350 if Map.member pkg directDeps
273 then ifaces
351 then ifaces
274 else Map.map I.privatize ifaces
352 else Map.map I.privatize ifaces
@@ -279,8 +357,8 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns =
279 let
357 let
280 isPublic di =
358 isPublic di =
281 case di of
359 case di of
282− I.Public _ -> Just (OneOrMore.one pkg)
360+ I.Public _ -> Just (OneOrMore.one pkg)
283− I.Private _ _ -> Nothing
361+ I.Private _ _ _ -> Nothing
284 in
362 in
285 Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
363 Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
286
364
@@ -292,42 +370,41 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns =
292data Artifacts =
370data Artifacts =
293 Artifacts
371 Artifacts
294 { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
372 { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
295− , _objects :: Opt.Graph
373+ , _objects :: Opt.GlobalGraph
296 }
374 }
297
375
298
376
299−type Result =
377+type Dep =
300− Either Problem Artifacts
378+ Either (Maybe Exit.DetailsBadDep) Artifacts
301−
302−
303−data Problem
304− = BadDownload Exit.PackageProblem
305− | BadBuild
306− | BadDependency
307
379
308
380
309−verifyDep :: Info -> MVar (Map.Map Pkg.Name (MVar Result)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Result
381+verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
310−verifyDep (Info cache manager _ _) resultsMVar solution name details@(Solver.Details version directDeps) =
382+verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
311− let
312− fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
383+ do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
313− in
314− do exists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
384+ exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
315 if exists
385 if exists
316 then
386 then
387+ do Reporting.report key Reporting.DCached
317− do maybeCache <- File.readBinary (Stuff.package cache name version </> "artifacts.dat")
388+ maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
318 case maybeCache of
389 case maybeCache of
319 Nothing ->
390 Nothing ->
320− build cache resultsMVar name details (Set.singleton fingerprint)
391+ build key cache depsMVar pkg details fingerprint Set.empty
321
392
322 Just (ArtifactCache fingerprints artifacts) ->
393 Just (ArtifactCache fingerprints artifacts) ->
323 if Set.member fingerprint fingerprints
394 if Set.member fingerprint fingerprints
324− then return (Right artifacts)
395+ then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
325− else build cache resultsMVar name details (Set.insert fingerprint fingerprints)
396+ else build key cache depsMVar pkg details fingerprint fingerprints
326 else
397 else
398+ do Reporting.report key Reporting.DRequested
327− do result <- downloadPackage cache manager name version
399+ result <- downloadPackage cache manager pkg vsn
328 case result of
400 case result of
329− Left p -> return (Left (BadDownload p))
401+ Left problem ->
402+ do Reporting.report key (Reporting.DFailed pkg vsn)
403+ return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem
404+
405+ Right () ->
406+ do Reporting.report key (Reporting.DReceived pkg vsn)
330− Right () -> build cache resultsMVar name details (Set.singleton fingerprint)
407+ build key cache depsMVar pkg details fingerprint Set.empty
331
408
332
409
333
410
@@ -349,65 +426,104 @@ type Fingerprint =
349-- BUILD
426-- BUILD
350
427
351
428
352−build :: Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Result)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Result
429+build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
353−build cache resultsMVar name (Solver.Details version _) fingerprints =
430+build key cache depsMVar pkg (Solver.Details vsn _) f fs =
354− do eitherOutline <- Outline.read (Stuff.package cache name version </> "elm.json")
431+ do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
355 case eitherOutline of
432 case eitherOutline of
356 Left _ ->
433 Left _ ->
357− return (Left BadBuild)
434+ do Reporting.report key Reporting.DBroken
435+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
358
436
359 Right (Outline.App _) ->
437 Right (Outline.App _) ->
360− return (Left BadBuild)
438+ do Reporting.report key Reporting.DBroken
439+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
361
440
362 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
363− do allResults <- readMVar resultsMVar
442+ do allDeps <- readMVar depsMVar
364− directResults <- traverse readMVar (Map.intersection allResults deps)
443+ directDeps <- traverse readMVar (Map.intersection allDeps deps)
365− case sequence directResults of
444+ case sequence directDeps of
366 Left _ ->
445 Left _ ->
446+ do Reporting.report key Reporting.DBroken
367− return (Left BadDependency)
447+ return $ Left $ Nothing
368
448
369 Right directArtifacts ->
449 Right directArtifacts ->
370− do mvar <- newMVar Map.empty
371− let src = Stuff.package cache name version </> "src"
450+ do let src = Stuff.package cache pkg vsn </> "src"
372 let foreignDeps = gatherForeignInterfaces directArtifacts
451 let foreignDeps = gatherForeignInterfaces directArtifacts
373− let exposedDict = Map.fromList $ map (\n -> (n,())) (Outline.flattenExposed exposed)
452+ let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
374− traverse_ readMVar =<<
453+ docsStatus <- getDocsStatus cache pkg vsn
454+ mvar <- newEmptyMVar
375− Map.traverseWithKey (const . fork . buildModule foreignDeps mvar name src) exposedDict
455+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
456+ putMVar mvar mvars
457+ mapM_ readMVar mvars
376− result <- traverse readMVar =<< readMVar mvar
458+ maybeStatuses <- traverse readMVar =<< readMVar mvar
377− case Map.traverseMaybeWithKey checkStatus result of
459+ case sequence maybeStatuses of
378 Nothing ->
460 Nothing ->
379− return (Left BadBuild)
461+ do Reporting.report key Reporting.DBroken
462+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
463+
464+ Just statuses ->
465+ do rmvar <- newEmptyMVar
466+ rmvars <- traverse (fork . compile pkg rmvar) statuses
467+ putMVar rmvar rmvars
468+ maybeResults <- traverse readMVar rmvars
469+ case sequence maybeResults of
470+ Nothing ->
471+ do Reporting.report key Reporting.DBroken
472+ return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
473+
474+ Just results ->
475+ let
476+ path = Stuff.package cache pkg vsn </> "artifacts.dat"
477+ ifaces = gatherInterfaces exposedDict results
478+ objects = gatherObjects results
479+ artifacts = Artifacts ifaces objects
480+ fingerprints = Set.insert f fs
481+ in
482+ do writeDocs cache pkg vsn docsStatus results
483+ File.writeBinary path (ArtifactCache fingerprints artifacts)
484+ Reporting.report key Reporting.DBuilt
485+ return (Right artifacts)
486+
380
487
381− Just artifactsDict ->
382− let
383− path = Stuff.package cache name version </> "artifacts.dat"
384− ifaces = gatherPackageInterfaces exposedDict artifactsDict
385− objects = Map.foldr (Opt.union . snd) Opt.empty artifactsDict
386− artifacts = Artifacts ifaces objects
387− in
388− do File.writeBinary path (ArtifactCache fingerprints artifacts)
389− return (Right artifacts)
390
488
489+-- GATHER
391
490
392−checkStatus :: ModuleName.Raw -> Status -> Maybe (Maybe (I.Interface, Opt.Graph))
491+
393−checkStatus _ status =
492+gatherObjects :: Map.Map ModuleName.Raw Result -> Opt.GlobalGraph
493+gatherObjects results =
494+ Map.foldrWithKey addLocalGraph Opt.empty results
495+
496+
497+addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph
498+addLocalGraph name status graph =
394 case status of
499 case status of
395− SFailure -> Nothing
500+ RLocal _ objs _ -> Opt.addLocalGraph objs graph
396− SLocal i g -> Just (Just (i,g))
501+ RForeign _ -> graph
397− SForeign _ -> Just Nothing
502+ RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
503+ RKernelForeign -> graph
398
504
399
505
400−gatherPackageInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw (I.Interface, Opt.Graph) -> Map.Map ModuleName.Raw I.DependencyInterface
506+gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface
401−gatherPackageInterfaces exposed artifacts =
507+gatherInterfaces exposed artifacts =
402− Map.merge onLeft onRight onBoth exposed artifacts
508+ let
403− where
404− onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherPackageInterfaces")
509+ onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces")
405− onRight = Map.mapMissing (\_ (i,_) -> I.private i)
510+ onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface)
406− onBoth = Map.zipWithMatched (\_ () (i,_) -> I.public i)
511+ onBoth = Map.zipWithMaybeMatched (\_ () iface -> toLocalInterface I.public iface)
512+ in
513+ Map.merge onLeft onRight onBoth exposed artifacts
407
514
408
515
516+toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a
517+toLocalInterface func result =
518+ case result of
519+ RLocal iface _ _ -> Just (func iface)
520+ RForeign _ -> Nothing
521+ RKernelLocal _ -> Nothing
522+ RKernelForeign -> Nothing
409
523
524+
525+
410−-- FOREIGN INTERFACES
526+-- GATHER FOREIGN INTERFACES
411
527
412
528
413data ForeignInterface
529data ForeignInterface
@@ -433,72 +549,196 @@ gatherForeignInterfaces directArtifacts =
433 isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
549 isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
434 isPublic di =
550 isPublic di =
435 case di of
551 case di of
436− I.Public iface -> Just (OneOrMore.one iface)
552+ I.Public iface -> Just (OneOrMore.one iface)
437− I.Private _ _ -> Nothing
553+ I.Private _ _ _ -> Nothing
438
554
439
555
440
556
441−-- BUILD MODULE
557+-- CRAWL
442
558
443
559
444type StatusDict =
560type StatusDict =
445− Map.Map ModuleName.Raw (MVar Status)
561+ Map.Map ModuleName.Raw (MVar (Maybe Status))
446
562
447
563
448data Status
564data Status
449− = SLocal !I.Interface !Opt.Graph
565+ = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
450 | SForeign I.Interface
566 | SForeign I.Interface
451− | SFailure
567+ | SKernelLocal [Kernel.Chunk]
568+ | SKernelForeign
452
569
453
570
454−buildModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO Status
571+crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)
455−buildModule foreignDeps mvar pkg src name =
572+crawlModule foreignDeps mvar pkg src docsStatus name =
456 do let path = src </> ModuleName.toFilePath name <.> "elm"
573 do let path = src </> ModuleName.toFilePath name <.> "elm"
457 exists <- File.exists path
574 exists <- File.exists path
458 case Map.lookup name foreignDeps of
575 case Map.lookup name foreignDeps of
459 Just ForeignAmbiguous ->
576 Just ForeignAmbiguous ->
460− return SFailure
577+ return Nothing
461
578
462 Just (ForeignSpecific iface) ->
579 Just (ForeignSpecific iface) ->
463 if exists
580 if exists
464− then return SFailure
581+ then return Nothing
465− else return (SForeign iface)
582+ else return (Just (SForeign iface))
466
583
467 Nothing ->
584 Nothing ->
468− if not exists
585+ if exists then
469− then return SFailure
586+ crawlFile foreignDeps mvar pkg src docsStatus name path
587+
588+ else if Pkg.isKernel pkg && Name.isKernel name then
589+ crawlKernel foreignDeps mvar pkg src name
590+
470 else
591 else
471− do result <- Parse.fromFile pkg path
592+ return Nothing
472− case result of
593+
594+
595+crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)
596+crawlFile foreignDeps mvar pkg src docsStatus expectedName path =
597+ do bytes <- File.readUtf8 path
598+ case Parse.fromByteString (Parse.Package pkg) bytes of
473− Right modul@(Src.Module (Just actualName) _ deps _ _ _ _ _) | name == actualName ->
599+ Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->
600+ do deps <- crawlImports foreignDeps mvar pkg src imports
601+ return (Just (SLocal docsStatus deps modul))
602+
603+ _ ->
604+ return Nothing
605+
606+
607+crawlImports :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> [Src.Import] -> IO (Map.Map ModuleName.Raw ())
608+crawlImports foreignDeps mvar pkg src imports =
474− do statusDict <- takeMVar mvar
609+ do statusDict <- takeMVar mvar
475− let depsDict = Map.fromList $ map (\i -> (Src.getImport i, ())) deps
610+ let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
476− let newsDict = Map.difference depsDict statusDict
611+ let news = Map.difference deps statusDict
477− statusMVars <- Map.traverseWithKey (const . fork . buildModule foreignDeps mvar pkg src) newsDict
612+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
478− putMVar mvar (Map.union statusMVars statusDict)
613+ putMVar mvar (Map.union mvars statusDict)
479− statuses <- traverse readMVar statusMVars
614+ mapM_ readMVar mvars
480− case traverse getInterface statuses of
615+ return deps
616+
617+
618+crawlKernel :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
619+crawlKernel foreignDeps mvar pkg src name =
620+ do let path = src </> ModuleName.toFilePath name <.> "js"
621+ exists <- File.exists path
622+ if exists
623+ then
624+ do bytes <- File.readUtf8 path
625+ case Kernel.fromByteString pkg (Map.mapMaybe getDepHome foreignDeps) bytes of
481− Nothing ->
626+ Nothing ->
482− return SFailure
627+ return Nothing
483−
628+
484− Just imports ->
629+ Just (Kernel.Content imports chunks) ->
485− case Compile.compile pkg imports modul of
630+ do _ <- crawlImports foreignDeps mvar pkg src imports
486− (_, Right (Compile.Artifacts canonical annotations objects)) ->
631+ return (Just (SKernelLocal chunks))
487− return (SLocal (I.fromModule pkg canonical annotations) objects)
632+ else
488−
633+ return (Just SKernelForeign)
489− (_, Left _) ->
634+
490− return SFailure
635+
491−
636+getDepHome :: ForeignInterface -> Maybe Pkg.Name
492− _ ->
637+getDepHome fi =
493− return SFailure
638+ case fi of
494−
639+ ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg
495−
640+ ForeignAmbiguous -> Nothing
496−getInterface :: Status -> Maybe I.Interface
641+
497−getInterface status =
642+
643+
644+-- COMPILE
645+
646+
647+data Result
648+ = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)
649+ | RForeign I.Interface
650+ | RKernelLocal [Kernel.Chunk]
651+ | RKernelForeign
652+
653+
654+compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
655+compile pkg mvar status =
498 case status of
656 case status of
499− SLocal iface _ -> Just iface
657+ SLocal docsStatus deps modul ->
658+ do resultsDict <- readMVar mvar
659+ maybeResults <- traverse readMVar (Map.intersection resultsDict deps)
660+ case sequence maybeResults of
661+ Nothing ->
662+ return Nothing
663+
664+ Just results ->
665+ case Compile.compile pkg (Map.mapMaybe getInterface results) modul of
666+ Left _ ->
667+ return Nothing
668+
669+ Right (Compile.Artifacts canonical annotations objects) ->
670+ let
671+ ifaces = I.fromModule pkg canonical annotations
672+ docs = makeDocs docsStatus canonical
673+ in
674+ return (Just (RLocal ifaces objects docs))
675+
500− SForeign iface -> Just iface
676+ SForeign iface ->
501− SFailure -> Nothing
677+ return (Just (RForeign iface))
678+
679+ SKernelLocal chunks ->
680+ return (Just (RKernelLocal chunks))
681+
682+ SKernelForeign ->
683+ return (Just RKernelForeign)
684+
685+
686+getInterface :: Result -> Maybe I.Interface
687+getInterface result =
688+ case result of
689+ RLocal iface _ _ -> Just iface
690+ RForeign iface -> Just iface
691+ RKernelLocal _ -> Nothing
692+ RKernelForeign -> Nothing
693+
694+
695+
696+-- MAKE DOCS
697+
698+
699+data DocsStatus
700+ = DocsNeeded
701+ | DocsNotNeeded
702+
703+
704+getDocsStatus :: Stuff.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus
705+getDocsStatus cache pkg vsn =
706+ do exists <- File.exists (Stuff.package cache pkg vsn </> "docs.json")
707+ if exists
708+ then return DocsNotNeeded
709+ else return DocsNeeded
710+
711+
712+makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module
713+makeDocs status modul =
714+ case status of
715+ DocsNeeded ->
716+ case Docs.fromModule modul of
717+ Right docs -> Just docs
718+ Left _ -> Nothing
719+
720+ DocsNotNeeded ->
721+ Nothing
722+
723+
724+writeDocs :: Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()
725+writeDocs cache pkg vsn status results =
726+ case status of
727+ DocsNeeded ->
728+ E.writeUgly (Stuff.package cache pkg vsn </> "docs.json") $
729+ Docs.encode $ Map.mapMaybe toDocs results
730+
731+ DocsNotNeeded ->
732+ return ()
733+
734+
735+toDocs :: Result -> Maybe Docs.Module
736+toDocs result =
737+ case result of
738+ RLocal _ _ docs -> docs
739+ RForeign _ -> Nothing
740+ RKernelLocal _ -> Nothing
741+ RKernelForeign -> Nothing
502
742
503
743
504
744
@@ -506,25 +746,28 @@ getInterface status =
506
746
507
747
508downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
748downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
509−downloadPackage cache manager name version =
749+downloadPackage cache manager pkg vsn =
750+ let
751+ url = Website.metadata pkg vsn "endpoint.json"
752+ in
510 do eitherByteString <-
753 do eitherByteString <-
511− Http.post manager (Website.metadata name version "endpoint.json") [] id (return . Right)
754+ Http.get manager url [] id (return . Right)
512
755
513 case eitherByteString of
756 case eitherByteString of
514 Left err ->
757 Left err ->
515− return (Left (Exit.PP_BadEndpointRequest err))
758+ return $ Left $ Exit.PP_BadEndpointRequest err
516
759
517 Right byteString ->
760 Right byteString ->
518 case D.fromByteString endpointDecoder byteString of
761 case D.fromByteString endpointDecoder byteString of
519 Left _ ->
762 Left _ ->
520− return (Left Exit.PP_BadEndpointContent)
763+ return $ Left $ Exit.PP_BadEndpointContent url
521
764
522 Right (endpoint, expectedHash) ->
765 Right (endpoint, expectedHash) ->
523− Http.fetchArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $
766+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
524 \(sha, archive) ->
767 \(sha, archive) ->
525 if expectedHash == Http.shaToChars sha
768 if expectedHash == Http.shaToChars sha
526− then Right <$> File.writeArchive (Stuff.package cache name version) archive
769+ then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
527− else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
770+ else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
528
771
529
772
530endpointDecoder :: D.Decoder e (String, String)
773endpointDecoder :: D.Decoder e (String, String)
@@ -539,27 +782,40 @@ endpointDecoder =
539
782
540
783
541instance Binary Details where
784instance Binary Details where
542− get = liftM4 Details get get get get
543− put (Details a b c d) = put a >> put b >> put c >> put d
785+ put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
786+ get =
787+ do a <- get
788+ b <- get
789+ c <- get
790+ d <- get
791+ e <- get
792+ return (Details a b c d e ArtifactsCached)
544
793
545
794
546instance Binary ValidOutline where
795instance Binary ValidOutline where
547 put outline =
796 put outline =
548 case outline of
797 case outline of
549− ValidApp a -> putWord8 0 >> put a
798+ ValidApp a -> putWord8 0 >> put a
550− ValidPkg a b -> putWord8 1 >> put a >> put b
799+ ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
551
800
552 get =
801 get =
553 do n <- getWord8
802 do n <- getWord8
554 case n of
803 case n of
555 0 -> liftM ValidApp get
804 0 -> liftM ValidApp get
556− 1 -> liftM2 ValidPkg get get
805+ 1 -> liftM3 ValidPkg get get get
557− _ -> error "binary encoding of ValidOutline was corrupted"
806+ _ -> fail "binary encoding of ValidOutline was corrupted"
558
807
559
808
560instance Binary Local where
809instance Binary Local where
561− get = liftM3 Local get get get
562− put (Local a b c) = put a >> put b >> put c
810+ put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
811+ get =
812+ do a <- get
813+ b <- get
814+ c <- get
815+ d <- get
816+ e <- get
817+ f <- get
818+ return (Local a b c d e f)
563
819
564
820
565instance Binary Foreign where
821instance Binary Foreign where
builder/src/Elm/Diff.hsdeleted−284
@@ -1,284 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Diff
4− ( Args(..)
5− , diff
6− )
7− where
8−
9−
10−import Control.Monad.Except (liftIO)
11−import qualified Data.List as List
12−import qualified Data.Map as Map
13−import qualified Data.Maybe as Maybe
14−import qualified Data.Name as Name
15−
16−import qualified Deps.Cache as Cache
17−import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18−import qualified Deps.Diff as Diff
19−import qualified Elm.Compiler.Type as Type
20−import qualified Elm.Docs as Docs
21−import qualified Elm.ModuleName as ModuleName
22−import qualified Elm.Package as Pkg
23−import qualified Elm.Project as Project
24−import qualified Elm.Project.Json as Project
25−import qualified Elm.Project.Summary as Summary
26−import qualified Elm.Version as V
27−import Reporting.Doc ((<>), (<+>))
28−import qualified Reporting.Doc as D
29−import qualified Reporting.Exit as Exit
30−import qualified Reporting.Exit.Diff as E
31−import qualified Reporting.Exit.Help as Help
32−import qualified Reporting.Render.Type.Localizer as L
33−import qualified Reporting.Task as Task
34−
35−
36−
37−-- DIFF
38−
39−
40−data Args
41− = CodeVsLatest
42− | CodeVsExactly V.Version
43− | LocalInquiry V.Version V.Version
44− | GlobalInquiry Pkg.Name V.Version V.Version
45−
46−
47−diff :: Args -> Task.Task ()
48−diff args =
49− case args of
50− GlobalInquiry name v1 v2 ->
51− do registry <- Cache.mandatoryUpdate
52− case Cache.getVersions name registry of
53− Left suggestions ->
54− throw $ E.UnknownPackage name suggestions
55−
56− Right vsns ->
57− do oldDocs <- getDocs name vsns (min v1 v2)
58− newDocs <- getDocs name vsns (max v1 v2)
59− writeDiff oldDocs newDocs
60−
61− LocalInquiry v1 v2 ->
62− do (_, name, vsns) <- getPackageInfo
63− oldDocs <- getDocs name vsns (min v1 v2)
64− newDocs <- getDocs name vsns (max v1 v2)
65− writeDiff oldDocs newDocs
66−
67− CodeVsLatest ->
68− do (summary, name, vsns) <- getPackageInfo
69− oldDocs <- getDocs name vsns (maximum vsns)
70− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
71− writeDiff oldDocs newDocs
72−
73− CodeVsExactly version ->
74− do (summary, name, vsns) <- getPackageInfo
75− oldDocs <- getDocs name vsns version
76− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
77− writeDiff oldDocs newDocs
78−
79−
80−throw :: E.Exit -> Task.Task a
81−throw exit =
82− Task.throw $ Exit.Diff exit
83−
84−
85−
86−-- DIFF HELPERS
87−
88−
89−getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation
90−getDocs name allVersions version =
91− if elem version allVersions then
92− Cache.getDocs name version
93− else
94− throw $ E.UnknownVersion name version allVersions
95−
96−
97−getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])
98−getPackageInfo =
99− do summary <- Project.getRoot
100− case Summary._project summary of
101− Project.App _ ->
102− throw $ E.Application
103−
104− Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
105− do registry <- Cache.mandatoryUpdate
106− case Cache.getVersions name registry of
107− Right vsns ->
108− return ( summary, name, vsns )
109−
110− Left _ ->
111− throw E.Unpublished
112−
113−
114−
115−-- WRITE DOC
116−
117−
118−writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
119−writeDiff oldDocs newDocs =
120− let
121− changes = Diff.diff oldDocs newDocs
122− localizer = L.fromNames (Map.union oldDocs newDocs)
123− in
124− liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
125−
126−
127−
128−-- TO DOC
129−
130−
131−toDoc :: L.Localizer -> PackageChanges -> D.Doc
132−toDoc localizer changes@(PackageChanges added changed removed) =
133− if null added && Map.null changed && null removed then
134− "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
135− else
136− let
137− magDoc =
138− D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))
139−
140− header =
141− "This is a" <+> D.green magDoc <+> "change."
142−
143− addedChunk =
144− if null added then [] else
145− [ Chunk "ADDED MODULES" MINOR $
146− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added
147− ]
148−
149− removedChunk =
150− if null removed then [] else
151− [ Chunk "REMOVED MODULES" MAJOR $
152− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed
153− ]
154−
155− chunks =
156− addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
157− in
158− D.vcat (header : "" : map chunkToDoc chunks)
159−
160−
161−data Chunk =
162− Chunk
163− { _title :: String
164− , _magnitude :: Magnitude
165− , _details :: D.Doc
166− }
167−
168−
169−chunkToDoc :: Chunk -> D.Doc
170−chunkToDoc (Chunk title magnitude details) =
171− let
172− magDoc =
173− Diff.magnitudeToString magnitude
174−
175− header =
176− "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"
177− in
178− D.vcat
179− [ D.dullcyan header
180− , ""
181− , D.indent 4 details
182− , ""
183− , ""
184− ]
185−
186−
187−changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
188−changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
189− let
190− magnitude =
191− Diff.moduleChangeMagnitude changes
192−
193− (unionAdd, unionChange, unionRemove) =
194− changesToDocTriple (unionToDoc localizer) unions
195−
196− (aliasAdd, aliasChange, aliasRemove) =
197− changesToDocTriple (aliasToDoc localizer) aliases
198−
199− (valueAdd, valueChange, valueRemove) =
200− changesToDocTriple (valueToDoc localizer) values
201−
202− (binopAdd, binopChange, binopRemove) =
203− changesToDocTriple (binopToDoc localizer) binops
204− in
205− Chunk (Name.toChars name) magnitude $
206− D.vcat $ List.intersperse "" $ Maybe.catMaybes $
207− [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
208− , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
209− , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
210− ]
211−
212−
213−changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
214−changesToDocTriple entryToDoc (Changes added changed removed) =
215− let
216− indented (name, value) =
217− D.indent 4 (entryToDoc name value)
218−
219− diffed (name, (oldValue, newValue)) =
220− D.vcat
221− [ " - " <> entryToDoc name oldValue
222− , " + " <> entryToDoc name newValue
223− , ""
224− ]
225− in
226− ( map indented (Map.toList added)
227− , map diffed (Map.toList changed)
228− , map indented (Map.toList removed)
229− )
230−
231−
232−changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
233−changesToDoc categoryName unions aliases values binops =
234− if null unions && null aliases && null values && null binops then
235− Nothing
236−
237− else
238− Just $ D.vcat $
239− D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
240−
241−
242−unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
243−unionToDoc localizer name (Docs.Union _ tvars ctors) =
244− let
245− setup =
246− "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
247−
248− ctorDoc (ctor, tipes) =
249− typeDoc localizer (Type.Type ctor tipes)
250− in
251− D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
252−
253−
254−aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
255−aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
256− let
257− declaration =
258− "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
259− in
260− D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
261−
262−
263−valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
264−valueToDoc localizer name (Docs.Value _ tipe) =
265− D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
266−
267−
268−binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
269−binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
270− "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
271− where
272− details =
273− " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
274−
275− assoc =
276− case associativity of
277− Docs.Left -> "left"
278− Docs.Non -> "non"
279− Docs.Right -> "right"
280−
281−
282−typeDoc :: L.Localizer -> Type.Type -> D.Doc
283−typeDoc localizer tipe =
284− Type.toDoc localizer Type.None tipe
builder/src/Elm/Install.hsdeleted−448
@@ -1,448 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Install
3− ( install
4− )
5− where
6−
7−
8−import Control.Monad (filterM, foldM, forM, msum, void)
9−import Control.Monad.Except (catchError, lift, liftIO)
10−import Data.Map ((!))
11−import qualified Data.Map as Map
12−import qualified Data.Map.Merge.Lazy as Map
13−
14−import qualified Elm.Package as Pkg
15−
16−import qualified Deps.Cache as Cache
17−import Deps.Explorer (Explorer)
18−import qualified Deps.Explorer as Explorer
19−import qualified Deps.Verify as Verify
20−import qualified Deps.Solver as Solver
21−import qualified Elm.Constraint as C
22−import qualified Elm.Project.Json as Project
23−import qualified Elm.Project.Root as Root
24−import qualified Elm.Version as V
25−import Reporting.Doc ((<>), (<+>))
26−import qualified Reporting.Doc as D
27−import qualified Reporting.Exit as Exit
28−import qualified Reporting.Exit.Install as E
29−import qualified Reporting.Task as Task
30−
31−
32−
33−-- INSTALL
34−
35−
36−install :: Pkg.Name -> Task.Task ()
37−install pkg =
38− do (root, oldProject) <- Root.unsafeGet
39− registry <- Cache.optionalUpdate
40−
41− case oldProject of
42− Project.App info ->
43− do changes <- makeAppPlan registry pkg info
44− attemptElmJsonChange root oldProject V.toChars changes
45−
46− Project.Pkg info ->
47− do changes <- makePkgPlan registry pkg info
48− attemptElmJsonChange root oldProject C.toChars changes
49−
50−
51−attemptElmJsonChange :: FilePath -> Project.Project -> (a -> String) -> Changes a -> Task.Task ()
52−attemptElmJsonChange root oldProject toChars changes =
53− let
54− attempt newProject question =
55− do approved <- Task.getApproval question
56− if approved
57− then upgrade newProject `catchError` revert
58− else liftIO $ putStrLn "Okay, I did not change anything!"
59−
60− upgrade newProject =
61− do liftIO $ Project.write root newProject
62− void $ Verify.verify root newProject
63−
64− revert err =
65− do liftIO $ Project.write root oldProject
66− Task.throw err
67− in
68− case changes of
69− AlreadyInstalled ->
70− do liftIO $ putStrLn "It is already installed!"
71−
72− PromoteTrans newProject ->
73− attempt newProject $
74− D.vcat
75− [ D.fillSep
76− ["I","found","it","in","your","elm.json","file,"
77− ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."
78− ]
79− , D.fillSep
80− ["Should","I","move","it","into",D.green "\"direct\""
81− ,"dependencies","for","more","general","use?","[Y/n]: "
82− ]
83− ]
84−
85− PromoteTest newProject ->
86− attempt newProject $
87− D.vcat
88− [ D.fillSep
89− ["I","found","it","in","your","elm.json","file,"
90− ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."
91− ]
92− , D.fillSep
93− ["Should","I","move","it","into",D.green "\"dependencies\""
94− ,"for","more","general","use?","[Y/n]: "
95− ]
96− ]
97−
98− Changes changeDict newProject ->
99− let
100− widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict
101− changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict
102− in
103− attempt newProject $ D.vcat $
104− [ "Here is my plan:"
105− , viewChangeDocs changeDocs
106− , ""
107− , "Would you like me to update your elm.json accordingly? [Y/n]: "
108− ]
109−
110−
111−
112−-- MAKE PLANS
113−
114−
115−data Changes vsn
116− = AlreadyInstalled
117− | PromoteTest Project.Project
118− | PromoteTrans Project.Project
119− | Changes (Map.Map Pkg.Name (Change vsn)) Project.Project
120−
121−
122−makeAppPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Changes V.Version)
123−makeAppPlan registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
124− if Map.member pkg depsDirect then
125− return AlreadyInstalled
126− else
127− do (AppAnswer old new newInfo) <- toAppAnswer registry pkg info
128−
129− return $
130− if Map.member pkg depsTrans then
131− PromoteTrans (Project.App newInfo)
132−
133− else if Map.member pkg testDirect || Map.member pkg testTrans then
134− PromoteTest (Project.App newInfo)
135−
136− else
137− Changes (detectChanges old new) (Project.App newInfo)
138−
139−
140−makePkgPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Changes C.Constraint)
141−makePkgPlan registry pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) =
142− if Map.member pkg deps then
143− return AlreadyInstalled
144− else
145− case Map.lookup pkg test of
146− Just con ->
147− return $ PromoteTest $ Project.Pkg $
148− info
149− { Project._pkg_deps = Map.insert pkg con deps
150− , Project._pkg_test_deps = Map.delete pkg test
151− }
152−
153− Nothing ->
154− do changes <- addToPkg registry pkg info
155− let news = Map.mapMaybe keepNew changes
156− return $ Changes changes $ Project.Pkg $
157− info
158− { Project._pkg_deps = addNews (Just pkg) news deps
159− , Project._pkg_test_deps = addNews Nothing news test
160− }
161−
162−
163−addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a
164−addNews pkg new old =
165− Map.merge
166− Map.preserveMissing
167− (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))
168− (Map.zipWithMatched (\_ _ n -> n))
169− old
170− new
171−
172−
173−
174−-- CHANGES
175−
176−
177−data Change a
178− = Insert a
179− | Change a a
180− | Remove a
181−
182−
183−detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
184−detectChanges old new =
185− Map.merge
186− (Map.mapMissing (\_ v -> Remove v))
187− (Map.mapMissing (\_ v -> Insert v))
188− (Map.zipWithMaybeMatched keepChange)
189− old
190− new
191−
192−
193−keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
194−keepChange _ old new =
195− if old == new then
196− Nothing
197− else
198− Just (Change old new)
199−
200−
201−keepNew :: Change a -> Maybe a
202−keepNew change =
203− case change of
204− Insert a ->
205− Just a
206−
207− Change _ a ->
208− Just a
209−
210− Remove _ ->
211− Nothing
212−
213−
214−
215−-- ADD TO APP
216−
217−
218−data AppAnswer =
219− AppAnswer
220− { _old :: Map.Map Pkg.Name V.Version
221− , _new :: Map.Map Pkg.Name V.Version
222− , _info :: Project.AppInfo
223− }
224−
225−
226−toAppAnswer :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task AppAnswer
227−toAppAnswer registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
228− Explorer.run registry $
229− do Explorer.exists pkg
230− result <- Solver.run (toAppAnswerHelp pkg info)
231− case result of
232− Just answer ->
233− return answer
234−
235− Nothing ->
236− do badNames <-
237− filterM isBadElm $
238− pkg : Map.keys depsDirect
239− ++ Map.keys depsTrans
240− ++ Map.keys testDirect
241− ++ Map.keys testTrans
242− lift $ Task.throw (Exit.Install (E.NoSolution badNames))
243−
244−
245−toAppAnswerHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver AppAnswer
246−toAppAnswerHelp pkg (Project.AppInfo elm srcDirs depsDirect depsTrans testDirect testTrans) =
247− let
248− directs =
249− Map.union depsDirect testDirect
250−
251− directAndTrans =
252− Map.union directs (Map.union depsTrans testTrans)
253−
254− try toConstraint deps =
255− do solution <- Solver.solve $ Map.insert pkg C.anything (Map.map toConstraint deps)
256− let newDepsDirect = Map.intersection solution (Map.insert pkg V.one depsDirect)
257− newDeps <- lift $ foldM (collectTransitive solution) Map.empty (Map.keys newDepsDirect)
258− return $
259− AppAnswer
260− { _old = directAndTrans
261− , _new = solution
262− , _info =
263− Project.AppInfo
264− elm
265− srcDirs
266− newDepsDirect
267− (Map.difference newDeps newDepsDirect)
268− (Map.intersection solution testDirect)
269− (Map.difference (Map.difference solution newDeps) testDirect)
270− }
271− in
272− msum
273− [ try C.exactly directAndTrans
274− , try C.exactly directs
275− , try C.untilNextMinor directs
276− , try C.untilNextMajor directs
277− , try (\_ -> C.anything) directs
278− ]
279−
280−
281−collectTransitive
282− :: Map.Map Pkg.Name V.Version
283− -> Map.Map Pkg.Name V.Version
284− -> Pkg.Name
285− -> Explorer (Map.Map Pkg.Name V.Version)
286−collectTransitive solution state name =
287− do let version = solution ! name
288− (Explorer.Info _ trans) <- Explorer.getConstraints name version
289− foldM
290− (collectTransitive solution)
291− (Map.insert name version state)
292− (Map.keys trans)
293−
294−
295−
296−
297−
298−-- ADD TO PKG
299−
300−
301−addToPkg :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Map.Map Pkg.Name (Change C.Constraint))
302−addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
303− Explorer.run registry $
304− do Explorer.exists pkg
305− let old = Map.union deps tests
306− result <- Solver.run (addToPkgHelp pkg info)
307− case result of
308− Just new ->
309− return $ detectChanges old new
310−
311− Nothing ->
312− do let pkgs = Map.keys deps ++ Map.keys tests
313− badNames <- filterM isBadElm (pkg : pkgs)
314− lift $ Task.throw (Exit.Install (E.NoSolution badNames))
315−
316−
317−addToPkgHelp :: Pkg.Name -> Project.PkgInfo -> Solver.Solver (Map.Map Pkg.Name C.Constraint)
318−addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
319− do let directs = Map.union deps tests
320− let newCons = Map.insert pkg C.anything directs
321− solution <- Solver.solve newCons
322− let con = C.untilNextMajor (solution ! pkg)
323− return $ Map.insert pkg con directs
324−
325−
326−
327−-- FAILURE HINTS
328−
329−
330−isBadElm :: Pkg.Name -> Explorer Bool
331−isBadElm name =
332− do versions <- Explorer.getVersions name
333−
334− elmVersions <- forM versions $ \vsn ->
335− Explorer._elm <$> Explorer.getConstraints name vsn
336−
337− return (not (any C.goodElm elmVersions))
338−
339−
340−
341−-- VIEW CHANGE DOCS
342−
343−
344−data ChangeDocs =
345− Docs
346− { _doc_inserts :: [D.Doc]
347− , _doc_changes :: [D.Doc]
348− , _doc_removes :: [D.Doc]
349− }
350−
351−
352−viewChangeDocs :: ChangeDocs -> D.Doc
353−viewChangeDocs (Docs inserts changes removes) =
354− D.indent 2 $ D.vcat $ concat $
355− [ viewNonZero "Add:" inserts
356− , viewNonZero "Change:" changes
357− , viewNonZero "Remove:" removes
358− ]
359−
360−
361−viewNonZero :: String -> [D.Doc] -> [D.Doc]
362−viewNonZero title entries =
363− if null entries then
364− []
365− else
366− [ ""
367− , D.fromChars title
368− , D.indent 2 (D.vcat entries)
369− ]
370−
371−
372−
373−-- VIEW CHANGE
374−
375−
376−addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
377−addChange toChars widths name change (Docs inserts changes removes) =
378− case change of
379− Insert new ->
380− Docs (viewInsert toChars widths name new : inserts) changes removes
381−
382− Change old new ->
383− Docs inserts (viewChange toChars widths name old new : changes) removes
384−
385− Remove old ->
386− Docs inserts changes (viewRemove toChars widths name old : removes)
387−
388−
389−viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
390−viewInsert toChars (Widths nameWidth leftWidth _) name new =
391− viewName nameWidth name <+> pad leftWidth (toChars new)
392−
393−
394−viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
395−viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =
396− D.hsep
397− [ viewName nameWidth name
398− , pad leftWidth (toChars old)
399− , "=>"
400− , pad rightWidth (toChars new)
401− ]
402−
403−
404−viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
405−viewRemove toChars (Widths nameWidth leftWidth _) name old =
406− viewName nameWidth name <+> pad leftWidth (toChars old)
407−
408−
409−viewName :: Int -> Pkg.Name -> D.Doc
410−viewName width name =
411− D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))
412−
413−
414−pad :: Int -> String -> D.Doc
415−pad width string =
416− D.fromChars (replicate (width - length string) ' ') <> D.fromChars string
417−
418−
419−
420−-- WIDTHS
421−
422−
423−data Widths =
424− Widths
425− { _name :: !Int
426− , _left :: !Int
427− , _right :: !Int
428− }
429−
430−
431−widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
432−widen toChars pkg change (Widths name left right) =
433− let
434− toLength a =
435− length (toChars a)
436−
437− newName =
438− max name (length (Pkg.toChars pkg))
439− in
440− case change of
441− Insert new ->
442− Widths newName (max left (toLength new)) right
443−
444− Change old new ->
445− Widths newName (max left (toLength old)) (max right (toLength new))
446−
447− Remove old ->
448− Widths newName (max left (toLength old)) right
builder/src/Elm/Outline.hs+157−147
@@ -1,17 +1,16 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
3module Elm.Outline
3module Elm.Outline
4 ( Outline(..)
4 ( Outline(..)
5 , AppOutline(..)
5 , AppOutline(..)
6 , PkgOutline(..)
6 , PkgOutline(..)
7 , Exposed(..)
7 , Exposed(..)
8+ , SrcDir(..)
8 , read
9 , read
9 , write
10 , write
10 , encode
11 , encode
11 , decoder
12 , decoder
12 , defaultSummary
13 , defaultSummary
13− , isPlatformPackage
14− , getName
15 , flattenExposed
14 , flattenExposed
16 )
15 )
17 where
16 where
@@ -20,10 +19,12 @@ module Elm.Outline
20import Prelude hiding (read)
19import Prelude hiding (read)
21import Control.Monad (filterM, liftM)
20import Control.Monad (filterM, liftM)
22import Data.Binary (Binary, get, put, getWord8, putWord8)
21import Data.Binary (Binary, get, put, getWord8, putWord8)
23−import Data.Foldable (traverse_)
24import qualified Data.Map as Map
22import qualified Data.Map as Map
25−import qualified Data.Utf8 as Utf8
23+import qualified Data.NonEmptyList as NE
24+import qualified Data.OneOrMore as OneOrMore
25+import Foreign.Ptr (minusPtr)
26import qualified System.Directory as Dir
26import qualified System.Directory as Dir
27+import qualified System.FilePath as FP
27import System.FilePath ((</>))
28import System.FilePath ((</>))
28
29
29import qualified Elm.Constraint as Con
30import qualified Elm.Constraint as Con
@@ -31,10 +32,13 @@ import qualified Elm.Licenses as Licenses
31import qualified Elm.ModuleName as ModuleName
32import qualified Elm.ModuleName as ModuleName
32import qualified Elm.Package as Pkg
33import qualified Elm.Package as Pkg
33import qualified Elm.Version as V
34import qualified Elm.Version as V
35+import qualified File
34import qualified Json.Decode as D
36import qualified Json.Decode as D
35import qualified Json.Encode as E
37import qualified Json.Encode as E
38+import Json.Encode ((==>))
39+import qualified Json.String as Json
40+import qualified Parse.Primitives as P
36import qualified Reporting.Exit as Exit
41import qualified Reporting.Exit as Exit
37−import qualified Reporting.Exit.Assets as E
38
42
39
43
40
44
@@ -49,7 +53,7 @@ data Outline
49data AppOutline =
53data AppOutline =
50 AppOutline
54 AppOutline
51 { _app_elm_version :: V.Version
55 { _app_elm_version :: V.Version
52− , _app_source_dirs :: [FilePath]
56+ , _app_source_dirs :: NE.List SrcDir
53 , _app_deps_direct :: Map.Map Pkg.Name V.Version
57 , _app_deps_direct :: Map.Map Pkg.Name V.Version
54 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
55 , _app_test_direct :: Map.Map Pkg.Name V.Version
59 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -60,7 +64,7 @@ data AppOutline =
60data PkgOutline =
64data PkgOutline =
61 PkgOutline
65 PkgOutline
62 { _pkg_name :: Pkg.Name
66 { _pkg_name :: Pkg.Name
63− , _pkg_summary :: Utf8.String
67+ , _pkg_summary :: Json.String
64 , _pkg_license :: Licenses.License
68 , _pkg_license :: Licenses.License
65 , _pkg_version :: V.Version
69 , _pkg_version :: V.Version
66 , _pkg_exposed :: Exposed
70 , _pkg_exposed :: Exposed
@@ -72,41 +76,25 @@ data PkgOutline =
72
76
73data Exposed
77data Exposed
74 = ExposedList [ModuleName.Raw]
78 = ExposedList [ModuleName.Raw]
75− | ExposedDict [(Utf8.String, [ModuleName.Raw])]
79+ | ExposedDict [(Json.String, [ModuleName.Raw])]
76
80
77
81
78−
82+data SrcDir
79−-- DEFAULTS
83+ = AbsoluteSrcDir FilePath
80−
84+ | RelativeSrcDir FilePath
81−
82−defaultSummary :: Utf8.String
83−defaultSummary =
84− "helpful summary of your project, less than 80 characters"
85−
86
85
87
86
88−-- QUERIES
89
87
88+-- DEFAULTS
90
89
91−isPlatformPackage :: Outline -> Bool
92−isPlatformPackage outline =
93− case outline of
94− App _ ->
95− False
96
90
97− Pkg pkgOutline ->
91+defaultSummary :: Json.String
98− let author = Pkg._author (_pkg_name pkgOutline) in
92+defaultSummary =
99− author == "elm" || author == "elm-explorations"
93+ Json.fromChars "helpful summary of your project, less than 80 characters"
100
94
101
95
102−getName :: Outline -> Pkg.Name
103−getName outline =
104− case outline of
105− App _ ->
106− Pkg.dummyName
107
96
108− Pkg (PkgOutline name _ _ _ _ _ _ _) ->
97+-- HELPERS
109− name
110
98
111
99
112flattenExposed :: Exposed -> [ModuleName.Raw]
100flattenExposed :: Exposed -> [ModuleName.Raw]
@@ -137,8 +125,8 @@ encode outline =
137 case outline of
125 case outline of
138 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
139 E.object
127 E.object
140− [ "type" ==> E.string "application"
128+ [ "type" ==> E.chars "application"
141− , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs
129+ , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
142 , "elm-version" ==> V.encode elm
130 , "elm-version" ==> V.encode elm
143 , "dependencies" ==>
131 , "dependencies" ==>
144 E.object
132 E.object
@@ -154,7 +142,7 @@ encode outline =
154
142
155 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
156 E.object
144 E.object
157− [ "type" ==> E.string "package"
145+ [ "type" ==> E.string (Json.fromChars "package")
158 , "name" ==> Pkg.encode name
146 , "name" ==> Pkg.encode name
159 , "summary" ==> E.string summary
147 , "summary" ==> E.string summary
160 , "license" ==> Licenses.encode license
148 , "license" ==> Licenses.encode license
@@ -166,11 +154,6 @@ encode outline =
166 ]
154 ]
167
155
168
156
169−(==>) :: a -> b -> (a, b)
170−(==>) a b =
171− (a, b)
172−
173−
174encodeExposed :: Exposed -> E.Value
157encodeExposed :: Exposed -> E.Value
175encodeExposed exposed =
158encodeExposed exposed =
176 case exposed of
159 case exposed of
@@ -188,35 +171,95 @@ encodeModule name =
188
171
189encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
190encodeDeps encodeValue deps =
173encodeDeps encodeValue deps =
191− E.dict Pkg.toString encodeValue deps
174+ E.dict Pkg.toJsonString encodeValue deps
175+
176+
177+encodeSrcDir :: SrcDir -> E.Value
178+encodeSrcDir srcDir =
179+ case srcDir of
180+ AbsoluteSrcDir dir -> E.chars dir
181+ RelativeSrcDir dir -> E.chars dir
192
182
193
183
194
184
195-- PARSE AND VERIFY
185-- PARSE AND VERIFY
196
186
197
187
198−read :: FilePath -> IO (Either Exit.OutlineProblem Outline)
188+read :: FilePath -> IO (Either Exit.Outline Outline)
199read root =
189read root =
200− do result <- D.fromFile decoder (root </> "elm.json")
190+ do bytes <- File.readUtf8 (root </> "elm.json")
201− case result of
191+ case D.fromByteString decoder bytes of
202 Left err ->
192 Left err ->
203− return $ Left (Exit.BadOutlineStructure err)
193+ return $ Left (Exit.OutlineHasBadStructure err)
204
194
205 Right outline ->
195 Right outline ->
206 case outline of
196 case outline of
207− Pkg _ ->
197+ Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
198+ return $
199+ if Map.notMember Pkg.core deps && pkg /= Pkg.core
200+ then Left Exit.OutlineNoPkgCore
201+ else Right outline
202+
203+ App (AppOutline _ srcDirs direct indirect _ _)
204+ | Map.notMember Pkg.core direct ->
205+ return $ Left Exit.OutlineNoAppCore
206+
207+ | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
208+ return $ Left Exit.OutlineNoAppJson
209+
210+ | otherwise ->
211+ do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
212+ case map toGiven badDirs of
213+ d:ds ->
214+ return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
215+
216+ [] ->
217+ do maybeDups <- detectDuplicates root (NE.toList srcDirs)
218+ case maybeDups of
219+ Nothing ->
208− return $ Right outline
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+
209
237
210− App (AppOutline _ srcDirs _ _ _ _) ->
238+toAbsolute :: FilePath -> SrcDir -> FilePath
211− do badDirs <- filterM (isBadSrcDir root) srcDirs
239+toAbsolute root srcDir =
212− case badDirs of
240+ case srcDir of
213− [] -> return $ Right outline
241+ AbsoluteSrcDir dir -> dir
214− d:ds -> return $ Left (Exit.BadOutlineSrcDirs d ds)
242+ RelativeSrcDir dir -> root </> dir
215
243
216
244
217−isBadSrcDir :: FilePath -> FilePath -> IO Bool
245+detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
218−isBadSrcDir root dir =
246+detectDuplicates root srcDirs =
219− not <$> Dir.doesDirectoryExist (root </> dir)
247+ do pairs <- traverse (toPair root) srcDirs
248+ return $ Map.lookupMin $ Map.mapMaybe isDup $
249+ Map.fromListWith OneOrMore.more pairs
250+
251+
252+toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
253+toPair root srcDir =
254+ do key <- Dir.canonicalizePath (toAbsolute root srcDir)
255+ return (key, OneOrMore.one (toGiven srcDir))
256+
257+
258+isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
259+isDup paths =
260+ case paths of
261+ OneOrMore.One _ -> Nothing
262+ OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
220
263
221
264
222
265
@@ -224,28 +267,26 @@ isBadSrcDir root dir =
224
267
225
268
226type Decoder a =
269type Decoder a =
227− D.Decoder E.BadElmJsonContent a
270+ D.Decoder Exit.OutlineProblem a
228
271
229
272
230decoder :: Decoder Outline
273decoder :: Decoder Outline
231decoder =
274decoder =
275+ let
276+ application = Json.fromChars "application"
277+ package = Json.fromChars "package"
278+ in
232 do tipe <- D.field "type" D.string
279 do tipe <- D.field "type" D.string
233− case tipe of
234− "application" ->
235− App <$> appDecoder
280+ if | tipe == application -> App <$> appDecoder
236−
237− "package" ->
238− Pkg <$> pkgDecoder
281+ | tipe == package -> Pkg <$> pkgDecoder
239−
282+ | otherwise -> D.failure Exit.OP_BadType
240− other ->
241− D.failure (E.BadType other)
242
283
243
284
244appDecoder :: Decoder AppOutline
285appDecoder :: Decoder AppOutline
245appDecoder =
286appDecoder =
246 AppOutline
287 AppOutline
247 <$> D.field "elm-version" versionDecoder
288 <$> D.field "elm-version" versionDecoder
248− <*> D.field "source-directories" (D.list dirDecoder)
289+ <*> D.field "source-directories" dirsDecoder
249 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
290 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
250 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
291 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
251 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
292 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
@@ -255,9 +296,9 @@ appDecoder =
255pkgDecoder :: Decoder PkgOutline
296pkgDecoder :: Decoder PkgOutline
256pkgDecoder =
297pkgDecoder =
257 PkgOutline
298 PkgOutline
258− <$> D.field "name" (D.mapError E.BadPkgName Pkg.decoder)
299+ <$> D.field "name" nameDecoder
259 <*> D.field "summary" summaryDecoder
300 <*> D.field "summary" summaryDecoder
260− <*> D.field "license" (Licenses.decoder E.BadLicense)
301+ <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
261 <*> D.field "version" versionDecoder
302 <*> D.field "version" versionDecoder
262 <*> D.field "exposed-modules" exposedDecoder
303 <*> D.field "exposed-modules" exposedDecoder
263 <*> D.field "dependencies" (depsDecoder constraintDecoder)
304 <*> D.field "dependencies" (depsDecoder constraintDecoder)
@@ -269,44 +310,43 @@ pkgDecoder =
269-- JSON DECODE HELPERS
310-- JSON DECODE HELPERS
270
311
271
312
313+nameDecoder :: Decoder Pkg.Name
314+nameDecoder =
315+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316+
317+
272−summaryDecoder :: Decoder Utf8.String
318+summaryDecoder :: Decoder Json.String
273summaryDecoder =
319summaryDecoder =
274− do summary <- D.string
320+ D.customString
275− if Utf8.size summary < 80
321+ (boundParser 80 Exit.OP_BadSummaryTooLong)
276− then return summary
322+ (\_ _ -> Exit.OP_BadSummaryTooLong)
277− else D.failure E.BadSummaryTooLong
278
323
279
324
280versionDecoder :: Decoder V.Version
325versionDecoder :: Decoder V.Version
281versionDecoder =
326versionDecoder =
282− D.mapError E.BadVersion V.decoder
327+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
283
328
284
329
285constraintDecoder :: Decoder Con.Constraint
330constraintDecoder :: Decoder Con.Constraint
286constraintDecoder =
331constraintDecoder =
287− D.mapError E.BadConstraint Con.decoder
332+ D.mapError Exit.OP_BadConstraint Con.decoder
288
333
289
334
290depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
291depsDecoder valueDecoder =
336depsDecoder valueDecoder =
292− Map.fromList <$> (
337+ D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
293− traverse validateKey =<< D.pairs valueDecoder
294− )
295
338
296
339
297−validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
340+dirsDecoder :: Decoder (NE.List SrcDir)
298−validateKey (key, value) =
341+dirsDecoder =
299− case Pkg.fromString key of
342+ fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
300− Right name ->
301− return (name, value)
302
343
303− Left _ ->
304− D.failure (E.BadDependencyName key)
305
344
306−
345+toSrcDir :: FilePath -> SrcDir
307−dirDecoder :: Decoder FilePath
346+toSrcDir path =
308−dirDecoder =
347+ if FP.isRelative path
309− Utf8.toChars <$> D.string
348+ then RelativeSrcDir path
349+ else AbsoluteSrcDir path
310
350
311
351
312
352
@@ -317,81 +357,51 @@ exposedDecoder :: Decoder Exposed
317exposedDecoder =
357exposedDecoder =
318 D.oneOf
358 D.oneOf
319 [ ExposedList <$> D.list moduleDecoder
359 [ ExposedList <$> D.list moduleDecoder
320− , do pairs <- D.pairs (D.list moduleDecoder)
360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
321− traverse_ (checkHeader . fst) pairs
322− return (ExposedDict pairs)
323 ]
361 ]
324
362
325
363
326moduleDecoder :: Decoder ModuleName.Raw
364moduleDecoder :: Decoder ModuleName.Raw
327moduleDecoder =
365moduleDecoder =
328− D.mapError E.BadModuleName ModuleName.decoder
366+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
329
367
330
368
331−checkHeader :: Utf8.String -> Decoder ()
369+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
332−checkHeader header =
370+headerKeyDecoder =
333− if Utf8.size header < 20
371+ D.KeyDecoder
334− then return ()
372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
335− else D.failure (E.BadModuleHeaderTooLong header)
373+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
336
374
337
375
338
376
339−-- BINARY
377+-- BOUND PARSER
340
378
341
379
342−instance Binary Outline where
380+boundParser :: Int -> x -> P.Parser x Json.String
343− put outline =
381+boundParser bound tooLong =
344− case outline of
382+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
345− App a -> putWord8 0 >> put a
383+ let
346− Pkg a -> putWord8 1 >> put a
384+ len = minusPtr end pos
347−
385+ newCol = col + fromIntegral len
348− get =
386+ in
349− do n <- getWord8
387+ if len < bound
350− case n of
388+ then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
351− 0 -> liftM App get
389+ else cerr row newCol (\_ _ -> tooLong)
352− 1 -> liftM Pkg get
353− _ -> error "binary encoding of Outline was corrupted"
354
390
355
391
356−instance Binary AppOutline where
357− put (AppOutline a b c d e f) =
358− put a >> put b >> put c >> put d >> put e >> put f
359−
360− get =
361− do a <- get
362− b <- get
363− c <- get
364− d <- get
365− e <- get
366− f <- get
367− return (AppOutline a b c d e f)
368
392
393+-- BINARY
369
394
370−instance Binary PkgOutline where
371− put (PkgOutline a b c d e f g h) =
372− put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
373
395
374− get =
375− do a <- get
376− b <- get
377− c <- get
378− d <- get
379− e <- get
380− f <- get
381− g <- get
382− h <- get
383− return (PkgOutline a b c d e f g h)
384−
385−
386−instance Binary Exposed where
396+instance Binary SrcDir where
387− put exposed =
397+ put outline =
388− case exposed of
398+ case outline of
389− ExposedList a -> putWord8 0 >> put a
399+ AbsoluteSrcDir a -> putWord8 0 >> put a
390− ExposedDict a -> putWord8 1 >> put a
400+ RelativeSrcDir a -> putWord8 1 >> put a
391
401
392 get =
402 get =
393 do n <- getWord8
403 do n <- getWord8
394 case n of
404 case n of
395− 0 -> liftM ExposedList get
405+ 0 -> liftM AbsoluteSrcDir get
396− 1 -> liftM ExposedDict get
406+ 1 -> liftM RelativeSrcDir get
397− _ -> error "binary encoding of ProjectDeps was corrupted"
407+ _ -> fail "binary encoding of SrcDir was corrupted"
builder/src/Elm/Publish.hsdeleted−255
@@ -1,255 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.Publish (publish) where
3−
4−
5−import Control.Monad (when)
6−import Control.Monad.Except (catchError, runExceptT)
7−import Control.Monad.Trans (liftIO, lift)
8−import qualified Data.List as List
9−import qualified Data.Utf8 as Utf8
10−import qualified System.Directory as Dir
11−import qualified System.Exit as Exit
12−import System.FilePath ((</>))
13−import qualified System.IO as IO
14−import qualified System.Process as Process
15−
16−import qualified Deps.Cache as Cache
17−import qualified Deps.Diff as Diff
18−import qualified Deps.Website as Website
19−import qualified Elm.Bump as Bump
20−import qualified Elm.Docs as Docs
21−import qualified Elm.Package as Pkg
22−import qualified Elm.Project.Json as Project
23−import qualified Elm.Project.Summary as Summary
24−import qualified Elm.Version as V
25−import qualified Reporting.Exit as Exit
26−import qualified Reporting.Exit.Publish as E
27−import qualified Reporting.Progress as Progress
28−import qualified Reporting.Task as Task
29−import qualified Stuff.Paths as Path
30−
31−
32−
33−-- PUBLISH
34−
35−
36−publish :: Summary.Summary -> Task.Task ()
37−publish summary@(Summary.Summary root project _ _ _) =
38− case project of
39− Project.App _ ->
40− throw E.Application
41−
42− Project.Pkg (Project.PkgInfo name smry _ version exposed _ _ _) ->
43− do
44− registry <- Cache.mandatoryUpdate
45− let maybePublishedVersions = either (const Nothing) Just (Cache.getVersions name registry)
46−
47− Task.report (Progress.PublishStart name version maybePublishedVersions)
48−
49− when (noExposed exposed) $ throw E.NoExposed
50− when (badSummary smry) $ throw E.NoSummary
51−
52− verifyReadme root
53− verifyLicense root
54− docs <- Task.silently (error "TODO Project.generateDocs summary" summary)
55− verifyVersion name version docs maybePublishedVersions
56− commitHash <- verifyTag name version
57− verifyNoChanges commitHash version
58− zipHash <- verifyZip name version
59−
60− Website.register name version commitHash zipHash
61−
62− Task.report Progress.PublishEnd
63−
64−
65−throw :: E.Exit -> Task.Task a
66−throw exit =
67− Task.throw (Exit.Publish exit)
68−
69−
70−
71−-- VERIFY SUMMARY
72−
73−
74−badSummary :: Utf8.String -> Bool
75−badSummary summary =
76− Utf8.isEmpty summary || Project.defaultSummary == summary
77−
78−
79−noExposed :: Project.Exposed -> Bool
80−noExposed exposed =
81− case exposed of
82− Project.ExposedList modules ->
83− null modules
84−
85− Project.ExposedDict chunks ->
86− all (null . snd) chunks
87−
88−
89−
90−-- VERIFY README
91−
92−
93−verifyReadme :: FilePath -> Task.Task ()
94−verifyReadme root =
95− phase Progress.CheckReadme $
96− do let readmePath = root </> "README.md"
97− exists <- liftIO $ Dir.doesFileExist readmePath
98− case exists of
99− False ->
100− throw E.NoReadme
101−
102− True ->
103− do size <- liftIO $ IO.withFile readmePath IO.ReadMode IO.hFileSize
104− if size < 300
105− then throw E.ShortReadme
106− else return ()
107−
108−
109−
110−-- VERIFY LICENSE
111−
112−
113−verifyLicense :: FilePath -> Task.Task ()
114−verifyLicense root =
115− phase Progress.CheckLicense $
116− do let licensePath = root </> "LICENSE"
117− exists <- liftIO $ Dir.doesFileExist licensePath
118− if exists
119− then return ()
120− else throw E.NoLicense
121−
122−
123−
124−-- VERIFY GITHUB TAG
125−
126−
127−verifyTag :: Pkg.Name -> V.Version -> Task.Task String
128−verifyTag name version =
129− phase (Progress.CheckTag version) $
130− Website.githubCommit name version `catchError` \_ ->
131− throw (E.MissingTag version)
132−
133−
134−
135−-- VERIFY NO LOCAL CHANGES SINCE TAG
136−
137−
138−verifyNoChanges :: String -> V.Version -> Task.Task ()
139−verifyNoChanges commitHash version =
140− phase Progress.CheckChanges $
141− do maybeGit <- liftIO $ Dir.findExecutable "git"
142− case maybeGit of
143− Nothing ->
144− throw E.NoGit
145−
146− Just git ->
147− do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
148− exitCode <- liftIO $
149− Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
150−
151− case exitCode of
152− Exit.ExitSuccess ->
153− return ()
154−
155− Exit.ExitFailure _ ->
156− throw (E.LocalChanges version)
157−
158−
159−
160−-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
161−
162−
163−verifyZip :: Pkg.Name -> V.Version -> Task.Task Website.Sha
164−verifyZip name version =
165− withTempDir $ \dir ->
166− do hash <- phase Progress.CheckDownload $
167− Website.githubDownload name version dir
168−
169− phase Progress.CheckBuild $
170− do runner <- Task.getSilentRunner
171− result <- liftIO $ Dir.withCurrentDirectory dir $ runner $
172− Task.silently $ error "TODO Project.generateDocs =<< Project.getRoot"
173− either Task.throw (\_ -> return ()) result
174−
175− return hash
176−
177−
178−withTempDir :: (FilePath -> Task.Task a) -> Task.Task a
179−withTempDir callback =
180− do liftIO $ Dir.createDirectoryIfMissing True Path.prepublishDir
181− result <- lift $ runExceptT $ callback Path.prepublishDir
182− liftIO $ Dir.removeDirectoryRecursive Path.prepublishDir
183− either Task.throw return result
184−
185−
186−
187−-- PHASE REPORTING
188−
189−
190−phase :: Progress.PublishPhase -> Task.Task a -> Task.Task a
191−phase publishPhase task =
192− do Task.report $ Progress.PublishProgress publishPhase Nothing
193−
194− result <- task `catchError` \exit ->
195− do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)
196− Task.throw exit
197−
198− Task.report $ Progress.PublishProgress publishPhase (Just Progress.Good)
199−
200− return result
201−
202−
203−
204−-- VERIFY VERSION
205−
206−
207−verifyVersion :: Pkg.Name -> V.Version -> Docs.Documentation -> Maybe [V.Version] -> Task.Task ()
208−verifyVersion name version docs maybePublishedVersions =
209− let
210− reportBumpPhase bumpPhase =
211− Task.report $ Progress.PublishCheckBump version bumpPhase
212− in
213− do reportBumpPhase Progress.StatedVersion
214− case maybePublishedVersions of
215− Nothing ->
216− if version == V.one then
217− reportBumpPhase Progress.GoodStart
218− else
219− throw (E.NotInitialVersion version)
220−
221− Just publishedVersions ->
222− if elem version publishedVersions then
223− throw $ E.AlreadyPublished version
224− else
225− do (old, magnitude) <- verifyBump name version docs publishedVersions
226− reportBumpPhase (Progress.GoodBump old magnitude)
227−
228− `catchError` \exit ->
229− do reportBumpPhase Progress.BadBump
230− Task.throw exit
231−
232−
233−verifyBump :: Pkg.Name -> V.Version -> Docs.Documentation -> [V.Version] -> Task.Task (V.Version, Diff.Magnitude)
234−verifyBump name statedVersion newDocs publishedVersions =
235− let
236− possibleBumps =
237− Bump.toPossibleBumps publishedVersions
238−
239− isTheBump (_ ,new, _) =
240− statedVersion == new
241− in
242− case List.find isTheBump possibleBumps of
243− Nothing ->
244− throw $ E.InvalidBump statedVersion (last publishedVersions)
245−
246− Just (old, new, magnitude) ->
247− do oldDocs <- Cache.getDocs name old
248− let changes = Diff.diff oldDocs newDocs
249− let realNew = Diff.bump changes old
250− if new == realNew
251− then
252− return (old, magnitude)
253− else
254− throw $ E.BadBump old new magnitude realNew $
255− Diff.toMagnitude changes
builder/src/File.hs+28−5
@@ -1,6 +1,7 @@
1module File
1module File
2 ( Time
2 ( Time
3 , getTime
3 , getTime
4+ , zeroTime
4 , writeBinary
5 , writeBinary
5 , readBinary
6 , readBinary
6 , writeUtf8
7 , writeUtf8
@@ -23,6 +24,7 @@ import qualified Data.ByteString.Builder as B
23import qualified Data.ByteString.Lazy as LBS
24import qualified Data.ByteString.Lazy as LBS
24import qualified Data.Fixed as Fixed
25import qualified Data.Fixed as Fixed
25import qualified Data.List as List
26import qualified Data.List as List
27+import qualified Data.Time.Clock as Time
26import qualified Data.Time.Clock.POSIX as Time
28import qualified Data.Time.Clock.POSIX as Time
27import qualified Foreign.ForeignPtr as FPtr
29import qualified Foreign.ForeignPtr as FPtr
28import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
@@ -44,11 +46,15 @@ newtype Time = Time Fixed.Pico
44getTime :: FilePath -> IO Time
46getTime :: FilePath -> IO Time
45getTime path =
47getTime path =
46 fmap
48 fmap
47− (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
48−-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
49+ (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
49 (Dir.getModificationTime path)
50 (Dir.getModificationTime path)
50
51
51
52
53+zeroTime :: Time
54+zeroTime =
55+ Time 0
56+
57+
52instance Binary.Binary Time where
58instance Binary.Binary Time where
53 put (Time time) = Binary.put time
59 put (Time time) = Binary.put time
54 get = Time <$> Binary.get
60 get = Time <$> Binary.get
@@ -72,8 +78,21 @@ readBinary path =
72 then
78 then
73 do result <- Binary.decodeFileOrFail path
79 do result <- Binary.decodeFileOrFail path
74 case result of
80 case result of
81+ Right a ->
75− Right a -> return (Just a)
82+ return (Just a)
83+
84+ Left (offset, message) ->
85+ do IO.hPutStrLn IO.stderr $ unlines $
86+ [ "+-------------------------------------------------------------------------------"
87+ , "| Corrupt File: " ++ path
88+ , "| Byte Offset: " ++ show offset
89+ , "| Message: " ++ message
90+ , "|"
91+ , "| Please report this to https://github.com/elm/compiler/issues"
92+ , "| Trying to continue anyway."
93+ , "+-------------------------------------------------------------------------------"
94+ ]
76− Left e -> return Nothing
95+ return Nothing
77 else
96 else
78 return Nothing
97 return Nothing
79
98
@@ -171,7 +190,11 @@ writeEntry destination root entry =
171 let
190 let
172 path = drop root (Zip.eRelativePath entry)
191 path = drop root (Zip.eRelativePath entry)
173 in
192 in
174− if List.isPrefixOf "src/" path then
193+ if List.isPrefixOf "src/" path
194+ || path == "LICENSE"
195+ || path == "README.md"
196+ || path == "elm.json"
197+ then
175 if not (null path) && last path == '/'
198 if not (null path) && last path == '/'
176 then Dir.createDirectoryIfMissing True (destination </> path)
199 then Dir.createDirectoryIfMissing True (destination </> path)
177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
200 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
builder/src/Generate.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Generate
3+ ( debug
4+ , dev
5+ , prod
6+ , repl
7+ )
8+ where
9+
10+
11+import Prelude hiding (cycle, print)
12+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13+import Control.Monad (liftM2)
14+import qualified Data.ByteString.Builder as B
15+import Data.Map ((!))
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+import qualified Data.Name as N
19+import qualified Data.NonEmptyList as NE
20+
21+import qualified AST.Optimized as Opt
22+import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
26+import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Package as Pkg
28+import qualified File
29+import qualified Generate.JavaScript as JS
30+import qualified Generate.Mode as Mode
31+import qualified Nitpick.Debug as Nitpick
32+import qualified Reporting.Exit as Exit
33+import qualified Reporting.Task as Task
34+import qualified Stuff
35+
36+
37+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38+-- desireable to have Repl and Reactor to keep foreign objects in memory
39+-- to make things a bit faster?
40+
41+
42+
43+-- GENERATORS
44+
45+
46+type Task a =
47+ Task.Task Exit.Generate a
48+
49+
50+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51+debug root details (Build.Artifacts pkg ifaces roots modules) =
52+ do loading <- loadObjects root details modules
53+ types <- loadTypes root ifaces modules
54+ objects <- finalizeObjects loading
55+ let mode = Mode.Dev (Just types)
56+ let graph = objectsToGlobalGraph objects
57+ let mains = gatherMains pkg objects roots
58+ return $ JS.generate mode graph mains
59+
60+
61+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62+dev root details (Build.Artifacts pkg _ roots modules) =
63+ do objects <- finalizeObjects =<< loadObjects root details modules
64+ let mode = Mode.Dev Nothing
65+ let graph = objectsToGlobalGraph objects
66+ let mains = gatherMains pkg objects roots
67+ return $ JS.generate mode graph mains
68+
69+
70+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71+prod root details (Build.Artifacts pkg _ roots modules) =
72+ do objects <- finalizeObjects =<< loadObjects root details modules
73+ checkForDebugUses objects
74+ let graph = objectsToGlobalGraph objects
75+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
76+ let mains = gatherMains pkg objects roots
77+ return $ JS.generate mode graph mains
78+
79+
80+repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81+repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82+ do objects <- finalizeObjects =<< loadObjects root details modules
83+ let graph = objectsToGlobalGraph objects
84+ return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85+
86+
87+
88+-- CHECK FOR DEBUG
89+
90+
91+checkForDebugUses :: Objects -> Task ()
92+checkForDebugUses (Objects _ locals) =
93+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94+ [] -> return ()
95+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96+
97+
98+
99+-- GATHER MAINS
100+
101+
102+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103+gatherMains pkg (Objects _ locals) roots =
104+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105+
106+
107+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108+lookupMain pkg locals root =
109+ let
110+ toPair name (Opt.LocalGraph maybeMain _ _) =
111+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
112+ in
113+ case root of
114+ Build.Inside name -> toPair name =<< Map.lookup name locals
115+ Build.Outside name _ g -> toPair name g
116+
117+
118+
119+-- LOADING OBJECTS
120+
121+
122+data LoadingObjects =
123+ LoadingObjects
124+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126+ }
127+
128+
129+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130+loadObjects root details modules =
131+ Task.io $
132+ do mvar <- Details.loadObjects root details
133+ mvars <- traverse (loadObject root) modules
134+ return $ LoadingObjects mvar (Map.fromList mvars)
135+
136+
137+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138+loadObject root modul =
139+ case modul of
140+ Build.Fresh name _ graph ->
141+ do mvar <- newMVar (Just graph)
142+ return (name, mvar)
143+
144+ Build.Cached name _ _ ->
145+ do mvar <- newEmptyMVar
146+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147+ return (name, mvar)
148+
149+
150+
151+-- FINALIZE OBJECTS
152+
153+
154+data Objects =
155+ Objects
156+ { _foreign :: Opt.GlobalGraph
157+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158+ }
159+
160+
161+finalizeObjects :: LoadingObjects -> Task Objects
162+finalizeObjects (LoadingObjects mvar mvars) =
163+ Task.eio id $
164+ do result <- readMVar mvar
165+ results <- traverse readMVar mvars
166+ case liftM2 Objects result (sequence results) of
167+ Just loaded -> return (Right loaded)
168+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169+
170+
171+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172+objectsToGlobalGraph (Objects globals locals) =
173+ foldr Opt.addLocalGraph globals locals
174+
175+
176+
177+-- LOAD TYPES
178+
179+
180+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181+loadTypes root ifaces modules =
182+ Task.eio id $
183+ do mvars <- traverse (loadTypesHelp root) modules
184+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185+ results <- traverse readMVar mvars
186+ case sequence results of
187+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189+
190+
191+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192+loadTypesHelp root modul =
193+ case modul of
194+ Build.Fresh name iface _ ->
195+ newMVar (Just (Extract.fromInterface name iface))
196+
197+ Build.Cached name _ ciMVar ->
198+ do cachedInterface <- readMVar ciMVar
199+ case cachedInterface of
200+ Build.Unneeded ->
201+ do mvar <- newEmptyMVar
202+ _ <- forkIO $
203+ do maybeIface <- File.readBinary (Stuff.elmi root name)
204+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
205+ return mvar
206+
207+ Build.Loaded iface ->
208+ newMVar (Just (Extract.fromInterface name iface))
209+
210+ Build.Corrupted ->
211+ newMVar Nothing
builder/src/Http.hs+14−1
@@ -16,6 +16,7 @@ module Http
16 -- upload
16 -- upload
17 , upload
17 , upload
18 , filePart
18 , filePart
19+ , jsonPart
19 , stringPart
20 , stringPart
20 )
21 )
21 where
22 where
@@ -26,6 +27,7 @@ import qualified Codec.Archive.Zip as Zip
26import Control.Exception (SomeException, handle)
27import Control.Exception (SomeException, handle)
27import qualified Data.Binary as Binary
28import qualified Data.Binary as Binary
28import qualified Data.Binary.Get as Binary
29import qualified Data.Binary.Get as Binary
30+import qualified Data.ByteString.Builder as B
29import qualified Data.ByteString.Char8 as BS
31import qualified Data.ByteString.Char8 as BS
30import qualified Data.Digest.Pure.SHA as SHA
32import qualified Data.Digest.Pure.SHA as SHA
31import qualified Data.String as String
33import qualified Data.String as String
@@ -34,8 +36,10 @@ import Network.HTTP.Client
34import Network.HTTP.Client.TLS (tlsManagerSettings)
36import Network.HTTP.Client.TLS (tlsManagerSettings)
35import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
36import Network.HTTP.Types.Method (Method, methodGet, methodPost)
38import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39+import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
37import qualified Network.HTTP.Client.MultipartFormData as Multi
40import qualified Network.HTTP.Client.MultipartFormData as Multi
38
41
42+import qualified Json.Encode as Encode
39import qualified Elm.Version as V
43import qualified Elm.Version as V
40
44
41
45
@@ -226,6 +230,15 @@ filePart name filePath =
226 Multi.partFileSource (String.fromString name) filePath
230 Multi.partFileSource (String.fromString name) filePath
227
231
228
232
233+jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
234+jsonPart name filePath value =
235+ let
236+ body =
237+ Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
238+ in
239+ Multi.partFileRequestBody (String.fromString name) filePath body
240+
241+
229stringPart :: String -> String -> Multi.Part
242stringPart :: String -> String -> Multi.Part
230stringPart name string =
243stringPart name string =
231− Multi.partBS (String.fromString name) (BS.pack string)
244+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hs+122−27
@@ -1,14 +1,17 @@
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Reporting
2module Reporting
3 ( Style
3 ( Style
4+ , silent
4 , json
5 , json
5 , terminal
6 , terminal
6 --
7 --
7 , attempt
8 , attempt
8− , exit
9+ , attemptWithStyle
9 --
10 --
10 , Key
11 , Key
11 , report
12 , report
13+ , ignorer
14+ , ask
12 --
15 --
13 , DKey
16 , DKey
14 , DMsg(..)
17 , DMsg(..)
@@ -24,12 +27,13 @@ module Reporting
24
27
25
28
26import Control.Concurrent
29import Control.Concurrent
30+import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
27import Control.Monad (when)
31import Control.Monad (when)
28import qualified Data.ByteString.Builder as B
32import qualified Data.ByteString.Builder as B
29import qualified Data.NonEmptyList as NE
33import qualified Data.NonEmptyList as NE
30import qualified System.Exit as Exit
34import qualified System.Exit as Exit
31import qualified System.Info as Info
35import qualified System.Info as Info
32−import System.IO (hFlush, hPutStr, stderr, stdout)
36+import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
33
37
34import qualified Elm.ModuleName as ModuleName
38import qualified Elm.ModuleName as ModuleName
35import qualified Elm.Package as Pkg
39import qualified Elm.Package as Pkg
@@ -46,10 +50,16 @@ import qualified Reporting.Exit.Help as Help
46
50
47
51
48data Style
52data Style
53+ = Silent
49− = Json
54+ | Json
50 | Terminal (MVar ())
55 | Terminal (MVar ())
51
56
52
57
58+silent :: Style
59+silent =
60+ Silent
61+
62+
53json :: Style
63json :: Style
54json =
64json =
55 Json
65 Json
@@ -64,25 +74,38 @@ terminal =
64-- ATTEMPT
74-- ATTEMPT
65
75
66
76
67−attempt :: Style -> IO (Either Help.Report a) -> IO a
77+attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
68−attempt style work =
78+attempt toReport work =
69− do result <- work
79+ do result <- work `catch` reportExceptionsNicely
70 case result of
80 case result of
81+ Right a ->
71− Right a -> return a
82+ return a
72− Left ex -> exit style ex
73
83
84+ Left x ->
85+ do Exit.toStderr (toReport x)
86+ Exit.exitFailure
74
87
75−exit :: Style -> Help.Report -> IO a
76−exit style rep =
77− case style of
78− Json ->
79− do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson rep))
80− Exit.exitFailure
81
88
89+attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
90+attemptWithStyle style toReport work =
91+ do result <- work `catch` reportExceptionsNicely
92+ case result of
93+ Right a ->
94+ return a
95+
96+ Left x ->
97+ case style of
98+ Silent ->
99+ do Exit.exitFailure
100+
101+ Json ->
102+ do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
103+ Exit.exitFailure
104+
82− Terminal mvar ->
105+ Terminal mvar ->
83− do readMVar mvar
106+ do readMVar mvar
84− Exit.toStderr rep
107+ Exit.toStderr (toReport x)
85− Exit.exitFailure
108+ Exit.exitFailure
86
109
87
110
88
111
@@ -99,11 +122,6 @@ badMark =
99 D.red $ if isWindows then "X" else "✗"
122 D.red $ if isWindows then "X" else "✗"
100
123
101
124
102−_waitingMark :: D.Doc
103−_waitingMark =
104− D.dullyellow $ if isWindows then "-" else "→"
105−
106−
107isWindows :: Bool
125isWindows :: Bool
108isWindows =
126isWindows =
109 Info.os == "mingw32"
127 Info.os == "mingw32"
@@ -121,6 +139,34 @@ report (Key send) msg =
121 send msg
139 send msg
122
140
123
141
142+ignorer :: Key msg
143+ignorer =
144+ Key (\_ -> return ())
145+
146+
147+
148+-- ASK
149+
150+
151+ask :: D.Doc -> IO Bool
152+ask doc =
153+ do Help.toStdout doc
154+ askHelp
155+
156+
157+askHelp :: IO Bool
158+askHelp =
159+ do hFlush stdout
160+ input <- getLine
161+ case input of
162+ "" -> return True
163+ "Y" -> return True
164+ "y" -> return True
165+ "n" -> return False
166+ _ ->
167+ do putStr "Must type 'y' for yes or 'n' for no: "
168+ askHelp
169+
124
170
125-- DETAILS
171-- DETAILS
126
172
@@ -131,6 +177,9 @@ type DKey = Key DMsg
131trackDetails :: Style -> (DKey -> IO a) -> IO a
177trackDetails :: Style -> (DKey -> IO a) -> IO a
132trackDetails style callback =
178trackDetails style callback =
133 case style of
179 case style of
180+ Silent ->
181+ callback (Key (\_ -> return ()))
182+
134 Json ->
183 Json ->
135 callback (Key (\_ -> return ()))
184 callback (Key (\_ -> return ()))
136
185
@@ -215,8 +264,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
215putDownload mark pkg vsn =
264putDownload mark pkg vsn =
216 Help.toStdout $ D.indent 2 $
265 Help.toStdout $ D.indent 2 $
217 mark
266 mark
218− <+> D.fromUtf8 (Pkg.toString pkg)
267+ <+> D.fromPackage pkg
219− <+> D.fromUtf8 (V.toString vsn)
268+ <+> D.fromVersion vsn
220 <> "\n"
269 <> "\n"
221
270
222
271
@@ -260,6 +309,9 @@ type BResult a = Either Exit.BuildProblem a
260trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
309trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
261trackBuild style callback =
310trackBuild style callback =
262 case style of
311 case style of
312+ Silent ->
313+ callback (Key (\_ -> return ()))
314+
263 Json ->
315 Json ->
264 callback (Key (\_ -> return ()))
316 callback (Key (\_ -> return ()))
265
317
@@ -312,10 +364,10 @@ toFinalMessage done result =
312
364
313 Left problem ->
365 Left problem ->
314 case problem of
366 case problem of
315− Exit.BuildModuleProblems _ [] ->
367+ Exit.BuildBadModules _ _ [] ->
316 "Detected problems in 1 module."
368 "Detected problems in 1 module."
317
369
318− Exit.BuildModuleProblems _ (_:ps) ->
370+ Exit.BuildBadModules _ _ (_:ps) ->
319 "Detected problems in " ++ show (2 + length ps) ++ " modules."
371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
320
372
321 Exit.BuildProjectProblem _ ->
373 Exit.BuildProjectProblem _ ->
@@ -329,6 +381,9 @@ toFinalMessage done result =
329reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
381reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
330reportGenerate style names output =
382reportGenerate style names output =
331 case style of
383 case style of
384+ Silent ->
385+ return ()
386+
332 Json ->
387 Json ->
333 return ()
388 return ()
334
389
@@ -377,3 +432,43 @@ vbottom = if isWindows then '+' else '┘'
377putStrFlush :: String -> IO ()
432putStrFlush :: String -> IO ()
378putStrFlush str =
433putStrFlush str =
379 hPutStr stdout str >> hFlush stdout
434 hPutStr stdout str >> hFlush stdout
435+
436+
437+
438+-- REPORT EXCEPTIONS NICELY
439+
440+
441+reportExceptionsNicely :: SomeException -> IO a
442+reportExceptionsNicely e =
443+ case fromException e of
444+ Just UserInterrupt -> throw e
445+ _ -> putException e >> throw e
446+
447+
448+putException :: SomeException -> IO ()
449+putException e = do
450+ hPutStrLn stderr ""
451+ Help.toStderr $ D.stack $
452+ [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
453+ , D.reflow $
454+ "I ran into something that bypassed the normal error reporting process!\
455+ \ I extracted whatever information I could from the internal error:"
456+ , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
457+ , D.reflow $
458+ "These errors are usually pretty confusing, so start by asking around on one of\
459+ \ forums listed at https://elm-lang.org/community to see if anyone can get you\
460+ \ unstuck quickly."
461+ , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
462+ , D.reflow $
463+ "If you are feeling up to it, please try to get your code down to the smallest\
464+ \ version that still triggers this message. Ideally in a single Main.elm and\
465+ \ elm.json file."
466+ , D.reflow $
467+ "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\
469+ \ worry about if someone else saw something similar. More examples is better!"
470+ , D.reflow $
471+ "This kind of error is usually tied up in larger architectural choices that are\
472+ \ hard to change, so even when we have a couple good examples, it can take some\
473+ \ time to resolve in a solid way."
474+ ]
builder/src/Reporting/Exit.hs+2015−64
@@ -1,6 +1,27 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Exit
2module Reporting.Exit
3− ( Exit(..)
3+ ( Init(..), initToReport
4+ , Diff(..), diffToReport
5+ , Make(..), makeToReport
6+ , Bump(..), bumpToReport
7+ , Repl(..), replToReport
8+ , Publish(..), publishToReport
9+ , Install(..), installToReport
10+ , Reactor(..), reactorToReport
11+ , newPackageOverview
12+ --
13+ , Solver(..)
14+ , Outline(..)
15+ , OutlineProblem(..)
16+ , Details(..)
17+ , DetailsBadDep(..)
18+ , PackageProblem(..)
19+ , RegistryProblem(..)
20+ , BuildProblem(..)
21+ , BuildProjectProblem(..)
22+ , DocsProblem(..)
23+ , Generate(..)
24+ --
4 , toString
25 , toString
5 , toStderr
26 , toStderr
6 , toJson
27 , toJson
@@ -8,66 +29,1579 @@ module Reporting.Exit
8 where
29 where
9
30
10
31
32+import qualified Data.ByteString as BS
33+import qualified Data.ByteString.UTF8 as BS_UTF8
34+import qualified Data.List as List
35+import qualified Data.Map as Map
36+import qualified Data.Name as N
37+import qualified Data.NonEmptyList as NE
38+import qualified Network.HTTP.Client as HTTP
39+import qualified Network.HTTP.Types.Header as HTTP
40+import qualified Network.HTTP.Types.Status as HTTP
41+import qualified System.FilePath as FP
42+import System.FilePath ((</>), (<.>))
43+
44+import qualified Elm.Constraint as C
45+import qualified Elm.Magnitude as M
11import qualified Elm.ModuleName as ModuleName
46import qualified Elm.ModuleName as ModuleName
47+import qualified Elm.Package as Pkg
48+import qualified Elm.Version as V
49+import qualified File
50+import qualified Http
51+import qualified Json.Decode as Decode
12import qualified Json.Encode as Encode
52import qualified Json.Encode as Encode
53+import qualified Json.String as Json
54+import Parse.Primitives (Row, Col)
55+import qualified Reporting.Annotation as A
56+import Reporting.Doc ((<>))
13import qualified Reporting.Doc as D
57import qualified Reporting.Doc as D
14−import qualified Reporting.Exit.Assets as Asset
58+import qualified Reporting.Error.Import as Import
15−import qualified Reporting.Exit.Bump as Bump
59+import qualified Reporting.Error.Json as Json
16−import qualified Reporting.Exit.Compile as Compile
17−import qualified Reporting.Exit.Crawl as Crawl
18−import qualified Reporting.Exit.Deps as Deps
19−import qualified Reporting.Exit.Diff as Diff
20import qualified Reporting.Exit.Help as Help
60import qualified Reporting.Exit.Help as Help
21−import qualified Reporting.Exit.Http as Http
61+import qualified Reporting.Error as Error
22−import qualified Reporting.Exit.Make as Make
23−import qualified Reporting.Exit.Init as Init
62+import qualified Reporting.Render.Code as Code
24−import qualified Reporting.Exit.Install as Install
25−import qualified Reporting.Exit.Publish as Publish
26
63
27
64
28
65
29−-- ALL POSSIBLE ERRORS
66+-- RENDERERS
30
67
31
68
32−data Exit
69+toString :: Help.Report -> String
33− = NoElmJson
70+toString report =
34− | Assets Asset.Exit
71+ Help.toString (Help.reportToDoc report)
35− | Bump Bump.Exit
36− | Compile Compile.Exit [Compile.Exit]
37− | Crawl Crawl.Exit
38− | Cycle [ModuleName.Raw] -- TODO write docs to help with this scenario
39− | Deps Deps.Exit
40− | Diff Diff.Exit
41− | Make Make.Exit
42− | Init Init.Exit
43− | Install Install.Exit
44− | Publish Publish.Exit
45− | BadHttp String Http.Exit
46
72
47
73
74+toStderr :: Help.Report -> IO ()
75+toStderr report =
76+ Help.toStderr (Help.reportToDoc report)
48
77
49−-- RENDERERS
50
78
79+toJson :: Help.Report -> Encode.Value
80+toJson report =
81+ Help.reportToJson report
82+
83+
84+
85+-- INIT
86+
87+
88+data Init
89+ = InitNoSolution [Pkg.Name]
90+ | InitNoOfflineSolution [Pkg.Name]
91+ | InitSolverProblem Solver
92+ | InitAlreadyExists
93+ | InitRegistryProblem RegistryProblem
94+
95+
96+initToReport :: Init -> Help.Report
97+initToReport exit =
98+ case exit of
99+ InitNoSolution pkgs ->
100+ Help.report "NO SOLUTION" Nothing
101+ "I tried to create an elm.json with the following direct dependencies:"
102+ [ D.indent 4 $ D.vcat $
103+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
104+ , D.reflow $
105+ "I could not find compatible versions though! This should not happen, so please\
106+ \ ask around one of the community forums at https://elm-lang.org/community to learn\
107+ \ what is going on!"
108+ ]
109+
110+ InitNoOfflineSolution pkgs ->
111+ Help.report "NO OFFLINE SOLUTION" Nothing
112+ "I tried to create an elm.json with the following direct dependencies:"
113+ [ D.indent 4 $ D.vcat $
114+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
115+ , D.reflow $
116+ "I could not find compatible versions though, but that may be because I could not\
117+ \ connect to https://package.elm-lang.org to get the latest list of packages. Are\
118+ \ you able to connect to the internet? Please ask around one of the community\
119+ \ forums at https://elm-lang.org/community for help!"
120+ ]
121+
122+ InitSolverProblem solver ->
123+ toSolverReport solver
124+
125+ InitAlreadyExists ->
126+ Help.report "EXISTING PROJECT" Nothing
127+ "You already have an elm.json file, so there is nothing for me to initialize!"
128+ [ D.fillSep
129+ ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"
130+ ,"you","figure","out","what","to","do","next?"
131+ ]
132+ ]
133+
134+ InitRegistryProblem problem ->
135+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
136+ "I need the list of published packages before I can start initializing projects"
137+
138+
139+
140+-- DIFF
141+
142+
143+data Diff
144+ = DiffNoOutline
145+ | DiffBadOutline Outline
146+ | DiffApplication
147+ | DiffNoExposed
148+ | DiffUnpublished
149+ | DiffUnknownPackage Pkg.Name [Pkg.Name]
150+ | DiffUnknownVersion Pkg.Name V.Version [V.Version]
151+ | DiffDocsProblem V.Version DocsProblem
152+ | DiffMustHaveLatestRegistry RegistryProblem
153+ | DiffBadDetails Details
154+ | DiffBadBuild BuildProblem
155+
156+
157+diffToReport :: Diff -> Help.Report
158+diffToReport diff =
159+ case diff of
160+ DiffNoOutline ->
161+ Help.report "DIFF WHAT?" Nothing
162+ "I cannot find an elm.json so I am not sure what you want me to diff.\
163+ \ Normally you run `elm diff` from within a project!"
164+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"
165+ , D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0"
166+ ]
167+
168+ DiffBadOutline outline ->
169+ toOutlineReport outline
170+
171+ DiffApplication ->
172+ Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")
173+ "Your elm.json says this project is an application, but `elm diff` only works\
174+ \ with packages. That way there are previously published versions of the API to\
175+ \ diff against!"
176+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"
177+ , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"
178+ ]
179+
180+ DiffNoExposed ->
181+ Help.report "NO EXPOSED MODULES" (Just "elm.json")
182+ "Your elm.json has no \"exposed-modules\" which means there is no public API at\
183+ \ all right now! What am I supposed to diff?"
184+ [ D.reflow $
185+ "Try adding some modules back to the \"exposed-modules\" field."
186+ ]
187+
188+ DiffUnpublished ->
189+ Help.report "UNPUBLISHED" Nothing
190+ "This package is not published yet. There is nothing to diff against!"
191+ []
192+
193+ DiffUnknownPackage pkg suggestions ->
194+ Help.report "UNKNOWN PACKAGE" Nothing
195+ ( "I cannot find a package called:"
196+ )
197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg
198+ , "Maybe you want one of these instead?"
199+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions
200+ , "But check <https://package.elm-lang.org> to see all possibilities!"
201+ ]
202+
203+ DiffUnknownVersion _pkg vsn realVersions ->
204+ Help.docReport "UNKNOWN VERSION" Nothing
205+ ( D.fillSep $
206+ [ "Version", D.red (D.fromVersion vsn)
207+ , "has", "never", "been", "published,", "so", "I"
208+ , "cannot", "diff", "against", "it."
209+ ]
210+ )
211+ [ "Here are all the versions that HAVE been published:"
212+ , D.indent 4 $ D.dullyellow $ D.vcat $
213+ let
214+ sameMajor v1 v2 = V._major v1 == V._major v2
215+ mkRow vsns = D.hsep $ map D.fromVersion vsns
216+ in
217+ map mkRow $ List.groupBy sameMajor (List.sort realVersions)
218+ , "Want one of those instead?"
219+ ]
220+
221+ DiffDocsProblem version problem ->
222+ toDocsProblemReport problem $
223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"
224+
225+ DiffMustHaveLatestRegistry problem ->
226+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
227+ "I need the latest list of published packages before I do this diff"
228+
229+ DiffBadDetails details ->
230+ toDetailsReport details
231+
232+ DiffBadBuild buildProblem ->
233+ toBuildProblemReport buildProblem
234+
235+
236+
237+-- BUMP
238+
239+
240+data Bump
241+ = BumpNoOutline
242+ | BumpBadOutline Outline
243+ | BumpApplication
244+ | BumpUnexpectedVersion V.Version [V.Version]
245+ | BumpMustHaveLatestRegistry RegistryProblem
246+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem
247+ | BumpBadDetails Details
248+ | BumpNoExposed
249+ | BumpBadBuild BuildProblem
250+
251+
252+bumpToReport :: Bump -> Help.Report
253+bumpToReport bump =
254+ case bump of
255+ BumpNoOutline ->
256+ Help.report "BUMP WHAT?" Nothing
257+ "I cannot find an elm.json so I am not sure what you want me to bump."
258+ [ D.reflow $
259+ "Elm packages always have an elm.json that says current the version number. If\
260+ \ you run this command from a directory with an elm.json file, I will try to bump\
261+ \ the version in there based on the API changes."
262+ ]
263+
264+ BumpBadOutline outline ->
265+ toOutlineReport outline
266+
267+ BumpApplication ->
268+ Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")
269+ "Your elm.json says this is an application. That means it cannot be published\
270+ \ on <https://package.elm-lang.org> and therefore has no version to bump!"
271+ []
272+
273+ BumpUnexpectedVersion vsn versions ->
274+ Help.docReport "CANNOT BUMP" (Just "elm.json")
275+ ( D.fillSep
276+ ["Your","elm.json","says","I","should","bump","relative","to","version"
277+ ,D.red (D.fromVersion vsn) <> ","
278+ ,"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"
280+ ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
281+ ]
282+ )
283+ [ D.fillSep $
284+ ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
285+ ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
286+ , D.vcat $ map (D.green . D.fromVersion) versions
287+ ]
288+
289+ BumpMustHaveLatestRegistry problem ->
290+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
291+ "I need the latest list of published packages before I can bump any versions"
292+
293+ BumpCannotFindDocs _ version problem ->
294+ toDocsProblemReport problem $
295+ "I need the docs for " ++ V.toChars version ++ " to compute the next version number"
296+
297+ BumpBadDetails details ->
298+ toDetailsReport details
299+
300+ BumpNoExposed ->
301+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
302+ ( D.fillSep $
303+ [ "To", "bump", "a", "package,", "the"
304+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
305+ , "elm.json", "must", "list", "at", "least", "one", "module."
306+ ]
307+ )
308+ [ D.reflow $
309+ "Try adding some modules back to the \"exposed-modules\" field."
310+ ]
311+
312+ BumpBadBuild problem ->
313+ toBuildProblemReport problem
314+
315+
316+
317+-- OVERVIEW OF VERSIONING
318+
319+
320+newPackageOverview :: String
321+newPackageOverview =
322+ unlines
323+ [ "This package has never been published before. Here's how things work:"
324+ , ""
325+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
326+ , ""
327+ , " - All packages start with initial version " ++ V.toChars V.one
328+ , ""
329+ , " - Versions are incremented based on how the API changes:"
330+ , ""
331+ , " PATCH = the API is the same, no risk of breaking code"
332+ , " MINOR = values have been added, existing values are unchanged"
333+ , " MAJOR = existing values have been changed or removed"
334+ , ""
335+ , " - I will bump versions for you, automatically enforcing these rules"
336+ , ""
337+ ]
338+
339+
340+
341+-- PUBLISH
342+
343+
344+data Publish
345+ = PublishNoOutline
346+ | PublishBadOutline Outline
347+ | PublishBadDetails Details
348+ | PublishMustHaveLatestRegistry RegistryProblem
349+ | PublishApplication
350+ | PublishNotInitialVersion V.Version
351+ | PublishAlreadyPublished V.Version
352+ | PublishInvalidBump V.Version V.Version
353+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude
354+ | PublishNoSummary
355+ | PublishNoExposed
356+ | PublishNoReadme
357+ | PublishShortReadme
358+ | PublishNoLicense
359+ | PublishBuildProblem BuildProblem
360+ | PublishMissingTag V.Version
361+ | PublishCannotGetTag V.Version Http.Error
362+ | PublishCannotGetTagData V.Version String BS.ByteString
363+ | PublishCannotGetZip Http.Error
364+ | PublishCannotDecodeZip String
365+ | PublishCannotGetDocs V.Version V.Version DocsProblem
366+ | PublishCannotRegister Http.Error
367+ | PublishNoGit
368+ | PublishLocalChanges V.Version
369+ --
370+ | PublishZipBadDetails Details
371+ | PublishZipApplication
372+ | PublishZipNoExposed
373+ | PublishZipBuildProblem BuildProblem
374+
375+
376+publishToReport :: Publish -> Help.Report
377+publishToReport publish =
378+ case publish of
379+ PublishNoOutline ->
380+ Help.report "PUBLISH WHAT?" Nothing
381+ "I cannot find an elm.json so I am not sure what you want me to publish."
382+ [ D.reflow $
383+ "Elm packages always have an elm.json that states the version number,\
384+ \ dependencies, exposed modules, etc."
385+ ]
386+
387+ PublishBadOutline outline ->
388+ toOutlineReport outline
389+
390+ PublishBadDetails problem ->
391+ toDetailsReport problem
392+
393+ PublishMustHaveLatestRegistry problem ->
394+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $
395+ "I need the latest list of published packages to make sure this is safe to publish"
396+
397+ PublishApplication ->
398+ Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
399+
400+ PublishNotInitialVersion vsn ->
401+ Help.docReport "INVALID VERSION" Nothing
402+ ( D.fillSep
403+ ["I","cannot","publish"
404+ ,D.red (D.fromVersion vsn)
405+ ,"as","the","initial","version."
406+ ]
407+ )
408+ [ D.fillSep
409+ ["Change","it","to",D.green "1.0.0","which","is"
410+ ,"the","initial","version","for","all","Elm","packages."
411+ ]
412+ ]
413+
414+ PublishAlreadyPublished vsn ->
415+ Help.docReport "ALREADY PUBLISHED" Nothing
416+ ( D.vcat
417+ [ D.fillSep
418+ [ "Version", D.green (D.fromVersion vsn)
419+ , "has", "already", "been", "published.", "You", "cannot"
420+ , "publish", "it", "again!"
421+ ]
422+ , "Try using the `bump` command:"
423+ ]
424+ )
425+ [ D.dullyellow $ D.indent 4 "elm bump"
426+ , D.reflow $
427+ "It computes the version number based on API changes, ensuring\
428+ \ that no breaking changes end up in PATCH releases!"
429+ ]
430+
431+ PublishInvalidBump statedVersion latestVersion ->
432+ Help.docReport "INVALID VERSION" (Just "elm.json")
433+ ( D.fillSep $
434+ ["Your","elm.json","says","the","next","version","should","be"
435+ ,D.red (D.fromVersion statedVersion) <> ","
436+ ,"but","that","is","not","valid","based","on","the","previously"
437+ ,"published","versions."
438+ ]
439+ )
440+ [ D.fillSep $
441+ ["Change","the","version","back","to"
442+ ,D.green (D.fromVersion latestVersion)
443+ ,"which","is","the","most","recently","published","version."
444+ ,"From","there,","have","Elm","bump","the","version","by","running:"
445+ ]
446+ , D.indent 4 $ D.green "elm bump"
447+ , D.reflow $
448+ "If you want more insight on the API changes Elm detects, you\
449+ \ can run `elm diff` at this point as well."
450+ ]
451+
452+ PublishBadBump old new magnitude realNew realMagnitude ->
453+ Help.docReport "INVALID VERSION" (Just "elm.json")
454+ (
455+ D.fillSep $
456+ ["Your","elm.json","says","the","next","version","should","be"
457+ ,D.red (D.fromVersion new) <> ","
458+ ,"indicating","a",D.fromChars (M.toChars magnitude)
459+ ,"change","to","the","public","API."
460+ ,"This","does","not","match","the","API","diff","given","by:"
461+ ]
462+ )
463+ [ D.indent 4 $ D.fromChars $
464+ "elm diff " ++ V.toChars old
465+
466+ , D.fillSep $
467+ ["This","command","says","this","is","a"
468+ ,D.fromChars (M.toChars realMagnitude)
469+ ,"change,","so","the","next","version","should","be"
470+ ,D.green (D.fromVersion realNew) <> "."
471+ ,"Double","check","everything","to","make","sure","you"
472+ ,"are","publishing","what","you","want!"
473+ ]
474+ , D.reflow $
475+ "Also, next time use `elm bump` and I'll figure all this out for you!"
476+ ]
477+
478+ PublishNoSummary ->
479+ Help.docReport "NO SUMMARY" (Just "elm.json")
480+ ( D.fillSep $
481+ [ "To", "publish", "a", "package,", "your", "elm.json", "must"
482+ , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"
483+ , "a", "consice", "overview", "of", "your", "project."
484+ ]
485+ )
486+ [ D.reflow $
487+ "The summary must be less than 80 characters. It should describe\
488+ \ the concrete use of your package as clearly and as plainly as possible."
489+ ]
490+
491+ PublishNoExposed ->
492+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
493+ ( D.fillSep $
494+ [ "To", "publish", "a", "package,", "the"
495+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
496+ , "elm.json", "must", "list", "at", "least", "one", "module."
497+ ]
498+ )
499+ [ D.reflow $
500+ "Which modules do you want users of the package to have access to? Add their\
501+ \ names to the \"exposed-modules\" list."
502+ ]
503+
504+ PublishNoReadme ->
505+ toBadReadmeReport "NO README" $
506+ "Every published package must have a helpful README.md\
507+ \ file, but I do not see one in your project."
508+
509+ PublishShortReadme ->
510+ toBadReadmeReport "SHORT README" $
511+ "This README.md is too short. Having more details will help\
512+ \ people assess your package quickly and fairly."
513+
514+ PublishNoLicense ->
515+ Help.report "NO LICENSE FILE" (Just "LICENSE")
516+ "By publishing a package you are inviting the Elm community to build\
517+ \ upon your work. But without knowing your license, we have no idea if\
518+ \ that is legal!"
519+ [ D.reflow $
520+ "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
521+ \ you must share that choice in two places. First, the license\
522+ \ identifier must appear in your elm.json file. Second, the full\
523+ \ license text must appear in the root of your project in a file\
524+ \ named LICENSE. Add that file and you will be all set!"
525+ ]
526+
527+ PublishBuildProblem buildProblem ->
528+ toBuildProblemReport buildProblem
529+
530+ PublishMissingTag version ->
531+ let vsn = V.toChars version in
532+ Help.docReport "NO TAG" Nothing
533+ ( D.fillSep $
534+ [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
535+ , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."
536+ ]
537+ )
538+ [ D.vcat
539+ [ "These tags make it possible to find this specific version on GitHub."
540+ , "To tag the most recent commit and push it to GitHub, run this:"
541+ ]
542+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
543+ [ "git tag -a " ++ vsn ++ " -m \"new release\""
544+ , "git push origin " ++ vsn
545+ ]
546+ , "The -m flag is for a helpful message. Try to make it more informative!"
547+ ]
548+
549+ PublishCannotGetTag version httpError ->
550+ case httpError of
551+ Http.BadHttp _ (HTTP.StatusCodeException response _)
552+ | HTTP.statusCode (HTTP.responseStatus response) == 404 ->
553+ let vsn = V.toChars version in
554+ Help.report "NO TAG ON GITHUB" Nothing
555+ ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")
556+ [ D.reflow
557+ "Run the following command to make this tag available on GitHub:"
558+ , D.indent 4 $ D.dullyellow $ D.fromChars $
559+ "git push origin " ++ vsn
560+ , D.reflow
561+ "This will make it possible to find your code online based on the version number."
562+ ]
563+
564+ _ ->
565+ toHttpErrorReport "PROBLEM VERIFYING TAG" httpError
566+ "I need to check that the version tag is registered on GitHub"
567+
568+ PublishCannotGetTagData version url body ->
569+ Help.report "PROBLEM VERIFYING TAG" Nothing
570+ ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")
571+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
572+ , D.reflow $
573+ "I got the data back, but it was not what I was expecting. The response\
574+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
575+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
576+ , D.indent 4 $ D.dullyellow $ D.fromChars $
577+ if BS.length body <= 76
578+ then BS_UTF8.toString body
579+ else take 73 (BS_UTF8.toString body) ++ "..."
580+ , D.reflow $
581+ "Does this error keep showing up? Maybe there is something weird with your\
582+ \ internet connection. We have gotten reports that schools, businesses,\
583+ \ airports, etc. sometimes intercept requests and add things to the body\
584+ \ or change its contents entirely. Could that be the problem?"
585+ ]
586+
587+ PublishCannotGetZip httpError ->
588+ toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $
589+ "I need to check that folks can download and build the source code when they\
590+ \ install this package"
591+
592+ PublishCannotDecodeZip url ->
593+ Help.report "PROBLEM DOWNLOADING CODE" Nothing
594+ "I need to check that folks can download and build the source code when they\
595+ \ install this package, so I downloaded the code from:"
596+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
597+ , D.reflow $
598+ "I was unable to unzip the archive though. Maybe there is something weird with\
599+ \ your internet connection. We have gotten reports that schools, businesses,\
600+ \ airports, etc. sometimes intercept requests and add things to the body or\
601+ \ change its contents entirely. Could that be the problem?"
602+ ]
603+
604+ PublishCannotGetDocs old new docsProblem ->
605+ toDocsProblemReport docsProblem $
606+ "I need the docs for " ++ V.toChars old ++ " to verify that "
607+ ++ V.toChars new ++ " really does come next"
608+
609+ PublishCannotRegister httpError ->
610+ toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
611+ "I need to send information about your package to the package website"
612+
613+ PublishNoGit ->
614+ Help.report "NO GIT" Nothing
615+ "I searched your PATH environment variable for `git` and could not\
616+ \ find it. Is it available through your PATH?"
617+ [ D.reflow $
618+ "Who cares about this? Well, I currently use `git` to check if there\
619+ \ are any local changes in your code. Local changes are a good sign\
620+ \ that some important improvements have gotten mistagged, so this\
621+ \ check can be extremely helpful for package authors!"
622+ , D.toSimpleNote $
623+ "We plan to do this without the `git` binary in a future release."
624+ ]
625+
626+ PublishLocalChanges version ->
627+ let vsn = V.toChars version in
628+ Help.docReport "LOCAL CHANGES" Nothing
629+ ( D.fillSep $
630+ [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"
631+ , "git", "does", "not", "match", "the", "code", "in", "your"
632+ , "working", "directory.", "This", "means", "you", "have"
633+ , "commits", "or", "local", "changes", "that", "are", "not"
634+ , "going", "to", "be", "published!"
635+ ]
636+ )
637+ [ D.toSimpleNote $
638+ "If you are sure everything is in order, you can run `git checkout "
639+ ++ vsn ++ "` and publish your code from there."
640+ ]
641+
642+ PublishZipBadDetails _ ->
643+ badZipReport
644+
645+ PublishZipApplication ->
646+ badZipReport
647+
648+ PublishZipNoExposed ->
649+ badZipReport
650+
651+ PublishZipBuildProblem _ ->
652+ badZipReport
653+
654+
655+toBadReadmeReport :: String -> String -> Help.Report
656+toBadReadmeReport title summary =
657+ Help.report title (Just "README.md") summary
658+ [ D.reflow $
659+ "When people look at your README, they are wondering:"
660+ , D.vcat
661+ [ " - What does this package even do?"
662+ , " - Will it help me solve MY problems?"
663+ ]
664+ , D.reflow $
665+ "So I recommend starting your README with a small example of the\
666+ \ most common usage scenario. Show people what they can expect if\
667+ \ they learn more!"
668+ , D.toSimpleNote $
669+ "By publishing your package, you are inviting people to invest time in\
670+ \ understanding your work. Spending an hour on your README to communicate your\
671+ \ knowledge more clearly can save the community days or weeks of time in\
672+ \ aggregate, and saving time in aggregate is the whole point of publishing\
673+ \ packages! People really appreciate it, and it makes the whole ecosystem feel\
674+ \ nicer!"
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+ ]
688+
689+
690+
691+-- DOCS
692+
693+
694+data DocsProblem
695+ = DP_Http Http.Error
696+ | DP_Data String BS.ByteString
697+ | DP_Cache
698+
699+
700+toDocsProblemReport :: DocsProblem -> String -> Help.Report
701+toDocsProblemReport problem context =
702+ case problem of
703+ DP_Http httpError ->
704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705+
706+ DP_Data url body ->
707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
709+ , D.reflow $
710+ "I got the data back, but it was not what I was expecting. The response\
711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713+ , D.indent 4 $ D.dullyellow $ D.fromChars $
714+ if BS.length body <= 76
715+ then BS_UTF8.toString body
716+ else take 73 (BS_UTF8.toString body) ++ "..."
717+ , D.reflow $
718+ "Does this error keep showing up? Maybe there is something weird with your\
719+ \ internet connection. We have gotten reports that schools, businesses,\
720+ \ airports, etc. sometimes intercept requests and add things to the body\
721+ \ or change its contents entirely. Could that be the problem?"
722+ ]
723+
724+ DP_Cache ->
725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726+ [ D.reflow $
727+ "I deleted the cached version, so the next run should download a fresh copy of\
728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730+ \ for some reason."
731+ ]
51
732
52−toString :: Exit -> String
53−toString exit =
54− Help.toString (Help.reportToDoc (toReport exit))
55
733
56
734
57−toStderr :: Exit -> IO ()
735+-- INSTALL
58−toStderr exit =
59− Help.toStderr (Help.reportToDoc (toReport exit))
60
736
61
737
62−toJson :: Exit -> Encode.Value
738+data Install
63−toJson exit =
739+ = InstallNoOutline
64− Help.reportToJson (toReport exit)
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
65
751
66
752
67−toReport :: Exit -> Help.Report
753+installToReport :: Install -> Help.Report
68−toReport exit =
754+installToReport exit =
69 case exit of
755 case exit of
70− NoElmJson ->
756+ InstallNoOutline ->
757+ Help.report "NEW PROJECT?" Nothing
758+ "Are you trying to start a new project? Try this command instead:"
759+ [ D.indent 4 $ D.green "elm init"
760+ , D.reflow "It will help you get started!"
761+ ]
762+
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
765+
766+ InstallBadRegistry problem ->
767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768+ "I need the list of published packages to figure out how to install things"
769+
770+ InstallNoArgs elmHome ->
771+ Help.report "INSTALL WHAT?" Nothing
772+ "I am expecting commands like:"
773+ [ D.green $ D.indent 4 $ D.vcat $
774+ [ "elm install elm/http"
775+ , "elm install elm/json"
776+ , "elm install elm/random"
777+ ]
778+ , D.toFancyHint
779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
782+ ,D.dullyellow (D.fromChars elmHome)
783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786+ ,"easier","to","work","offline.","As","a","result"
787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790+ ]
791+ ]
792+
793+ InstallNoOnlineAppSolution pkg ->
794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795+ (
796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797+ \ with your existing dependencies."
798+ )
799+ [ D.reflow $
800+ "I checked all the published versions. When that failed, I tried to find any\
801+ \ compatible combination of these packages, even if it meant changing all your\
802+ \ existing dependencies! That did not work either!"
803+ , D.reflow $
804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805+ \ version of Elm came out recently? Maybe a common package was changed recently?\
806+ \ Maybe a better package came along, so there was no need to upgrade this one?\
807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\
808+ \ with this package."
809+ , D.toSimpleNote $
810+ "Whatever the case, please be kind to the relevant package authors! Having\
811+ \ friendly interactions with users is great motivation, and conversely, getting\
812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814+ \ goals, etc. They face obstacles outside of their technical work you will never\
815+ \ know about, so please assume the best and try to be patient and supportive!"
816+ ]
817+
818+ InstallNoOfflineAppSolution pkg ->
819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820+ (
821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822+ \ with your existing dependencies."
823+ )
824+ [ D.reflow $
825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826+ \ able to look through packages that you have downloaded in the past."
827+ , D.reflow $
828+ "Try again later when you have internet!"
829+ ]
830+
831+ InstallNoOnlinePkgSolution pkg ->
832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833+ (
834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835+ \ with your existing constraints."
836+ )
837+ [ D.reflow $
838+ "With applications, I try to broaden the constraints to see if anything works,\
839+ \ but messing with package constraints is much more delicate business. E.g. making\
840+ \ your constraints stricter may make it harder for applications to find compatible\
841+ \ dependencies. So fixing something here may break it for a lot of other people!"
842+ , D.reflow $
843+ "So I recommend making an application with the same dependencies as your package.\
844+ \ See if there is a solution at all. From there it may be easier to figure out\
845+ \ how to proceed in a way that will disrupt your users as little as possible. And\
846+ \ the solution may be to help other package authors to get their packages updated,\
847+ \ or to drop a dependency entirely."
848+ ]
849+
850+ InstallNoOfflinePkgSolution pkg ->
851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852+ (
853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854+ \ with your existing constraints."
855+ )
856+ [ D.reflow $
857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858+ \ able to look through packages that you have downloaded in the past."
859+ , D.reflow $
860+ "Try again later when you have internet!"
861+ ]
862+
863+ InstallHadSolverTrouble solver ->
864+ toSolverReport solver
865+
866+ InstallUnknownPackageOnline pkg suggestions ->
867+ Help.docReport "UNKNOWN PACKAGE" Nothing
868+ (
869+ D.fillSep
870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871+ )
872+ [ D.reflow $
873+ "I looked through https://package.elm-lang.org for packages with similar names\
874+ \ and found these:"
875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876+ , D.reflow $ "Maybe you want one of these instead?"
877+ ]
878+
879+ InstallUnknownPackageOffline pkg suggestions ->
880+ Help.docReport "UNKNOWN PACKAGE" Nothing
881+ (
882+ D.fillSep
883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884+ )
885+ [ D.reflow $
886+ "I could not connect to https://package.elm-lang.org though, so new packages may\
887+ \ have been published since I last updated my local cache of package names."
888+ , D.reflow $
889+ "Looking through the locally cached names, the closest ones are:"
890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891+ , D.reflow $ "Maybe you want one of these instead?"
892+ ]
893+
894+ InstallBadDetails details ->
895+ toDetailsReport details
896+
897+
898+
899+-- SOLVER
900+
901+
902+data Solver
903+ = SolverBadCacheData Pkg.Name V.Version
904+ | SolverBadHttpData Pkg.Name V.Version String
905+ | SolverBadHttp Pkg.Name V.Version Http.Error
906+
907+
908+toSolverReport :: Solver -> Help.Report
909+toSolverReport problem =
910+ case problem of
911+ SolverBadCacheData pkg vsn ->
912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913+ (
914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915+ \ help me search for a set of compatible packages. I had it cached locally, but\
916+ \ it looks like the file was corrupted!"
917+ )
918+ [ D.reflow $
919+ "I deleted the cached version, so the next run should download a fresh copy.\
920+ \ Hopefully that will get you unstuck, but it will not resolve the root\
921+ \ problem if a 3rd party tool is modifing cached files for some reason."
922+ ]
923+
924+ SolverBadHttpData pkg vsn url ->
925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926+ (
927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928+ \ help me search for a set of compatible packages, but I ran into corrupted\
929+ \ information from:"
930+ )
931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
932+ , D.reflow $
933+ "Is something weird with your internet connection. We have gotten reports that\
934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935+ \ to the body or change its contents entirely. Could that be the problem?"
936+ ]
937+
938+ SolverBadHttp pkg vsn httpError ->
939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941+ ++ " to help me search for a set of compatible packages"
942+
943+
944+
945+-- OUTLINE
946+
947+
948+data Outline
949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)
950+ | OutlineHasMissingSrcDirs FilePath [FilePath]
951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952+ | OutlineNoPkgCore
953+ | OutlineNoAppCore
954+ | OutlineNoAppJson
955+
956+
957+data OutlineProblem
958+ = OP_BadType
959+ | OP_BadPkgName Row Col
960+ | OP_BadVersion Row Col
961+ | OP_BadConstraint C.Error
962+ | OP_BadModuleName Row Col
963+ | OP_BadModuleHeaderTooLong
964+ | OP_BadDependencyName Row Col
965+ | OP_BadLicense Json.String [Json.String]
966+ | OP_BadSummaryTooLong
967+ | OP_NoSrcDirs
968+
969+
970+toOutlineReport :: Outline -> Help.Report
971+toOutlineReport problem =
972+ case problem of
973+ OutlineHasBadStructure decodeError ->
974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975+ Json.ExplicitReason "I ran into a problem with your elm.json file."
976+
977+ OutlineHasMissingSrcDirs dir dirs ->
978+ case dirs of
979+ [] ->
980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982+ [ D.indent 4 $ D.red $ D.fromChars dir
983+ , D.reflow $
984+ "I cannot find it though. Is it missing? Is there a typo?"
985+ ]
986+
987+ _:_ ->
988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990+ [ D.indent 4 $ D.vcat $
991+ map (D.red . D.fromChars) (dir:dirs)
992+ , D.reflow $
993+ "I cannot find them though. Are they missing? Are there typos?"
994+ ]
995+
996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997+ if dir1 == dir2 then
998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000+ [ D.indent 4 $ D.vcat $
1001+ map (D.red . D.fromChars) [dir1,dir2]
1002+ , D.reflow $
1003+ "Remove one of the entries!"
1004+ ]
1005+ else
1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008+ [ D.indent 4 $ D.vcat $
1009+ map (D.red . D.fromChars) [dir1,dir2]
1010+ , D.reflow $
1011+ "These are two different ways of refering to the same directory:"
1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013+ , D.reflow $
1014+ "Remove one of the redundant entries from your \"source-directories\" field."
1015+ ]
1016+
1017+ OutlineNoPkgCore ->
1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020+ \ of `List` and `Maybe` do not work without it."
1021+ [ D.reflow $
1022+ "If you modified your elm.json by hand, try to change it back! And if you are\
1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\
1024+ \ working package and start fresh with their elm.json file."
1025+ ]
1026+
1027+ OutlineNoAppCore ->
1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030+ \ of `List` and `Maybe` do not work without it."
1031+ [ D.reflow $
1032+ "If you modified your elm.json by hand, try to change it back! And if you are\
1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034+ \ and use `elm init` to start fresh."
1035+ ]
1036+
1037+ OutlineNoAppJson ->
1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040+ \ flags and ports."
1041+ [ D.reflow $
1042+ "If you modified your elm.json by hand, try to change it back! And if you are\
1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044+ \ and use `elm init` to start fresh."
1045+ ]
1046+
1047+
1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049+toOutlineProblemReport path source _ region problem =
1050+ let
1051+ toHighlight row col =
1052+ Just $ A.Region (A.Position row col) (A.Position row col)
1053+
1054+ toSnippet title highlight pair =
1055+ Help.jsonReport title (Just path) $
1056+ Code.toSnippet source region highlight pair
1057+ in
1058+ case problem of
1059+ OP_BadType ->
1060+ toSnippet "UNEXPECTED TYPE" Nothing
1061+ ( D.reflow $
1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063+ , D.fillSep
1064+ ["Try","changing","the","\"type\"","to"
1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066+ ]
1067+ )
1068+
1069+ OP_BadPkgName row col ->
1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071+ ( D.reflow $
1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073+ , D.stack
1074+ [ D.fillSep
1075+ ["Package","names","are","always","written","as"
1076+ ,D.green "\"author/project\""
1077+ ,"so","I","am","expecting","to","see","something","like:"
1078+ ]
1079+ , D.dullyellow $ D.indent 4 $ D.vcat $
1080+ [ "\"mdgriffith/elm-ui\""
1081+ , "\"w0rm/elm-physics\""
1082+ , "\"Microsoft/elm-json-tree-view\""
1083+ , "\"FordLabs/elm-star-rating\""
1084+ , "\"1602/json-schema\""
1085+ ]
1086+ , D.reflow
1087+ "The author name should match your GitHub name exactly, and the project name\
1088+ \ needs to follow these rules:"
1089+ , D.indent 4 $ D.vcat $
1090+ [ "+--------------------------------------+-----------+-----------+"
1091+ , "| RULE | BAD | GOOD |"
1092+ , "+--------------------------------------+-----------+-----------+"
1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094+ , "| no leading digits | 3D | elm-3d |"
1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096+ , "| no underscores | elm_ui | elm-ui |"
1097+ , "| no double hyphens | elm--hash | elm-hash |"
1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099+ , "+--------------------------------------+-----------+-----------+"
1100+ ]
1101+ , D.toSimpleNote $
1102+ "These rules only apply to the project name, so you should never need\
1103+ \ to change your GitHub name!"
1104+ ]
1105+ )
1106+
1107+ OP_BadVersion row col ->
1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109+ ( D.reflow $
1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111+ , D.fillSep
1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113+ ,"that","explicitly","states","all","three","numbers!"
1114+ ]
1115+ )
1116+
1117+ OP_BadConstraint constraintError ->
1118+ case constraintError of
1119+ C.BadFormat row col ->
1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121+ ( D.reflow $
1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123+ , D.stack
1124+ [ D.fillSep
1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127+ ]
1128+ , D.toSimpleNote $
1129+ "The spaces in there are required! Taking them out will confuse me. Adding\
1130+ \ extra spaces confuses me too. I recommend starting with a valid example\
1131+ \ and just changing the version numbers."
1132+ ]
1133+ )
1134+
1135+ C.InvalidRange before after ->
1136+ if before == after then
1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138+ ( D.reflow $
1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140+ , D.fillSep
1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145+ ,"happen","in","any","of","the","versions","in","that","range."
1146+ ]
1147+ )
1148+
1149+ else
1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151+ ( D.reflow $
1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153+ , D.fillSep
1154+ ["Maybe","you","want","something","like"
1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159+ ]
1160+ )
1161+
1162+ OP_BadModuleName row col ->
1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164+ ( D.reflow $
1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166+ , D.fillSep
1167+ ["I","need","something","like",D.green "\"Html.Events\""
1168+ ,"or",D.green "\"Browser.Navigation\""
1169+ ,"where","each","segment","starts","with","a","capital"
1170+ ,"letter","and","the","segments","are","separated","by","dots."
1171+ ]
1172+ )
1173+
1174+ OP_BadModuleHeaderTooLong ->
1175+ toSnippet "HEADER TOO LONG" Nothing
1176+ ( D.reflow $
1177+ "I got stuck while reading your elm.json file. This section header is too long:"
1178+ , D.stack
1179+ [ D.fillSep
1180+ ["I","need","it","to","be"
1181+ ,D.green "under",D.green "20",D.green "bytes"
1182+ ,"so","it","renders","nicely","on","the","package","website!"
1183+ ]
1184+ , D.toSimpleNote
1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187+ \ overly restrictive for your needs."
1188+ ]
1189+ )
1190+
1191+ OP_BadDependencyName row col ->
1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193+ ( D.reflow $
1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195+ , D.stack
1196+ [ D.fillSep
1197+ ["Package","names","always","include","the","name","of","the","author,"
1198+ ,"so","I","am","expecting","to","see","dependencies","like"
1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201+ ]
1202+ , D.fillSep $
1203+ ["I","generally","recommend","finding","the","package","you","want","on"
1204+ ,"the","package","website,","and","installing","it","with","the"
1205+ ,D.green "elm install","command!"
1206+ ]
1207+ ]
1208+ )
1209+
1210+ OP_BadLicense _ suggestions ->
1211+ toSnippet "UNKNOWN LICENSE" Nothing
1212+ ( D.reflow $
1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214+ ,
1215+ D.stack
1216+ [ D.fillSep
1217+ ["Elm","packages","generally","use"
1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."
1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"
1221+ ]
1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223+ , D.reflow $
1224+ "Check out https://spdx.org/licenses/ for the full list of options."
1225+ ]
1226+ )
1227+
1228+ OP_BadSummaryTooLong ->
1229+ toSnippet "SUMMARY TOO LONG" Nothing
1230+ ( D.reflow $
1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232+ , D.stack
1233+ [ D.fillSep
1234+ ["I","need","it","to","be"
1235+ ,D.green "under",D.green "80",D.green "bytes"
1236+ ,"so","it","renders","nicely","on","the","package","website!"
1237+ ]
1238+ , D.toSimpleNote
1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241+ \ overly restrictive for your needs."
1242+ ]
1243+ )
1244+
1245+ OP_NoSrcDirs ->
1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing
1247+ ( D.reflow $
1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249+ , D.fillSep
1250+ ["I","need","something","like",D.green "[\"src\"]"
1251+ ,"so","I","know","where","to","look","for","your","modules!"
1252+ ]
1253+ )
1254+
1255+
1256+
1257+-- DETAILS
1258+
1259+
1260+data Details
1261+ = DetailsNoSolution
1262+ | DetailsNoOfflineSolution
1263+ | DetailsSolverProblem Solver
1264+ | DetailsBadElmInPkg C.Constraint
1265+ | DetailsBadElmInAppOutline V.Version
1266+ | DetailsHandEditedDependencies
1267+ | DetailsBadOutline Outline
1268+ | DetailsCannotGetRegistry RegistryProblem
1269+ | DetailsBadDeps FilePath [DetailsBadDep]
1270+
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
1280+ DetailsNoSolution ->
1281+ Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")
1282+ "The dependencies in your elm.json are not compatible."
1283+ [ D.fillSep
1284+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
1285+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1286+ ]
1287+ , D.reflow $
1288+ "Please ask for help on the community forums if you try those paths and are still\
1289+ \ having problems!"
1290+ ]
1291+
1292+ DetailsNoOfflineSolution ->
1293+ Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json")
1294+ "I could not connect to https://package.elm-lang.org to get the latest list of\
1295+ \ packages, and I was unable to verify your dependencies with the information I\
1296+ \ have cached locally."
1297+ [ D.reflow $
1298+ "Are you able to connect to the internet? These dependencies may work once you\
1299+ \ get access to the registry!"
1300+ , D.toFancyNote
1301+ ["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!"
1302+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1303+ ]
1304+ ]
1305+
1306+ DetailsSolverProblem solver ->
1307+ toSolverReport solver
1308+
1309+ DetailsBadElmInPkg constraint ->
1310+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1311+ "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
1313+ , D.fillSep
1314+ [ "But", "you", "are", "using", "Elm"
1315+ , D.red (D.fromVersion V.compiler)
1316+ , "right", "now."
1317+ ]
1318+ ]
1319+
1320+ DetailsBadElmInAppOutline version ->
1321+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
1322+ "Your elm.json says this application needs a different version of Elm."
1323+ [ D.fillSep
1324+ [ "It", "requires"
1325+ , D.green (D.fromVersion version) <> ","
1326+ , "but", "you", "are", "using"
1327+ , D.red (D.fromVersion V.compiler)
1328+ , "right", "now."
1329+ ]
1330+ ]
1331+
1332+ DetailsHandEditedDependencies ->
1333+ Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")
1334+ "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\
1335+ \ party tool) leaving them in an invalid state."
1336+ [ D.fillSep
1337+ ["Try","to","change","them","back","to","what","they","were","before!"
1338+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."
1339+ ]
1340+ , D.reflow $
1341+ "Please ask for help on the community forums if you try those paths and are still\
1342+ \ having problems!"
1343+ ]
1344+
1345+ DetailsBadOutline outline ->
1346+ toOutlineReport outline
1347+
1348+ DetailsCannotGetRegistry problem ->
1349+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
1350+ "I need the list of published packages to verify your dependencies"
1351+
1352+ DetailsBadDeps cacheDir deps ->
1353+ case List.sortOn toBadDepRank deps of
1354+ [] ->
1355+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing
1356+ "I am not sure what is going wrong though."
1357+ [ D.reflow $
1358+ "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\
1359+ \ trying to build again. That will work if some cached files got corrupted\
1360+ \ somehow."
1361+ , D.reflow $
1362+ "If that does not work, go to https://elm-lang.org/community and ask for\
1363+ \ help. This is a weird case!"
1364+ ]
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+
1439+ PP_BadArchiveContent url ->
1440+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing
1441+ (
1442+ "I downloaded the source code for " ++ thePackage ++ " from:"
1443+ )
1444+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1445+ , D.reflow $
1446+ "But I was unable to unzip the data. Maybe there is something weird with\
1447+ \ your internet connection. We have gotten reports that schools, businesses,\
1448+ \ airports, etc. sometimes intercept requests and add things to the body or\
1449+ \ change its contents entirely. Could that be the problem?"
1450+ ]
1451+
1452+ PP_BadArchiveHash url expectedHash actualHash ->
1453+ Help.report "CORRUPT PACKAGE DATA" Nothing
1454+ (
1455+ "I downloaded the source code for " ++ thePackage ++ " from:"
1456+ )
1457+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1458+ , D.reflow "But it looks like the hash of the archive has changed since publication:"
1459+ , D.vcat $ map D.fromChars $
1460+ [ " Expected: " ++ expectedHash
1461+ , " Actual: " ++ actualHash
1462+ ]
1463+ , D.reflow $
1464+ "This usually means that the package author moved the version\
1465+ \ tag, so report it to them and see if that is the issue. Folks\
1466+ \ on Elm slack can probably help as well."
1467+ ]
1468+
1469+
1470+
1471+-- REGISTRY PROBLEM
1472+
1473+
1474+data RegistryProblem
1475+ = RP_Http Http.Error
1476+ | RP_Data String BS.ByteString
1477+
1478+
1479+toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report
1480+toRegistryProblemReport title problem context =
1481+ case problem of
1482+ RP_Http err ->
1483+ toHttpErrorReport title err context
1484+
1485+ RP_Data url body ->
1486+ Help.report title Nothing (context ++ ", so I fetched:")
1487+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
1488+ , D.reflow $
1489+ "I got the data back, but it was not what I was expecting. The response\
1490+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
1491+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
1492+ , D.indent 4 $ D.dullyellow $ D.fromChars $
1493+ if BS.length body <= 76
1494+ then BS_UTF8.toString body
1495+ else take 73 (BS_UTF8.toString body) ++ "..."
1496+ , D.reflow $
1497+ "Does this error keep showing up? Maybe there is something weird with your\
1498+ \ internet connection. We have gotten reports that schools, businesses,\
1499+ \ airports, etc. sometimes intercept requests and add things to the body\
1500+ \ or change its contents entirely. Could that be the problem?"
1501+ ]
1502+
1503+
1504+toHttpErrorReport :: String -> Http.Error -> String -> Help.Report
1505+toHttpErrorReport title err context =
1506+ let
1507+ toHttpReport intro url details =
1508+ Help.report title Nothing intro $
1509+ D.indent 4 (D.dullyellow (D.fromChars url)) : details
1510+ in
1511+ case err of
1512+ Http.BadUrl url reason ->
1513+ toHttpReport (context ++ ", so I wanted to fetch:") url
1514+ [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"
1515+ , D.indent 4 $ D.fromChars reason
1516+ , D.reflow $
1517+ "This may indicate that there is some problem in the compiler, so please open an\
1518+ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\
1519+ \ version, the command you ran, the terminal output, and any additional information\
1520+ \ that might help others reproduce the error."
1521+ ]
1522+
1523+ Http.BadHttp url httpExceptionContent ->
1524+ case httpExceptionContent of
1525+ HTTP.StatusCodeException response body ->
1526+ let
1527+ (HTTP.Status code message) = HTTP.responseStatus response
1528+ in
1529+ toHttpReport (context ++ ", so I tried to fetch:") url
1530+ [ D.fillSep $
1531+ ["But","it","came","back","as",D.red (D.fromInt code)]
1532+ ++ map D.fromChars (words (BS_UTF8.toString message))
1533+ , D.indent 4 $ D.reflow $ BS_UTF8.toString body
1534+ , D.reflow $
1535+ "This may mean some online endpoint changed in an unexpected way, so if does not\
1536+ \ seem like something on your side is causing this (e.g. firewall) please report\
1537+ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\
1538+ \ version, the command you ran, the terminal output, and any additional information\
1539+ \ that can help others reproduce the error!"
1540+ ]
1541+
1542+ HTTP.TooManyRedirects responses ->
1543+ toHttpReport (context ++ ", so I tried to fetch:") url
1544+ [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"
1545+ , D.indent 4 $ D.vcat $ map toRedirectDoc responses
1546+ , D.reflow $
1547+ "Is it possible that your internet connection intercepts certain requests? That\
1548+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1549+ \ and certain countries. Try asking for help locally or in a community forum!"
1550+ ]
1551+
1552+ otherException ->
1553+ toHttpReport (context ++ ", so I tried to fetch:") url
1554+ [ D.reflow $ "But my HTTP library is giving me the following error message:"
1555+ , D.indent 4 $ D.fromChars (show otherException)
1556+ , D.reflow $
1557+ "Are you somewhere with a slow internet connection? Or no internet?\
1558+ \ Does the link I am trying to fetch work in your browser? Maybe the\
1559+ \ site is down? Does your internet connection have a firewall that\
1560+ \ blocks certain domains? It is usually something like that!"
1561+ ]
1562+
1563+ Http.BadMystery url someException ->
1564+ toHttpReport (context ++ ", so I tried to fetch:") url
1565+ [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"
1566+ , D.indent 4 $ D.fromChars (show someException)
1567+ , D.reflow $
1568+ "Is it possible that your internet connection intercepts certain requests? That\
1569+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\
1570+ \ and certain countries. Try asking for help locally or in a community forum!"
1571+ ]
1572+
1573+
1574+toRedirectDoc :: HTTP.Response body -> D.Doc
1575+toRedirectDoc response =
1576+ let
1577+ (HTTP.Status code message) = HTTP.responseStatus response
1578+ in
1579+ case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of
1580+ Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)
1581+ Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)
1582+
1583+
1584+
1585+-- MAKE
1586+
1587+
1588+data Make
1589+ = MakeNoOutline
1590+ | MakeCannotOptimizeAndDebug
1591+ | MakeBadDetails Details
1592+ | MakeAppNeedsFileNames
1593+ | MakePkgNeedsExposing
1594+ | MakeMultipleFilesIntoHtml
1595+ | MakeNoMain
1596+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
1597+ | MakeCannotBuild BuildProblem
1598+ | MakeBadGenerate Generate
1599+
1600+
1601+makeToReport :: Make -> Help.Report
1602+makeToReport make =
1603+ case make of
1604+ MakeNoOutline ->
71 Help.report "NO elm.json FILE" Nothing
1605 Help.report "NO elm.json FILE" Nothing
72 "It looks like you are starting a new Elm project. Very exciting! Try running:"
1606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
73 [ D.indent 4 $ D.green $ "elm init"
1607 [ D.indent 4 $ D.green $ "elm init"
@@ -75,44 +1609,461 @@ toReport exit =
75 "It will help you get set up. It is really simple!"
1609 "It will help you get set up. It is really simple!"
76 ]
1610 ]
77
1611
78− Assets assetExit ->
1612+ MakeCannotOptimizeAndDebug ->
79− Asset.toReport assetExit
1613+ Help.docReport "CLASHING FLAGS" Nothing
1614+ ( D.fillSep
1615+ ["I","cannot","compile","with",D.red "--optimize","and"
1616+ ,D.red "--debug","at","the","same","time."
1617+ ]
1618+ )
1619+ [ D.reflow
1620+ "I need to take away information to optimize things, and I need to\
1621+ \ add information to add the debugger. It is impossible to do both\
1622+ \ at once though! Pick just one of those flags and it should work!"
1623+ ]
1624+
1625+ MakeBadDetails detailsProblem ->
1626+ toDetailsReport detailsProblem
1627+
1628+ MakeAppNeedsFileNames ->
1629+ Help.report "NO INPUT" Nothing
1630+ "What should I make though? I need specific files like:"
1631+ [ D.vcat
1632+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1633+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1634+ ]
1635+ , D.reflow $
1636+ "I recommend reading through https://guide.elm-lang.org for guidance on what to\
1637+ \ actually put in those files!"
1638+ ]
1639+
1640+ MakePkgNeedsExposing ->
1641+ Help.report "NO INPUT" Nothing
1642+ "What should I make though? I need specific files like:"
1643+ [ D.vcat
1644+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1645+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646+ ]
1647+ , D.reflow $
1648+ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649+ \ I will try to compile the relevant files."
1650+ ]
1651+
1652+ MakeMultipleFilesIntoHtml ->
1653+ Help.report "TOO MANY FILES" Nothing
1654+ (
1655+ "When producing an HTML file, I can only handle one file."
1656+ )
1657+ [ D.fillSep
1658+ ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"
1659+ ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"
1660+ ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."
1661+ ]
1662+ , D.fillSep
1663+ ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"
1664+ ,"`main`","values","available","in","a","single","JavaScript","file.","Then"
1665+ ,"you","can","make","your","own","customized","HTML","file","that","embeds"
1666+ ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"
1667+ ,"dependencies","between","modules,","so","it","should","be","smaller","than"
1668+ ,"compiling","each","module","separately."
1669+ ]
1670+ ]
1671+
1672+ MakeNoMain ->
1673+ Help.report "NO MAIN" Nothing
1674+ (
1675+ "When producing an HTML file, I require that the given file has a `main` value.\
1676+ \ That way I have something to show on screen!"
1677+ )
1678+ [ D.reflow $
1679+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1680+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1681+ \ altogether."
1682+ , D.toSimpleNote $
1683+ "Adding a `main` value can be as brief as adding something like this:"
1684+ , D.vcat
1685+ [ D.fillSep [D.cyan "import","Html"]
1686+ , ""
1687+ , D.fillSep [D.green "main","="]
1688+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1689+ ]
1690+ , D.reflow $
1691+ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\
1692+ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\
1693+ \ the `main` value."
1694+ ]
1695+
1696+ MakeNonMainFilesIntoJavaScript m ms ->
1697+ case ms of
1698+ [] ->
1699+ Help.report "NO MAIN" Nothing
1700+ (
1701+ "When producing a JS file, I require that the given file has a `main` value. That\
1702+ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\
1703+ \ resulting file!"
1704+ )
1705+ [ D.reflow $
1706+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1707+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1708+ \ altogether."
1709+ , D.toSimpleNote $
1710+ "Adding a `main` value can be as brief as adding something like this:"
1711+ , D.vcat
1712+ [ D.fillSep [D.cyan "import","Html"]
1713+ , ""
1714+ , D.fillSep [D.green "main","="]
1715+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1716+ ]
1717+ , D.reflow $
1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1719+ \ make a `main` with no user interface."
1720+ ]
1721+
1722+ _:_ ->
1723+ Help.report "NO MAIN" Nothing
1724+ (
1725+ "When producing a JS file, I require that given files all have `main` values.\
1726+ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\
1727+ \ definitely defined in the resulting file. I am missing `main` values in:"
1728+ )
1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)
1730+ , D.reflow $
1731+ "Try adding a `main` value to them? Or if you just want to verify that these\
1732+ \ modules compile, switch to --output=/dev/null to skip the code gen phase\
1733+ \ altogether."
1734+ , D.toSimpleNote $
1735+ "Adding a `main` value can be as brief as adding something like this:"
1736+ , D.vcat
1737+ [ D.fillSep [D.cyan "import","Html"]
1738+ , ""
1739+ , D.fillSep [D.green "main","="]
1740+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1741+ ]
1742+ , D.reflow $
1743+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1744+ \ make a `main` with no user interface."
1745+ ]
1746+
1747+ MakeCannotBuild buildProblem ->
1748+ toBuildProblemReport buildProblem
1749+
1750+ MakeBadGenerate generateProblem ->
1751+ toGenerateReport generateProblem
1752+
1753+
1754+
1755+-- BUILD PROBLEM
1756+
1757+
1758+data BuildProblem
1759+ = BuildBadModules FilePath Error.Module [Error.Module]
1760+ | BuildProjectProblem BuildProjectProblem
1761+
1762+
1763+data BuildProjectProblem
1764+ = BP_PathUnknown FilePath
1765+ | BP_WithBadExtension FilePath
1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath
1767+ | BP_MainPathDuplicate FilePath FilePath
1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath
1769+ | BP_RootNameInvalid FilePath FilePath [String]
1770+ | BP_CannotLoadDependencies
1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1773+
1774+
1775+toBuildProblemReport :: BuildProblem -> Help.Report
1776+toBuildProblemReport problem =
1777+ case problem of
1778+ BuildBadModules root e es ->
1779+ Help.compilerReport root e es
1780+
1781+ BuildProjectProblem projectProblem ->
1782+ toProjectProblemReport projectProblem
1783+
1784+
1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report
1786+toProjectProblemReport projectProblem =
1787+ case projectProblem of
1788+ BP_PathUnknown path ->
1789+ Help.report "FILE NOT FOUND" Nothing
1790+ "I cannot find this file:"
1791+ [ D.indent 4 $ D.red $ D.fromChars path
1792+ , D.reflow $ "Is there a typo?"
1793+ , D.toSimpleNote $
1794+ "If you are just getting started, try working through the examples in the\
1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\
1796+ \ that typically go in a src/Main.elm file."
1797+ ]
1798+
1799+ BP_WithBadExtension path ->
1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing
1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"
1802+ [ D.indent 4 $ D.red $ D.fromChars path
1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"
1804+ ]
1805+
1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->
1807+ Help.report "CONFUSING FILE" Nothing
1808+ "I am getting confused when I try to compile this file:"
1809+ [ D.indent 4 $ D.red $ D.fromChars path
1810+ , D.reflow $
1811+ "I always check if files appear in any of the \"source-directories\" listed in\
1812+ \ your elm.json to see if there might be some cached information about them. That\
1813+ \ can help me compile faster! But in this case, it looks like this file may be in\
1814+ \ either of these directories:"
1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]
1816+ , D.reflow $
1817+ "Try to make it so no source directory contains another source directory!"
1818+ ]
80
1819
81− Bump bumpExit ->
1820+ BP_MainPathDuplicate path1 path2 ->
82− Bump.toReport bumpExit
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+ ]
83
1846
84− Compile e es ->
1847+ BP_RootNameInvalid givenPath srcDir _ ->
85− Help.compilerReport e es
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+ ]
86
1864
87− Crawl crawlExit ->
1865+ BP_CannotLoadDependencies ->
88− Crawl.toReport crawlExit
1866+ corruptCacheReport
89
1867
90− Cycle names ->
1868+ BP_Cycle name names ->
91 Help.report "IMPORT CYCLE" Nothing
1869 Help.report "IMPORT CYCLE" Nothing
92 "Your module imports form a cycle:"
1870 "Your module imports form a cycle:"
93− [ D.cycle 4 names
1871+ [ D.cycle 4 name names
94 , D.reflow $
1872 , D.reflow $
95 "Learn more about why this is disallowed and how to break cycles here:"
1873 "Learn more about why this is disallowed and how to break cycles here:"
96 ++ D.makeLink "import-cycles"
1874 ++ D.makeLink "import-cycles"
97 ]
1875 ]
98
1876
99− Deps depsExit ->
1877+ BP_MissingExposed (NE.List (name, problem) _) ->
100− Deps.toReport depsExit
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
1964+ "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)
1966+ , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"
1967+ , D.toSimpleNote $
1968+ "The issue is that --optimize strips out info needed by `Debug` functions.\
1969+ \ Here are two examples:"
1970+ , D.indent 4 $ D.reflow $
1971+ "(1) It shortens record field names. This makes the generated JavaScript\
1972+ \ smaller, but `Debug.toString` cannot know the real field names anymore."
1973+ , D.indent 4 $ D.reflow $
1974+ "(2) Values like `type Height = Height Float` are unboxed. This reduces\
1975+ \ allocation, but it also means that `Debug.toString` cannot tell if it is\
1976+ \ looking at a `Height` or `Float` value."
1977+ , D.reflow $
1978+ "There are a few other cases like that, and it will be much worse once we start\
1979+ \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\
1980+ \ resulting in unpredictable behavior. I hope that clarifies why this restriction\
1981+ \ exists!"
1982+ ]
1983+
1984+
1985+
1986+-- CORRUPT CACHE
1987+
1988+
1989+corruptCacheReport :: Help.Report
1990+corruptCacheReport =
1991+ Help.report "CORRUPT CACHE" Nothing
1992+ "It looks like some of the information cached in elm-stuff/ has been corrupted."
1993+ [ D.reflow $
1994+ "Try deleting your elm-stuff/ directory to get unstuck."
1995+ , D.toSimpleNote $
1996+ "This almost certainly means that a 3rd party tool (or editor plugin) is\
1997+ \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\
1998+ \ one by one until you figure out which it is!"
1999+ ]
2000+
2001+
2002+
2003+-- REACTOR
2004+
2005+
2006+data Reactor
2007+ = ReactorNoOutline
2008+ | ReactorBadDetails Details
2009+ | ReactorBadBuild BuildProblem
2010+ | ReactorBadGenerate Generate
2011+
2012+
2013+reactorToReport :: Reactor -> Help.Report
2014+reactorToReport problem =
2015+ case problem of
2016+ ReactorNoOutline ->
2017+ Help.report "NEW PROJECT?" Nothing
2018+ "Are you trying to start a new project? Try this command in the terminal:"
2019+ [ D.indent 4 $ D.green "elm init"
2020+ , D.reflow "It will help you get started!"
2021+ ]
2022+
2023+ ReactorBadDetails details ->
2024+ toDetailsReport details
2025+
2026+ ReactorBadBuild buildProblem ->
2027+ toBuildProblemReport buildProblem
2028+
2029+ ReactorBadGenerate generate ->
2030+ toGenerateReport generate
2031+
2032+
2033+
2034+-- REPL
2035+
2036+
2037+data Repl
2038+ = ReplBadDetails Details
2039+ | ReplBadInput BS.ByteString Error.Error
2040+ | ReplBadLocalDeps FilePath Error.Module [Error.Module]
2041+ | ReplProjectProblem BuildProjectProblem
2042+ | ReplBadGenerate Generate
2043+ | ReplBadCache
2044+ | ReplBlocked
2045+
2046+
2047+replToReport :: Repl -> Help.Report
2048+replToReport problem =
2049+ case problem of
2050+ ReplBadDetails details ->
2051+ toDetailsReport details
101
2052
102− Diff commandsExit ->
2053+ ReplBadInput source err ->
103− Diff.toReport commandsExit
2054+ Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
104
2055
105− Make makeExit ->
2056+ ReplBadLocalDeps root e es ->
106− Make.toReport makeExit
2057+ Help.compilerReport root e es
107
2058
108− Init initExit ->
2059+ ReplProjectProblem projectProblem ->
109− Init.toReport initExit
2060+ toProjectProblemReport projectProblem
110
2061
111− Install installExit ->
2062+ ReplBadGenerate generate ->
112− Install.toReport installExit
2063+ toGenerateReport generate
113
2064
114− Publish publishExit ->
2065+ ReplBadCache ->
115− Publish.toReport publishExit
2066+ corruptCacheReport
116
2067
117− BadHttp url httpExit ->
2068+ ReplBlocked ->
118− Http.toReport url httpExit
2069+ corruptCacheReport
builder/src/Reporting/Exit/Assets.hsdeleted−227
@@ -1,227 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Assets
3− ( Exit(..)
4− , ElmJsonProblem(..)
5− , toReport
6− , BadElmJsonContent(..)
7− , badContentToDocs
8− )
9− where
10−
11−
12−import qualified Data.Text as Text
13−
14−import qualified Elm.Package as Pkg
15−import Reporting.Doc ((<>))
16−import qualified Reporting.Doc as D
17−import qualified Reporting.Exit.Help as Help
18−
19−
20−
21−-- EXITS
22−
23−
24−data Exit
25− = BadElmJson ElmJsonProblem
26− | CorruptElmJson Pkg.Name Pkg.Version
27− | CorruptDocumentation Pkg.Name Pkg.Version
28− | CorruptBinary FilePath FilePath
29−
30−
31−
32−-- ELM JSON PROBLEM
33−
34−
35−data ElmJsonProblem
36− = BadJson D.Doc
37− | BadSrcDir FilePath
38− | NoPkgCore
39− | NoAppCore
40− | NoAppJson
41−
42−
43−
44−-- TO REPORT
45−
46−
47−toReport :: Exit -> Help.Report
48−toReport exit =
49− case exit of
50− CorruptElmJson pkg vsn ->
51− corruptJsonToReport "elm.json" pkg vsn
52−
53− CorruptDocumentation pkg vsn ->
54− corruptJsonToReport "docs.json" pkg vsn
55−
56− CorruptBinary elmHome path ->
57− Help.report "CORRUPT BINARY" (Just path)
58− ("The binary data at " ++ path ++ " is corrupt.")
59− [ D.reflow "Elm caches build artifacts in the following directories:"
60− , D.dullyellow $ D.indent 4 $ D.vcat $
61− [ D.fromString elmHome
62− , "elm-stuff/"
63− ]
64− , D.reflow
65− "Maybe you recently installed a command line tool or editor plugin that messes\
66− \ with them? They definitely should not be doing that, but you never know! So\
67− \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68− \ help reveal the corrupting influence."
69− ]
70−
71− BadElmJson problem ->
72− elmJsonProblemToReport problem
73−
74−
75−
76−-- CORRUPT JSON
77−
78−
79−corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80−corruptJsonToReport path pkg vsn =
81− Help.report "CORRUPT JSON" Nothing
82− ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83− ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84− )
85− [ D.reflow $
86− "I removed it from my file cache, so if it was some transient\
87− \ error it should be fixed if you try the same thing again.\
88− \ Please report this if it seems like an Elm problem though!"
89− ]
90−
91−
92−
93−-- BAD ELM JSON
94−
95−
96−elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97−elmJsonProblemToReport problem =
98− case problem of
99− BadJson doc ->
100− Help.jsonReport "BAD JSON" (Just "elm.json") doc
101−
102− BadSrcDir dir ->
103− Help.report "BAD JSON" (Just "elm.json")
104− "The \"source-directories\" in your elm.json lists the following directory:"
105− [ D.indent 4 (D.dullyellow (D.fromString dir))
106− , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107− ]
108−
109− NoPkgCore ->
110− Help.report "MISSING DEPENDENCY" (Just "elm.json")
111− "A package must have \"elm/core\" as a dependency. Try running:"
112− [ D.indent 4 $ D.green $ "elm install elm/core"
113− , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114− ]
115−
116− NoAppCore ->
117− Help.report "MISSING DEPENDENCY" (Just "elm.json")
118− "An application must have \"elm/core\" as a dependency. Try running:"
119− [ D.indent 4 $ D.green $ "elm install elm/core"
120− , D.reflow "It has some supporting code that is needed by every Elm application!"
121− ]
122−
123− NoAppJson ->
124− Help.report "MISSING DEPENDENCY" (Just "elm.json")
125− "An application must have \"elm/json\" as a dependency. Try running:"
126− [ D.indent 4 $ D.green $ "elm install elm/json"
127− , D.reflow "It helps me handle flags and ports."
128− ]
129−
130−
131−
132−-- PROBLEM TO DOCS
133−
134−
135−data BadElmJsonContent
136− = BadType Text.Text
137− | BadPkgName String
138− | BadVersion Text.Text
139− | BadConstraint String
140− | BadModuleName Text.Text
141− | BadModuleHeaderTooLong Text.Text
142− | BadDependencyName Text.Text
143− | BadLicense Text.Text [Text.Text]
144− | BadDirectoryNotString
145− | BadSummaryTooLong
146−
147−
148−badContentToDocs :: BadElmJsonContent -> [D.Doc]
149−badContentToDocs badContent =
150− case badContent of
151− BadType _ ->
152− ["The","only","valid","types","of","elm.json","are"
153− ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154− ]
155−
156− BadPkgName problem ->
157− map D.fromString (words problem)
158−
159− BadVersion txt ->
160− ["You","provided",D.red (D.fromString (show txt))
161− ,"which","is","not","a","valid","version.","I","need","something","like"
162− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163− ]
164−
165− BadConstraint problem ->
166− map D.fromString (words ("It is not a valid constraint. " ++ problem))
167−
168− BadModuleName name ->
169− ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170− ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171− ]
172−
173− BadModuleHeaderTooLong header ->
174− ["The",D.fromString (show header),"header","is","too","long."
175− ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176− ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177− ]
178−
179− BadDependencyName name ->
180− ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181− ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182− ,"the","package","website,","and","installing","it","with","the"
183− ,D.green "`elm install`","command","instead."
184− ]
185−
186− BadLicense _given suggestions ->
187− case suggestions of
188− [] ->
189− ["I","need","an","OSI","approved","SPDX","license,","like"
190− ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191− ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192− ]
193−
194− code:codes ->
195− ["I","need","an","OSI","approved","SPDX","license."]
196− ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197− ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198−
199− BadDirectoryNotString ->
200− ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201− ]
202−
203− BadSummaryTooLong ->
204− ["Your","summary","is","too","long.","I","need","it","to"
205− ,"be",D.green "under",D.green "80",D.green "characters."
206− ]
207−
208−
209−oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210−oneOf code codes =
211− let
212− toDoc spdx =
213− D.green (D.fromString (show spdx))
214− in
215− case codes of
216− [] ->
217− [toDoc code]
218−
219− [code2] ->
220− [toDoc code,"or",toDoc code2]
221−
222− _:_ ->
223− let
224− these = code : init codes
225− final = last codes
226− in
227− map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Bump.hsdeleted−51
@@ -1,51 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Bump
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.Version as V
10−import Reporting.Doc ((<>))
11−import qualified Reporting.Doc as D
12−import qualified Reporting.Exit.Help as Help
13−
14−
15−
16−-- EXITS
17−
18−
19−data Exit
20− = Application
21− | Unbumpable V.Version [V.Version]
22−
23−
24−
25−-- TO REPORT
26−
27−
28−toReport :: Exit -> Help.Report
29−toReport exit =
30− case exit of
31− Application ->
32− Help.report "UNBUMPABLE" (Just "elm.json")
33− "Your elm.json says this is an application. That means it cannot be published\
34− \ on <https://package.elm-lang.org> and therefore has no version to bump!"
35− []
36−
37− Unbumpable vsn versions ->
38− Help.docReport "UNBUMPABLE" (Just "elm.json")
39− ( D.fillSep
40− ["Your","elm.json","says","I","should","bump","relative","to","version"
41− ,D.red (D.fromUtf8 (V.toString vsn)) <> ","
42− ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
43− ,"That","means","there","is","no","API","for","me","to","diff","against","and"
44− ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
45− ]
46− )
47− [ D.fillSep $
48− ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]
49− ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
50− , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions
51− ]
builder/src/Reporting/Exit/Compile.hsdeleted−104
@@ -1,104 +0,0 @@
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.hsdeleted−345
@@ -1,345 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Crawl
3− ( Exit(..)
4− , Problem(..)
5− , Origin(..)
6− , SrcDirs(..)
7− , toReport
8− )
9− where
10−
11−
12−import qualified Data.Char as Char
13−import qualified Data.Map as Map
14−import qualified Data.Time.Clock as Time
15−
16−import qualified Elm.Compiler as Compiler
17−import qualified Elm.ModuleName as ModuleName
18−import qualified Elm.Package as Pkg
19−import qualified Elm.Version as V
20−import Reporting.Doc ((<+>), (<>))
21−import qualified Reporting.Doc as D
22−import qualified Reporting.Exit.Compile as Compile
23−import qualified Reporting.Exit.Help as Help
24−
25−
26−
27−-- EXIT
28−
29−
30−data Exit
31− = RootFileNotFound FilePath
32− | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33− | RootNameless FilePath
34− | DependencyProblems Problem [Problem]
35− | BadKernelHeader FilePath
36−
37−
38−data Problem
39− = ModuleNotFound Origin ModuleName.Raw SrcDirs
40− | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41− | BadHeader FilePath Time.UTCTime String Compiler.Error
42− | ModuleNameReservedForKernel Origin ModuleName.Raw
43− | ModuleNameMissing FilePath ModuleName.Raw
44− | ModuleNameMismatch
45− FilePath
46− ModuleName.Raw -- expected
47− ModuleName.Raw -- actual
48− | PortsInPackage FilePath ModuleName.Raw
49− | EffectsUnexpected FilePath ModuleName.Raw
50−
51−
52−data Origin
53− = ElmJson
54− | File FilePath
55− | Module FilePath ModuleName.Raw
56−
57−
58−data SrcDirs
59− = App [FilePath]
60− | Pkg
61−
62−
63−
64−-- TO REPORT
65−
66−
67−toReport :: Exit -> Help.Report
68−toReport exit =
69− case exit of
70− RootFileNotFound path ->
71− Help.report "FILE NOT FOUND" Nothing
72− "You want me to compile this file:"
73− [ D.indent 4 $ D.dullyellow $ D.fromChars path
74− , "I cannot find it though! Is there a typo?"
75− ]
76−
77− RootModuleNameDuplicate name paths ->
78− Help.report "DUPLICATE NAMES" Nothing
79− "I am trying to compile multiple modules with the same name:"
80− [ D.indent 4 $ D.dullyellow $ D.vcat $
81− map D.fromChars paths
82− , D.fillSep $
83− [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84− , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85− , "Change", "them", "to", "have", "unique", "names", "and", "you"
86− , "should", "be", "all", "set!"
87− ]
88− ]
89−
90− RootNameless path ->
91− namelessToDoc path "Main"
92−
93− DependencyProblems problem otherProblems ->
94− case otherProblems of
95− [] ->
96− problemToReport problem
97−
98− _ ->
99− problemToReport problem
100− -- error "TODO handle multiple dependency errors"
101−
102− BadKernelHeader filePath ->
103− Help.report "BAD KERNEL HEADER" Nothing
104− "I ran into a bad header in this file:"
105− [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106− , D.reflow $
107− "NOTE: Kernel code is only available to core Elm libraries to ensure\
108− \ the portability and security of the Elm ecosystem. This restriction\
109− \ also makes it possible to improve code gen (i.e. performance) without\
110− \ disrupting the ecosystem."
111− ]
112−
113−
114−
115−-- PROBLEM TO REPORT
116−
117−
118−problemToReport :: Problem -> Help.Report
119−problemToReport problem =
120− case problem of
121− ModuleNotFound origin name srcDirs ->
122− notFoundToDoc origin name srcDirs
123−
124− ModuleAmbiguous origin child paths pkgs ->
125− ambiguousToDoc origin child paths pkgs
126−
127− BadHeader path time source compilerError ->
128− let
129− compilerExit =
130− Compile.Exit "???" path time source [compilerError]
131− in
132− Help.compilerReport compilerExit []
133−
134− ModuleNameMissing path name ->
135− namelessToDoc path name
136−
137− ModuleNameMismatch path expected actual ->
138− Help.report "MODULE NAME MISMATCH" (Just path)
139− ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140− )
141− [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142− , "Looks like a typo or copy/paste error. Instead it needs to say:"
143− , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144− , "Make the change and you should be all set!"
145− ]
146−
147− ModuleNameReservedForKernel origin name ->
148− kernelNameToDoc origin name
149−
150− PortsInPackage path name ->
151− badTagToDoc path name "port" "port-modules" $
152− "Packages cannot have any `port` modules."
153−
154− EffectsUnexpected path name ->
155− badTagToDoc path name "effect" "effect-modules" $
156− "Creating `effect` modules is relatively experimental. There are a\
157− \ couple in @elm repos right now, but we have decided to be very\
158− \ cautious in expanding its usage."
159−
160−
161−badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162−badTagToDoc path name tag hintName summary =
163− Help.report
164− ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165− (Just path)
166− summary
167− [ D.fillSep $
168− [ "Get", "rid", "of", "all", "the"
169− , D.red (D.fromChars tag)
170− , "stuff", "in"
171− , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172− , "to", "proceed."
173− ]
174− , D.toSimpleNote $
175− "You can learn the reasoning behind this design choice at "
176− ++ D.makeLink hintName
177− ]
178−
179−
180−
181−-- NAMELESS
182−
183−
184−namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185−namelessToDoc path name =
186− Help.report "UNNAMED MODULE" (Just path)
187− ( "The `" ++ ModuleName.nameToChars name
188− ++ "` module must start with a line like this:"
189− )
190− [ D.indent 4 $ D.dullyellow $ D.fromChars $
191− "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192− , D.reflow $
193− "Try adding that as the first line of your file!"
194− , D.toSimpleNote $
195− "It is best to replace (..) with an explicit list of types and\
196− \ functions you want to expose. If you know a value is only used\
197− \ WITHIN this module, it is extra easy to refactor. This kind of\
198− \ information is great, especially as your project grows!"
199− ]
200−
201−
202−
203−-- NOT FOUND
204−
205−
206−notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207−notFoundToDoc origin child srcDirs =
208− case origin of
209− ElmJson ->
210− Help.report "MODULE NOT FOUND" (Just "elm.json")
211− "Your elm.json says your project has the following module:"
212− [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213− , D.reflow $
214− "When creating packages, all modules must live in the src/ directory."
215− ]
216−
217− File path ->
218− Help.report "UNKNOWN IMPORT" (Just path)
219− ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220− (notFoundDetails child srcDirs)
221−
222− Module path parent ->
223− Help.report "UNKNOWN IMPORT" (Just path)
224− ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225− (notFoundDetails child srcDirs)
226−
227−
228−notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229−notFoundDetails child srcDirs =
230− let
231− simulatedCode =
232− D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233− in
234− case Map.lookup child Pkg.suggestions of
235− Just pkg ->
236− [ simulatedCode
237− , D.reflow $
238− "Do you want the one from the " ++ Pkg.toChars pkg
239− ++ " package? If so, run this command to add that dependency to your elm.json file:"
240− , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241− , case srcDirs of
242− Pkg ->
243− D.reflow $
244− "If you want a local file, make sure the `"
245− ++ ModuleName.nameToChars child
246− ++ "` module is in your src/ directory."
247−
248− App _ ->
249− D.reflow $
250− "If you want a local file, make sure the `"
251− ++ ModuleName.nameToChars child
252− ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253− ]
254−
255− Nothing ->
256− [ simulatedCode
257− , "I cannot find that module! Is there a typo in the module name?"
258− , D.reflow $
259− case srcDirs of
260− Pkg ->
261− "When creating a package, all modules must live in the src/ directory."
262−
263− App [] ->
264− "The \"source-directories\" field of your elm.json is empty, so I only\
265− \ searched in packages. Maybe you need to add a \"src\" directory there?"
266−
267− App [dir] ->
268− "The \"source-directories\" field of your elm.json tells me to only look in the "
269− ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270−
271− App (dir:_:_) ->
272− "The \"source-directories\" field of your elm.json tells me to look in directories like "
273− ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274− ]
275−
276−
277−ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278−ambiguousToDoc origin child paths pkgs =
279− let
280− pkgToString (Pkg.Canonical pkg vsn) =
281− "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282−
283− makeReport maybePath summary yellowString =
284− Help.report "AMBIGUOUS IMPORT" maybePath summary
285− [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286− , D.reflow $
287− "I found multiple module with that name though:"
288− , D.indent 4 $ D.dullyellow $ D.vcat $
289− map D.fromChars $ paths ++ map pkgToString pkgs
290− , D.reflow $
291− if null paths then
292− "It looks like the name clash is in your dependencies, which is\
293− \ out of your control. Elm does not support this scenario right\
294− \ now, but it may be worthwhile. Please open an issue describing\
295− \ your scenario so we can gather more usage information!"
296− else
297− "Which is the right one? Try renaming your modules to have unique names."
298− ]
299− in
300− case origin of
301− ElmJson ->
302− makeReport
303− Nothing
304− "Your elm.json wants the following module:"
305− (ModuleName.nameToChars child)
306−
307− File path ->
308− makeReport
309− (Just path)
310− ("The file at " ++ path ++ " has an ambiguous import:")
311− ("import " ++ ModuleName.nameToChars child)
312−
313− Module path parent ->
314− makeReport
315− (Just path)
316− ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317− ("import " ++ ModuleName.nameToChars child)
318−
319−
320−kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321−kernelNameToDoc origin kernelName =
322− let
323− (maybePath, statement) =
324− case origin of
325− ElmJson ->
326− ( Nothing
327− , "Your elm.json says your project has the following module:"
328− )
329−
330− File path ->
331− ( Just path
332− , "This file is trying to import the following module:"
333− )
334−
335− Module path parent ->
336− ( Just path
337− , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338− )
339− in
340− Help.report "BAD MODULE NAME" maybePath statement
341− [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342− , D.reflow $
343− "But names like that are reserved for internal use.\
344− \ Switch to a name outside of the Elm/Kernel/ namespace."
345− ]
builder/src/Reporting/Exit/Deps.hsdeleted−123
@@ -1,123 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Deps
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.Constraint as Con
10−import qualified Elm.Package as Pkg
11−import qualified Elm.Version as V
12−import Reporting.Doc ((<>))
13−import qualified Reporting.Doc as D
14−import qualified Reporting.Exit.Help as Help
15−
16−
17−
18−-- EXITS
19−
20−
21−data Exit
22− = CorruptVersionCache FilePath Pkg.Name
23− | PackageNotFound Pkg.Name [Pkg.Name]
24− -- verify
25− | PkgBadElm Con.Constraint
26− | AppBadElm V.Version
27− | AppMissingTrans [(Pkg.Name, V.Version)]
28− | BadDeps
29− | BuildFailure FilePath Pkg.Name V.Version
30−
31−
32−
33−-- TO DOC
34−
35−
36−toReport :: Exit -> Help.Report
37−toReport exit =
38− case exit of
39− CorruptVersionCache elmHome pkg ->
40− Help.report "CORRUPT CACHE" Nothing
41− ( "I ran into an unknown package while exploring dependencies:"
42− )
43− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44− , D.reflow $
45− "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46− \ Maybe some program is messing with it? It is just cached files,\
47− \ so you can delete it and see if that fixes the issue."
48− ]
49−
50− PackageNotFound package suggestions ->
51− Help.docReport "PACKAGE NOT FOUND" Nothing
52− ( D.fillSep
53− ["I","cannot","find","a"
54− ,D.red (D.fromUtf8 (Pkg.toString package))
55− ,"package","on","the","package","website."
56− ]
57− )
58− [ "Maybe you want one of these instead?"
59− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60− , "But check <https://package.elm-lang.org> to see all possibilities!"
61− ]
62−
63− PkgBadElm constraint ->
64− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65− "Your elm.json says this package needs a version of Elm in this range:"
66− [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67− , D.fillSep
68− [ "But", "you", "are", "using", "Elm"
69− , D.red (D.fromUtf8 (V.toString V.compiler))
70− , "right", "now."
71− ]
72− ]
73−
74− AppBadElm version ->
75− Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76− "Your elm.json says this application needs a different version of Elm."
77− [ D.fillSep
78− [ "It", "requires"
79− , D.green (D.fromUtf8 (V.toString version)) <> ","
80− , "but", "you", "are", "using"
81− , D.red (D.fromUtf8 (V.toString V.compiler))
82− , "right", "now."
83− ]
84− ]
85−
86− AppMissingTrans missingDeps ->
87− let
88− toEntry (pkg, vsn) =
89− "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90− in
91− Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92− "Your elm.json is missing some \"indirect\" dependencies:"
93− [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94− , D.fillSep
95− ["This","usually","means","you","are","editing","elm.json","by","hand."
96− ,"It","is","much","more","reliable","to","use","the"
97− ,D.green "elm install","command","instead."
98− ]
99− ]
100−
101− BadDeps ->
102− Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103− "The dependencies in your elm.json are not compatible."
104− [ D.fillSep
105− ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106− ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107− ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108− ]
109− , D.reflow $
110− "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111− \ you try those paths and still cannot figure it out!"
112− ]
113−
114− BuildFailure elmHome pkg vsn ->
115− Help.report "CORRUPT DEPENDENCY" Nothing
116− "I ran into a problem while building the following package:"
117− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118− , D.fillSep
119− ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120− ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121− ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122− ]
123− ]
builder/src/Reporting/Exit/Diff.hsdeleted−73
@@ -1,73 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Diff
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Data.List as List
10−
11−import qualified Elm.Package as Pkg
12−import qualified Elm.Version as V
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− = Application
23− | Unpublished
24− | UnknownPackage Pkg.Name [Pkg.Name]
25− | UnknownVersion Pkg.Name V.Version [V.Version]
26−
27−
28−
29−-- TO DOC
30−
31−
32−toReport :: Exit -> Help.Report
33−toReport exit =
34− case exit of
35− Application ->
36− Help.report "CANNOT DIFF APPLICATIONS" Nothing
37− "I cannot perform diffs on applications, only packages! If you are\
38− \ just curious to see a diff, try running this command:"
39− [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"
40− ]
41−
42− Unpublished ->
43− Help.report "UNPUBLISHED" Nothing
44− "This package is not published yet. There is nothing to diff against!"
45− []
46−
47− UnknownPackage pkg suggestions ->
48− Help.report "UNKNOWN PACKAGE" Nothing
49− ( "I cannot find a package called:"
50− )
51− [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg
52− , "Maybe you want one of these instead?"
53− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
54− , "But check <https://package.elm-lang.org> to see all possibilities!"
55− ]
56−
57− UnknownVersion _pkg vsn realVersions ->
58− Help.docReport "UNKNOWN VERSION" Nothing
59− ( D.fillSep $
60− [ "Version", D.red (D.fromUtf8 (V.toString vsn))
61− , "has", "never", "been", "published,", "so", "I"
62− , "cannot", "diff", "against", "it."
63− ]
64− )
65− [ "Here are all the versions that HAVE been published:"
66− , D.indent 4 $ D.dullyellow $ D.vcat $
67− let
68− sameMajor v1 v2 = V._major v1 == V._major v2
69− mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns
70− in
71− map mkRow $ List.groupBy sameMajor (List.sort realVersions)
72− , "Want one of those instead?"
73− ]
builder/src/Reporting/Exit/Help.hs+11−12
@@ -14,7 +14,6 @@ module Reporting.Exit.Help
14 where
14 where
15
15
16
16
17−import qualified Data.Utf8 as Utf8
18import GHC.IO.Handle (hIsTerminalDevice)
17import GHC.IO.Handle (hIsTerminalDevice)
19import System.IO (Handle, hPutStr, stderr, stdout)
18import System.IO (Handle, hPutStr, stderr, stdout)
20
19
@@ -22,7 +21,7 @@ import qualified Json.Encode as E
22import Json.Encode ((==>))
21import Json.Encode ((==>))
23import Reporting.Doc ((<+>))
22import Reporting.Doc ((<+>))
24import qualified Reporting.Doc as D
23import qualified Reporting.Doc as D
25−import qualified Reporting.Exit.Compile as Compile
24+import qualified Reporting.Error as Error
26
25
27
26
28
27
@@ -30,7 +29,7 @@ import qualified Reporting.Exit.Compile as Compile
30
29
31
30
32data Report
31data Report
33− = CompilerReport Compile.Exit [Compile.Exit]
32+ = CompilerReport FilePath Error.Module [Error.Module]
34 | Report
33 | Report
35 { _title :: String
34 { _title :: String
36 , _path :: Maybe FilePath
35 , _path :: Maybe FilePath
@@ -53,7 +52,7 @@ jsonReport =
53 Report
52 Report
54
53
55
54
56−compilerReport :: Compile.Exit -> [Compile.Exit] -> Report
55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
57compilerReport =
56compilerReport =
58 CompilerReport
57 CompilerReport
59
58
@@ -65,8 +64,8 @@ compilerReport =
65reportToDoc :: Report -> D.Doc
64reportToDoc :: Report -> D.Doc
66reportToDoc report_ =
65reportToDoc report_ =
67 case report_ of
66 case report_ of
68− CompilerReport e es ->
67+ CompilerReport root e es ->
69− Compile.toDoc e es
68+ Error.toDoc root e es
70
69
71 Report title maybePath message ->
70 Report title maybePath message ->
72 let
71 let
@@ -95,17 +94,17 @@ reportToDoc report_ =
95reportToJson :: Report -> E.Value
94reportToJson :: Report -> E.Value
96reportToJson report_ =
95reportToJson report_ =
97 case report_ of
96 case report_ of
98− CompilerReport e es ->
97+ CompilerReport _ e es ->
99 E.object
98 E.object
100− [ "type" ==> E.string "compile-errors"
99+ [ "type" ==> E.chars "compile-errors"
101− , "errors" ==> E.list Compile.toJson (e:es)
100+ , "errors" ==> E.list Error.toJson (e:es)
102 ]
101 ]
103
102
104 Report title maybePath message ->
103 Report title maybePath message ->
105 E.object
104 E.object
106− [ "type" ==> E.string "error"
105+ [ "type" ==> E.chars "error"
107− , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath
106+ , "path" ==> maybe E.null E.chars maybePath
108− , "title" ==> E.string (Utf8.fromChars title)
107+ , "title" ==> E.chars title
109 , "message" ==> D.encode message
108 , "message" ==> D.encode message
110 ]
109 ]
111
110
builder/src/Reporting/Exit/Http.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Http
3− ( Exit(..)
4− , toReport
5− , BadJson(..)
6− , badJsonToDocs
7− )
8− where
9−
10−
11−import qualified Data.Text as Text
12−
13−import Reporting.Doc ((<>))
14−import qualified Reporting.Doc as D
15−import qualified Reporting.Exit.Help as Help
16−
17−
18−
19−-- EXITS
20−
21−
22−data Exit
23− = Unknown String
24− | BadJson String D.Doc
25− | BadZipData
26− | BadZipSha String String
27−
28−
29−
30−-- TO REPORT
31−
32−
33−toReport :: String -> Exit -> Help.Report
34−toReport url exit =
35− let
36− urlDoc =
37− D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38− in
39− case exit of
40− Unknown message ->
41− Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42− [ urlDoc
43− , D.stack
44− [ "Here is the error message I was able to extract:"
45− , D.indent 4 $ D.reflow message
46− ]
47− ]
48−
49− BadJson path doc ->
50− Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51−
52− BadZipData ->
53− Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54− [ urlDoc
55− , D.reflow $
56− "If it is a transient issue, it should be fixed if you try this\
57− \ again. If it seems like an Elm problem, please report it though!"
58− ]
59−
60− BadZipSha expectedHash actualHash ->
61− Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62− [ urlDoc
63− , D.reflow "I check the hash the zip, and it seems off:"
64− , D.vcat $ map D.fromString $
65− [ " Expected: " ++ expectedHash
66− , " Actual: " ++ actualHash
67− ]
68− , D.reflow $
69− "This usually means that the package author moved the version\
70− \ tag, so report it to them and see if that is the issue. Folks\
71− \ on Elm slack can probably help as well."
72− ]
73−
74−
75−
76−-- BAD JSON
77−
78−
79−data BadJson
80− = BadNewPkg Text.Text
81− | BadAllPkg Text.Text String
82− | BadAllVsn Text.Text
83−
84−
85−badJsonToDocs :: BadJson -> [D.Doc]
86−badJsonToDocs badJson =
87− case badJson of
88− BadNewPkg txt ->
89− ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90− ,"but","I","need","entries","like"
91− ,D.green "\"elm/core@6.0.0\"" <> "."
92− ]
93−
94− BadAllPkg txt suggestion ->
95− ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96− ]
97− ++ map D.fromString (words suggestion)
98−
99− BadAllVsn txt ->
100− ["You","provided",D.red (D.fromString (show txt))
101− ,"which","is","not","a","valid","version.","I","need","something","like"
102− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103− ]
104−
builder/src/Reporting/Exit/Init.hsdeleted−48
@@ -1,48 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Init
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.Package as Pkg
10−import qualified Reporting.Doc as D
11−import qualified Reporting.Exit.Help as Help
12−
13−
14−
15−-- EXITS
16−
17−
18−data Exit
19− = NoSolution [Pkg.Name]
20− | AlreadyStarted
21−
22−
23−
24−-- TO REPORT
25−
26−
27−toReport :: Exit -> Help.Report
28−toReport exit =
29− case exit of
30− NoSolution pkgs ->
31− Help.report "NO SOLUTION" Nothing
32− "I tried to create an elm.json with the following direct dependencies:"
33− [ D.indent 4 $ D.vcat $
34− map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs
35− , D.reflow $
36− "I could not find compatible versions though! This should not happen, so please\
37− \ ask around one of the community forums <http://elm-lang.org/community> to learn\
38− \ what is going on!"
39− ]
40−
41− AlreadyStarted ->
42− Help.report "EXISTING PROJECT" Nothing
43− "You already have an elm.json file, so there is nothing for me to initialize!"
44− [ D.fillSep
45− ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"
46− ,"you","figure","out","what","to","do","next?"
47− ]
48− ]
builder/src/Reporting/Exit/Install.hsdeleted−82
@@ -1,82 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Install
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.Package as Pkg
10−import qualified Elm.Version as V
11−import qualified Reporting.Doc as D
12−import qualified Reporting.Exit.Help as Help
13−
14−
15−
16−-- EXITS
17−
18−
19−data Exit
20− = NoArgs FilePath
21− | NoSolution [Pkg.Name]
22−
23−
24−
25−-- TO REPORT
26−
27−
28−toReport :: Exit -> Help.Report
29−toReport exit =
30− case exit of
31− NoArgs elmHome ->
32− Help.report "INSTALL WHAT?" Nothing
33− "I am expecting commands like:"
34− [ D.green $ D.indent 4 $ D.vcat $
35− [ "elm install elm/http"
36− , "elm install elm/json"
37− , "elm install elm/random"
38− ]
39− , D.toFancyHint
40− ["In","JavaScript","folks","run","`npm install`","to","start","projects."
41− ,"\"Gotta","download","everything!\"","But","why","download","packages"
42− ,"again","and","again?","Instead,","Elm","caches","packages","in"
43− ,D.dullyellow (D.fromChars elmHome)
44− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
45− ,"Elm","projects","check","that","cache","before","trying","the","internet."
46− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
47− ,"easier","to","work","offline.","As","a","result"
48− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
49− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
50− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
51− ]
52− ]
53−
54− NoSolution badPackages ->
55− case badPackages of
56− [] ->
57− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json")
58− "This usually happens if you try to modify dependency constraints by\
59− \ hand. I recommend deleting any dependency you added recently (or all\
60− \ of them if things are bad) and then adding them again with:"
61− [ D.indent 4 $ D.green "elm install"
62− , D.reflow $
63− "And do not be afaid to ask for help on Slack if you get stuck!"
64− ]
65−
66− _:_ ->
67− Help.report "OLD DEPENDENCIES" (Just "elm.json")
68− ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"
69− )
70− [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages
71− , D.reflow $
72− "This may be because it is not upgraded yet. It may be because a\
73− \ better solution came along, so there was no need to upgrade it.\
74− \ Etc. Try asking around on Slack to learn more about the topic."
75− , D.toSimpleNote
76− "Whatever the case, please be kind to the relevant package authors! Having\
77− \ friendly interactions with users is great motivation, and conversely, getting\
78− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
79− \ authors are humans with families, friends, jobs, vacations, responsibilities,\
80− \ goals, etc. They face obstacles outside of their technical work you will never\
81− \ know about, so please assume the best and try to be patient and supportive!"
82− ]
builder/src/Reporting/Exit/Make.hsdeleted−75
@@ -1,75 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Make
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import qualified Elm.ModuleName as ModuleName
10−import qualified Reporting.Doc as D
11−import qualified Reporting.Exit.Help as Help
12−
13−
14−
15−-- EXITS
16−
17−
18−data Exit
19− = CannotMakeNothing
20− | CannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
21− | CannotOptimizeAndDebug
22−
23−
24−
25−-- TO REPORT
26−
27−
28−toReport :: Exit -> Help.Report
29−toReport exit =
30− case exit of
31− CannotMakeNothing ->
32− Help.report "NO INPUT" Nothing
33− "What should I make though? I need more information, like:"
34− [ D.vcat
35− [ D.indent 4 $ D.green "elm make src/Main.elm"
36− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
37− ]
38− , D.reflow
39− "However many files you give, I will create one JS file out of them."
40− ]
41−
42− CannotOptimizeDebugValues m ms ->
43− Help.report "DEBUG REMNANTS" Nothing
44− "There are uses of the `Debug` module in the following modules:"
45− [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.nameToChars) (m:ms)
46− , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"
47− , D.toSimpleNote $
48− "The issue is that --optimize strips out info needed by `Debug` functions.\
49− \ Here are two examples:"
50− , D.indent 4 $ D.reflow $
51− "(1) It shortens record field names. This makes the generated JavaScript is\
52− \ smaller, but `Debug.toString` cannot know the real field names anymore."
53− , D.indent 4 $ D.reflow $
54− "(2) Values like `type Height = Height Float` are unboxed. This reduces\
55− \ allocation, but it also means that `Debug.toString` cannot tell if it is\
56− \ looking at a `Height` or `Float` value."
57− , D.reflow $
58− "There are a few other cases like that, and it will be much worse once we start\
59− \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\
60− \ resulting in unpredictable behavior. I hope that clarifies why this restriction\
61− \ exists!"
62− ]
63−
64− CannotOptimizeAndDebug ->
65− Help.docReport "CLASHING FLAGS" Nothing
66− ( D.fillSep
67− ["I","cannot","compile","with",D.red "--optimize","and"
68− ,D.red "--debug","at","the","same","time."
69− ]
70− )
71− [ D.reflow
72− "I need to take away information to optimize things, and I need to\
73− \ add information to add the debugger. It is impossible to do both\
74− \ at once, so pick just one of those flags."
75− ]
builder/src/Reporting/Exit/Publish.hsdeleted−241
@@ -1,241 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Exit.Publish
3− ( Exit(..)
4− , toReport
5− )
6− where
7−
8−
9−import Deps.Diff (Magnitude, magnitudeToString)
10−import qualified Elm.Version as V
11−import Reporting.Doc ((<>))
12−import qualified Reporting.Doc as D
13−import qualified Reporting.Exit.Help as Help
14−
15−
16−
17−-- EXITS
18−
19−
20−data Exit
21− = Application
22− | NotInitialVersion V.Version
23− | AlreadyPublished V.Version
24− | InvalidBump V.Version V.Version
25− | BadBump V.Version V.Version Magnitude V.Version Magnitude
26− | NoSummary
27− | NoExposed
28− | NoReadme
29− | ShortReadme
30− | NoLicense
31− | MissingTag V.Version
32− | NoGit
33− | LocalChanges V.Version
34−
35−
36−
37−-- TO REPORT
38−
39−
40−toReport :: Exit -> Help.Report
41−toReport exit =
42− case exit of
43− Application ->
44− Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
45−
46− NotInitialVersion vsn ->
47− Help.docReport "INVALID VERSION" Nothing
48− ( D.fillSep
49− ["I","cannot","publish"
50− ,D.red (D.fromUtf8 (V.toString vsn))
51− ,"as","the","initial","version."
52− ]
53− )
54− [ D.fillSep
55− ["Change","it","to",D.green "1.0.0","which","is"
56− ,"the","initial","version","for","all","Elm","packages."
57− ]
58− ]
59−
60− AlreadyPublished vsn ->
61− Help.docReport "ALREADY PUBLISHED" Nothing
62− ( D.vcat
63− [ D.fillSep
64− [ "Version", D.green (D.fromUtf8 (V.toString vsn))
65− , "has", "already", "been", "published.", "You", "cannot"
66− , "publish", "it", "again!"
67− ]
68− , "Try using the `bump` command:"
69− ]
70− )
71− [ D.dullyellow $ D.indent 4 "elm bump"
72− , D.reflow $
73− "It computes the version number based on API changes, ensuring\
74− \ that no breaking changes end up in PATCH releases!"
75− ]
76−
77− InvalidBump statedVersion latestVersion ->
78− Help.docReport "INVALID VERSION" (Just "elm.json")
79− ( D.fillSep $
80− ["Your","elm.json","says","the","next","version","should","be"
81− ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","
82− ,"but","that","is","not","valid","based","on","the","previously"
83− ,"published","versions."
84− ]
85− )
86− [ D.fillSep $
87− ["Change","the","version","back","to"
88− ,D.green (D.fromUtf8 (V.toString latestVersion))
89− ,"which","is","the","most","recently","published","version."
90− ,"From","there,","have","Elm","bump","the","version","by","running:"
91− ]
92− , D.indent 4 $ D.green "elm bump"
93− , D.reflow $
94− "If you want more insight on the API changes Elm detects, you\
95− \ can run `elm diff` at this point as well."
96− ]
97−
98− BadBump old new magnitude realNew realMagnitude ->
99− Help.docReport "INVALID VERSION" (Just "elm.json")
100− (
101− D.fillSep $
102− ["Your","elm.json","says","the","next","version","should","be"
103− ,D.red (D.fromUtf8 (V.toString new)) <> ","
104− ,"indicating","a",D.fromChars (magnitudeToString magnitude)
105− ,"change","to","the","public","API."
106− ,"This","does","not","match","the","API","diff","given","by:"
107− ]
108− )
109− [ D.indent 4 $ D.fromChars $
110− "elm diff " ++ V.toChars old
111−
112− , D.fillSep $
113− ["This","command","says","this","is","a"
114− ,D.fromChars (magnitudeToString realMagnitude)
115− ,"change,","so","the","next","version","should","be"
116− ,D.green (D.fromUtf8 (V.toString realNew)) <> "."
117− ,"Double","check","everything","to","make","sure","you"
118− ,"are","publishing","what","you","want!"
119− ]
120− , D.reflow $
121− "Also, next time use `elm bump` and I'll figure all this out for you!"
122− ]
123−
124− NoSummary ->
125− Help.docReport "NO SUMMARY" (Just "elm.json")
126− ( D.fillSep $
127− [ "To", "publish", "a", "package,", "your", "elm.json", "must"
128− , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"
129− , "a", "consice", "overview", "of", "your", "project."
130− ]
131− )
132− [ D.reflow $
133− "The summary must be less than 80 characters. It should describe\
134− \ the concrete use of your package as clearly and as plainly as possible."
135− ]
136−
137− NoExposed ->
138− Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
139− ( D.fillSep $
140− [ "To", "publish", "a", "package,", "the"
141− , D.dullyellow "\"exposed-modules\"", "field", "of", "your"
142− , "elm.json", "must", "list", "at", "least", "one", "module."
143− ]
144− )
145− [ D.reflow $
146− "What is the point of a package that has no modules?!"
147− ]
148−
149− NoReadme ->
150− badReadmeReport "NO README" $
151− "Every published package must have a helpful README.md\
152− \ file, but I do not see one in your project."
153−
154− ShortReadme ->
155− badReadmeReport "SHORT README" $
156− "This README.md is too short. Having more details will help\
157− \ people assess your package quickly and fairly."
158−
159− NoLicense ->
160− Help.report "NO LICENSE FILE" (Just "LICENSE")
161− "By publishing a package you are inviting the Elm community to build\
162− \ upon your work. But without knowing your license, we have no idea if\
163− \ that is legal!"
164− [ D.reflow $
165− "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
166− \ you must share that choice in two places. First, the license\
167− \ identifier must appear in your elm.json file. Second, the full\
168− \ license text must appear in the root of your project in a file\
169− \ named LICENSE. Add that file and you will be all set!"
170− ]
171−
172− MissingTag version ->
173− let vsn = V.toChars version in
174− Help.docReport "NO TAG" Nothing
175− ( D.fillSep $
176− [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
177− , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."
178− ]
179− )
180− [ D.vcat
181− [ "These tags make it possible to find this specific version on GitHub."
182− , "To tag the most recent commit and push it to GitHub, run this:"
183− ]
184− , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $
185− [ "git tag -a " ++ vsn ++ " -m \"new release\""
186− , "git push origin " ++ vsn
187− ]
188− , "The -m flag is for a helpful message. Try to make it more informative!"
189− ]
190−
191− NoGit ->
192− Help.report "NO GIT" Nothing
193− "I searched your PATH environment variable for `git` and could not\
194− \ find it. Is it available through your PATH?"
195− [ D.reflow $
196− "Who cares about this? Well, I currently use `git` to check if there\
197− \ are any local changes in your code. Local changes are a good sign\
198− \ that some important improvements have gotten mistagged, so this\
199− \ check can be extremely helpful for package authors!"
200− , D.toSimpleNote $
201− "We plan to do this without the `git` binary in a future release."
202− ]
203−
204− LocalChanges version ->
205− let vsn = V.toChars version in
206− Help.docReport "LOCAL CHANGES" Nothing
207− ( D.fillSep $
208− [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"
209− , "git", "does", "not", "match", "the", "code", "in", "your"
210− , "working", "directory.", "This", "means", "you", "have"
211− , "commits", "or", "local", "changes", "that", "are", "not"
212− , "going", "to", "be", "published!"
213− ]
214− )
215− [ D.toSimpleNote $
216− "If you are sure everything is in order, you can run `git checkout "
217− ++ vsn ++ "` and publish your code from there."
218− ]
219−
220−
221−badReadmeReport :: String -> String -> Help.Report
222−badReadmeReport title summary =
223− Help.report title (Just "README.md") summary
224− [ D.reflow $
225− "When people look at your README, they are wondering:"
226− , D.vcat
227− [ " - What does this package even do?"
228− , " - Will it help me solve MY problems?"
229− ]
230− , D.reflow $
231− "So I recommend starting your README with a small example of the\
232− \ most common usage scenario. Show people what they can expect if\
233− \ they learn more!"
234− , D.toSimpleNote $
235− "By publishing your package, you are inviting people to invest time\
236− \ in understanding your work. Spending an hour to communicate your\
237− \ knowledge more clearly can save the community days or weeks of time\
238− \ in aggregate, and saving time in aggregate is the whole point of\
239− \ publishing packages! People really appreciate it, and it makes the\
240− \ whole ecosystem feel nicer!"
241− ]
builder/src/Reporting/Task.hs+17
@@ -3,8 +3,10 @@ module Reporting.Task
3 ( Task
3 ( Task
4 , run
4 , run
5 , throw
5 , throw
6+ , mapError
6 --
7 --
7 , io
8 , io
9+ , mio
8 , eio
10 , eio
9 )
11 )
10 where
12 where
@@ -31,6 +33,12 @@ throw x =
31 Task $ \_ err -> err x
33 Task $ \_ err -> err x
32
34
33
35
36+mapError :: (x -> y) -> Task x a -> Task y a
37+mapError func (Task task) =
38+ Task $ \ok err ->
39+ task ok (err . func)
40+
41+
34
42
35-- IO
43-- IO
36
44
@@ -41,6 +49,15 @@ io work =
41 Task $ \ok _ -> work >>= ok
49 Task $ \ok _ -> work >>= ok
42
50
43
51
52+mio :: x -> IO (Maybe a) -> Task x a
53+mio x work =
54+ Task $ \ok err ->
55+ do result <- work
56+ case result of
57+ Just a -> ok a
58+ Nothing -> err x
59+
60+
44eio :: (x -> y) -> IO (Either x a) -> Task y a
61eio :: (x -> y) -> IO (Either x a) -> Task y a
45eio func work =
62eio func work =
46 Task $ \ok err ->
63 Task $ \ok err ->
builder/src/Stuff.hs+9−9
@@ -8,13 +8,14 @@ module Stuff
8 , elmo
8 , elmo
9 , temp
9 , temp
10 , findRoot
10 , findRoot
11− , withProjectLock
11+ , withRootLock
12− , withCacheLock
12+ , withRegistryLock
13 , PackageCache
13 , PackageCache
14 , getPackageCache
14 , getPackageCache
15 , registry
15 , registry
16 , package
16 , package
17 , getReplCache
17 , getReplCache
18+ , getElmHome
18 )
19 )
19 where
20 where
20
21
@@ -119,17 +120,16 @@ findRootHelp dirs =
119-- LOCKS
120-- LOCKS
120
121
121
122
122−withProjectLock :: FilePath -> IO a -> IO a
123+withRootLock :: FilePath -> IO a -> IO a
123−withProjectLock root work =
124+withRootLock root work =
124 do let dir = stuff root
125 do let dir = stuff root
125 Dir.createDirectoryIfMissing True dir
126 Dir.createDirectoryIfMissing True dir
126− Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
127+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
127
128
128
129
129−withCacheLock :: PackageCache -> IO a -> IO a
130+withRegistryLock :: PackageCache -> IO a -> IO a
130−withCacheLock (PackageCache dir) work =
131+withRegistryLock (PackageCache dir) work =
131− Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
132+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
132−
133
133
134
134
135
135
cabal.confignew file+2
@@ -0,0 +1,2 @@
1+profiling: False
2+library-profiling: True
compiler/src/AST/Canonical.hs+12−9
@@ -56,12 +56,14 @@ import Data.Binary
56import qualified Data.List as List
56import qualified Data.List as List
57import qualified Data.Map as Map
57import qualified Data.Map as Map
58import Data.Name (Name)
58import Data.Name (Name)
59−import qualified Data.Utf8 as Utf8
60
59
60+import qualified AST.Source as Src
61import qualified AST.Utils.Binop as Binop
61import qualified AST.Utils.Binop as Binop
62import qualified AST.Utils.Shader as Shader
62import qualified AST.Utils.Shader as Shader
63import qualified Data.Index as Index
63import qualified Data.Index as Index
64+import qualified Elm.Float as EF
64import qualified Elm.ModuleName as ModuleName
65import qualified Elm.ModuleName as ModuleName
66+import qualified Elm.String as ES
65import qualified Reporting.Annotation as A
67import qualified Reporting.Annotation as A
66
68
67
69
@@ -82,10 +84,10 @@ data Expr_
82 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
84 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
83 | VarDebug ModuleName.Canonical Name Annotation
85 | VarDebug ModuleName.Canonical Name Annotation
84 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
86 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
85− | Chr Utf8.String
87+ | Chr ES.String
86− | Str Utf8.String
88+ | Str ES.String
87 | Int Int
89 | Int Int
88− | Float (Utf8.Under256 Float)
90+ | Float EF.Float
89 | List [Expr]
91 | List [Expr]
90 | Negate Expr
92 | Negate Expr
91 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
93 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -128,7 +130,7 @@ data Def
128
130
129data Decls
131data Decls
130 = Declare Def Decls
132 = Declare Def Decls
131− | DeclareRec [Def] Decls
133+ | DeclareRec Def [Def] Decls
132 | SaveTheEnvironment
134 | SaveTheEnvironment
133
135
134
136
@@ -150,8 +152,8 @@ data Pattern_
150 | PList [Pattern]
152 | PList [Pattern]
151 | PCons Pattern Pattern
153 | PCons Pattern Pattern
152 | PBool Union Bool
154 | PBool Union Bool
153− | PChr Utf8.String
155+ | PChr ES.String
154− | PStr Utf8.String
156+ | PStr ES.String
155 | PInt Int
157 | PInt Int
156 | PCtor
158 | PCtor
157 { _p_home :: ModuleName.Canonical
159 { _p_home :: ModuleName.Canonical
@@ -231,6 +233,7 @@ data Module =
231 Module
233 Module
232 { _name :: ModuleName.Canonical
234 { _name :: ModuleName.Canonical
233 , _exports :: Exports
235 , _exports :: Exports
236+ , _docs :: Src.Docs
234 , _decls :: Decls
237 , _decls :: Decls
235 , _unions :: Map.Map Name Union
238 , _unions :: Map.Map Name Union
236 , _aliases :: Map.Map Name Alias
239 , _aliases :: Map.Map Name Alias
@@ -339,7 +342,7 @@ instance Binary CtorOpts where
339 0 -> return Normal
342 0 -> return Normal
340 1 -> return Enum
343 1 -> return Enum
341 2 -> return Unbox
344 2 -> return Unbox
342− _ -> error "binary encoding of CtorOpts was corrupted"
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
343
346
344
347
345instance Binary Annotation where
348instance Binary Annotation where
@@ -390,7 +393,7 @@ instance Binary AliasType where
390 case n of
393 case n of
391 0 -> liftM Holey get
394 0 -> liftM Holey get
392 1 -> liftM Filled get
395 1 -> liftM Filled get
393− _ -> error "binary encoding of AliasType was corrupted"
396+ _ -> fail "binary encoding of AliasType was corrupted"
394
397
395
398
396instance Binary FieldType where
399instance Binary FieldType where
compiler/src/AST/Optimized.hs+101−40
@@ -7,30 +7,35 @@ module AST.Optimized
7 , Destructor(..)
7 , Destructor(..)
8 , Decider(..)
8 , Decider(..)
9 , Choice(..)
9 , Choice(..)
10− , Graph(..)
10+ , GlobalGraph(..)
11+ , LocalGraph(..)
11 , Main(..)
12 , Main(..)
12 , Node(..)
13 , Node(..)
13 , EffectsType(..)
14 , EffectsType(..)
14 , empty
15 , empty
15− , union
16+ , addGlobalGraph
16− , unions
17+ , addLocalGraph
18+ , addKernel
19+ , toKernelGlobal
17 )
20 )
18 where
21 where
19
22
20
23
21import Control.Monad (liftM, liftM2, liftM3, liftM4)
24import Control.Monad (liftM, liftM2, liftM3, liftM4)
22import Data.Binary (Binary, get, put, getWord8, putWord8)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
23−import qualified Data.List as List
24import qualified Data.Map as Map
26import qualified Data.Map as Map
27+import qualified Data.Name as Name
25import Data.Name (Name)
28import Data.Name (Name)
26import qualified Data.Set as Set
29import qualified Data.Set as Set
27−import qualified Data.Utf8 as Utf8
28
30
29import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
30import qualified AST.Utils.Shader as Shader
32import qualified AST.Utils.Shader as Shader
31import qualified Data.Index as Index
33import qualified Data.Index as Index
34+import qualified Elm.Float as EF
32import qualified Elm.Kernel as K
35import qualified Elm.Kernel as K
33import qualified Elm.ModuleName as ModuleName
36import qualified Elm.ModuleName as ModuleName
37+import qualified Elm.Package as Pkg
38+import qualified Elm.String as ES
34import qualified Optimize.DecisionTree as DT
39import qualified Optimize.DecisionTree as DT
35import qualified Reporting.Annotation as A
40import qualified Reporting.Annotation as A
36
41
@@ -41,10 +46,10 @@ import qualified Reporting.Annotation as A
41
46
42data Expr
47data Expr
43 = Bool Bool
48 = Bool Bool
44− | Chr Utf8.String
49+ | Chr ES.String
45− | Str Utf8.String
50+ | Str ES.String
46 | Int Int
51 | Int Int
47− | Float (Utf8.Under256 Float)
52+ | Float EF.Float
48 | VarLocal Name
53 | VarLocal Name
49 | VarGlobal Global
54 | VarGlobal Global
50 | VarEnum Global Index.ZeroBased
55 | VarEnum Global Index.ZeroBased
@@ -70,7 +75,6 @@ data Expr
70
75
71
76
72data Global = Global ModuleName.Canonical Name
77data Global = Global ModuleName.Canonical Name
73− deriving (Eq, Ord)
74
78
75
79
76
80
@@ -121,11 +125,18 @@ data Choice
121-- OBJECT GRAPH
125-- OBJECT GRAPH
122
126
123
127
124−data Graph =
128+data GlobalGraph =
125− Graph
129+ GlobalGraph
126− { _mains :: Map.Map ModuleName.Canonical Main
130+ { _g_nodes :: Map.Map Global Node
131+ , _g_fields :: Map.Map Name Int
132+ }
133+
134+
135+data LocalGraph =
136+ LocalGraph
137+ { _l_main :: Maybe Main
127− , _nodes :: Map.Map Global Node
138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
128− , _fields :: Map.Map Name Int
139+ , _l_fields :: Map.Map Name Int
129 }
140 }
130
141
131
142
@@ -159,27 +170,72 @@ data EffectsType = Cmd | Sub | Fx
159
170
160
171
161{-# NOINLINE empty #-}
172{-# NOINLINE empty #-}
162−empty :: Graph
173+empty :: GlobalGraph
163empty =
174empty =
164− Graph Map.empty Map.empty Map.empty
175+ GlobalGraph Map.empty Map.empty
176+
177+
178+addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph
179+addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) =
180+ GlobalGraph
181+ { _g_nodes = Map.union nodes1 nodes2
182+ , _g_fields = Map.union fields1 fields2
183+ }
184+
185+
186+addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph
187+addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) =
188+ GlobalGraph
189+ { _g_nodes = Map.union nodes1 nodes2
190+ , _g_fields = Map.union fields1 fields2
191+ }
192+
165
193
194+addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph
195+addKernel shortName chunks (GlobalGraph nodes fields) =
196+ let
197+ global = toKernelGlobal shortName
198+ node = Kernel chunks (foldr addKernelDep Set.empty chunks)
199+ in
200+ GlobalGraph
201+ { _g_nodes = Map.insert global node nodes
202+ , _g_fields = Map.union (K.countFields chunks) fields
203+ }
204+
205+
206+addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global
207+addKernelDep chunk deps =
208+ case chunk of
209+ K.JS _ -> deps
210+ K.ElmVar home name -> Set.insert (Global home name) deps
211+ K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps
212+ K.ElmField _ -> deps
213+ K.JsField _ -> deps
214+ K.JsEnum _ -> deps
215+ K.Debug -> deps
216+ K.Prod -> deps
217+
218+
219+toKernelGlobal :: Name.Name -> Global
220+toKernelGlobal shortName =
221+ Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar
166
222
167−union :: Graph -> Graph -> Graph
168−union (Graph mains1 graph1 fields1) (Graph mains2 graph2 fields2) =
169− Graph
170− (Map.union mains1 mains2)
171− (Map.union graph1 graph2)
172− (Map.union fields1 fields2)
173
223
174
224
175−unions :: [Graph] -> Graph
225+-- INSTANCES
176−unions graphs =
177− case graphs of
178− [] ->
179− empty
180
226
181− g:gs ->
227+
182− List.foldl' union g gs
228+instance Eq Global where
229+ (==) (Global home1 name1) (Global home2 name2) =
230+ name1 == name2 && home1 == home2
231+
232+
233+instance Ord Global where
234+ compare (Global home1 name1) (Global home2 name2) =
235+ case compare name1 name2 of
236+ LT -> LT
237+ EQ -> compare home1 home2
238+ GT -> GT
183
239
184
240
185
241
@@ -252,7 +308,7 @@ instance Binary Expr where
252 24 -> pure Unit
308 24 -> pure Unit
253 25 -> liftM3 Tuple get get get
309 25 -> liftM3 Tuple get get get
254 26 -> liftM3 Shader get get get
310 26 -> liftM3 Shader get get get
255− _ -> error "problem getting Opt.Expr binary"
311+ _ -> fail "problem getting Opt.Expr binary"
256
312
257
313
258instance Binary Def where
314instance Binary Def where
@@ -266,7 +322,7 @@ instance Binary Def where
266 case word of
322 case word of
267 0 -> liftM2 Def get get
323 0 -> liftM2 Def get get
268 1 -> liftM3 TailDef get get get
324 1 -> liftM3 TailDef get get get
269− _ -> error "problem getting Opt.Def binary"
325+ _ -> fail "problem getting Opt.Def binary"
270
326
271
327
272instance Binary Destructor where
328instance Binary Destructor where
@@ -289,7 +345,7 @@ instance Binary Path where
289 1 -> liftM2 Field get get
345 1 -> liftM2 Field get get
290 2 -> liftM Unbox get
346 2 -> liftM Unbox get
291 3 -> liftM Root get
347 3 -> liftM Root get
292− _ -> error "problem getting Opt.Path binary"
348+ _ -> fail "problem getting Opt.Path binary"
293
349
294
350
295instance (Binary a) => Binary (Decider a) where
351instance (Binary a) => Binary (Decider a) where
@@ -305,7 +361,7 @@ instance (Binary a) => Binary (Decider a) where
305 0 -> liftM Leaf get
361 0 -> liftM Leaf get
306 1 -> liftM3 Chain get get get
362 1 -> liftM3 Chain get get get
307 2 -> liftM3 FanOut get get get
363 2 -> liftM3 FanOut get get get
308− _ -> error "problem getting Opt.Decider binary"
364+ _ -> fail "problem getting Opt.Decider binary"
309
365
310
366
311instance Binary Choice where
367instance Binary Choice where
@@ -319,13 +375,18 @@ instance Binary Choice where
319 case word of
375 case word of
320 0 -> liftM Inline get
376 0 -> liftM Inline get
321 1 -> liftM Jump get
377 1 -> liftM Jump get
322− _ -> error "problem getting Opt.Choice binary"
378+ _ -> fail "problem getting Opt.Choice binary"
379+
380+
323
381
382+instance Binary GlobalGraph where
383+ get = liftM2 GlobalGraph get get
384+ put (GlobalGraph a b) = put a >> put b
324
385
325
386
326−instance Binary Graph where
387+instance Binary LocalGraph where
327− get = liftM3 Graph get get get
388+ get = liftM3 LocalGraph get get get
328− put (Graph a b c) = put a >> put b >> put c
389+ put (LocalGraph a b c) = put a >> put b >> put c
329
390
330
391
331instance Binary Main where
392instance Binary Main where
@@ -339,7 +400,7 @@ instance Binary Main where
339 case word of
400 case word of
340 0 -> return Static
401 0 -> return Static
341 1 -> liftM2 Dynamic get get
402 1 -> liftM2 Dynamic get get
342− _ -> error "problem getting Opt.Main binary"
403+ _ -> fail "problem getting Opt.Main binary"
343
404
344
405
345instance Binary Node where
406instance Binary Node where
@@ -371,7 +432,7 @@ instance Binary Node where
371 8 -> liftM2 Kernel get get
432 8 -> liftM2 Kernel get get
372 9 -> liftM2 PortIncoming get get
433 9 -> liftM2 PortIncoming get get
373 10 -> liftM2 PortOutgoing get get
434 10 -> liftM2 PortOutgoing get get
374− _ -> error "problem getting Opt.Node binary"
435+ _ -> fail "problem getting Opt.Node binary"
375
436
376
437
377instance Binary EffectsType where
438instance Binary EffectsType where
@@ -387,4 +448,4 @@ instance Binary EffectsType where
387 0 -> return Cmd
448 0 -> return Cmd
388 1 -> return Sub
449 1 -> return Sub
389 2 -> return Fx
450 2 -> return Fx
390− _ -> error "problem getting Opt.EffectsType binary"
451+ _ -> fail "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+36−19
@@ -1,5 +1,4 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module AST.Source
2module AST.Source
4 ( Expr, Expr_(..), VarType(..)
3 ( Expr, Expr_(..), VarType(..)
5 , Def(..)
4 , Def(..)
@@ -12,10 +11,12 @@ module AST.Source
12 , Value(..)
11 , Value(..)
13 , Union(..)
12 , Union(..)
14 , Alias(..)
13 , Alias(..)
15− , Binop(..)
14+ , Infix(..)
16 , Port(..)
15 , Port(..)
17 , Effects(..)
16 , Effects(..)
18 , Manager(..)
17 , Manager(..)
18+ , Docs(..)
19+ , Comment(..)
19 , Exposing(..)
20 , Exposing(..)
20 , Exposed(..)
21 , Exposed(..)
21 , Privacy(..)
22 , Privacy(..)
@@ -24,10 +25,13 @@ module AST.Source
24
25
25
26
26import Data.Name (Name)
27import Data.Name (Name)
27−import qualified Data.Utf8 as Utf8
28+import qualified Data.Name as Name
28
29
29import qualified AST.Utils.Binop as Binop
30import qualified AST.Utils.Binop as Binop
30import qualified AST.Utils.Shader as Shader
31import qualified AST.Utils.Shader as Shader
32+import qualified Elm.Float as EF
33+import qualified Elm.String as ES
34+import qualified Parse.Primitives as P
31import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
32
36
33
37
@@ -39,10 +43,10 @@ type Expr = A.Located Expr_
39
43
40
44
41data Expr_
45data Expr_
42− = Chr Utf8.String
46+ = Chr ES.String
43− | Str Utf8.String
47+ | Str ES.String
44 | Int Int
48 | Int Int
45− | Float (Utf8.Under256 Float)
49+ | Float EF.Float
46 | Var VarType Name
50 | Var VarType Name
47 | VarQual VarType Name Name
51 | VarQual VarType Name Name
48 | List [Expr]
52 | List [Expr]
@@ -93,8 +97,8 @@ data Pattern_
93 | PCtorQual A.Region Name Name [Pattern]
97 | PCtorQual A.Region Name Name [Pattern]
94 | PList [Pattern]
98 | PList [Pattern]
95 | PCons Pattern Pattern
99 | PCons Pattern Pattern
96− | PChr Utf8.String
100+ | PChr ES.String
97− | PStr Utf8.String
101+ | PStr ES.String
98 | PInt Int
102 | PInt Int
99
103
100
104
@@ -122,22 +126,26 @@ data Type_
122
126
123data Module =
127data Module =
124 Module
128 Module
125− { _name :: Maybe Name
129+ { _name :: Maybe (A.Located Name)
126 , _exports :: A.Located Exposing
130 , _exports :: A.Located Exposing
131+ , _docs :: Docs
127 , _imports :: [Import]
132 , _imports :: [Import]
128 , _values :: [A.Located Value]
133 , _values :: [A.Located Value]
129 , _unions :: [A.Located Union]
134 , _unions :: [A.Located Union]
130 , _aliases :: [A.Located Alias]
135 , _aliases :: [A.Located Alias]
131− , _binops :: [A.Located Binop]
136+ , _binops :: [A.Located Infix]
132 , _effects :: Effects
137 , _effects :: Effects
133 }
138 }
134
139
135
140
136getName :: Module -> Name
141getName :: Module -> Name
137−getName (Module maybeName _ _ _ _ _ _ _) =
142+getName (Module maybeName _ _ _ _ _ _ _ _) =
138 case maybeName of
143 case maybeName of
139− Just name -> name
144+ Just (A.At _ name) ->
145+ name
146+
140− Nothing -> "Main"
147+ Nothing ->
148+ Name._Main
141
149
142
150
143getImportName :: Import -> Name
151getImportName :: Import -> Name
@@ -156,7 +164,7 @@ data Import =
156data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
157data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
158data Alias = Alias (A.Located Name) [A.Located Name] Type
166data Alias = Alias (A.Located Name) [A.Located Name] Type
159−data Binop = Binop Name Binop.Associativity Binop.Precedence Name
167+data Infix = Infix Name Binop.Associativity Binop.Precedence Name
160data Port = Port (A.Located Name) Type
168data Port = Port (A.Located Name) Type
161
169
162
170
@@ -172,21 +180,30 @@ data Manager
172 | Fx (A.Located Name) (A.Located Name)
180 | Fx (A.Located Name) (A.Located Name)
173
181
174
182
183+data Docs
184+ = NoDocs A.Region
185+ | YesDocs Comment [(Name, Comment)]
186+
187+
188+newtype Comment =
189+ Comment P.Snippet
190+
191+
175
192
176-- EXPOSING
193-- EXPOSING
177
194
178
195
179data Exposing
196data Exposing
180 = Open
197 = Open
181− | Explicit [A.Located Exposed]
198+ | Explicit [Exposed]
182
199
183
200
184data Exposed
201data Exposed
185− = Lower Name
202+ = Lower (A.Located Name)
186− | Upper Name Privacy
203+ | Upper (A.Located Name) Privacy
187− | Operator Name
204+ | Operator A.Region Name
188
205
189
206
190data Privacy
207data Privacy
191− = Public
208+ = Public A.Region
192 | Private
209 | Private
compiler/src/AST/Utils/Binop.hs+5−6
@@ -41,12 +41,11 @@ instance Binary Precedence where
41instance Binary Associativity where
41instance Binary Associativity where
42 get =
42 get =
43 do n <- getWord8
43 do n <- getWord8
44− return $
45− case n of
44+ case n of
46− 0 -> Left
45+ 0 -> return Left
47− 1 -> Non
46+ 1 -> return Non
48− 2 -> Right
47+ 2 -> return Right
49− _ -> error "Error reading valid associativity from serialized string"
48+ _ -> fail "Error reading valid associativity from serialized string"
50
49
51 put assoc =
50 put assoc =
52 putWord8 $
51 putWord8 $
compiler/src/AST/Utils/Shader.hs+51−4
@@ -4,22 +4,27 @@ module AST.Utils.Shader
4 ( Source
4 ( Source
5 , Types(..)
5 , Types(..)
6 , Type(..)
6 , Type(..)
7+ , fromChars
8+ , toJsStringBuilder
7 )
9 )
8 where
10 where
9
11
10
12
13+import Control.Monad (liftM)
14+import Data.Binary (Binary, get, put)
15+import qualified Data.ByteString as BS
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.ByteString.UTF8 as BS_UTF8
11import qualified Data.Map as Map
18import qualified Data.Map as Map
12import qualified Data.Name as Name
19import qualified Data.Name as Name
13−import qualified Data.Utf8 as Utf8
14
20
15
21
16
22
17-- SOURCE
23-- SOURCE
18
24
19
25
20−type Source = Utf8.VeryLong SOURCE
26+newtype Source =
21−
27+ Source BS.ByteString
22−data SOURCE
23
28
24
29
25
30
@@ -42,3 +47,45 @@ data Type
42 | V4
47 | V4
43 | M4
48 | M4
44 | Texture
49 | Texture
50+
51+
52+
53+-- TO BUILDER
54+
55+
56+toJsStringBuilder :: Source -> B.Builder
57+toJsStringBuilder (Source src) =
58+ B.byteString src
59+
60+
61+
62+-- FROM CHARS
63+
64+
65+fromChars :: [Char] -> Source
66+fromChars chars =
67+ Source (BS_UTF8.fromString (escape chars))
68+
69+
70+escape :: [Char] -> [Char]
71+escape chars =
72+ case chars of
73+ [] ->
74+ []
75+
76+ c:cs
77+ | c == '\r' -> escape cs
78+ | c == '\n' -> '\\' : 'n' : escape cs
79+ | c == '\"' -> '\\' : '"' : escape cs
80+ | c == '\'' -> '\\' : '\'' : escape cs
81+ | c == '\\' -> '\\' : '\\' : escape cs
82+ | otherwise -> c : escape cs
83+
84+
85+
86+-- BINARY
87+
88+
89+instance Binary Source where
90+ get = liftM Source get
91+ put (Source a) = put a
compiler/src/AST/Utils/Type.hs−1
@@ -1,5 +1,4 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module AST.Utils.Type
2module AST.Utils.Type
4 ( delambda
3 ( delambda
5 , dealias
4 , dealias
compiler/src/Canonicalize/Environment.hs+50−20
@@ -4,6 +4,8 @@ module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5 , Exposed
5 , Exposed
6 , Qualified
6 , Qualified
7+ , Info(..)
8+ , mergeInfo
7 , Var(..)
9 , Var(..)
8 , Type(..)
10 , Type(..)
9 , Ctor(..)
11 , Ctor(..)
@@ -20,8 +22,8 @@ module Canonicalize.Environment
20
22
21import qualified Data.Map.Merge.Strict as Map
23import qualified Data.Map.Merge.Strict as Map
22import qualified Data.Map.Strict as Map
24import qualified Data.Map.Strict as Map
23−import qualified Data.Map.Strict.Internal as I
24import qualified Data.Name as Name
25import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
25
27
26import qualified AST.Utils.Binop as Binop
28import qualified AST.Utils.Binop as Binop
27import qualified AST.Canonical as Can
29import qualified AST.Canonical as Can
@@ -58,11 +60,34 @@ data Env =
58
60
59
61
60type Exposed a =
62type Exposed a =
61− Map.Map Name.Name (Map.Map ModuleName.Canonical a)
63+ Map.Map Name.Name (Info a)
62
64
63
65
64type Qualified a =
66type Qualified a =
65− Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
67+ Map.Map Name.Name (Map.Map Name.Name (Info a))
68+
69+
70+
71+-- INFO
72+
73+
74+data Info a
75+ = Specific ModuleName.Canonical a
76+ | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77+
78+
79+mergeInfo :: Info a -> Info a -> Info a
80+mergeInfo info1 info2 =
81+ case info1 of
82+ Specific h1 _ ->
83+ case info2 of
84+ Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86+
87+ Ambiguous h1 hs1 ->
88+ case info2 of
89+ Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
66
91
67
92
68
93
@@ -72,7 +97,8 @@ type Qualified a =
72data Var
97data Var
73 = Local A.Region
98 = Local A.Region
74 | TopLevel A.Region
99 | TopLevel A.Region
75− | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
76
102
77
103
78
104
@@ -139,7 +165,10 @@ addLocalLeft _ region =
139addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
140addLocalBoth name region var =
166addLocalBoth name region var =
141 case var of
167 case var of
142− Foreign _ ->
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
143 Result.ok (Local region)
172 Result.ok (Local region)
144
173
145 Local parentRegion ->
174 Local parentRegion ->
@@ -150,17 +179,18 @@ addLocalBoth name region var =
150
179
151
180
152
181
182+
153-- FIND TYPE
183-- FIND TYPE
154
184
155
185
156findType :: A.Region -> Env -> Name.Name -> Result i w Type
186findType :: A.Region -> Env -> Name.Name -> Result i w Type
157findType region (Env _ _ ts _ _ _ qts _) name =
187findType region (Env _ _ ts _ _ _ qts _) name =
158 case Map.lookup name ts of
188 case Map.lookup name ts of
159− Just (I.Bin 1 _ tipe _ _) ->
189+ Just (Specific _ tipe) ->
160 Result.ok tipe
190 Result.ok tipe
161
191
162− Just homes ->
192+ Just (Ambiguous h hs) ->
163− Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
164
194
165 Nothing ->
195 Nothing ->
166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -171,11 +201,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
171 case Map.lookup prefix qts of
201 case Map.lookup prefix qts of
172 Just qualified ->
202 Just qualified ->
173 case Map.lookup name qualified of
203 case Map.lookup name qualified of
174− Just (I.Bin 1 _ tipe _ _) ->
204+ Just (Specific _ tipe) ->
175 Result.ok tipe
205 Result.ok tipe
176
206
177− Just homes ->
207+ Just (Ambiguous h hs) ->
178− Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
179
209
180 Nothing ->
210 Nothing ->
181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -191,11 +221,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
191findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
193 case Map.lookup name cs of
223 case Map.lookup name cs of
194− Just (I.Bin 1 _ ctor _ _) ->
224+ Just (Specific _ ctor) ->
195 Result.ok ctor
225 Result.ok ctor
196
226
197− Just homes ->
227+ Just (Ambiguous h hs) ->
198− Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
199
229
200 Nothing ->
230 Nothing ->
201 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -206,11 +236,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
206 case Map.lookup prefix qcs of
236 case Map.lookup prefix qcs of
207 Just qualified ->
237 Just qualified ->
208 case Map.lookup name qualified of
238 case Map.lookup name qualified of
209− Just (I.Bin 1 _ pattern _ _) ->
239+ Just (Specific _ pattern) ->
210 Result.ok pattern
240 Result.ok pattern
211
241
212− Just homes ->
242+ Just (Ambiguous h hs) ->
213− Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
214
244
215 Nothing ->
245 Nothing ->
216 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -226,11 +256,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
226findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
227findBinop region (Env _ _ _ _ binops _ _ _) name =
257findBinop region (Env _ _ _ _ binops _ _ _) name =
228 case Map.lookup name binops of
258 case Map.lookup name binops of
229− Just (I.Bin 1 _ binop _ _) ->
259+ Just (Specific _ binop) ->
230 Result.ok binop
260 Result.ok binop
231
261
232− Just homes ->
262+ Just (Ambiguous h hs) ->
233− Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
263+ Result.throw (Error.AmbiguousBinop region name h hs)
234
264
235 Nothing ->
265 Nothing ->
236 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
compiler/src/Canonicalize/Environment/Dups.hs+6−3
@@ -57,8 +57,11 @@ 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 _ _ ->
60+ OneOrMore.More left right ->
61+ let
61− let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in
62+ (Info r1 _, Info r2 _) =
63+ OneOrMore.getFirstTwo left right
64+ in
62 Result.throw (toError name r1 r2)
65 Result.throw (toError name r1 r2)
63
66
64
67
@@ -102,7 +105,7 @@ one name region value =
102
105
103insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
104insert name region value dict =
107insert name region value dict =
105− Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
106
109
107
110
108union :: Dict a -> Dict a -> Dict a
111union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+49−37
@@ -35,7 +35,14 @@ type Result i w a =
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
36createInitialEnv home ifaces imports =
36createInitialEnv home ifaces imports =
37 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
37 do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38− Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
38+ Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
39+
40+
41+infoToVar :: Env.Info Can.Annotation -> Env.Var
42+infoToVar info =
43+ case info of
44+ Env.Specific home tipe -> Env.Foreign home tipe
45+ Env.Ambiguous h hs -> Env.Foreigns h hs
39
46
40
47
41
48
@@ -61,7 +68,7 @@ emptyState =
61
68
62emptyTypes :: Env.Exposed Env.Type
69emptyTypes :: Env.Exposed Env.Type
63emptyTypes =
70emptyTypes =
64− Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
71+ Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
65
72
66
73
67
74
@@ -102,8 +109,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
102 (Map.mapMaybeWithKey (unionToType home) unions)
109 (Map.mapMaybeWithKey (unionToType home) unions)
103 (Map.mapMaybeWithKey (aliasToType home) aliases)
110 (Map.mapMaybeWithKey (aliasToType home) aliases)
104
111
105− !vars = Map.map (Map.singleton home) defs
112+ !vars = Map.map (Env.Specific home) defs
106− !types = Map.map (Map.singleton home . fst) rawTypeInfo
113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo
107 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
108
115
109 !qvs2 = addQualified prefix vars qvs
116 !qvs2 = addQualified prefix vars qvs
@@ -129,7 +136,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
129
136
130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
131addExposed =
138addExposed =
132− Map.unionWith Map.union
139+ Map.unionWith Env.mergeInfo
133
140
134
141
135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -150,7 +157,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
150unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
151 let
158 let
152 addCtor dict (Can.Ctor ctor index _ args) =
159 addCtor dict (Can.Ctor ctor index _ args) =
153− Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
154 in
161 in
155 ( Env.Union (length vars) home
162 ( Env.Union (length vars) home
156 , List.foldl' addCtor Map.empty ctors
163 , List.foldl' addCtor Map.empty ctors
@@ -181,7 +188,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
181 (Can.TAlias home name avars (Can.Filled tipe))
188 (Can.TAlias home name avars (Can.Filled tipe))
182 (Can.fieldsToList fields)
189 (Can.fieldsToList fields)
183 in
190 in
184− Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
185
192
186 _ ->
193 _ ->
187 Map.empty
194 Map.empty
@@ -192,9 +199,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
192-- BINOP
199-- BINOP
193
200
194
201
195−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
196binopToBinop home op (I.Binop name annotation associativity precedence) =
203binopToBinop home op (I.Binop name annotation associativity precedence) =
197− Map.singleton home (Env.Binop op home name annotation associativity precedence)
204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)
198
205
199
206
200
207
@@ -207,19 +214,19 @@ addExposedValue
207 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
214 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
208 -> Map.Map Name.Name I.Binop
215 -> Map.Map Name.Name I.Binop
209 -> State
216 -> State
210− -> A.Located Src.Exposed
217+ -> Src.Exposed
211 -> Result i w State
218 -> Result i w State
212−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
219+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
213 case exposed of
220 case exposed of
214− Src.Lower name ->
221+ Src.Lower (A.At region name) ->
215 case Map.lookup name vars of
222 case Map.lookup name vars of
216 Just info ->
223 Just info ->
217− Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
218
225
219 Nothing ->
226 Nothing ->
220 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
221
228
222− Src.Upper name privacy ->
229+ Src.Upper (A.At region name) privacy ->
223 case privacy of
230 case privacy of
224 Src.Private ->
231 Src.Private ->
225 case Map.lookup name types of
232 case Map.lookup name types of
@@ -227,43 +234,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg
227 case tipe of
234 case tipe of
228 Env.Union _ _ ->
235 Env.Union _ _ ->
229 let
236 let
230− !ts2 = Map.insert name (Map.singleton home tipe) ts
237+ !ts2 = Map.insert name (Env.Specific home tipe) ts
231 in
238 in
232 Result.ok (State vs ts2 cs bs qvs qts qcs)
239 Result.ok (State vs ts2 cs bs qvs qts qcs)
233
240
234 Env.Alias _ _ _ _ ->
241 Env.Alias _ _ _ _ ->
235 let
242 let
236− !ts2 = Map.insert name (Map.singleton home tipe) ts
243+ !ts2 = Map.insert name (Env.Specific home tipe) ts
237 !cs2 = addExposed cs ctors
244 !cs2 = addExposed cs ctors
238 in
245 in
239 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
240
247
241 Nothing ->
248 Nothing ->
242− case Map.lookup name (toCtors types) of
249+ case checkForCtorMistake name types of
243− Just tipe ->
250+ tipe:_ ->
244 Result.throw $ Error.ImportCtorByName region name tipe
251 Result.throw $ Error.ImportCtorByName region name tipe
245
252
246− Nothing ->
253+ [] ->
247 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
248
255
249− Src.Public ->
256+ Src.Public dotDotRegion ->
250 case Map.lookup name types of
257 case Map.lookup name types of
251 Just (tipe, ctors) ->
258 Just (tipe, ctors) ->
252 case tipe of
259 case tipe of
253 Env.Union _ _ ->
260 Env.Union _ _ ->
254 let
261 let
255− !ts2 = Map.insert name (Map.singleton home tipe) ts
262+ !ts2 = Map.insert name (Env.Specific home tipe) ts
256 !cs2 = addExposed cs ctors
263 !cs2 = addExposed cs ctors
257 in
264 in
258 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
259
266
260 Env.Alias _ _ _ _ ->
267 Env.Alias _ _ _ _ ->
261− Result.throw (Error.ImportOpenAlias region name)
268+ Result.throw (Error.ImportOpenAlias dotDotRegion name)
262
269
263 Nothing ->
270 Nothing ->
264 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
271 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
265
272
266− Src.Operator op ->
273+ Src.Operator region op ->
267 case Map.lookup op binops of
274 case Map.lookup op binops of
268 Just binop ->
275 Just binop ->
269 let
276 let
@@ -275,18 +282,23 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg
275 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
276
283
277
284
278−
279−toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
285+checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
280−toCtors types =
286+checkForCtorMistake givenName types =
281− Map.foldr addCtors Map.empty types
287+ Map.foldr addMatches [] types
282 where
288 where
283− addCtors (_, exposedCtors) dict =
289+ addMatches (_, exposedCtors) matches =
284− Map.foldrWithKey addCtor dict exposedCtors
290+ Map.foldrWithKey addMatch matches exposedCtors
285−
291+
286− addCtor ctorName homes dict =
292+ addMatch ctorName info matches =
293+ if ctorName /= givenName
294+ then matches
295+ else
287− case Map.elems homes of
296+ case info of
288− [Env.Ctor _ tipeName _ _ _] ->
297+ Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
289− Map.insert ctorName tipeName dict
298+ tipeName : matches
290−
299+
291− _ ->
300+ Env.Specific _ (Env.RecordCtor _ _ _) ->
292− dict
301+ matches
302+
303+ Env.Ambiguous _ _ ->
304+ matches
compiler/src/Canonicalize/Environment/Local.hs+8−8
@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
54
54
55
55
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57−collectVars (Src.Module _ _ _ values _ _ _ effects) =
57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
58 let
58 let
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
60 Dups.insert name region (Env.TopLevel region) dict
60 Dups.insert name region (Env.TopLevel region) dict
@@ -95,7 +95,7 @@ toEffectDups effects =
95
95
96
96
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98−addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
98+addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
99 let
99 let
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs q
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112 do arity <- checkUnionFreeVars union
112 do arity <- checkUnionFreeVars union
113− let one = Map.singleton home (Env.Union arity home)
113+ let one = Env.Specific home (Env.Union arity home)
114 Result.ok $ Map.insert name one types
114 Result.ok $ Map.insert name one types
115
115
116
116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134 do args <- checkAliasFreeVars alias
134 do args <- checkAliasFreeVars alias
135 ctype <- Type.canonicalize env tipe
135 ctype <- Type.canonicalize env tipe
136− let one = Map.singleton home (Env.Alias (length args) home args ctype)
136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)
137 let ts1 = Map.insert name one ts
137 let ts1 = Map.insert name one ts
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139
139
@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =
262
262
263
263
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265−addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
265+addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266 do unionInfo <- traverse (canonicalizeUnion env) unions
266 do unionInfo <- traverse (canonicalizeUnion env) unions
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
268
268
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs q
281 )
281 )
282
282
283
283
284−type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)
285
285
286
286
287
287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297 ,
297 ,
298 case ctipe of
298 case ctipe of
299 Can.TRecord fields Nothing ->
299 Can.TRecord fields Nothing ->
300− Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
300+ Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
301
301
302 _ ->
302 _ ->
303 Dups.none
303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351
351
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Map.singleton home $
354+ Dups.one name region $ Env.Specific home $
355 Env.Ctor home typeName union index args
355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+6−7
@@ -14,7 +14,6 @@ import Control.Monad (foldM)
14import qualified Data.Graph as Graph
14import qualified Data.Graph as Graph
15import qualified Data.List as List
15import qualified Data.List as List
16import qualified Data.Map.Strict as Map
16import qualified Data.Map.Strict as Map
17−import qualified Data.Map.Strict.Internal as I
18import qualified Data.Name as Name
17import qualified Data.Name as Name
19
18
20import qualified AST.Canonical as Can
19import qualified AST.Canonical as Can
@@ -696,15 +695,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
696 Env.TopLevel _ ->
695 Env.TopLevel _ ->
697 logVar name (Can.VarTopLevel localHome name)
696 logVar name (Can.VarTopLevel localHome name)
698
697
699− Env.Foreign (I.Bin 1 home annotation _ _) ->
698+ Env.Foreign home annotation ->
700 Result.ok $
699 Result.ok $
701 if home == ModuleName.debug then
700 if home == ModuleName.debug then
702 Can.VarDebug localHome name annotation
701 Can.VarDebug localHome name annotation
703 else
702 else
704 Can.VarForeign home name annotation
703 Can.VarForeign home name annotation
705
704
706− Env.Foreign homes ->
705+ Env.Foreigns h hs ->
707− Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
708
707
709 Nothing ->
708 Nothing ->
710 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -715,15 +714,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
715 case Map.lookup prefix qvs of
714 case Map.lookup prefix qvs of
716 Just qualified ->
715 Just qualified ->
717 case Map.lookup name qualified of
716 case Map.lookup name qualified of
718− Just (I.Bin 1 home annotation _ _) ->
717+ Just (Env.Specific home annotation) ->
719 Result.ok $
718 Result.ok $
720 if home == ModuleName.debug then
719 if home == ModuleName.debug then
721 Can.VarDebug localHome name annotation
720 Can.VarDebug localHome name annotation
722 else
721 else
723 Can.VarForeign home name annotation
722 Can.VarForeign home name annotation
724
723
725− Just homes ->
724+ Just (Env.Ambiguous h hs) ->
726− Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
727
726
728 Nothing ->
727 Nothing ->
729 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Canonicalize/Module.hs+31−19
@@ -42,7 +42,7 @@ type Result i w a =
42
42
43
43
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45−canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
48
48
@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops ef
54 ceffects <- Effects.canonicalize env values cunions effects
54 ceffects <- Effects.canonicalize env values cunions effects
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
56
56
57− return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
58
58
59
59
60
60
61-- CANONICALIZE BINOP
61-- CANONICALIZE BINOP
62
62
63
63
64−canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )
64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =
65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
66 ( op, Can.Binop_ associativity precedence func )
66 ( op, Can.Binop_ associativity precedence func )
67
67
68
68
@@ -93,13 +93,11 @@ detectCycles sccs =
93 Graph.AcyclicSCC (def, _, _) ->
93 Graph.AcyclicSCC (def, _, _) ->
94 Can.Declare def <$> detectCycles otherSccs
94 Can.Declare def <$> detectCycles otherSccs
95
95
96− Graph.CyclicSCC [] ->
97− detectCycles otherSccs
98−
99 Graph.CyclicSCC subNodes ->
96 Graph.CyclicSCC subNodes ->
100− Can.DeclareRec
101− <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
97+ do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)
98+ case defs of
99+ [] -> detectCycles otherSccs
102− <*> detectCycles otherSccs
100+ d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs
103
101
104
102
105detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
@@ -108,8 +106,22 @@ detectBadCycles scc =
108 Graph.AcyclicSCC def ->
106 Graph.AcyclicSCC def ->
109 Result.ok def
107 Result.ok def
110
108
111− Graph.CyclicSCC cyclicValueDefs ->
109+ Graph.CyclicSCC [] ->
110+ error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"
111+
112+ Graph.CyclicSCC (def:defs) ->
113+ let
114+ (A.At region name) = extractDefName def
115+ names = map (A.toValue . extractDefName) defs
116+ in
112− Result.throw (Error.RecursiveDecl cyclicValueDefs)
117+ Result.throw (Error.RecursiveDecl region name names)
118+
119+
120+extractDefName :: Can.Def -> A.Located Name.Name
121+extractDefName def =
122+ case def of
123+ Can.Def name _ _ -> name
124+ Can.TypedDef name _ _ _ _ -> name
113
125
114
126
115
127
@@ -224,11 +236,11 @@ checkExposed
224 -> Map.Map Name.Name alias
236 -> Map.Map Name.Name alias
225 -> Map.Map Name.Name binop
237 -> Map.Map Name.Name binop
226 -> Can.Effects
238 -> Can.Effects
227− -> A.Located Src.Exposed
239+ -> Src.Exposed
228 -> Result i w (Dups.Dict (A.Located Can.Export))
240 -> Result i w (Dups.Dict (A.Located Can.Export))
229−checkExposed values unions aliases binops effects (A.At region exposed) =
241+checkExposed values unions aliases binops effects exposed =
230 case exposed of
242 case exposed of
231− Src.Lower name ->
243+ Src.Lower (A.At region name) ->
232 if Map.member name values then
244 if Map.member name values then
233 ok name region Can.ExportValue
245 ok name region Can.ExportValue
234 else
246 else
@@ -240,23 +252,23 @@ checkExposed values unions aliases binops effects (A.At region exposed) =
240 Result.throw $ Error.ExportNotFound region Error.BadVar name $
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
241 ports ++ Map.keys values
253 ports ++ Map.keys values
242
254
243− Src.Operator name ->
255+ Src.Operator region name ->
244 if Map.member name binops then
256 if Map.member name binops then
245 ok name region Can.ExportBinop
257 ok name region Can.ExportBinop
246 else
258 else
247 Result.throw $ Error.ExportNotFound region Error.BadOp name $
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
248 Map.keys binops
260 Map.keys binops
249
261
250− Src.Upper name Src.Public ->
262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
251 if Map.member name unions then
263 if Map.member name unions then
252 ok name region Can.ExportUnionOpen
264 ok name region Can.ExportUnionOpen
253 else if Map.member name aliases then
265 else if Map.member name aliases then
254− Result.throw $ Error.ExportOpenAlias region name
266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name
255 else
267 else
256 Result.throw $ Error.ExportNotFound region Error.BadType name $
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
257 Map.keys unions ++ Map.keys aliases
269 Map.keys unions ++ Map.keys aliases
258
270
259− Src.Upper name Src.Private ->
271+ Src.Upper (A.At region name) Src.Private ->
260 if Map.member name unions then
272 if Map.member name unions then
261 ok name region Can.ExportUnionClosed
273 ok name region Can.ExportUnionClosed
262 else if Map.member name aliases then
274 else if Map.member name aliases then
compiler/src/Canonicalize/Pattern.hs+3−2
@@ -8,6 +8,7 @@ module Canonicalize.Pattern
8 where
8 where
9
9
10
10
11+import qualified Data.List as List
11import qualified Data.Map.Strict as Map
12import qualified Data.Map.Strict as Map
12import qualified Data.Name as Name
13import qualified Data.Name as Name
13
14
@@ -173,8 +174,8 @@ logVar name region value =
173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
174logFields fields value =
175logFields fields value =
175 let
176 let
176− addField (A.At region name) dict =
177+ addField dict (A.At region name) =
177 Dups.insert name region region dict
178 Dups.insert name region region dict
178 in
179 in
179 Result.Result $ \bindings warnings _ ok ->
180 Result.Result $ \bindings warnings _ ok ->
180− ok (foldr addField bindings fields) warnings value
181+ ok (List.foldl' addField bindings fields) warnings value
compiler/src/Compile.hs+27−19
@@ -8,7 +8,6 @@ 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
12
11
13import qualified AST.Source as Src
12import qualified AST.Source as Src
14import qualified AST.Canonical as Can
13import qualified AST.Canonical as Can
@@ -21,7 +20,7 @@ import qualified Nitpick.PatternMatches as PatternMatches
21import qualified Optimize.Module as Optimize
20import qualified Optimize.Module as Optimize
22import qualified Reporting.Error as E
21import qualified Reporting.Error as E
23import qualified Reporting.Result as R
22import qualified Reporting.Result as R
24−import qualified Reporting.Warning as W
23+import qualified Reporting.Render.Type.Localizer as Localizer
25import qualified Type.Constrain.Module as Type
24import qualified Type.Constrain.Module as Type
26import qualified Type.Solve as Type
25import qualified Type.Solve as Type
27
26
@@ -36,17 +35,16 @@ data Artifacts =
36 Artifacts
35 Artifacts
37 { _modul :: Can.Module
36 { _modul :: Can.Module
38 , _types :: Map.Map Name.Name Can.Annotation
37 , _types :: Map.Map Name.Name Can.Annotation
39− , _graph :: Opt.Graph
38+ , _graph :: Opt.LocalGraph
40 }
39 }
41
40
42
41
43−compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> ([W.Warning], Either (OneOrMore.OneOrMore E.Error) Artifacts)
42+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
44compile pkg ifaces modul =
43compile pkg ifaces modul =
45− R.run $
46 do canonical <- canonicalize pkg ifaces modul
44 do canonical <- canonicalize pkg ifaces modul
47− annotations <- typeCheck canonical
45+ annotations <- typeCheck modul canonical
48 () <- nitpick canonical
46 () <- nitpick canonical
49− objects <- optimize annotations canonical
47+ objects <- optimize modul annotations canonical
50 return (Artifacts canonical annotations objects)
48 return (Artifacts canonical annotations objects)
51
49
52
50
@@ -54,31 +52,41 @@ compile pkg ifaces modul =
54-- PHASES
52-- PHASES
55
53
56
54
57−canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> R.Result i [W.Warning] E.Error Can.Module
55+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
58canonicalize pkg ifaces modul =
56canonicalize pkg ifaces modul =
59− R.mapError E.Canonicalize $ Canonicalize.canonicalize pkg ifaces modul
57+ case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
58+ Right canonical ->
59+ Right canonical
60+
61+ Left errors ->
62+ Left $ E.BadNames errors
60
63
61
64
62−typeCheck :: Can.Module -> R.Result i w E.Error (Map.Map Name.Name Can.Annotation)
65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
63−typeCheck canonical =
66+typeCheck modul canonical =
64 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
67 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
65 Right annotations ->
68 Right annotations ->
66− R.ok annotations
69+ Right annotations
67
70
68 Left errors ->
71 Left errors ->
69− R.throw (E.Type errors)
72+ Left (E.BadTypes (Localizer.fromModule modul) errors)
70
73
71
74
72−nitpick :: Can.Module -> R.Result i w E.Error ()
75+nitpick :: Can.Module -> Either E.Error ()
73nitpick canonical =
76nitpick canonical =
74 case PatternMatches.check canonical of
77 case PatternMatches.check canonical of
75 Right () ->
78 Right () ->
76− R.ok ()
79+ Right ()
77
80
78 Left errors ->
81 Left errors ->
79− R.throw (E.Pattern errors)
82+ Left (E.BadPatterns errors)
80
83
81
84
82−optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> R.Result i [W.Warning] E.Error Opt.Graph
85+optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
83−optimize annotations canonical =
86+optimize modul annotations canonical =
84− R.mapError E.Main $ Optimize.optimize annotations canonical
87+ case snd $ R.run $ Optimize.optimize annotations canonical of
88+ Right localGraph ->
89+ Right localGraph
90+
91+ Left errors ->
92+ Left (E.BadMains (Localizer.fromModule modul) errors)
compiler/src/Data/Map/Utils.hsnew file+43
@@ -0,0 +1,43 @@
1+module Data.Map.Utils
2+ ( fromKeys
3+ , fromKeysA
4+ , fromValues
5+ , any
6+ )
7+ where
8+
9+
10+import Prelude hiding (any)
11+import qualified Data.Map as Map
12+import Data.Map.Internal (Map(..))
13+
14+
15+
16+-- FROM KEYS
17+
18+
19+fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v
20+fromKeys toValue keys =
21+ Map.fromList $ map (\k -> (k, toValue k)) keys
22+
23+
24+fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v)
25+fromKeysA toValue keys =
26+ Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
27+
28+
29+fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v
30+fromValues toKey values =
31+ Map.fromList $ map (\v -> (toKey v, v)) values
32+
33+
34+
35+-- ANY
36+
37+
38+{-# INLINE any #-}
39+any :: (v -> Bool) -> Map.Map k v -> Bool
40+any isGood = go
41+ where
42+ go Tip = False
43+ go (Bin _ _ v l r) = isGood v || go l || go r
compiler/src/Data/Name.hs+166−177
@@ -1,130 +1,119 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Name
3module Data.Name
4 ( Name
4 ( Name
5− , toUtf8
5+ --
6− , fromUtf8
6+ , toChars
7− , toEscapedBuilder
7+ , toElmString
8− , Utf8.toBuilder
8+ , toBuilder
9+ --
9− , Utf8.fromPtr
10+ , fromPtr
10− , Utf8.fromChars
11+ , fromChars
11− , Utf8.toChars
12− -- misc
12+ --
13 , getKernel
13 , getKernel
14 , hasDot
14 , hasDot
15+ , splitDots
15 , isKernel
16 , isKernel
16 , isNumberType
17 , isNumberType
17 , isComparableType
18 , isComparableType
18 , isAppendableType
19 , isAppendableType
19 , isCompappendType
20 , isCompappendType
20 , fromVarIndex
21 , fromVarIndex
21− , fromReplCount
22 , fromWords
22 , fromWords
23 , fromManyNames
23 , fromManyNames
24 , fromTypeVariable
24 , fromTypeVariable
25 , fromTypeVariableScheme
25 , fromTypeVariableScheme
26 , sepBy
26 , sepBy
27− -- interned
27+ --
28 , int, float, bool, char, string
28 , int, float, bool, char, string
29 , maybe, result, list, array, dict, tuple, jsArray
29 , maybe, result, list, array, dict, tuple, jsArray
30 , task, router, cmd, sub, platform, virtualDom
30 , task, router, cmd, sub, platform, virtualDom
31 , shader, debug, debugger, bitwise, basics
31 , shader, debug, debugger, bitwise, basics
32 , utils, negate, true, false, value
32 , utils, negate, true, false, value
33− , node, program, main, dollar, identity
33+ , node, program, _main, _Main, dollar, identity
34− , replModule
34+ , replModule, replValueToPrint
35 )
35 )
36 where
36 where
37
37
38
38
39import Prelude hiding (length, maybe, negate)
39import Prelude hiding (length, maybe, negate)
40import Control.Exception (assert)
40import Control.Exception (assert)
41+import qualified Data.Binary as Binary
41import qualified Data.ByteString.Builder.Internal as B
42import qualified Data.ByteString.Builder.Internal as B
42−import Data.Coerce (coerce)
43+import qualified Data.Coerce as Coerce
43import qualified Data.List as List
44import qualified Data.List as List
45+import qualified Data.String as Chars
44import qualified Data.Utf8 as Utf8
46import qualified Data.Utf8 as Utf8
45−import Foreign.Ptr (plusPtr, minusPtr)
46import GHC.Exts
47import GHC.Exts
47− ( Int(I#), Ptr(Ptr)
48+ ( Int(I#), Ptr
48− , RealWorld
49 , MutableByteArray#
49 , MutableByteArray#
50 , isTrue#
50 , isTrue#
51 , newByteArray#
51 , newByteArray#
52 , sizeofByteArray#
52 , sizeofByteArray#
53− , writeWord8OffAddr#
54− , copyByteArrayToAddr#
55 , unsafeFreezeByteArray#
53 , unsafeFreezeByteArray#
56 )
54 )
57−import GHC.IO
58import GHC.ST (ST(ST), runST)
55import GHC.ST (ST(ST), runST)
59import GHC.Prim
56import GHC.Prim
60import GHC.Word (Word8(W8#))
57import GHC.Word (Word8(W8#))
61
58
59+import qualified Elm.String as ES
60+
62
61
63
62
64-- NAME
63-- NAME
65
64
66
65
67−type Name = Utf8.Under256 NAME
66+type Name =
67+ Utf8.Utf8 ELM_NAME
68
68
69
69
70−data NAME
70+data ELM_NAME
71
71
72
72
73−toUtf8 :: Name -> Utf8.String
74−toUtf8 =
75− coerce
76
73
74+-- INSTANCES
77
75
78−fromUtf8 :: Utf8.String -> Name
79−fromUtf8 =
80− coerce
81
76
77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78+ fromString = Utf8.fromChars
82
79
80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81+ get = Utf8.getUnder256
82+ put = Utf8.putUnder256
83
83
84−-- TO ESCAPED BUILDER
85
84
86
85
87−{-# INLINE toEscapedBuilder #-}
86+-- TO
88−toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
89−toEscapedBuilder before after =
90− \name -> B.builder (toEscapedBuilderHelp before after name)
91
87
92
88
93−{-# INLINE toEscapedBuilderHelp #-}
89+toChars :: Name -> [Char]
94−toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
90+toChars =
95−toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
91+ Utf8.toChars
96− go 0 (I# (sizeofByteArray# ba#))
97− where
98− go !offset !len !(B.BufferRange bOffset bEnd) =
99− let
100− !bLen = minusPtr bEnd bOffset
101− in
102− if len <= bLen then
103− do -- TODO test if writing word-by-word is faster
104− stToIO (copyToPtr name offset bOffset len)
105− stToIO (escape before after bOffset name offset len 0)
106− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
107− k newBufferRange
108− else
109− do stToIO (copyToPtr name offset bOffset bLen)
110− stToIO (escape before after bOffset name offset bLen 0)
111− let !newOffset = offset + bLen
112− let !newLength = len - bLen
113− return $ B.bufferFull 1 bEnd (go newOffset newLength)
114−
115−
116−escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
117−escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
118− if isTrue# (i# <# len#) then
119− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
120− then
121− do writeWordToPtr ptr i after
122− escape before after ptr name offset len (i + 1)
123− else
124− do escape before after ptr name offset len (i + 1)
125
92
126− else
93+
127− return ()
94+toElmString :: Name -> ES.String
95+toElmString =
96+ Coerce.coerce
97+
98+
99+{-# INLINE toBuilder #-}
100+toBuilder :: Name -> B.Builder
101+toBuilder =
102+ Utf8.toBuilder
103+
104+
105+
106+-- FROM
107+
108+
109+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110+fromPtr =
111+ Utf8.fromPtr
112+
113+
114+fromChars :: [Char] -> Name
115+fromChars =
116+ Utf8.fromChars
128
117
129
118
130
119
@@ -133,7 +122,12 @@ escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) l
133
122
134hasDot :: Name -> Bool
123hasDot :: Name -> Bool
135hasDot name =
124hasDot name =
136− Utf8.contains 0x2E {- . -} (coerce name)
125+ Utf8.contains 0x2E {- . -} name
126+
127+
128+splitDots :: Name -> [Name]
129+splitDots name =
130+ Utf8.split 0x2E {- . -} name
137
131
138
132
139
133
@@ -181,23 +175,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
181
175
182{-# NOINLINE prefix_kernel #-}
176{-# NOINLINE prefix_kernel #-}
183prefix_kernel :: Name
177prefix_kernel :: Name
184−prefix_kernel = "Elm.Kernel."
178+prefix_kernel = fromChars "Elm.Kernel."
185
179
186{-# NOINLINE prefix_number #-}
180{-# NOINLINE prefix_number #-}
187prefix_number :: Name
181prefix_number :: Name
188−prefix_number = "number"
182+prefix_number = fromChars "number"
189
183
190{-# NOINLINE prefix_comparable #-}
184{-# NOINLINE prefix_comparable #-}
191prefix_comparable :: Name
185prefix_comparable :: Name
192−prefix_comparable = "comparable"
186+prefix_comparable = fromChars "comparable"
193
187
194{-# NOINLINE prefix_appendable #-}
188{-# NOINLINE prefix_appendable #-}
195prefix_appendable :: Name
189prefix_appendable :: Name
196−prefix_appendable = "appendable"
190+prefix_appendable = fromChars "appendable"
197
191
198{-# NOINLINE prefix_compappend #-}
192{-# NOINLINE prefix_compappend #-}
199prefix_compappend :: Name
193prefix_compappend :: Name
200−prefix_compappend = "compappend"
194+prefix_compappend = fromChars "compappend"
201
195
202
196
203
197
@@ -208,11 +202,11 @@ fromVarIndex :: Int -> Name
208fromVarIndex n =
202fromVarIndex n =
209 runST
203 runST
210 (
204 (
211− do let !size = getIndexSize n
205+ do let !size = 2 + getIndexSize n
212 mba <- newByteArray size
206 mba <- newByteArray size
213 writeWord8 mba 0 0x5F {- _ -}
207 writeWord8 mba 0 0x5F {- _ -}
214 writeWord8 mba 1 0x76 {- v -}
208 writeWord8 mba 1 0x76 {- v -}
215− writeDigits mba (size - 1) n
209+ writeDigitsAtEnd mba size n
216 freeze mba
210 freeze mba
217 )
211 )
218
212
@@ -220,19 +214,20 @@ fromVarIndex n =
220{-# INLINE getIndexSize #-}
214{-# INLINE getIndexSize #-}
221getIndexSize :: Int -> Int
215getIndexSize :: Int -> Int
222getIndexSize n
216getIndexSize n
223− | n < 10 = 3
217+ | n < 10 = 1
224− | n < 100 = 4
218+ | n < 100 = 2
225− | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
226
220
227
221
228
222
229−writeDigits :: MBA s -> Int -> Int -> ST s ()
223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
230−writeDigits !mba !offset !n =
224+writeDigitsAtEnd !mba !oldOffset !n =
231 do let (q,r) = quotRem n 10
225 do let (q,r) = quotRem n 10
226+ let !newOffset = oldOffset - 1
232− writeWord8 mba offset (0x30 + fromIntegral r)
227+ writeWord8 mba newOffset (0x30 + fromIntegral r)
233 if q <= 0
228 if q <= 0
234 then return ()
229 then return ()
235− else writeDigits mba (offset-1) q
230+ else writeDigitsAtEnd mba newOffset q
236
231
237
232
238
233
@@ -255,7 +250,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
255 mba <- newByteArray size
250 mba <- newByteArray size
256 copyToMBA name mba
251 copyToMBA name mba
257 writeWord8 mba (I# len#) 0x5F {- _ -}
252 writeWord8 mba (I# len#) 0x5F {- _ -}
258− writeDigits mba (size - 1) index
253+ writeDigitsAtEnd mba size index
259 freeze mba
254 freeze mba
260 )
255 )
261 else
256 else
@@ -264,7 +259,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
264 do let !size = I# len# + getIndexSize index
259 do let !size = I# len# + getIndexSize index
265 mba <- newByteArray size
260 mba <- newByteArray size
266 copyToMBA name mba
261 copyToMBA name mba
267− writeDigits mba (size - 1) index
262+ writeDigitsAtEnd mba size index
268 freeze mba
263 freeze mba
269 )
264 )
270
265
@@ -283,61 +278,61 @@ fromTypeVariableScheme scheme =
283 freeze mba
278 freeze mba
284 else
279 else
285 do let (extra, letter) = quotRem scheme 26
280 do let (extra, letter) = quotRem scheme 26
286− let !size = getIndexSize extra
281+ let !size = 1 + getIndexSize extra
287 mba <- newByteArray size
282 mba <- newByteArray size
288 writeWord8 mba 0 (0x61 + fromIntegral letter)
283 writeWord8 mba 0 (0x61 + fromIntegral letter)
289− writeDigits mba (size - 1) extra
284+ writeDigitsAtEnd mba size extra
290 freeze mba
285 freeze mba
291 )
286 )
292
287
293
288
294
289
295−-- FROM REPL COUNT
296−
297−
298−fromReplCount :: Int -> Name
299−fromReplCount n =
300− Utf8.fromChars ("repl_value_" ++ show n)
301−
302−
303−
304-- FROM MANY NAMES
290-- FROM MANY NAMES
291+--
292+-- Creating a unique name by combining all the subnames can create names
293+-- longer than 256 bytes relatively easily. So instead, the first given name
294+-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295+--
296+-- This should be a unique name since 0.19 disallows shadowing. It would not
297+-- be possible for multiple top-level cycles to include values with the same
298+-- name, so the important thing is to make the cycle name distinct from the
299+-- normal name. Same logic for destructuring patterns like (x,y)
305
300
306
301
307fromManyNames :: [Name] -> Name
302fromManyNames :: [Name] -> Name
308fromManyNames names =
303fromManyNames names =
309− let
310− !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
311− in
312− runST
313− (
314− ST $ \s ->
315− case newByteArray# size# s of
316− (# s, mba# #) ->
317− case writeNames mba# 0# names s of
318− s ->
319− case unsafeFreezeByteArray# mba# s of
320− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
321− )
322−
323−
324−writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
325−writeNames mba# !offset# names s =
326 case names of
304 case names of
327 [] ->
305 [] ->
328− s
306+ blank
329−
307+ -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308+ -- but maybe unused patterns should be stripped out instead
309+
330− (Utf8.Utf8 ba#) : names ->
310+ Utf8.Utf8 ba# : _ ->
331− case writeWord8Array# mba# offset# 0x24## {- $ -} s of
311+ let
332− s ->
333− let
334− !offset1# = offset# +# 1#
335− !len# = sizeofByteArray# ba#
312+ len# = sizeofByteArray# ba#
336− !newOffset# = offset1# +# len#
313+ in
337− in
314+ runST
338− case copyByteArray# ba# 0# mba# offset1# len# s of
315+ (
316+ ST $ \s ->
317+ case newByteArray# (len# +# 3#) s of
339− s ->
318+ (# s, mba# #) ->
340− writeNames mba# newOffset# names s
319+ case writeWord8Array# mba# 0# 0x5F## {-_-} s of
320+ s ->
321+ case writeWord8Array# mba# 1# 0x4D## {-M-} s of
322+ s ->
323+ case writeWord8Array# mba# 2# 0x24## {-$-} s of
324+ s ->
325+ case copyByteArray# ba# 0# mba# 3# len# s of
326+ s ->
327+ case unsafeFreezeByteArray# mba# s of
328+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329+ )
330+
331+
332+{-# NOINLINE blank #-}
333+blank :: Name
334+blank =
335+ fromWords [0x5F,0x4D,0x24] {-_M$-}
341
336
342
337
343
338
@@ -423,22 +418,6 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
423 s -> (# s, () #)
418 s -> (# s, () #)
424
419
425
420
426−{-# INLINE writeWordToPtr #-}
427−writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
428−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
429− ST $ \s ->
430− case writeWord8OffAddr# addr# offset# word# s of
431− s -> (# s, () #)
432−
433−
434−{-# INLINE copyToPtr #-}
435−copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
436−copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =
437− ST $ \s ->
438− case copyByteArrayToAddr# ba# offset# addr# len# s of
439− s -> (# s, () #)
440−
441−
442{-# INLINE copyToMBA #-}
421{-# INLINE copyToMBA #-}
443copyToMBA :: Name -> MBA s -> ST s ()
422copyToMBA :: Name -> MBA s -> ST s ()
444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -453,169 +432,179 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
453
432
454{-# NOINLINE int #-}
433{-# NOINLINE int #-}
455int :: Name
434int :: Name
456−int = "Int"
435+int = fromChars "Int"
457
436
458
437
459{-# NOINLINE float #-}
438{-# NOINLINE float #-}
460float :: Name
439float :: Name
461−float = "Float"
440+float = fromChars "Float"
462
441
463
442
464{-# NOINLINE bool #-}
443{-# NOINLINE bool #-}
465bool :: Name
444bool :: Name
466−bool = "Bool"
445+bool = fromChars "Bool"
467
446
468
447
469{-# NOINLINE char #-}
448{-# NOINLINE char #-}
470char :: Name
449char :: Name
471−char = "Char"
450+char = fromChars "Char"
472
451
473
452
474{-# NOINLINE string #-}
453{-# NOINLINE string #-}
475string :: Name
454string :: Name
476−string = "String"
455+string = fromChars "String"
477
456
478
457
479{-# NOINLINE maybe #-}
458{-# NOINLINE maybe #-}
480maybe :: Name
459maybe :: Name
481−maybe = "Maybe"
460+maybe = fromChars "Maybe"
482
461
483
462
484{-# NOINLINE result #-}
463{-# NOINLINE result #-}
485result :: Name
464result :: Name
486−result = "Result"
465+result = fromChars "Result"
487
466
488
467
489{-# NOINLINE list #-}
468{-# NOINLINE list #-}
490list :: Name
469list :: Name
491−list = "List"
470+list = fromChars "List"
492
471
493
472
494{-# NOINLINE array #-}
473{-# NOINLINE array #-}
495array :: Name
474array :: Name
496−array = "Array"
475+array = fromChars "Array"
497
476
498
477
499{-# NOINLINE dict #-}
478{-# NOINLINE dict #-}
500dict :: Name
479dict :: Name
501−dict = "Dict"
480+dict = fromChars "Dict"
502
481
503
482
504{-# NOINLINE tuple #-}
483{-# NOINLINE tuple #-}
505tuple :: Name
484tuple :: Name
506−tuple = "Tuple"
485+tuple = fromChars "Tuple"
507
486
508
487
509{-# NOINLINE jsArray #-}
488{-# NOINLINE jsArray #-}
510jsArray :: Name
489jsArray :: Name
511−jsArray = "JsArray"
490+jsArray = fromChars "JsArray"
512
491
513
492
514{-# NOINLINE task #-}
493{-# NOINLINE task #-}
515task :: Name
494task :: Name
516−task = "Task"
495+task = fromChars "Task"
517
496
518
497
519{-# NOINLINE router #-}
498{-# NOINLINE router #-}
520router :: Name
499router :: Name
521−router = "Router"
500+router = fromChars "Router"
522
501
523
502
524{-# NOINLINE cmd #-}
503{-# NOINLINE cmd #-}
525cmd :: Name
504cmd :: Name
526−cmd = "Cmd"
505+cmd = fromChars "Cmd"
527
506
528
507
529{-# NOINLINE sub #-}
508{-# NOINLINE sub #-}
530sub :: Name
509sub :: Name
531−sub = "Sub"
510+sub = fromChars "Sub"
532
511
533
512
534{-# NOINLINE platform #-}
513{-# NOINLINE platform #-}
535platform :: Name
514platform :: Name
536−platform = "Platform"
515+platform = fromChars "Platform"
537
516
538
517
539{-# NOINLINE virtualDom #-}
518{-# NOINLINE virtualDom #-}
540virtualDom :: Name
519virtualDom :: Name
541−virtualDom = "VirtualDom"
520+virtualDom = fromChars "VirtualDom"
542
521
543
522
544{-# NOINLINE shader #-}
523{-# NOINLINE shader #-}
545shader :: Name
524shader :: Name
546−shader = "Shader"
525+shader = fromChars "Shader"
547
526
548
527
549{-# NOINLINE debug #-}
528{-# NOINLINE debug #-}
550debug :: Name
529debug :: Name
551−debug = "Debug"
530+debug = fromChars "Debug"
552
531
553
532
554{-# NOINLINE debugger #-}
533{-# NOINLINE debugger #-}
555debugger :: Name
534debugger :: Name
556−debugger = "Debugger"
535+debugger = fromChars "Debugger"
557
536
558
537
559{-# NOINLINE bitwise #-}
538{-# NOINLINE bitwise #-}
560bitwise :: Name
539bitwise :: Name
561−bitwise = "Bitwise"
540+bitwise = fromChars "Bitwise"
562
541
563
542
564{-# NOINLINE basics #-}
543{-# NOINLINE basics #-}
565basics :: Name
544basics :: Name
566−basics = "Basics"
545+basics = fromChars "Basics"
567
546
568
547
569{-# NOINLINE utils #-}
548{-# NOINLINE utils #-}
570utils :: Name
549utils :: Name
571−utils = "Utils"
550+utils = fromChars "Utils"
572
551
573
552
574{-# NOINLINE negate #-}
553{-# NOINLINE negate #-}
575negate :: Name
554negate :: Name
576−negate = "negate"
555+negate = fromChars "negate"
577
556
578
557
579{-# NOINLINE true #-}
558{-# NOINLINE true #-}
580true :: Name
559true :: Name
581−true = "True"
560+true = fromChars "True"
582
561
583
562
584{-# NOINLINE false #-}
563{-# NOINLINE false #-}
585false :: Name
564false :: Name
586−false = "False"
565+false = fromChars "False"
587
566
588
567
589{-# NOINLINE value #-}
568{-# NOINLINE value #-}
590value :: Name
569value :: Name
591−value = "Value"
570+value = fromChars "Value"
592
571
593
572
594{-# NOINLINE node #-}
573{-# NOINLINE node #-}
595node :: Name
574node :: Name
596−node = "Node"
575+node = fromChars "Node"
597
576
598
577
599{-# NOINLINE program #-}
578{-# NOINLINE program #-}
600program :: Name
579program :: Name
601−program = "Program"
580+program = fromChars "Program"
581+
602
582
583+{-# NOINLINE _main #-}
584+_main :: Name
585+_main = fromChars "main"
603
586
587+
604−{-# NOINLINE main #-}
588+{-# NOINLINE _Main #-}
605−main :: Name
589+_Main :: Name
606−main = "main"
590+_Main = fromChars "Main"
607
591
608
592
609{-# NOINLINE dollar #-}
593{-# NOINLINE dollar #-}
610dollar :: Name
594dollar :: Name
611−dollar = "$"
595+dollar = fromChars "$"
612
596
613
597
614{-# NOINLINE identity #-}
598{-# NOINLINE identity #-}
615identity :: Name
599identity :: Name
616−identity = "identity"
600+identity = fromChars "identity"
617
601
618
602
619{-# NOINLINE replModule #-}
603{-# NOINLINE replModule #-}
620replModule :: Name
604replModule :: Name
621−replModule = "Elm_Repl"
605+replModule = fromChars "Elm_Repl"
606+
607+
608+{-# NOINLINE replValueToPrint #-}
609+replValueToPrint :: Name
610+replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hsnew file+78
@@ -0,0 +1,78 @@
1+module Data.NonEmptyList
2+ ( List(..)
3+ , singleton
4+ , toList
5+ , sortBy
6+ )
7+ where
8+
9+
10+import Control.Monad (liftM2)
11+import Data.Binary (Binary, get, put)
12+import qualified Data.List as List
13+
14+
15+
16+-- LIST
17+
18+
19+data List a =
20+ List a [a]
21+
22+
23+singleton :: a -> List a
24+singleton a =
25+ List a []
26+
27+
28+toList :: List a -> [a]
29+toList (List x xs) =
30+ x:xs
31+
32+
33+
34+-- INSTANCES
35+
36+
37+instance Functor List where
38+ fmap func (List x xs) = List (func x) (map func xs)
39+
40+
41+instance Traversable List where
42+ traverse func (List x xs) = List <$> func x <*> traverse func xs
43+
44+
45+instance Foldable List where
46+ 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
48+ 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+39−24
@@ -3,9 +3,9 @@ module Data.OneOrMore
3 ( OneOrMore(..)
3 ( OneOrMore(..)
4 , one
4 , one
5 , more
5 , more
6− , toList
7 , map
6 , map
8 , destruct
7 , destruct
8+ , getFirstTwo
9 )
9 )
10 where
10 where
11
11
@@ -33,25 +33,6 @@ 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−
55-- MAP
36-- MAP
56
37
57
38
@@ -71,14 +52,48 @@ map func oneOrMore =
71
52
72destruct :: (a -> [a] -> b) -> OneOrMore a -> b
53destruct :: (a -> [a] -> b) -> OneOrMore a -> b
73destruct func oneOrMore =
54destruct func oneOrMore =
74− destructHelp func oneOrMore []
55+ destructLeft func oneOrMore []
75
56
76
57
77−destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
58+destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
78−destructHelp func oneOrMore xs =
59+destructLeft func oneOrMore xs =
79 case oneOrMore of
60 case oneOrMore of
80 One x ->
61 One x ->
81 func x xs
62 func x xs
82
63
83 More a b ->
64 More a b ->
84− destructHelp func a (toListHelp b xs)
65+ destructLeft func a (destructRight 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+158−300
@@ -1,36 +1,42 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Utf8
3module Data.Utf8
4− ( String
5− , Utf8(..)
4+ ( Utf8(..)
6− , VeryLong
7− , Under256
8 , isEmpty
5 , isEmpty
6+ , empty
9 , size
7 , size
10 , contains
8 , contains
11− , containsDouble
12 , startsWith
9 , startsWith
13 , startsWithChar
10 , startsWithChar
14− , endsWithWord
11+ , endsWithWord8
15 , split
12 , split
16 , join
13 , join
17− , all
14+ --
18− , any
15+ , getUnder256
19− , toWord16
16+ , putUnder256
20− , fromWord16
17+ --
21− -- conversions
18+ , getVeryLong
22− , fromChars
19+ , putVeryLong
20+ --
23 , toChars
21 , toChars
24 , toBuilder
22 , toBuilder
23+ , toEscapedBuilder
24+ --
25 , fromPtr
25 , fromPtr
26− , fromChunks
26+ , fromSnippet
27− , Chunk(..)
27+ , fromChars
28+ --
29+ , MBA
30+ , newByteArray
31+ , copyFromPtr
32+ , writeWord8
33+ , freeze
28 )
34 )
29 where
35 where
30
36
31
37
32import Prelude hiding (String, all, any, concat)
38import Prelude hiding (String, all, any, concat)
33−import Data.Binary (Binary(..), Get, getWord8, putWord8)
39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)
34import Data.Binary.Put (putBuilder)
40import Data.Binary.Put (putBuilder)
35import Data.Binary.Get.Internal (readN)
41import Data.Binary.Get.Internal (readN)
36import Data.Bits ((.&.), shiftR)
42import Data.Bits ((.&.), shiftR)
@@ -38,7 +44,6 @@ import qualified Data.ByteString.Internal as B
38import qualified Data.ByteString.Builder.Internal as B
44import qualified Data.ByteString.Builder.Internal as B
39import qualified Data.Char as Char
45import qualified Data.Char as Char
40import qualified Data.List as List
46import qualified Data.List as List
41−import Data.String (IsString(..))
42import Foreign.ForeignPtr (touchForeignPtr)
47import Foreign.ForeignPtr (touchForeignPtr)
43import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
44import Foreign.Ptr (minusPtr, plusPtr)
49import Foreign.Ptr (minusPtr, plusPtr)
@@ -53,36 +58,35 @@ import GHC.Exts
53 , copyByteArray#
58 , copyByteArray#
54 , copyAddrToByteArray#
59 , copyAddrToByteArray#
55 , copyByteArrayToAddr#
60 , copyByteArrayToAddr#
56− , writeWord8Array#,
61+ , writeWord8Array#
57 )
62 )
58import GHC.IO
63import GHC.IO
59import GHC.ST (ST(ST), runST)
64import GHC.ST (ST(ST), runST)
60import GHC.Prim
65import GHC.Prim
61−import GHC.Word (Word8(W8#), Word16(W16#))
66+import GHC.Word (Word8(W8#))
67+
68+import qualified Parse.Primitives as P
62
69
63
70
64
71
65-- UTF-8
72-- UTF-8
66
73
67
74
68−data Utf8 size tipe =
75+data Utf8 tipe =
69 Utf8 ByteArray#
76 Utf8 ByteArray#
70
77
71
78
72−type String = Utf8 VERY_LONG STRING
73−type VeryLong t = Utf8 VERY_LONG t
74−type Under256 t = Utf8 UNDER_256 t
75−
76−data STRING
77−data VERY_LONG
78−data UNDER_256
79
79
80+-- EMPTY
80
81
81
82
82−-- IS EMPTY
83+{-# NOINLINE empty #-}
84+empty :: Utf8 t
85+empty =
86+ runST (freeze =<< newByteArray 0)
83
87
84
88
85−isEmpty :: Utf8 l t -> Bool
89+isEmpty :: Utf8 t -> Bool
86isEmpty (Utf8 ba#) =
90isEmpty (Utf8 ba#) =
87 isTrue# (sizeofByteArray# ba# ==# 0#)
91 isTrue# (sizeofByteArray# ba# ==# 0#)
88
92
@@ -91,7 +95,7 @@ isEmpty (Utf8 ba#) =
91-- SIZE
95-- SIZE
92
96
93
97
94−size :: Utf8 l t -> Int
98+size :: Utf8 t -> Int
95size (Utf8 ba#) =
99size (Utf8 ba#) =
96 I# (sizeofByteArray# ba#)
100 I# (sizeofByteArray# ba#)
97
101
@@ -100,7 +104,7 @@ size (Utf8 ba#) =
100-- CONTAINS
104-- CONTAINS
101
105
102
106
103−contains :: Word8 -> Utf8 l t -> Bool
107+contains :: Word8 -> Utf8 t -> Bool
104contains (W8# word#) (Utf8 ba#) =
108contains (W8# word#) (Utf8 ba#) =
105 containsHelp word# ba# 0# (sizeofByteArray# ba#)
109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
106
110
@@ -116,32 +120,11 @@ containsHelp word# ba# !offset# len# =
116
120
117
121
118
122
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−
140-- STARTS WITH
123-- STARTS WITH
141
124
142
125
143{-# INLINE startsWith #-}
126{-# INLINE startsWith #-}
144−startsWith :: Utf8 l t -> Utf8 l t -> Bool
127+startsWith :: Utf8 t -> Utf8 t -> Bool
145startsWith (Utf8 ba1#) (Utf8 ba2#) =
128startsWith (Utf8 ba1#) (Utf8 ba2#) =
146 let
129 let
147 !len1# = sizeofByteArray# ba1#
130 !len1# = sizeofByteArray# ba1#
@@ -156,9 +139,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
156-- STARTS WITH CHAR
139-- STARTS WITH CHAR
157
140
158
141
159−startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
160−startsWithChar isGood str@(Utf8 ba#) =
143+startsWithChar isGood bytes@(Utf8 ba#) =
161− if isEmpty str then
144+ if isEmpty bytes then
162 False
145 False
163 else
146 else
164 let
147 let
@@ -176,8 +159,8 @@ startsWithChar isGood str@(Utf8 ba#) =
176-- ENDS WITH WORD
159-- ENDS WITH WORD
177
160
178
161
179−endsWithWord :: Word8 -> Utf8 l t -> Bool
162+endsWithWord8 :: Word8 -> Utf8 t -> Bool
180−endsWithWord (W8# w#) (Utf8 ba#) =
163+endsWithWord8 (W8# w#) (Utf8 ba#) =
181 let len# = sizeofByteArray# ba# in
164 let len# = sizeofByteArray# ba# in
182 isTrue# (len# ># 0#)
165 isTrue# (len# ># 0#)
183 &&
166 &&
@@ -188,12 +171,12 @@ endsWithWord (W8# w#) (Utf8 ba#) =
188-- SPLIT
171-- SPLIT
189
172
190
173
191−split :: Word8 -> String -> [String]
174+split :: Word8 -> Utf8 t -> [Utf8 t]
192split (W8# divider#) str@(Utf8 ba#) =
175split (W8# divider#) str@(Utf8 ba#) =
193 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
194
177
195
178
196−splitHelp :: String -> Int -> [Int] -> [String]
179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
197splitHelp str start offsets =
180splitHelp str start offsets =
198 case offsets of
181 case offsets of
199 [] ->
182 [] ->
@@ -214,7 +197,7 @@ findDividers divider# ba# !offset# len# revOffsets =
214 reverse revOffsets
197 reverse revOffsets
215
198
216
199
217−unsafeSlice :: String -> Int -> Int -> String
200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
218unsafeSlice str start end =
201unsafeSlice str start end =
219 let !len = end - start in
202 let !len = end - start in
220 if len == 0 then
203 if len == 0 then
@@ -230,7 +213,7 @@ unsafeSlice str start end =
230-- JOIN
213-- JOIN
231
214
232
215
233−join :: Word8 -> [String] -> String
216+join :: Word8 -> [Utf8 t] -> Utf8 t
234join sep strings =
217join sep strings =
235 case strings of
218 case strings of
236 [] ->
219 [] ->
@@ -244,7 +227,7 @@ join sep strings =
244 freeze mba
227 freeze mba
245
228
246
229
247−joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
248joinHelp sep mba offset str strings =
231joinHelp sep mba offset str strings =
249 let
232 let
250 !len = size str
233 !len = size str
@@ -262,46 +245,10 @@ joinHelp sep mba offset str strings =
262
245
263
246
264
247
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−
301-- EQUAL
248-- EQUAL
302
249
303
250
304−instance Eq (Utf8 l t) where
251+instance Eq (Utf8 t) where
305 (==) (Utf8 ba1#) (Utf8 ba2#) =
252 (==) (Utf8 ba1#) (Utf8 ba2#) =
306 let
253 let
307 !len1# = sizeofByteArray# ba1#
254 !len1# = sizeofByteArray# ba1#
@@ -314,9 +261,11 @@ instance Eq (Utf8 l t) where
314
261
315
262
316-- COMPARE
263-- COMPARE
264+--
265+-- TODO: is it fine to sort by length and only compare bytes on length ties?
266+--
317
267
318−
319−instance Ord (Utf8 l t) where
268+instance Ord (Utf8 t) where
320 compare (Utf8 ba1#) (Utf8 ba2#) =
269 compare (Utf8 ba1#) (Utf8 ba2#) =
321 let
270 let
322 !len1# = sizeofByteArray# ba1#
271 !len1# = sizeofByteArray# ba1#
@@ -333,84 +282,20 @@ instance Ord (Utf8 l t) where
333
282
334
283
335
284
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−
395-- FROM STRING
285-- FROM STRING
396
286
397
287
398−fromChars :: [Char] -> Utf8 l t
288+fromChars :: [Char] -> Utf8 t
399−fromChars =
289+fromChars chars =
400− fromString
401−
402−
403−instance IsString (Utf8 l t) where
404− fromString str =
405− runST
290+ runST
406− (
291+ (
407− do mba <- newByteArray (sum (map getWidth str))
292+ do mba <- newByteArray (sum (map getWidth chars))
408− writeString mba 0 str
293+ writeChars mba 0 chars
409− )
294+ )
410
295
411
296
412−writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
413−writeString !mba !offset chars =
298+writeChars !mba !offset chars =
414 case chars of
299 case chars of
415 [] ->
300 [] ->
416 freeze mba
301 freeze mba
@@ -418,25 +303,25 @@ writeString !mba !offset chars =
418 char : chars
303 char : chars
419 | n < 0x80 ->
304 | n < 0x80 ->
420 do writeWord8 mba (offset ) (fromIntegral n)
305 do writeWord8 mba (offset ) (fromIntegral n)
421− writeString mba (offset + 1) chars
306+ writeChars mba (offset + 1) chars
422
307
423 | n < 0x800 ->
308 | n < 0x800 ->
424 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
425 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
426− writeString mba (offset + 2) chars
311+ writeChars mba (offset + 2) chars
427
312
428 | n < 0x10000 ->
313 | n < 0x10000 ->
429 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
430 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
431 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
432− writeString mba (offset + 3) chars
317+ writeChars mba (offset + 3) chars
433
318
434 | otherwise ->
319 | otherwise ->
435 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
436 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
437 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
438 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
439− writeString mba (offset + 4) chars
324+ writeChars mba (offset + 4) chars
440
325
441 where
326 where
442 n = Char.ord char
327 n = Char.ord char
@@ -454,10 +339,10 @@ getWidth char
454
339
455
340
456
341
457−-- TO STRING
342+-- TO CHARS
458
343
459
344
460−toChars :: Utf8 l t -> [Char]
345+toChars :: Utf8 t -> [Char]
461toChars (Utf8 ba#) =
346toChars (Utf8 ba#) =
462 toCharsHelp ba# 0# (sizeofByteArray# ba#)
347 toCharsHelp ba# 0# (sizeofByteArray# ba#)
463
348
@@ -527,13 +412,13 @@ chr4 ba# offset# firstWord# =
527
412
528
413
529{-# INLINE toBuilder #-}
414{-# INLINE toBuilder #-}
530−toBuilder :: Utf8 l t -> B.Builder
415+toBuilder :: Utf8 t -> B.Builder
531toBuilder =
416toBuilder =
532 \bytes -> B.builder (toBuilderHelp bytes)
417 \bytes -> B.builder (toBuilderHelp bytes)
533
418
534
419
535{-# INLINE toBuilderHelp #-}
420{-# INLINE toBuilderHelp #-}
536−toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
537toBuilderHelp !bytes@(Utf8 ba#) k =
422toBuilderHelp !bytes@(Utf8 ba#) k =
538 go 0 (I# (sizeofByteArray# ba#))
423 go 0 (I# (sizeofByteArray# ba#))
539 where
424 where
@@ -553,144 +438,109 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
553
438
554
439
555
440
556−-- FROM PTR
441+-- TO ESCAPED BUILDER
557
442
558
443
444+{-# INLINE toEscapedBuilder #-}
559−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
560−fromPtr pos end =
446+toEscapedBuilder before after =
561− unsafeDupablePerformIO (stToIO (
447+ \name -> B.builder (toEscapedBuilderHelp before after name)
562− do let !len = minusPtr end pos
563− mba <- newByteArray len
564− copyFromPtr pos mba 0 len
565− freeze mba
566− ))
567
448
568
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 ()
569
485
570−-- FROM CHUNKS
571
486
572
487
573−data Chunk
488+-- FROM PTR
574− = Slice (Ptr Word8) Int
575− | Escape Word8
576− | CodePoint Int
577
489
578
490
579−fromChunks :: [Chunk] -> Utf8 l t
491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
580−fromChunks chunks =
492+fromPtr pos end =
581 unsafeDupablePerformIO (stToIO (
493 unsafeDupablePerformIO (stToIO (
582− do let !len = sum (map chunkToWidth chunks)
494+ do let !len = minusPtr end pos
583 mba <- newByteArray len
495 mba <- newByteArray len
584− writeChunks mba 0 chunks
496+ copyFromPtr pos mba 0 len
585 freeze mba
497 freeze mba
586 ))
498 ))
587
499
588
500
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)
649
501
502+-- FROM SNIPPET
650
503
651
504
652−-- UNDER 256 BINARY
505+fromSnippet :: P.Snippet -> Utf8 t
653−
506+fromSnippet (P.Snippet fptr off len _ _) =
654−
507+ unsafeDupablePerformIO (stToIO (
655−instance Binary (Utf8 UNDER_256 t) where
508+ do mba <- newByteArray len
656− put bytes@(Utf8 ba#) =
509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
657− do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
510+ copyFromPtr pos mba 0 len
658− putBuilder (toBuilder bytes)
511+ freeze mba
659− get =
512+ ))
660− getUnder256 =<< getWord8
661
513
662
514
663−{-# INLINE getUnder256 #-}
664−getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
665−getUnder256 w =
666− let !n = fromIntegral w in
667− readN n (copyFromByteString n)
668
515
516+-- BINARY
669
517
670
518
671−-- VERY LONG BINARY
519+putUnder256 :: Utf8 t -> Put
520+putUnder256 bytes =
521+ do putWord8 (fromIntegral (size bytes))
522+ putBuilder (toBuilder bytes)
672
523
673
524
674−instance Binary (Utf8 VERY_LONG t) where
525+getUnder256 :: Get (Utf8 t)
675− put str =
526+getUnder256 =
676− do put (size str)
527+ do word <- getWord8
677− putBuilder (toBuilder str)
528+ let !n = fromIntegral word
678− get =
529+ readN n (copyFromByteString n)
679− getVeryLong =<< get
680
530
681
531
682−{-# INLINE getVeryLong #-}
532+putVeryLong :: Utf8 t -> Put
683−getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
533+putVeryLong bytes =
684−getVeryLong n =
534+ do put (size bytes)
685− if n > 0
535+ putBuilder (toBuilder bytes)
686− then readN n (copyFromByteString n)
687− else return empty
688
536
689
537
690−{-# NOINLINE empty #-}
538+getVeryLong :: Get (Utf8 t)
691−empty :: Utf8 l t
539+getVeryLong =
692−empty =
540+ do n <- get
693− runST (freeze =<< newByteArray 0)
541+ if n > 0
542+ then readN n (copyFromByteString n)
543+ else return empty
694
544
695
545
696
546
@@ -698,7 +548,7 @@ empty =
698
548
699
549
700{-# INLINE copyFromByteString #-}
550{-# INLINE copyFromByteString #-}
701−copyFromByteString :: Int -> B.ByteString -> Utf8 l t
551+copyFromByteString :: Int -> B.ByteString -> Utf8 t
702copyFromByteString len (B.PS fptr offset _) =
552copyFromByteString len (B.PS fptr offset _) =
703 unsafeDupablePerformIO
553 unsafeDupablePerformIO
704 (
554 (
@@ -717,21 +567,21 @@ data MBA s =
717 MBA# (MutableByteArray# s)
567 MBA# (MutableByteArray# s)
718
568
719
569
720−newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
721newByteArray (I# len#) =
571newByteArray (I# len#) =
722 ST $ \s ->
572 ST $ \s ->
723 case newByteArray# len# s of
573 case newByteArray# len# s of
724 (# s, mba# #) -> (# s, MBA# mba# #)
574 (# s, mba# #) -> (# s, MBA# mba# #)
725
575
726
576
727−freeze :: MBA s -> ST s (Utf8 l t)
577+freeze :: MBA s -> ST s (Utf8 t)
728freeze (MBA# mba#) =
578freeze (MBA# mba#) =
729 ST $ \s ->
579 ST $ \s ->
730 case unsafeFreezeByteArray# mba# s of
580 case unsafeFreezeByteArray# mba# s of
731 (# s, ba# #) -> (# s, Utf8 ba# #)
581 (# s, ba# #) -> (# s, Utf8 ba# #)
732
582
733
583
734−copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
735copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
736 ST $ \s ->
586 ST $ \s ->
737 case copyByteArray# ba# offset# mba# i# len# s of
587 case copyByteArray# ba# offset# mba# i# len# s of
@@ -745,11 +595,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
745 s -> (# s, () #)
595 s -> (# s, () #)
746
596
747
597
748−copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
750− IO $ \s ->
600+ IO $ \s ->
751− case copyByteArrayToAddr# ba# offset# mba# len# s of
601+ case copyByteArrayToAddr# ba# offset# mba# len# s of
752− s -> (# s, () #)
602+ s -> (# s, () #)
753
603
754
604
755{-# INLINE writeWord8 #-}
605{-# INLINE writeWord8 #-}
@@ -758,3 +608,11 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
758 ST $ \s ->
608 ST $ \s ->
759 case writeWord8Array# mba# offset# w# s of
609 case writeWord8Array# mba# offset# w# s of
760 s -> (# s, () #)
610 s -> (# s, () #)
611+
612+
613+{-# INLINE writeWordToPtr #-}
614+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
615+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
616+ IO $ \s ->
617+ case writeWord8OffAddr# addr# offset# word# s of
618+ s -> (# s, () #)
compiler/src/Elm/Compiler.hsdeleted−99
@@ -1,99 +0,0 @@
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+4−13
@@ -1,7 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Imports
3module Elm.Compiler.Imports
4− ( addDefaults
4+ ( defaults
5 )
5 )
6 where
6 where
7
7
@@ -14,15 +14,6 @@ import qualified Reporting.Annotation as A
14
14
15
15
16
16
17−-- ADD DEFAULTS
18−
19−
20−addDefaults :: [Src.Import] -> [Src.Import]
21−addDefaults imports =
22− defaults ++ imports
23−
24−
25−
26-- DEFAULTS
17-- DEFAULTS
27
18
28
19
@@ -58,14 +49,14 @@ closed =
58
49
59typeOpen :: Name.Name -> Src.Exposing
50typeOpen :: Name.Name -> Src.Exposing
60typeOpen name =
51typeOpen name =
61− Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
62
53
63
54
64typeClosed :: Name.Name -> Src.Exposing
55typeClosed :: Name.Name -> Src.Exposing
65typeClosed name =
56typeClosed name =
66− Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
67
58
68
59
69operator :: Name.Name -> Src.Exposing
60operator :: Name.Name -> Src.Exposing
70operator op =
61operator op =
71− Src.Explicit [ A.At A.zero (Src.Operator op) ]
62+ Src.Explicit [ Src.Operator A.zero op ]
compiler/src/Elm/Compiler/Type.hs+33−35
@@ -15,21 +15,19 @@ module Elm.Compiler.Type
15
15
16
16
17import qualified Data.Name as Name
17import qualified Data.Name as Name
18−import qualified Data.Text as Text
19−import qualified Data.Text.Encoding as Text
20
18
21import qualified AST.Source as Src
19import qualified AST.Source as Src
20+import qualified Json.Decode as D
21+import qualified Json.Encode as E
22+import Json.Encode ((==>))
23+import qualified Json.String as Json
22−import qualified Parse.Primitives as Parse
24+import qualified Parse.Primitives as P
23import qualified Parse.Type as Type
25import qualified Parse.Type as Type
24import qualified Reporting.Annotation as A
26import qualified Reporting.Annotation as A
25import qualified Reporting.Doc as D
27import qualified Reporting.Doc as D
26import qualified Reporting.Render.Type as RT
28import qualified Reporting.Render.Type as RT
27import qualified Reporting.Render.Type.Localizer as L
29import qualified Reporting.Render.Type.Localizer as L
28
30
29−import qualified Json.Decode as Decode
30−import qualified Json.Encode as Encode
31−import Json.Encode ((==>))
32−
33
31
34
32
35-- TYPES
33-- TYPES
@@ -113,20 +111,18 @@ collectLambdas tipe =
113-- JSON for TYPE
111-- JSON for TYPE
114
112
115
113
116−encode :: Type -> Encode.Value
114+encode :: Type -> E.Value
117encode tipe =
115encode tipe =
118− Encode.text $ Text.pack $ D.toLine (toDoc L.empty RT.None tipe)
116+ E.chars $ D.toLine (toDoc L.empty RT.None tipe)
119
117
120
118
121−decoder :: Decode.Decoder () Type
119+decoder :: D.Decoder () Type
122decoder =
120decoder =
123− do txt <- Decode.text
121+ let
124− case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
122+ parser =
125− Left _ ->
123+ P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
126− Decode.fail ()
124+ in
127−
125+ D.customString parser (\_ _ -> ())
128− Right (tipe, _, _) ->
129− Decode.succeed (fromRawType tipe)
130
126
131
127
132fromRawType :: Src.Type -> Type
128fromRawType :: Src.Type -> Type
@@ -164,33 +160,35 @@ fromRawType (A.At _ astType) =
164-- JSON for PROGRAM
160-- JSON for PROGRAM
165
161
166
162
167−encodeMetadata :: DebugMetadata -> Encode.Value
163+encodeMetadata :: DebugMetadata -> E.Value
168encodeMetadata (DebugMetadata msg aliases unions) =
164encodeMetadata (DebugMetadata msg aliases unions) =
169− Encode.object
165+ E.object
170 [ "message" ==> encode msg
166 [ "message" ==> encode msg
171− , "aliases" ==> Encode.object (map toAliasField aliases)
167+ , "aliases" ==> E.object (map toTypeAliasField aliases)
172− , "unions" ==> Encode.object (map toUnionField unions)
168+ , "unions" ==> E.object (map toCustomTypeField unions)
173 ]
169 ]
174
170
175
171
176−toAliasField :: Alias -> ( Text.Text, Encode.Value )
172+toTypeAliasField :: Alias -> ( Json.String, E.Value )
177−toAliasField (Alias name args tipe) =
173+toTypeAliasField (Alias name args tipe) =
178− Name.toText name ==>
174+ ( Json.fromName name
179− Encode.object
175+ , E.object
180− [ "args" ==> Encode.list Encode.name args
176+ [ "args" ==> E.list E.name args
181 , "type" ==> encode tipe
177 , "type" ==> encode tipe
182 ]
178 ]
179+ )
183
180
184
181
185−toUnionField :: Union -> ( Text.Text, Encode.Value )
182+toCustomTypeField :: Union -> ( Json.String, E.Value )
186−toUnionField (Union name args constructors) =
183+toCustomTypeField (Union name args constructors) =
187− Name.toText name ==>
184+ ( Json.fromName name
188− Encode.object
185+ , E.object
189− [ "args" ==> Encode.list Encode.name args
186+ [ "args" ==> E.list E.name args
190− , "tags" ==> Encode.object (map toCtorObject constructors)
187+ , "tags" ==> E.object (map toVariantObject constructors)
191 ]
188 ]
189+ )
192
190
193
191
194−toCtorObject :: (Name.Name, [Type]) -> ( Text.Text, Encode.Value )
192+toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
195−toCtorObject (name, args) =
193+toVariantObject (name, args) =
196− Name.toText name ==> Encode.list encode args
194+ ( Json.fromName name, E.list encode args )
compiler/src/Elm/Compiler/Type/Extract.hs+69−20
@@ -1,15 +1,20 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}
3−{-# LANGUAGE Rank2Types #-}
4module Elm.Compiler.Type.Extract
3module Elm.Compiler.Type.Extract
5 ( fromAnnotation
4 ( fromAnnotation
6 , fromType
5 , fromType
6+ , Types(..)
7+ , mergeMany
8+ , merge
9+ , fromInterface
10+ , fromDependencyInterface
7 , fromMsg
11 , fromMsg
8 )
12 )
9 where
13 where
10
14
11
15
12import Data.Map ((!))
16import Data.Map ((!))
17+import qualified Data.Map as Map
13import qualified Data.Maybe as Maybe
18import qualified Data.Maybe as Maybe
14import qualified Data.Name as Name
19import qualified Data.Name as Name
15import qualified Data.Set as Set
20import qualified Data.Set as Set
@@ -77,23 +82,70 @@ toPublicName (ModuleName.Canonical _ home) name =
77
82
78
83
79
84
85+-- TRANSITIVELY AVAILABLE TYPES
86+
87+
88+newtype Types =
89+ Types (Map.Map ModuleName.Canonical Types_)
90+ -- PERF profile Opt.Global representation
91+ -- current representation needs less allocation
92+ -- but maybe the lookup is much worse
93+
94+
95+data Types_ =
96+ Types_
97+ { _union_info :: Map.Map Name.Name Can.Union
98+ , _alias_info :: Map.Map Name.Name Can.Alias
99+ }
100+
101+
102+mergeMany :: [Types] -> Types
103+mergeMany listOfTypes =
104+ case listOfTypes of
105+ [] -> Types Map.empty
106+ t:ts -> foldr merge t ts
107+
108+
109+merge :: Types -> Types -> Types
110+merge (Types types1) (Types types2) =
111+ Types (Map.union types1 types2)
112+
113+
114+fromInterface :: ModuleName.Raw -> I.Interface -> Types
115+fromInterface name (I.Interface pkg _ unions aliases _) =
116+ Types $ Map.singleton (ModuleName.Canonical pkg name) $
117+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
118+
119+
120+fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types
121+fromDependencyInterface home di =
122+ Types $ Map.singleton home $
123+ case di of
124+ I.Public (I.Interface _ _ unions aliases _) ->
125+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)
126+
127+ I.Private _ unions aliases ->
128+ Types_ unions aliases
129+
130+
131+
80-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
132-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
81
133
82
134
83−fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
135+fromMsg :: Types -> Can.Type -> T.DebugMetadata
84−fromMsg interfaces message =
136+fromMsg types message =
85 let
137 let
86 (msgDeps, msgType) =
138 (msgDeps, msgType) =
87 run (extract message)
139 run (extract message)
88
140
89 (aliases, unions) =
141 (aliases, unions) =
90− extractTransitive interfaces noDeps msgDeps
142+ extractTransitive types noDeps msgDeps
91 in
143 in
92 T.DebugMetadata msgType aliases unions
144 T.DebugMetadata msgType aliases unions
93
145
94
146
95−extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
147+extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )
96−extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
148+extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
97 let
149 let
98 aliases = Set.difference nextAliases seenAliases
150 aliases = Set.difference nextAliases seenAliases
99 unions = Set.difference nextUnions seenUnions
151 unions = Set.difference nextUnions seenUnions
@@ -106,39 +158,36 @@ extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nex
106 (newDeps, result) =
158 (newDeps, result) =
107 run $
159 run $
108 (,)
160 (,)
109− <$> traverse (extractAlias interfaces) (Set.toList aliases)
161+ <$> traverse (extractAlias types) (Set.toList aliases)
110− <*> traverse (extractUnion interfaces) (Set.toList unions)
162+ <*> traverse (extractUnion types) (Set.toList unions)
111
163
112 oldDeps =
164 oldDeps =
113 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
165 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
114
166
115 remainingResult =
167 remainingResult =
116− extractTransitive interfaces oldDeps newDeps
168+ extractTransitive types oldDeps newDeps
117 in
169 in
118 mappend result remainingResult
170 mappend result remainingResult
119
171
120
172
121−extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
173+extractAlias :: Types -> Opt.Global -> Extractor T.Alias
122−extractAlias interfaces (Opt.Global home name) =
174+extractAlias (Types dict) (Opt.Global home name) =
123 let
175 let
124− (I.Interface _ _ aliases _) = interfaces ! home
125− (Can.Alias args aliasType) = I.toAliasInternals (aliases ! name)
176+ (Can.Alias args aliasType) = _alias_info (dict ! home) ! name
126 in
177 in
127 T.Alias (toPublicName home name) args <$> extract aliasType
178 T.Alias (toPublicName home name) args <$> extract aliasType
128
179
129
180
130−extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
181+extractUnion :: Types -> Opt.Global -> Extractor T.Union
131−extractUnion interfaces (Opt.Global home name) =
182+extractUnion (Types dict) (Opt.Global home name) =
132 if name == Name.list && home == ModuleName.list
183 if name == Name.list && home == ModuleName.list
133 then return $ T.Union (toPublicName home name) ["a"] []
184 then return $ T.Union (toPublicName home name) ["a"] []
134 else
185 else
135 let
186 let
136 pname = toPublicName home name
187 pname = toPublicName home name
137− unions = I._unions (interfaces ! home)
188+ (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name
138 in
189 in
139− case I.toUnionInternals (unions ! name) of
140− Can.Union vars ctors _ _ ->
141− T.Union pname vars <$> traverse extractCtor ctors
190+ T.Union pname vars <$> traverse extractCtor ctors
142
191
143
192
144extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
193extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
compiler/src/Elm/Constraint.hs+55−77
@@ -5,9 +5,6 @@ module Elm.Constraint
5 , exactly
5 , exactly
6 , anything
6 , anything
7 , toChars
7 , toChars
8− , toString
9− , Error(..)
10− , fromString
11 , satisfies
8 , satisfies
12 , check
9 , check
13 , intersect
10 , intersect
@@ -16,6 +13,8 @@ module Elm.Constraint
16 , untilNextMajor
13 , untilNextMajor
17 , untilNextMinor
14 , untilNextMinor
18 , expand
15 , expand
16+ --
17+ , Error(..)
19 , decoder
18 , decoder
20 , encode
19 , encode
21 )
20 )
@@ -24,11 +23,12 @@ module Elm.Constraint
24
23
25import Control.Monad (liftM4)
24import Control.Monad (liftM4)
26import Data.Binary (Binary, get, put, getWord8, putWord8)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
27−import qualified Data.Utf8 as Utf8
28
26
29import qualified Elm.Version as V
27import qualified Elm.Version as V
30import qualified Json.Decode as D
28import qualified Json.Decode as D
31import qualified Json.Encode as E
29import qualified Json.Encode as E
30+import qualified Parse.Primitives as P
31+import Parse.Primitives (Row, Col)
32
32
33
33
34
34
@@ -61,78 +61,21 @@ anything =
61
61
62
62
63
63
64−-- TO STRING
64+-- TO CHARS
65
65
66
66
67−toChars :: Constraint -> String
67+toChars :: Constraint -> [Char]
68toChars constraint =
68toChars constraint =
69− Utf8.toChars (toString constraint)
70−
71−
72−toString :: Constraint -> Utf8.String
73−toString constraint =
74 case constraint of
69 case constraint of
75 Range lower lowerOp upperOp upper ->
70 Range lower lowerOp upperOp upper ->
76− Utf8.join 0x20 {- -}
71+ V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
77− [ V.toString lower
78− , toStringHelp lowerOp
79− , "v"
80− , toStringHelp upperOp
81− , V.toString upper
82− ]
83
72
84
73
85−toStringHelp :: Op -> Utf8.String
74+opToChars :: Op -> [Char]
86−toStringHelp op =
75+opToChars op =
87 case op of
76 case op of
88− Less -> "<"
77+ Less -> " < "
89− LessOrEqual -> "<="
78+ LessOrEqual -> " <= "
90−
91−
92−
93−-- FROM STRING
94−
95−
96−data Error
97− = BadLower Utf8.String
98− | BadUpper Utf8.String
99− | BadFormat
100− | InvalidOp
101− | InvalidRange V.Version V.Version
102−
103−
104−fromString :: Utf8.String -> Either Error Constraint
105−fromString string =
106− case Utf8.split 0x20 {- -} string of
107− [lower, lowerOp, "v", upperOp, upper] ->
108− do lo <- versionFromString lower BadLower
109− lop <- opFromString lowerOp
110− hop <- opFromString upperOp
111− hi <- versionFromString upper BadUpper
112− if lo < hi
113− then Right (Range lo lop hop hi)
114− else Left (InvalidRange lo hi)
115−
116− _ ->
117− Left BadFormat
118−
119−
120−versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version
121−versionFromString string toError =
122− case V.fromString string of
123− Just vsn ->
124− Right vsn
125−
126− Nothing ->
127− Left (toError string)
128−
129−
130−opFromString :: Utf8.String -> Either Error Op
131−opFromString text =
132− case text of
133− "<=" -> Right LessOrEqual
134− "<" -> Right Less
135− _ -> Left InvalidOp
136
79
137
80
138
81
@@ -245,18 +188,12 @@ expand constraint@(Range lower lowerOp upperOp upper) version
245
188
246encode :: Constraint -> E.Value
189encode :: Constraint -> E.Value
247encode constraint =
190encode constraint =
248− E.string (toString constraint)
191+ E.chars (toChars constraint)
249
192
250
193
251decoder :: D.Decoder Error Constraint
194decoder :: D.Decoder Error Constraint
252decoder =
195decoder =
253− do str <- D.string
196+ D.customString parser BadFormat
254− case fromString str of
255− Right constraint ->
256− return constraint
257−
258− Left err ->
259− D.failure err
260
197
261
198
262
199
@@ -279,4 +216,45 @@ instance Binary Op where
279 case n of
216 case n of
280 0 -> return Less
217 0 -> return Less
281 1 -> return LessOrEqual
218 1 -> return LessOrEqual
282− _ -> error "binary encoding of Op was corrupted"
219+ _ -> fail "binary encoding of Op was corrupted"
220+
221+
222+
223+-- PARSER
224+
225+
226+data Error
227+ = BadFormat Row Col
228+ | InvalidRange V.Version V.Version
229+
230+
231+parser :: P.Parser Error Constraint
232+parser =
233+ do lower <- parseVersion
234+ P.word1 0x20 {- -} BadFormat
235+ loOp <- parseOp
236+ P.word1 0x20 {- -} BadFormat
237+ P.word1 0x76 {-v-} BadFormat
238+ P.word1 0x20 {- -} BadFormat
239+ hiOp <- parseOp
240+ P.word1 0x20 {- -} BadFormat
241+ higher <- parseVersion
242+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
243+ if lower < higher
244+ then eok (Range lower loOp hiOp higher) state
245+ else eerr row col (\_ _ -> InvalidRange lower higher)
246+
247+
248+parseVersion :: P.Parser Error V.Version
249+parseVersion =
250+ P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser
251+
252+
253+parseOp :: P.Parser Error Op
254+parseOp =
255+ do P.word1 0x3C {-<-} BadFormat
256+ P.oneOfWithFallback
257+ [ do P.word1 0x3D {-=-} BadFormat
258+ return LessOrEqual
259+ ]
260+ Less
compiler/src/Elm/Docs.hs+218−158
@@ -1,8 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
3module Elm.Docs
3module Elm.Docs
4 ( Documentation
4 ( Documentation
5− , toDict
6 , Module(..)
5 , Module(..)
7 , fromModule
6 , fromModule
8 , Union(..)
7 , Union(..)
@@ -18,33 +17,35 @@ module Elm.Docs
18 where
17 where
19
18
20
19
21−import qualified Data.ByteString as B
20+import qualified Data.Coerce as Coerce
22import qualified Data.List as List
21import qualified Data.List as List
23import Data.Map ((!))
22import Data.Map ((!))
24import qualified Data.Map as Map
23import qualified Data.Map as Map
24+import qualified Data.Map.Merge.Strict as Map
25import qualified Data.Name as Name
25import qualified Data.Name as Name
26−import qualified Data.Text as Text
26+import qualified Data.NonEmptyList as NE
27−import qualified Data.Text.Encoding as Text
27+import qualified Data.OneOrMore as OneOrMore
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr)
28
30
29import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
32+import qualified AST.Source as Src
30import qualified AST.Utils.Binop as Binop
33import qualified AST.Utils.Binop as Binop
31−import qualified Data.OneOrMore as OneOrMore
32import qualified Elm.Compiler.Type as Type
34import qualified Elm.Compiler.Type as Type
33import qualified Elm.Compiler.Type.Extract as Extract
35import qualified Elm.Compiler.Type.Extract as Extract
34import qualified Elm.ModuleName as ModuleName
36import qualified Elm.ModuleName as ModuleName
35import qualified Json.Decode as D
37import qualified Json.Decode as D
36import qualified Json.Encode as E
38import qualified Json.Encode as E
37import Json.Encode ((==>))
39import Json.Encode ((==>))
40+import qualified Json.String as Json
41+import Parse.Primitives (Row, Col, word1)
42+import qualified Parse.Primitives as P
43+import qualified Parse.Space as Space
44+import qualified Parse.Symbol as Symbol
45+import qualified Parse.Variable as Var
38import qualified Reporting.Annotation as A
46import qualified Reporting.Annotation as A
39−import qualified Reporting.Error as Error
40import qualified Reporting.Error.Docs as E
47import qualified Reporting.Error.Docs as E
41−import qualified Reporting.Region as R
42import qualified Reporting.Result as Result
48import qualified Reporting.Result as Result
43−import Parse.Primitives (Parser)
44−import qualified Parse.Primitives as P
45−import qualified Parse.Primitives.Symbol as Symbol
46−import qualified Parse.Primitives.Variable as Var
47−import qualified Parse.Primitives.Whitespace as W
48
49
49
50
50
51
@@ -55,21 +56,6 @@ type Documentation =
55 Map.Map Name.Name Module
56 Map.Map Name.Name Module
56
57
57
58
58−toDict :: [Module] -> Documentation
59−toDict modules =
60− Map.fromList (map toPair modules)
61−
62−
63−
64−toPair :: Module -> (Name.Name, Module)
65−toPair modul@(Module name _ _ _ _ _) =
66− (name, modul)
67−
68−
69−
70−-- MODULES
71−
72−
73data Module =
59data Module =
74 Module
60 Module
75 { _name :: Name.Name
61 { _name :: Name.Name
@@ -80,9 +66,7 @@ data Module =
80 , _binops :: Map.Map Name.Name Binop
66 , _binops :: Map.Map Name.Name Binop
81 }
67 }
82
68
83−
84−type Comment = Text.Text
69+type Comment = Json.String
85−
86
70
87data Alias = Alias Comment [Name.Name] Type.Type
71data Alias = Alias Comment [Name.Name] Type.Type
88data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -91,14 +75,19 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
91
75
92
76
93
77
94−-- JSON ENCODE / DECODE
78+-- JSON
79+
80+
81+encode :: Documentation -> E.Value
82+encode docs =
83+ E.list encodeModule (Map.elems docs)
95
84
96
85
97−encode :: Module -> E.Value
86+encodeModule :: Module -> E.Value
98−encode (Module name comment unions aliases values binops) =
87+encodeModule (Module name comment unions aliases values binops) =
99 E.object $
88 E.object $
100 [ "name" ==> ModuleName.encode name
89 [ "name" ==> ModuleName.encode name
101− , "comment" ==> E.text comment
90+ , "comment" ==> E.string comment
102 , "unions" ==> E.list encodeUnion (Map.toList unions)
91 , "unions" ==> E.list encodeUnion (Map.toList unions)
103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
92 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
104 , "values" ==> E.list encodeValue (Map.toList values)
93 , "values" ==> E.list encodeValue (Map.toList values)
@@ -107,16 +96,31 @@ encode (Module name comment unions aliases values binops) =
107
96
108
97
109data Error
98data Error
110− = BadAssociativity Text.Text
99+ = BadAssociativity
111− | BadName
100+ | BadModuleName
112 | BadType
101 | BadType
113
102
114
103
115−decoder :: D.Decoder Error Module
104+decoder :: D.Decoder Error Documentation
116decoder =
105decoder =
106+ toDict <$> D.list moduleDecoder
107+
108+
109+toDict :: [Module] -> Documentation
110+toDict modules =
111+ Map.fromList (map toDictHelp modules)
112+
113+
114+toDictHelp :: Module -> (Name.Name, Module)
115+toDictHelp modul@(Module name _ _ _ _ _) =
116+ (name, modul)
117+
118+
119+moduleDecoder :: D.Decoder Error Module
120+moduleDecoder =
117 Module
121 Module
118− <$> D.field "name" nameDecoder
122+ <$> D.field "name" moduleNameDecoder
119− <*> D.field "comment" D.text
123+ <*> D.field "comment" D.string
120 <*> D.field "unions" (dictDecoder union)
124 <*> D.field "unions" (dictDecoder union)
121 <*> D.field "aliases" (dictDecoder alias)
125 <*> D.field "aliases" (dictDecoder alias)
122 <*> D.field "values" (dictDecoder value)
126 <*> D.field "values" (dictDecoder value)
@@ -131,13 +135,18 @@ dictDecoder entryDecoder =
131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
132named entryDecoder =
136named entryDecoder =
133 (,)
137 (,)
134− <$> D.field "name" D.name
138+ <$> D.field "name" nameDecoder
135 <*> entryDecoder
139 <*> entryDecoder
136
140
137
141
138−nameDecoder :: D.Decoder Error Name.Name
142+nameDecoder :: D.Decoder e Name.Name
139nameDecoder =
143nameDecoder =
144+ fmap Coerce.coerce D.string
145+
146+
147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148+moduleNameDecoder =
140− D.mapError (const BadName) ModuleName.decoder
149+ D.mapError (const BadModuleName) ModuleName.decoder
141
150
142
151
143typeDecoder :: D.Decoder Error Type.Type
152typeDecoder :: D.Decoder Error Type.Type
@@ -153,7 +162,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
153encodeUnion (name, Union comment args cases) =
162encodeUnion (name, Union comment args cases) =
154 E.object
163 E.object
155 [ "name" ==> E.name name
164 [ "name" ==> E.name name
156− , "comment" ==> E.text comment
165+ , "comment" ==> E.string comment
157 , "args" ==> E.list E.name args
166 , "args" ==> E.list E.name args
158 , "cases" ==> E.list encodeCase cases
167 , "cases" ==> E.list encodeCase cases
159 ]
168 ]
@@ -162,8 +171,8 @@ encodeUnion (name, Union comment args cases) =
162union :: D.Decoder Error Union
171union :: D.Decoder Error Union
163union =
172union =
164 Union
173 Union
165− <$> D.field "comment" D.text
174+ <$> D.field "comment" D.string
166− <*> D.field "args" (D.list D.name)
175+ <*> D.field "args" (D.list nameDecoder)
167 <*> D.field "cases" (D.list caseDecoder)
176 <*> D.field "cases" (D.list caseDecoder)
168
177
169
178
@@ -174,7 +183,7 @@ encodeCase ( tag, args ) =
174
183
175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
176caseDecoder =
185caseDecoder =
177− D.pair D.name (D.list typeDecoder)
186+ D.pair nameDecoder (D.list typeDecoder)
178
187
179
188
180
189
@@ -185,7 +194,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
185encodeAlias ( name, Alias comment args tipe) =
194encodeAlias ( name, Alias comment args tipe) =
186 E.object
195 E.object
187 [ "name" ==> E.name name
196 [ "name" ==> E.name name
188− , "comment" ==> E.text comment
197+ , "comment" ==> E.string comment
189 , "args" ==> E.list E.name args
198 , "args" ==> E.list E.name args
190 , "type" ==> Type.encode tipe
199 , "type" ==> Type.encode tipe
191 ]
200 ]
@@ -194,8 +203,8 @@ encodeAlias ( name, Alias comment args tipe) =
194alias :: D.Decoder Error Alias
203alias :: D.Decoder Error Alias
195alias =
204alias =
196 Alias
205 Alias
197− <$> D.field "comment" D.text
206+ <$> D.field "comment" D.string
198− <*> D.field "args" (D.list D.name)
207+ <*> D.field "args" (D.list nameDecoder)
199 <*> D.field "type" typeDecoder
208 <*> D.field "type" typeDecoder
200
209
201
210
@@ -207,7 +216,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
207encodeValue (name, Value comment tipe) =
216encodeValue (name, Value comment tipe) =
208 E.object
217 E.object
209 [ "name" ==> E.name name
218 [ "name" ==> E.name name
210− , "comment" ==> E.text comment
219+ , "comment" ==> E.string comment
211 , "type" ==> Type.encode tipe
220 , "type" ==> Type.encode tipe
212 ]
221 ]
213
222
@@ -215,7 +224,7 @@ encodeValue (name, Value comment tipe) =
215value :: D.Decoder Error Value
224value :: D.Decoder Error Value
216value =
225value =
217 Value
226 Value
218− <$> D.field "comment" D.text
227+ <$> D.field "comment" D.string
219 <*> D.field "type" typeDecoder
228 <*> D.field "type" typeDecoder
220
229
221
230
@@ -227,7 +236,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
227encodeBinop (name, Binop comment tipe assoc prec) =
236encodeBinop (name, Binop comment tipe assoc prec) =
228 E.object
237 E.object
229 [ "name" ==> E.name name
238 [ "name" ==> E.name name
230− , "comment" ==> E.text comment
239+ , "comment" ==> E.string comment
231 , "type" ==> Type.encode tipe
240 , "type" ==> Type.encode tipe
232 , "associativity" ==> encodeAssoc assoc
241 , "associativity" ==> encodeAssoc assoc
233 , "precedence" ==> encodePrec prec
242 , "precedence" ==> encodePrec prec
@@ -237,7 +246,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
237binop :: D.Decoder Error Binop
246binop :: D.Decoder Error Binop
238binop =
247binop =
239 Binop
248 Binop
240− <$> D.field "comment" D.text
249+ <$> D.field "comment" D.string
241 <*> D.field "type" typeDecoder
250 <*> D.field "type" typeDecoder
242 <*> D.field "associativity" assocDecoder
251 <*> D.field "associativity" assocDecoder
243 <*> D.field "precedence" precDecoder
252 <*> D.field "precedence" precDecoder
@@ -250,19 +259,23 @@ binop =
250encodeAssoc :: Binop.Associativity -> E.Value
259encodeAssoc :: Binop.Associativity -> E.Value
251encodeAssoc assoc =
260encodeAssoc assoc =
252 case assoc of
261 case assoc of
253− Binop.Left -> E.text "left"
262+ Binop.Left -> E.chars "left"
254− Binop.Non -> E.text "non"
263+ Binop.Non -> E.chars "non"
255− Binop.Right -> E.text "right"
264+ Binop.Right -> E.chars "right"
256
265
257
266
258assocDecoder :: D.Decoder Error Binop.Associativity
267assocDecoder :: D.Decoder Error Binop.Associativity
259assocDecoder =
268assocDecoder =
260− do txt <- D.text
269+ let
261− case txt of
270+ left = Json.fromChars "left"
271+ non = Json.fromChars "non"
272+ right = Json.fromChars "right"
273+ in
274+ do str <- D.string
262− "left" -> D.succeed Binop.Left
275+ if | str == left -> return Binop.Left
263− "non" -> D.succeed Binop.Non
276+ | str == non -> return Binop.Non
264− "right" -> D.succeed Binop.Right
277+ | str == right -> return Binop.Right
265− _ -> D.fail (BadAssociativity txt)
278+ | otherwise -> D.failure BadAssociativity
266
279
267
280
268
281
@@ -283,142 +296,190 @@ precDecoder =
283-- FROM MODULE
296-- FROM MODULE
284
297
285
298
286−fromModule :: Can.Module -> Result.Result i w Error.Error Module
299+fromModule :: Can.Module -> Either E.Error Module
287−fromModule (Can.Module name docs exports decls unions aliases binops effects) =
300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
288 case exports of
301 case exports of
289 Can.ExportEverything region ->
302 Can.ExportEverything region ->
290− Result.throw $ Error.Docs $ E.ImplicitExposing region
303+ Left (E.ImplicitExposing region)
291
304
292 Can.Export exportDict ->
305 Can.Export exportDict ->
293 case docs of
306 case docs of
294− Can.NoDocs region ->
307+ Src.NoDocs region ->
295− Result.throw $ Error.Docs $ E.NoDocs region
308+ Left (E.NoDocs region)
296
309
297− Can.YesDocs region overview comments ->
310+ Src.YesDocs overview comments ->
298− do names <- parseOverview region overview
311+ do names <- parseOverview overview
299− Result.mapError Error.Docs $
300− do checkNames exportDict names
312+ checkNames exportDict names
301− let types = gatherTypes decls Map.empty
313+ checkDefs exportDict overview (Map.fromList comments) modul
302− let info = Info comments types unions aliases binops effects
303− inserters <- Map.traverseWithKey (checkExport info) exportDict
304− return $ foldr ($) (emptyModule name overview) inserters
305−
306−
307−emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308−emptyModule (ModuleName.Canonical _ name) overview =
309− Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
310
314
311
315
312
316
313-- PARSE OVERVIEW
317-- PARSE OVERVIEW
314
318
315
319
316−parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
320+parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
317−parseOverview (R.Region (R.Position row col) _) overview =
321+parseOverview (Src.Comment snippet) =
318− case P.runAt row (col + 3) (chompOverview []) overview of
322+ case P.fromSnippet (chompOverview []) E.BadEnd snippet of
319 Left err ->
323 Left err ->
320− Result.throw (Error.Syntax err)
324+ Left (E.SyntaxProblem err)
321
325
322 Right names ->
326 Right names ->
323− Result.ok names
327+ Right names
328+
329+
330+type Parser a =
331+ P.Parser E.SyntaxProblem a
324
332
325
333
326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
327chompOverview names =
335chompOverview names =
328− do isDocs <- W.chompUntilDocs
336+ do isDocs <- chompUntilDocs
329 if isDocs
337 if isDocs
330− then chompOverviewHelp names
338+ then
331− else return names
339+ do Space.chomp E.Space
332−
333−
334−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335−chompOverviewHelp names =
336− do pos <- P.getPosition
337− (W.SPos spos) <- W.whitespace
338− if pos == spos
339− then chompOverview names
340− else chompOverview =<< chompDocs names
340+ chompOverview =<< chompDocs names
341+ else
342+ return names
341
343
342
344
343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
344chompDocs names =
346chompDocs names =
345− do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
347+ do name <-
346− spos <- W.whitespace
348+ P.addLocation $
347− P.oneOf
349+ P.oneOf E.Name
348− [ do P.checkSpace spos
350+ [ Var.lower E.Name
349− Symbol.comma
351+ , Var.upper E.Name
350− P.spaces
352+ , chompOperator
353+ ]
354+
355+ Space.chomp E.Space
356+
357+ P.oneOfWithFallback
358+ [ do pos <- P.getPosition
359+ Space.checkIndent pos E.Comma
360+ word1 0x2C {-,-} E.Comma
361+ Space.chomp E.Space
351 chompDocs (name:names)
362 chompDocs (name:names)
352− , return (name:names)
353 ]
363 ]
354−
364+ (name:names)
355−
365+
366+
356−chompBinop :: Parser Name.Name
367+chompOperator :: Parser Name.Name
357−chompBinop =
368+chompOperator =
358− do Symbol.leftParen
369+ do word1 0x28 {-(-} E.Op
359− name <- Symbol.binop
370+ op <- Symbol.operator E.Op E.OpBad
360− Symbol.rightParen
371+ word1 0x29 {-)-} E.Op
361− return name
372+ return op
373+
374+
375+-- TODO add rule that @docs must be after newline in 0.20
376+--
377+chompUntilDocs :: Parser Bool
378+chompUntilDocs =
379+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
380+ let
381+ (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382+ !newState = P.State src newPos end indent newRow newCol
383+ in
384+ cok isDocs newState
385+
386+
387+untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388+untilDocs pos end row col =
389+ if pos >= end then
390+ (# False, pos, row, col #)
391+ else
392+ let !word = P.unsafeIndex pos in
393+ if word == 0x0A {-\n-} then
394+ untilDocs (plusPtr pos 1) end (row + 1) 1
395+ else
396+ let !pos5 = plusPtr pos 5 in
397+ if pos5 <= end
398+ && P.unsafeIndex ( pos ) == 0x40 {-@-}
399+ && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}
400+ && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}
401+ && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}
402+ && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}
403+ && Var.getInnerWidth pos5 end == 0
404+ then
405+ (# True, pos5, row, col + 5 #)
406+ else
407+ let !newPos = plusPtr pos (P.getCharWidth word) in
408+ untilDocs newPos end row (col + 1)
362
409
363
410
364
411
365-- CHECK NAMES
412-- CHECK NAMES
366
413
367
414
368−type Result i w a =
415+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
369− Result.Result i w E.Error a
416+checkNames exports names =
370−
417+ let
371−
418+ docs = List.foldl' addName Map.empty names
372−type Dups =
419+ loneDoc = Map.traverseMissing onlyInDocs
373− Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
420+ loneExport = Map.traverseMissing onlyInExports
421+ checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
422+ in
423+ case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of
424+ (_, Right _) -> Right ()
425+ (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))
374
426
375
427
376−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
428+type DocNameRegions =
377−checkNames exports names =
429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
378− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379− let overlap = Map.size (Map.intersection docs exports)
380− if Map.size exports == overlap && overlap == Map.size docs
381− then Result.ok ()
382− else
383− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385− Result.ok ()
386
430
387
431
388−addName :: Dups -> A.Located Name.Name -> Dups
432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
389addName dict (A.At region name) =
433addName dict (A.At region name) =
390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
391
435
392
436
393−isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
394isUnique name regions =
438isUnique name regions =
395 case regions of
439 case regions of
396 OneOrMore.One region ->
440 OneOrMore.One region ->
397 Result.ok region
441 Result.ok region
398
442
399− OneOrMore.More _ _ ->
443+ OneOrMore.More left right ->
400− let (r1:r2:_) = OneOrMore.toList regions in
444+ let (r1, r2) = OneOrMore.getFirstTwo left right in
401− Result.throw (E.Duplicate name r1 r2)
445+ Result.throw (E.NameDuplicate name r1 r2)
402
446
403
447
404−onlyInDocs :: Name.Name -> R.Region -> Result i w a
448+onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
405−onlyInDocs name region =
449+onlyInDocs name regions =
450+ do region <- isUnique name regions
406− Result.throw $ E.OnlyInDocs name region
451+ Result.throw $ E.NameOnlyInDocs name region
407
452
408
453
409−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
410onlyInExports name (A.At region _) =
455onlyInExports name (A.At region _) =
411− Result.throw $ E.OnlyInExports name region
456+ Result.throw $ E.NameOnlyInExports name region
457+
458+
459+
460+-- CHECK DEFS
461+
412
462
463+checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module
464+checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =
465+ let
466+ types = gatherTypes decls Map.empty
467+ info = Info comments types unions aliases infixes effects
468+ in
469+ case Result.run (Map.traverseWithKey (checkExport info) exportDict) of
470+ (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)
471+ (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters
413
472
414
473
415−-- CHECK EXPORTS
474+emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
475+emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476+ Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
416
477
417
478
418data Info =
479data Info =
419 Info
480 Info
420− { _iComments :: Map.Map Name.Name Comment
481+ { _iComments :: Map.Map Name.Name Src.Comment
421− , _iValues :: Types
482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
422 , _iUnions :: Map.Map Name.Name Can.Union
483 , _iUnions :: Map.Map Name.Name Can.Union
423 , _iAliases :: Map.Map Name.Name Can.Alias
484 , _iAliases :: Map.Map Name.Name Can.Alias
424 , _iBinops :: Map.Map Name.Name Can.Binop
485 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -426,7 +487,7 @@ data Info =
426 }
487 }
427
488
428
489
429−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
430checkExport info name (A.At region export) =
491checkExport info name (A.At region export) =
431 case export of
492 case export of
432 Can.ExportValue ->
493 Can.ExportValue ->
@@ -467,23 +528,23 @@ checkExport info name (A.At region export) =
467 m { _values = Map.insert name (Value comment tipe) (_values m) }
528 m { _values = Map.insert name (Value comment tipe) (_values m) }
468
529
469
530
470−getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
471getComment region name info =
532getComment region name info =
472 case Map.lookup name (_iComments info) of
533 case Map.lookup name (_iComments info) of
473 Nothing ->
534 Nothing ->
474 Result.throw (E.NoComment name region)
535 Result.throw (E.NoComment name region)
475
536
476− Just comment ->
537+ Just (Src.Comment snippet) ->
477− Result.ok comment
538+ Result.ok (Json.fromComment snippet)
478
539
479
540
480−getType :: Name.Name -> Info -> Result i w Type.Type
541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
481getType name info =
542getType name info =
482 case _iValues info ! name of
543 case _iValues info ! name of
483− A.At defRegion Nothing ->
544+ Left region ->
484− Result.throw (E.NoAnnotation name defRegion)
545+ Result.throw (E.NoAnnotation name region)
485
546
486− A.At _ (Just tipe) ->
547+ Right tipe ->
487 Result.ok (Extract.fromType tipe)
548 Result.ok (Extract.fromType tipe)
488
549
489
550
@@ -497,7 +558,7 @@ dector (Can.Ctor name _ _ args) =
497
558
498
559
499type Types =
560type Types =
500− Map.Map Name.Name (A.Located (Maybe Can.Type))
561+ Map.Map Name.Name (Either A.Region Can.Type)
501
562
502
563
503gatherTypes :: Can.Decls -> Types -> Types
564gatherTypes :: Can.Decls -> Types -> Types
@@ -506,8 +567,8 @@ gatherTypes decls types =
506 Can.Declare def subDecls ->
567 Can.Declare def subDecls ->
507 gatherTypes subDecls (addDef types def)
568 gatherTypes subDecls (addDef types def)
508
569
509− Can.DeclareRec defs subDecls ->
570+ Can.DeclareRec def defs subDecls ->
510− gatherTypes subDecls (List.foldl' addDef types defs)
571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
511
572
512 Can.SaveTheEnvironment ->
573 Can.SaveTheEnvironment ->
513 types
574 types
@@ -517,11 +578,10 @@ addDef :: Types -> Can.Def -> Types
517addDef types def =
578addDef types def =
518 case def of
579 case def of
519 Can.Def (A.At region name) _ _ ->
580 Can.Def (A.At region name) _ _ ->
520− Map.insert name (A.At region Nothing) types
581+ Map.insert name (Left region) types
521
582
522− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
523 let
584 let
524− tipe =
525− foldr Can.TLambda resultType (map snd typedArgs)
585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)
526 in
586 in
527− Map.insert name (A.At region (Just tipe)) types
587+ Map.insert name (Right tipe) types
compiler/src/Elm/Float.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}
3+module Elm.Float
4+ ( Float
5+ , fromPtr
6+ , toBuilder
7+ )
8+ where
9+
10+
11+import Prelude hiding (Float)
12+import Data.Binary (Binary, get, put)
13+import qualified Data.ByteString.Builder as B
14+import qualified Data.Utf8 as Utf8
15+import Data.Word (Word8)
16+import Foreign.Ptr (Ptr)
17+
18+
19+
20+-- FLOATS
21+
22+
23+type Float =
24+ Utf8.Utf8 ELM_FLOAT
25+
26+
27+data ELM_FLOAT
28+
29+
30+
31+-- HELPERS
32+
33+
34+fromPtr :: Ptr Word8 -> Ptr Word8 -> Float
35+fromPtr =
36+ Utf8.fromPtr
37+
38+
39+{-# INLINE toBuilder #-}
40+toBuilder :: Float -> B.Builder
41+toBuilder =
42+ Utf8.toBuilder
43+
44+
45+
46+-- BINARY
47+
48+
49+instance Binary (Utf8.Utf8 ELM_FLOAT) where
50+ get = Utf8.getUnder256
51+ put = Utf8.putUnder256
compiler/src/Elm/Interface.hs+17−14
@@ -11,11 +11,13 @@ module Elm.Interface
11 , public
11 , public
12 , private
12 , private
13 , privatize
13 , privatize
14+ , extractUnion
15+ , extractAlias
14 )
16 )
15 where
17 where
16
18
17
19
18−import Control.Monad (liftM, liftM2, liftM4, liftM5)
20+import Control.Monad (liftM, liftM3, liftM4, liftM5)
19import Data.Binary
21import Data.Binary
20import Data.Map.Strict ((!))
22import Data.Map.Strict ((!))
21import qualified Data.Map.Strict as Map
23import qualified Data.Map.Strict as Map
@@ -71,7 +73,7 @@ data Binop =
71
73
72
74
73fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
75fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
74−fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =
76+fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =
75 Interface
77 Interface
76 { _home = home
78 { _home = home
77 , _values = restrict exports annotations
79 , _values = restrict exports annotations
@@ -153,7 +155,10 @@ toPublicAlias iAlias =
153
155
154data DependencyInterface
156data DependencyInterface
155 = Public Interface
157 = Public Interface
158+ | Private
159+ Pkg.Name
156− | Private (Map.Map Name.Name Can.Union) (Map.Map Name.Name Can.Alias)
160+ (Map.Map Name.Name Can.Union)
161+ (Map.Map Name.Name Can.Alias)
157
162
158
163
159public :: Interface -> DependencyInterface
164public :: Interface -> DependencyInterface
@@ -162,10 +167,8 @@ public =
162
167
163
168
164private :: Interface -> DependencyInterface
169private :: Interface -> DependencyInterface
165−private (Interface _ _ unions aliases _) =
170+private (Interface pkg _ unions aliases _) =
166− Private
167− (Map.map extractUnion unions)
168− (Map.map extractAlias aliases)
171+ Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases)
169
172
170
173
171extractUnion :: Union -> Can.Union
174extractUnion :: Union -> Can.Union
@@ -187,7 +190,7 @@ privatize :: DependencyInterface -> DependencyInterface
187privatize di =
190privatize di =
188 case di of
191 case di of
189 Public i -> private i
192 Public i -> private i
190− Private _ _ -> di
193+ Private _ _ _ -> di
191
194
192
195
193
196
@@ -212,7 +215,7 @@ instance Binary Union where
212 0 -> liftM OpenUnion get
215 0 -> liftM OpenUnion get
213 1 -> liftM ClosedUnion get
216 1 -> liftM ClosedUnion get
214 2 -> liftM PrivateUnion get
217 2 -> liftM PrivateUnion get
215− _ -> error "binary encoding of Union was corrupted"
218+ _ -> fail "binary encoding of Union was corrupted"
216
219
217
220
218instance Binary Alias where
221instance Binary Alias where
@@ -226,7 +229,7 @@ instance Binary Alias where
226 case n of
229 case n of
227 0 -> liftM PublicAlias get
230 0 -> liftM PublicAlias get
228 1 -> liftM PrivateAlias get
231 1 -> liftM PrivateAlias get
229− _ -> error "binary encoding of Alias was corrupted"
232+ _ -> fail "binary encoding of Alias was corrupted"
230
233
231
234
232instance Binary Binop where
235instance Binary Binop where
@@ -240,12 +243,12 @@ instance Binary Binop where
240instance Binary DependencyInterface where
243instance Binary DependencyInterface where
241 put union =
244 put union =
242 case union of
245 case union of
243− Public a -> putWord8 0 >> put a
246+ Public a -> putWord8 0 >> put a
244− Private a b -> putWord8 1 >> put a >> put b
247+ Private a b c -> putWord8 1 >> put a >> put b >> put c
245
248
246 get =
249 get =
247 do n <- getWord8
250 do n <- getWord8
248 case n of
251 case n of
249 0 -> liftM Public get
252 0 -> liftM Public get
250− 1 -> liftM2 Private get get
253+ 1 -> liftM3 Private get get get
251− _ -> error "binary encoding of DependencyInterface was corrupted"
254+ _ -> fail "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+132−127
@@ -3,55 +3,40 @@
3module Elm.Kernel
3module Elm.Kernel
4 ( Content(..)
4 ( Content(..)
5 , Chunk(..)
5 , Chunk(..)
6− , Dep(..)
6+ , fromByteString
7− , parser
7+ , countFields
8 )
8 )
9 where
9 where
10
10
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 Data.Coerce (coerce)
14+import qualified Data.ByteString.Internal as B
15import qualified Data.List as List
15import qualified Data.List as List
16import qualified Data.Map as Map
16import qualified Data.Map as Map
17import qualified Data.Name as Name
17import qualified Data.Name as Name
18−import qualified Data.Set as Set
19−import qualified Data.Utf8 as Utf8
20−import Data.Word (Word8, Word16)
18+import Data.Word (Word8)
21−import Foreign.Ptr (Ptr, plusPtr)
19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20+import Foreign.ForeignPtr (ForeignPtr)
21+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
22
22
23import qualified AST.Source as Src
23import qualified AST.Source as Src
24import qualified Elm.ModuleName as ModuleName
24import qualified Elm.ModuleName as ModuleName
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
27import qualified Parse.Variable as Var
28import qualified Parse.Variable as Var
28−import Parse.Utils
29−import Parse.Primitives hiding (Parser, State)
29+import Parse.Primitives hiding (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
33
32
34
33
35
34
36−-- CONTENT
35+-- CHUNK
37−
38−
39−data Content =
40− Content [Chunk] (Set.Set Dep)
41−
42−
43−data Dep
44− = ElmDep ModuleName.Canonical Name.Name
45− | KernelDep Name.Name
46− deriving (Eq, Ord)
47−
48−
49−
50−-- CHUNKS
51
36
52
37
53data Chunk
38data Chunk
54− = JS (Utf8.VeryLong UNCHECKED)
39+ = JS B.ByteString
55 | ElmVar ModuleName.Canonical Name.Name
40 | ElmVar ModuleName.Canonical Name.Name
56 | JsVar Name.Name Name.Name
41 | JsVar Name.Name Name.Name
57 | ElmField Name.Name
42 | ElmField Name.Name
@@ -61,56 +46,93 @@ data Chunk
61 | Prod
46 | Prod
62
47
63
48
64−data UNCHECKED
65
49
50+-- COUNT FIELDS
51+
52+
53+countFields :: [Chunk] -> Map.Map Name.Name Int
54+countFields chunks =
55+ foldr addField Map.empty chunks
66
56
67
57
68−-- PARSE
58+addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int
59+addField chunk fields =
60+ case chunk of
61+ JS _ -> fields
62+ ElmVar _ _ -> fields
63+ JsVar _ _ -> fields
64+ ElmField f -> Map.insertWith (+) f 1 fields
65+ JsField _ -> fields
66+ JsEnum _ -> fields
67+ Debug -> fields
68+ Prod -> fields
69
69
70
70
71−type ImportDict =
72− Map.Map Name.Name [Pkg.Name]
73
71
72+-- FROM FILE
73+
74+
75+data Content =
76+ Content [Src.Import] [Chunk]
74
77
78+
79+type Foreigns =
80+ Map.Map ModuleName.Raw Pkg.Name
81+
82+
83+fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content
84+fromByteString pkg foreigns bytes =
85+ case P.fromByteString (parser pkg foreigns) toError bytes of
86+ Right content ->
87+ Just content
88+
89+ Left () ->
90+ Nothing
91+
92+
75−parser :: ImportDict -> Parser Content
93+parser :: Pkg.Name -> Foreigns -> Parser () Content
76−parser importDict =
94+parser pkg foreigns =
77− do word2 0x2F 0x2A {-/*-} E.XXX
95+ do word2 0x2F 0x2A {-/*-} toError
78− Module.freshLine
96+ Space.chomp ignoreError
97+ Space.checkFreshLine toError
79− imports <- Module.chompImports []
98+ imports <- specialize ignoreError (Module.chompImports [])
80− word2 0x2A 0x2F {-*/-} E.XXX
99+ word2 0x2A 0x2F {-*/-} toError
81− let (vtable, deps) = processImports importDict imports
82− chunks <- parseChunks vtable Map.empty Map.empty
100+ chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty
83− return $ Content chunks deps
101+ return (Content imports chunks)
102+
103+
104+toError :: Row -> Col -> ()
105+toError _ _ =
106+ ()
107+
108+
109+ignoreError :: a -> Row -> Col -> ()
110+ignoreError _ _ _ =
111+ ()
84
112
85
113
86
114
87-- PARSE CHUNKS
115-- PARSE CHUNKS
88
116
89
117
90−parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]
118+parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
91parseChunks vtable enums fields =
119parseChunks vtable enums fields =
92− P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr _ ->
120+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
93 let
121 let
94 (# chunks, newPos, newRow, newCol #) =
122 (# chunks, newPos, newRow, newCol #) =
95− chompChunks vtable enums fields pos end row col pos []
123+ chompChunks vtable enums fields src pos end row col pos []
96 in
124 in
97 if newPos == end then
125 if newPos == end then
98− cok chunks (P.State newPos end indent newRow newCol ctx)
126+ cok chunks (P.State src newPos end indent newRow newCol)
99 else
127 else
100− cerr row col ctx E.XXX
128+ cerr row col toError
101−
102−
103−addJS :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
104−addJS start end revChunks =
105− if start == end
106− then revChunks
107− else JS (Utf8.fromPtr start end) : revChunks
108
129
109
130
110−chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
131+chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
111−chompChunks vs es fs pos end row col lastPos revChunks =
132+chompChunks vs es fs src pos end row col lastPos revChunks =
112 if pos >= end then
133 if pos >= end then
134+ let !js = toByteString src lastPos end in
113− (# reverse (addJS lastPos end revChunks), pos, row, col #)
135+ (# reverse (JS js : revChunks), pos, row, col #)
114
136
115 else
137 else
116 let !word = unsafeIndex pos in
138 let !word = unsafeIndex pos in
@@ -120,31 +142,45 @@ chompChunks vs es fs pos end row col lastPos revChunks =
120 !pos3 = plusPtr pos 3
142 !pos3 = plusPtr pos 3
121 in
143 in
122 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
145+ let !js = toByteString src lastPos pos in
123− chompTag vs es fs pos3 end row (col + 3) (addJS lastPos pos revChunks)
146+ chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
124 else
147 else
125− chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
148+ chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
126
149
127 else if word == 0x0A {-\n-} then
150 else if word == 0x0A {-\n-} then
128− chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
151+ chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
129
152
130 else
153 else
131 let
154 let
132− !newPos = plusPtr pos (getCharWidth pos end word)
155+ !newPos = plusPtr pos (getCharWidth word)
133 in
156 in
134− chompChunks vs es fs newPos end row (col + 1) lastPos revChunks
157+ chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
158+
159+
160+toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString
161+toByteString src pos end =
162+ let
163+ !off = minusPtr pos (unsafeForeignPtrToPtr src)
164+ !len = minusPtr end pos
165+ in
166+ B.PS src off len
167+
135
168
136
169
137-- relies on external checks in chompChunks
170-- relies on external checks in chompChunks
138−chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
171+chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
139−chompTag vs es fs pos end row col revChunks =
172+chompTag vs es fs src pos end row col revChunks =
140 let
173 let
141 (# newPos, newCol #) = Var.chompInnerChars pos end col
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
142 !tagPos = plusPtr pos (-1)
175 !tagPos = plusPtr pos (-1)
143 !word = unsafeIndex tagPos
176 !word = unsafeIndex tagPos
144 in
177 in
145 if word == 0x24 {-$-} then
178 if word == 0x24 {-$-} then
179+ let
180+ !name = Name.fromPtr pos newPos
181+ in
146− chompChunks vs es fs newPos end row newCol newPos $
182+ chompChunks vs es fs src newPos end row newCol newPos $
147− ElmField (Name.fromPtr pos newPos) : revChunks
183+ ElmField name : revChunks
148 else
184 else
149 let
185 let
150 !name = Name.fromPtr tagPos newPos
186 !name = Name.fromPtr tagPos newPos
@@ -154,7 +190,7 @@ chompTag vs es fs pos end row col revChunks =
154 (enum, newEnums) =
190 (enum, newEnums) =
155 lookupEnum (word - 0x30) name es
191 lookupEnum (word - 0x30) name es
156 in
192 in
157− chompChunks vs newEnums fs newPos end row newCol newPos $
193+ chompChunks vs newEnums fs src newPos end row newCol newPos $
158 JsEnum enum : revChunks
194 JsEnum enum : revChunks
159
195
160 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
@@ -162,19 +198,19 @@ chompTag vs es fs pos end row col revChunks =
162 (field, newFields) =
198 (field, newFields) =
163 lookupField name fs
199 lookupField name fs
164 in
200 in
165− chompChunks vs es newFields newPos end row newCol newPos $
201+ chompChunks vs es newFields src newPos end row newCol newPos $
166 JsField field : revChunks
202 JsField field : revChunks
167
203
168 else if name == "DEBUG" then
204 else if name == "DEBUG" then
169− chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
205+ chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
170
206
171 else if name == "PROD" then
207 else if name == "PROD" then
172− chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
208+ chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
173
209
174 else
210 else
175 case Map.lookup name vs of
211 case Map.lookup name vs of
176 Just chunk ->
212 Just chunk ->
177− chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
213+ chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
178
214
179 Nothing ->
215 Nothing ->
180 (# revChunks, pos, row, col #)
216 (# revChunks, pos, row, col #)
@@ -230,60 +266,34 @@ type VarTable =
230 Map.Map Name.Name Chunk
266 Map.Map Name.Name Chunk
231
267
232
268
233−type State =
269+toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable
234− (VarTable, Set.Set Dep)
270+toVarTable pkg foreigns imports =
271+ List.foldl' (addImport pkg foreigns) Map.empty imports
235
272
236
273
237−processImports :: ImportDict -> [Src.Import] -> State
274+addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable
238−processImports importDict imports =
239− List.foldl' (addImport importDict) (Map.empty, Set.empty) imports
240−
241−
242−addImport :: ImportDict -> State -> Src.Import -> State
243−addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
275+addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) =
244− if Name.isKernel home then
276+ if Name.isKernel importName then
245 case maybeAlias of
277 case maybeAlias of
246 Just _ ->
278 Just _ ->
247− error ("Cannot use aliases on kernel import of: " ++ Name.toChars home)
279+ error ("cannot use `as` with kernel import of: " ++ Name.toChars importName)
248
280
249 Nothing ->
281 Nothing ->
250− addKernelImport (Name.getKernel home) exposing state
251−
252− else
253− case Map.lookup home importDict of
254− Just [pkg] ->
255 let
282 let
256− canonicalHome = ModuleName.Canonical pkg home
283+ home = Name.getKernel importName
257− prefix = toPrefix home maybeAlias
284+ add table name =
285+ Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
258 in
286 in
259− addNormalImport canonicalHome prefix exposing state
287+ List.foldl' add vtable (toNames exposing)
260−
261− _ ->
262− error ("Cannot find kernel import of: " ++ Name.toChars home)
263−
264
288
265−-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
289+ else
266−--
290+ let
267−addKernelImport :: Name.Name -> Src.Exposing -> State -> State
291+ home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName
268−addKernelImport home exposing (vtable, deps) =
292+ prefix = toPrefix importName maybeAlias
269− let
293+ add table name =
270− addVar table name =
271− Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
272− in
273− ( List.foldl' addVar vtable (toNames exposing)
274− , Set.insert (KernelDep home) deps
275− )
276−
277−
278−addNormalImport :: ModuleName.Canonical -> Name.Name -> Src.Exposing -> State -> State
279−addNormalImport home prefix exposing state =
280− let
281− addVar (vtable, deps) name =
282− ( Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) vtable
294+ Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table
283− , Set.insert (ElmDep home name) deps
284− )
285− in
295+ in
286− List.foldl' addVar state (toNames exposing)
296+ List.foldl' add vtable (toNames exposing)
287
297
288
298
289toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name
299toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name
@@ -303,25 +313,25 @@ toNames :: Src.Exposing -> [Name.Name]
303toNames exposing =
313toNames exposing =
304 case exposing of
314 case exposing of
305 Src.Open ->
315 Src.Open ->
306− error "Cannot have `exposing (..)` in kernel code."
316+ error "cannot have `exposing (..)` in kernel code."
307
317
308 Src.Explicit exposedList ->
318 Src.Explicit exposedList ->
309 map toName exposedList
319 map toName exposedList
310
320
311
321
312−toName :: A.Located Src.Exposed -> Name.Name
322+toName :: Src.Exposed -> Name.Name
313−toName (A.At _ exposed) =
323+toName exposed =
314 case exposed of
324 case exposed of
315− Src.Lower name ->
325+ Src.Lower (A.At _ name) ->
316 name
326 name
317
327
318− Src.Upper name Src.Private ->
328+ Src.Upper (A.At _ name) Src.Private ->
319 name
329 name
320
330
321− Src.Upper _ Src.Public ->
331+ Src.Upper _ (Src.Public _) ->
322 error "cannot have Maybe(..) syntax in kernel code header"
332 error "cannot have Maybe(..) syntax in kernel code header"
323
333
324− Src.Operator _ ->
334+ Src.Operator _ _ ->
325 error "cannot use binops in kernel code"
335 error "cannot use binops in kernel code"
326
336
327
337
@@ -332,7 +342,7 @@ toName (A.At _ exposed) =
332instance Binary Chunk where
342instance Binary Chunk where
333 put chunk =
343 put chunk =
334 case chunk of
344 case chunk of
335− JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
345+ JS a -> putWord8 0 >> put a
336 ElmVar a b -> putWord8 1 >> put a >> put b
346 ElmVar a b -> putWord8 1 >> put a >> put b
337 JsVar a b -> putWord8 2 >> put a >> put b
347 JsVar a b -> putWord8 2 >> put a >> put b
338 ElmField a -> putWord8 3 >> put a
348 ElmField a -> putWord8 3 >> put a
@@ -344,7 +354,7 @@ instance Binary Chunk where
344 get =
354 get =
345 do word <- getWord8
355 do word <- getWord8
346 case word of
356 case word of
347− 0 -> liftM toJS get
357+ 0 -> liftM JS get
348 1 -> liftM2 ElmVar get get
358 1 -> liftM2 ElmVar get get
349 2 -> liftM2 JsVar get get
359 2 -> liftM2 JsVar get get
350 3 -> liftM ElmField get
360 3 -> liftM ElmField get
@@ -353,8 +363,3 @@ instance Binary Chunk where
353 6 -> return Debug
363 6 -> return Debug
354 7 -> return Prod
364 7 -> return Prod
355 _ -> error "problem deserializing Elm.Kernel.Chunk"
365 _ -> error "problem deserializing Elm.Kernel.Chunk"
356−
357−
358−toJS :: Utf8.String -> Chunk
359−toJS str =
360− JS (coerce str)
compiler/src/Elm/Licenses.hs+48−65
@@ -9,14 +9,12 @@ module Elm.Licenses
9 where
9 where
10
10
11
11
12−import Control.Monad (liftM2)
13−import Data.Binary (Binary, get, put)
14−import Data.Map ((!))
15import qualified Data.Map as Map
12import qualified Data.Map as Map
16import qualified Data.Utf8 as Utf8
13import qualified Data.Utf8 as Utf8
17
14
18import qualified Json.Decode as D
15import qualified Json.Decode as D
19import qualified Json.Encode as E
16import qualified Json.Encode as E
17+import qualified Json.String as Json
20import qualified Reporting.Suggest as Suggest
18import qualified Reporting.Suggest as Suggest
21
19
22
20
@@ -24,25 +22,21 @@ import qualified Reporting.Suggest as Suggest
24-- LICENCES
22-- LICENCES
25
23
26
24
27−data License =
25+newtype License =
28− License
26+ License Json.String
29− { _name :: Utf8.String
30− , _code :: Utf8.String
31− }
32− deriving (Eq, Ord)
33
27
34
28
35bsd3 :: License
29bsd3 :: License
36bsd3 =
30bsd3 =
37− osiApprovedSpdxLicenses ! "BSD-3-Clause"
31+ License (Json.fromChars "BSD-3-Clause")
38
32
39
33
40encode :: License -> E.Value
34encode :: License -> E.Value
41−encode (License _ code) =
35+encode (License code) =
42 E.string code
36 E.string code
43
37
44
38
45−decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License
39+decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
46decoder toError =
40decoder toError =
47 do str <- D.string
41 do str <- D.string
48 case check str of
42 case check str of
@@ -57,97 +51,93 @@ decoder toError =
57-- CHECK
51-- CHECK
58
52
59
53
60−check :: Utf8.String -> Either [Utf8.String] License
54+check :: Json.String -> Either [Json.String] License
61−check rawName =
55+check givenCode =
62− case Map.lookup rawName osiApprovedSpdxLicenses of
56+ if Map.member givenCode osiApprovedSpdxLicenses then
63− Just license ->
57+ Right (License givenCode)
64− Right license
65
58
66− Nothing ->
59+ else
67− let
60+ let
68− toPairs (License name code) =
61+ pairs =
69− [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]
62+ map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)
70−
63+ ++
71− pairs =
72− concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
64+ Map.toList osiApprovedSpdxLicenses
73− in
65+ in
74− Left $ map snd $
66+ Left $ map fst $ take 4 $
75− Suggest.sort (Utf8.toChars rawName) fst pairs
67+ Suggest.sort (Utf8.toChars givenCode) snd pairs
76
68
77
69
78
70
79-- LIST OF LICENCES
71-- LIST OF LICENCES
80
72
81
73
82−(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)
74+(==>) :: [Char] -> [Char] -> (Json.String, [Char])
83−(==>) code name =
75+(==>) code fullName =
84− ( code, License name code )
76+ ( Json.fromChars code, fullName )
85
77
86
78
87--
79--
88-- OSI approved licenses in SPDX format.
80-- OSI approved licenses in SPDX format.
89-- <https://spdx.org/licenses/>
81-- <https://spdx.org/licenses/>
90--
82--
91−osiApprovedSpdxLicenses :: Map.Map Utf8.String License
83+osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
92osiApprovedSpdxLicenses =
84osiApprovedSpdxLicenses =
93 Map.fromList
85 Map.fromList
86+ [ "0BSD" ==> "BSD Zero Clause License"
87+ , "AAL" ==> "Attribution Assurance License"
94− [ "AFL-1.1" ==> "Academic Free License v1.1"
88+ , "AFL-1.1" ==> "Academic Free License v1.1"
95 , "AFL-1.2" ==> "Academic Free License v1.2"
89 , "AFL-1.2" ==> "Academic Free License v1.2"
96 , "AFL-2.0" ==> "Academic Free License v2.0"
90 , "AFL-2.0" ==> "Academic Free License v2.0"
97 , "AFL-2.1" ==> "Academic Free License v2.1"
91 , "AFL-2.1" ==> "Academic Free License v2.1"
98 , "AFL-3.0" ==> "Academic Free License v3.0"
92 , "AFL-3.0" ==> "Academic Free License v3.0"
99− , "APL-1.0" ==> "Adaptive Public License 1.0"
93+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
100 , "Apache-1.1" ==> "Apache License 1.1"
94 , "Apache-1.1" ==> "Apache License 1.1"
101 , "Apache-2.0" ==> "Apache License 2.0"
95 , "Apache-2.0" ==> "Apache License 2.0"
96+ , "APL-1.0" ==> "Adaptive Public License 1.0"
102 , "APSL-1.0" ==> "Apple Public Source License 1.0"
97 , "APSL-1.0" ==> "Apple Public Source License 1.0"
103 , "APSL-1.1" ==> "Apple Public Source License 1.1"
98 , "APSL-1.1" ==> "Apple Public Source License 1.1"
104 , "APSL-1.2" ==> "Apple Public Source License 1.2"
99 , "APSL-1.2" ==> "Apple Public Source License 1.2"
105 , "APSL-2.0" ==> "Apple Public Source License 2.0"
100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
106 , "Artistic-1.0" ==> "Artistic License 1.0"
101 , "Artistic-1.0" ==> "Artistic License 1.0"
107− , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
108 , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
102 , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103+ , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
109 , "Artistic-2.0" ==> "Artistic License 2.0"
104 , "Artistic-2.0" ==> "Artistic License 2.0"
110− , "AAL" ==> "Attribution Assurance License"
111− , "BSL-1.0" ==> "Boost Software License 1.0"
112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
114− , "0BSD" ==> "BSD Zero Clause License"
107+ , "BSL-1.0" ==> "Boost Software License 1.0"
108+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
116 , "CNRI-Python" ==> "CNRI Python License"
111 , "CNRI-Python" ==> "CNRI Python License"
117− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
119 , "CPL-1.0" ==> "Common Public License 1.0"
113 , "CPL-1.0" ==> "Common Public License 1.0"
120− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
122− , "EPL-1.0" ==> "Eclipse Public License 1.0"
123 , "ECL-1.0" ==> "Educational Community License v1.0"
115 , "ECL-1.0" ==> "Educational Community License v1.0"
124 , "ECL-2.0" ==> "Educational Community License v2.0"
116 , "ECL-2.0" ==> "Educational Community License v2.0"
125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
127 , "Entessa" ==> "Entessa Public License v1.0"
119 , "Entessa" ==> "Entessa Public License v1.0"
120+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
128 , "EUDatagrid" ==> "EU DataGrid Software License"
121 , "EUDatagrid" ==> "EU DataGrid Software License"
129 , "EUPL-1.1" ==> "European Union Public License 1.1"
122 , "EUPL-1.1" ==> "European Union Public License 1.1"
130 , "Fair" ==> "Fair License"
123 , "Fair" ==> "Fair License"
131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
132− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
134 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
135− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
136− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
137− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
138 , "HPND" ==> "Historic Permission Notice and Disclaimer"
127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
139− , "IPL-1.0" ==> "IBM Public License v1.0"
140 , "Intel" ==> "Intel Open Source License"
128 , "Intel" ==> "Intel Open Source License"
141 , "IPA" ==> "IPA Font License"
129 , "IPA" ==> "IPA Font License"
130+ , "IPL-1.0" ==> "IBM Public License v1.0"
142 , "ISC" ==> "ISC License"
131 , "ISC" ==> "ISC License"
143− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
132+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
133+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
144 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
145− , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
146 , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
136 , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
147− , "LPL-1.02" ==> "Lucent Public License v1.02"
137+ , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
148 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
138 , "LPL-1.0" ==> "Lucent Public License Version 1.0"
149− , "MS-PL" ==> "Microsoft Public License"
139+ , "LPL-1.02" ==> "Lucent Public License v1.02"
150− , "MS-RL" ==> "Microsoft Reciprocal License"
140+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
151 , "MirOS" ==> "MirOS Licence"
141 , "MirOS" ==> "MirOS Licence"
152 , "MIT" ==> "MIT License"
142 , "MIT" ==> "MIT License"
153 , "Motosoto" ==> "Motosoto License"
143 , "Motosoto" ==> "Motosoto License"
@@ -155,48 +145,41 @@ osiApprovedSpdxLicenses =
155 , "MPL-1.1" ==> "Mozilla Public License 1.1"
145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
156 , "MPL-2.0" ==> "Mozilla Public License 2.0"
146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
157 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
147 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
148+ , "MS-PL" ==> "Microsoft Public License"
149+ , "MS-RL" ==> "Microsoft Reciprocal License"
158 , "Multics" ==> "Multics License"
150 , "Multics" ==> "Multics License"
159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
160 , "Naumen" ==> "Naumen Public License"
152 , "Naumen" ==> "Naumen Public License"
153+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
161 , "NGPL" ==> "Nethack General Public License"
154 , "NGPL" ==> "Nethack General Public License"
162 , "Nokia" ==> "Nokia Open Source License"
155 , "Nokia" ==> "Nokia Open Source License"
163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
164 , "NTP" ==> "NTP License"
157 , "NTP" ==> "NTP License"
165 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
166 , "OGTSL" ==> "Open Group Test Suite License"
160 , "OGTSL" ==> "Open Group Test Suite License"
161+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
167 , "OSL-1.0" ==> "Open Software License 1.0"
162 , "OSL-1.0" ==> "Open Software License 1.0"
168 , "OSL-2.0" ==> "Open Software License 2.0"
163 , "OSL-2.0" ==> "Open Software License 2.0"
169 , "OSL-2.1" ==> "Open Software License 2.1"
164 , "OSL-2.1" ==> "Open Software License 2.1"
170 , "OSL-3.0" ==> "Open Software License 3.0"
165 , "OSL-3.0" ==> "Open Software License 3.0"
171− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
172 , "PHP-3.0" ==> "PHP License v3.0"
166 , "PHP-3.0" ==> "PHP License v3.0"
173 , "PostgreSQL" ==> "PostgreSQL License"
167 , "PostgreSQL" ==> "PostgreSQL License"
174 , "Python-2.0" ==> "Python License 2.0"
168 , "Python-2.0" ==> "Python License 2.0"
175 , "QPL-1.0" ==> "Q Public License 1.0"
169 , "QPL-1.0" ==> "Q Public License 1.0"
176− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
178 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
179 , "RSCPL" ==> "Ricoh Source Code Public License"
173 , "RSCPL" ==> "Ricoh Source Code Public License"
180− , "OFL-1.1" ==> "SIL Open Font License 1.1"
181 , "SimPL-2.0" ==> "Simple Public License 2.0"
174 , "SimPL-2.0" ==> "Simple Public License 2.0"
182− , "Sleepycat" ==> "Sleepycat License"
183 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
175 , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176+ , "Sleepycat" ==> "Sleepycat License"
184 , "SPL-1.0" ==> "Sun Public License v1.0"
177 , "SPL-1.0" ==> "Sun Public License v1.0"
185− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
186 , "UPL-1.0" ==> "Universal Permissive License v1.0"
178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
187− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
188 , "VSL-1.0" ==> "Vovida Software License v1.0"
179 , "VSL-1.0" ==> "Vovida Software License v1.0"
189 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
190 , "Xnet" ==> "X.Net License"
182 , "Xnet" ==> "X.Net License"
191 , "Zlib" ==> "zlib License"
183 , "Zlib" ==> "zlib License"
192 , "ZPL-2.0" ==> "Zope Public License 2.0"
184 , "ZPL-2.0" ==> "Zope Public License 2.0"
193 ]
185 ]
194−
195−
196−
197−-- BINARY
198−
199−
200−instance Binary License where
201− get = liftM2 License get get
202− put (License a b) = put a >> put b
compiler/src/Elm/ModuleName.hs+72−46
@@ -1,19 +1,19 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}
2module Elm.ModuleName
2module Elm.ModuleName
3 ( Raw
3 ( Raw
4 , toChars
4 , toChars
5− , toString
6 , toFilePath
5 , toFilePath
7 , toHyphenPath
6 , toHyphenPath
8− , fromHyphenPath
7+ --
9 , encode
8 , encode
10 , decoder
9 , decoder
10+ , parser
11+ --
11 , Canonical(..)
12 , Canonical(..)
12− , canonicalIsKernel
13 , basics, char, string
13 , basics, char, string
14 , maybe, result, list, array, dict, tuple
14 , maybe, result, list, array, dict, tuple
15 , platform, cmd, sub
15 , platform, cmd, sub
16− , debug, bitwise
16+ , debug
17 , virtualDom
17 , virtualDom
18 , jsonDecode, jsonEncode
18 , jsonDecode, jsonEncode
19 , webgl, texture, vector2, vector3, vector4, matrix4
19 , webgl, texture, vector2, vector3, vector4, matrix4
@@ -23,15 +23,19 @@ module Elm.ModuleName
23
23
24import Control.Monad (liftM2)
24import Control.Monad (liftM2)
25import Data.Binary (Binary(..))
25import Data.Binary (Binary(..))
26−import qualified Data.Char as Char
27import qualified Data.Name as Name
26import qualified Data.Name as Name
28import qualified Data.Utf8 as Utf8
27import qualified Data.Utf8 as Utf8
28+import Data.Word (Word8)
29+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
29import Prelude hiding (maybe)
30import Prelude hiding (maybe)
30import qualified System.FilePath as FP
31import qualified System.FilePath as FP
31
32
32import qualified Elm.Package as Pkg
33import qualified Elm.Package as Pkg
33−import qualified Json.Decode as Decode
34+import qualified Json.Decode as D
34−import qualified Json.Encode as Encode
35+import qualified Json.Encode as E
36+import qualified Parse.Variable as Var
37+import qualified Parse.Primitives as P
38+import Parse.Primitives (Row, Col)
35
39
36
40
37
41
@@ -46,11 +50,6 @@ toChars =
46 Name.toChars
50 Name.toChars
47
51
48
52
49−toString :: Raw -> Utf8.String
50−toString =
51− Name.toUtf8
52−
53−
54toFilePath :: Raw -> FilePath
53toFilePath :: Raw -> FilePath
55toFilePath name =
54toFilePath name =
56 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)
@@ -61,38 +60,68 @@ toHyphenPath name =
61 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
60 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
62
61
63
62
64−fromHyphenPath :: Utf8.String -> Maybe Raw
65−fromHyphenPath str =
66− let
67− chunks =
68− Utf8.split 0x2D {- - -} str
69− in
70− if all isGoodChunk chunks
71− then Just (Name.fromUtf8 (Utf8.join 0x2E {- . -} chunks))
72− else Nothing
73−
74−
75
63
76-- JSON
64-- JSON
77
65
78
66
79−encode :: Raw -> Encode.Value
67+encode :: Raw -> E.Value
80encode =
68encode =
81− Encode.name
69+ E.name
82
70
83
71
84−decoder :: Decode.Decoder Utf8.String Raw
72+decoder :: D.Decoder (Row, Col) Raw
85decoder =
73decoder =
86− do str <- Decode.string
74+ D.customString parser (,)
87− if all isGoodChunk (Utf8.split 0x2E {- . -} str)
88− then return (Name.fromUtf8 str)
89− else Decode.failure str
90
75
91
76
92−isGoodChunk :: Utf8.String -> Bool
77+
93−isGoodChunk chunk =
78+-- PARSER
94− Utf8.startsWithChar Char.isUpper chunk
79+
95− && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk
80+
81+parser :: P.Parser (Row, Col) Raw
82+parser =
83+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
84+ let
85+ (# isGood, newPos, newCol #) = chompStart pos end col
86+ in
87+ if isGood && minusPtr newPos pos < 256 then
88+ let !newState = P.State src newPos end indent row newCol in
89+ cok (Utf8.fromPtr pos newPos) newState
90+
91+ else if col == newCol then
92+ eerr row newCol (,)
93+
94+ else
95+ cerr row newCol (,)
96+
97+
98+chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
99+chompStart pos end col =
100+ let
101+ !width = Var.getUpperWidth pos end
102+ in
103+ if width == 0 then
104+ (# False, pos, col #)
105+ else
106+ chompInner (plusPtr pos width) end (col + 1)
107+
108+
109+chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)
110+chompInner pos end col =
111+ if pos >= end then
112+ (# True, pos, col #)
113+ else
114+ let
115+ !word = P.unsafeIndex pos
116+ !width = Var.getInnerWidthHelp pos end word
117+ in
118+ if width == 0 then
119+ if word == 0x2E {-.-} then
120+ chompStart (plusPtr pos 1) end (col + 1)
121+ else
122+ (# True, pos, col #)
123+ else
124+ chompInner (plusPtr pos width) end (col + 1)
96
125
97
126
98
127
@@ -104,12 +133,6 @@ data Canonical =
104 { _package :: !Pkg.Name
133 { _package :: !Pkg.Name
105 , _module :: !Name.Name
134 , _module :: !Name.Name
106 }
135 }
107− deriving (Ord)
108−
109−
110−canonicalIsKernel :: Canonical -> Bool
111−canonicalIsKernel (Canonical _ name) =
112− Name.isKernel name
113
136
114
137
115
138
@@ -121,6 +144,14 @@ instance Eq Canonical where
121 name1 == name2 && pkg1 == pkg2
144 name1 == name2 && pkg1 == pkg2
122
145
123
146
147+instance Ord Canonical where
148+ compare (Canonical pkg1 name1) (Canonical pkg2 name2) =
149+ case compare name1 name2 of
150+ LT -> LT
151+ EQ -> compare pkg1 pkg2
152+ GT -> GT
153+
154+
124instance Binary Canonical where
155instance Binary Canonical where
125 put (Canonical a b) = put a >> put b
156 put (Canonical a b) = put a >> put b
126 get = liftM2 Canonical get get
157 get = liftM2 Canonical get get
@@ -195,11 +226,6 @@ debug :: Canonical
195debug = Canonical Pkg.core Name.debug
226debug = Canonical Pkg.core Name.debug
196
227
197
228
198−{-# NOINLINE bitwise #-}
199−bitwise :: Canonical
200−bitwise = Canonical Pkg.core Name.bitwise
201−
202−
203
229
204-- HTML
230-- HTML
205
231
compiler/src/Elm/Package.hs+220−89
@@ -1,38 +1,52 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}
3module Elm.Package
3module Elm.Package
4 ( Name(..)
4 ( Name(..)
5+ , Author
6+ , Project
5 , Canonical(..)
7 , Canonical(..)
6 , isKernel
8 , isKernel
7− , toString
8 , toChars
9 , toChars
9 , toUrl
10 , toUrl
10 , toFilePath
11 , toFilePath
11− , BadName(..)
12+ , toJsonString
12− , fromString
13+ --
13 , dummyName, kernel, core
14 , dummyName, kernel, core
14 , browser, virtualDom, html
15 , browser, virtualDom, html
15 , json, http, url
16 , json, http, url
16 , webgl, linearAlgebra
17 , webgl, linearAlgebra
18+ --
17 , suggestions
19 , suggestions
20+ , nearbyNames
21+ --
18 , decoder
22 , decoder
19 , encode
23 , encode
24+ , keyDecoder
25+ --
26+ , parser
20 )
27 )
21 where
28 where
22
29
23
30
24import Control.Monad (liftM2)
31import Control.Monad (liftM2)
25import Data.Binary (Binary, get, put)
32import Data.Binary (Binary, get, put)
26−import qualified Data.Char as Char
33+import qualified Data.Coerce as Coerce
27−import qualified Data.Name as Name
34+import qualified Data.List as List
28import qualified Data.Map as Map
35import qualified Data.Map as Map
36+import qualified Data.Name as Name
29import Data.Monoid ((<>))
37import Data.Monoid ((<>))
30import qualified Data.Utf8 as Utf8
38import qualified Data.Utf8 as Utf8
39+import Data.Word (Word8)
40+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
31import System.FilePath ((</>))
41import System.FilePath ((</>))
32
42
33import qualified Elm.Version as V
43import qualified Elm.Version as V
34−import qualified Json.Decode as Decode
44+import qualified Json.Decode as D
35−import qualified Json.Encode as Encode
45+import qualified Json.Encode as E
46+import qualified Json.String as Json
47+import qualified Parse.Primitives as P
48+import Parse.Primitives (Row, Col)
49+import qualified Reporting.Suggest as Suggest
36
50
37
51
38
52
@@ -41,10 +55,17 @@ import qualified Json.Encode as Encode
41
55
42data Name =
56data Name =
43 Name
57 Name
44− { _author :: !Name.Name
58+ { _author :: !Author
45− , _project :: !Name.Name
59+ , _project :: !Project
46 }
60 }
47− deriving (Eq, Ord)
61+ deriving (Ord)
62+
63+
64+type Author = Utf8.Utf8 AUTHOR
65+type Project = Utf8.Utf8 PROJECT
66+
67+data AUTHOR
68+data PROJECT
48
69
49
70
50data Canonical =
71data Canonical =
@@ -52,7 +73,7 @@ data Canonical =
52 { _name :: !Name
73 { _name :: !Name
53 , _version :: !V.Version
74 , _version :: !V.Version
54 }
75 }
55− deriving (Eq, Ord)
76+ deriving (Ord)
56
77
57
78
58
79
@@ -61,127 +82,114 @@ data Canonical =
61
82
62isKernel :: Name -> Bool
83isKernel :: Name -> Bool
63isKernel (Name author _) =
84isKernel (Name author _) =
64− author == "elm" || author == "elm-explorations"
85+ author == elm || author == elm_explorations
65−
66−
67−toString :: Name -> Utf8.String
68−toString (Name author project) =
69− Utf8.join 0x2F [ Name.toUtf8 author, Name.toUtf8 project ]
70
86
71
87
72toChars :: Name -> String
88toChars :: Name -> String
73toChars (Name author project) =
89toChars (Name author project) =
74− Name.toChars author <> "/" <> Name.toChars project
90+ Utf8.toChars author <> "/" <> Utf8.toChars project
75
91
76
92
77toUrl :: Name -> String
93toUrl :: Name -> String
78toUrl (Name author project) =
94toUrl (Name author project) =
79− Name.toChars author ++ "/" ++ Name.toChars project
95+ Utf8.toChars author ++ "/" ++ Utf8.toChars project
80
96
81
97
82toFilePath :: Name -> FilePath
98toFilePath :: Name -> FilePath
83toFilePath (Name author project) =
99toFilePath (Name author project) =
84− Name.toChars author </> Name.toChars project
100+ Utf8.toChars author </> Utf8.toChars project
85
101
86
102
87−fromString :: Utf8.String -> Either BadName Name
103+toJsonString :: Name -> Json.String
88−fromString str =
104+toJsonString (Name author project) =
89− case Utf8.split 0x2F {- / -} str of
90− [author, project]
105+ Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
91− | Utf8.isEmpty author -> Left BadStructure
92− | Utf8.isEmpty project -> Left BadStructure
93− | Utf8.size project >= 256 -> Left TooLong
94− | Utf8.containsDouble 0x2D {- - -} project -> Left HasDoubleDash
95− | Utf8.contains 0x5F {- _ -} project -> Left HasUnderscore
96− | Utf8.contains 0x2E {- . -} project -> Left HasDot
97− | Utf8.any Char.isUpper project -> Left HasUppercase
98− | Utf8.endsWithWord 0x2D {- - -} project -> Left HasDashEnd
99− | Utf8.startsWithChar Char.isLower project -> Right (Name (Name.fromUtf8 author) (Name.fromUtf8 project))
100− | True -> Left HasNonLowercaseStart
101
106
102− _ ->
103− Left BadStructure
104
107
105
108
106−data BadName
109+-- COMMON PACKAGE NAMES
107− = BadStructure
108− | TooLong
109− | HasDoubleDash
110− | HasUnderscore
111− | HasDot
112− | HasUppercase
113− | HasDashEnd
114− | HasNonLowercaseStart
115−
116
110
117
111
118−-- COMMON PACKAGE NAMES
112+toName :: Author -> [Char] -> Name
113+toName author project =
114+ Name author (Utf8.fromChars project)
119
115
120
116
121{-# NOINLINE dummyName #-}
117{-# NOINLINE dummyName #-}
122dummyName :: Name
118dummyName :: Name
123dummyName =
119dummyName =
124− Name "author" "project"
120+ toName (Utf8.fromChars "author") "project"
125
121
126
122
127{-# NOINLINE kernel #-}
123{-# NOINLINE kernel #-}
128kernel :: Name
124kernel :: Name
129kernel =
125kernel =
130− Name "elm" "kernel"
126+ toName elm "kernel"
131
127
132
128
133{-# NOINLINE core #-}
129{-# NOINLINE core #-}
134core :: Name
130core :: Name
135core =
131core =
136− Name "elm" "core"
132+ toName elm "core"
137
133
138
134
139{-# NOINLINE browser #-}
135{-# NOINLINE browser #-}
140browser :: Name
136browser :: Name
141browser =
137browser =
142− Name "elm" "browser"
138+ toName elm "browser"
143
139
144
140
145{-# NOINLINE virtualDom #-}
141{-# NOINLINE virtualDom #-}
146virtualDom :: Name
142virtualDom :: Name
147virtualDom =
143virtualDom =
148− Name "elm" "virtual-dom"
144+ toName elm "virtual-dom"
149
145
150
146
151{-# NOINLINE html #-}
147{-# NOINLINE html #-}
152html :: Name
148html :: Name
153html =
149html =
154− Name "elm" "html"
150+ toName elm "html"
155
151
156
152
157{-# NOINLINE json #-}
153{-# NOINLINE json #-}
158json :: Name
154json :: Name
159json =
155json =
160− Name "elm" "json"
156+ toName elm "json"
161
157
162
158
163{-# NOINLINE http #-}
159{-# NOINLINE http #-}
164http :: Name
160http :: Name
165http =
161http =
166− Name "elm" "http"
162+ toName elm "http"
167
163
168
164
169{-# NOINLINE url #-}
165{-# NOINLINE url #-}
170url :: Name
166url :: Name
171url =
167url =
172− Name "elm" "url"
168+ toName elm "url"
173
169
174
170
175{-# NOINLINE webgl #-}
171{-# NOINLINE webgl #-}
176webgl :: Name
172webgl :: Name
177webgl =
173webgl =
178− Name "elm-explorations" "webgl"
174+ toName elm_explorations "webgl"
179
175
180
176
181{-# NOINLINE linearAlgebra #-}
177{-# NOINLINE linearAlgebra #-}
182linearAlgebra :: Name
178linearAlgebra :: Name
183linearAlgebra =
179linearAlgebra =
184− Name "elm-explorations" "linear-algebra"
180+ toName elm_explorations "linear-algebra"
181+
182+
183+{-# NOINLINE elm #-}
184+elm :: Author
185+elm =
186+ Utf8.fromChars "elm"
187+
188+
189+{-# NOINLINE elm_explorations #-}
190+elm_explorations :: Author
191+elm_explorations =
192+ Utf8.fromChars "elm-explorations"
185
193
186
194
187
195
@@ -190,54 +198,177 @@ linearAlgebra =
190
198
191suggestions :: Map.Map Name.Name Name
199suggestions :: Map.Map Name.Name Name
192suggestions =
200suggestions =
201+ let
202+ random = toName elm "random"
203+ time = toName elm "time"
204+ file = toName elm "file"
205+ in
193 Map.fromList
206 Map.fromList
194− [ ("Browser", browser)
207+ [ "Browser" ==> browser
208+ , "File" ==> file
209+ , "File.Download" ==> file
210+ , "File.Select" ==> file
195− , ("Html", html)
211+ , "Html" ==> html
212+ , "Html.Attributes" ==> html
213+ , "Html.Events" ==> html
196− , ("Http", http)
214+ , "Http" ==> http
197− , ("Json.Decode", json)
215+ , "Json.Decode" ==> json
198− , ("Json.Encode", json)
216+ , "Json.Encode" ==> json
217+ , "Random" ==> random
218+ , "Time" ==> time
199− , ("Url.Parser", url)
219+ , "Url.Parser" ==> url
200− , ("Url", url)
220+ , "Url" ==> url
201 ]
221 ]
202
222
203
223
224+(==>) :: [Char] -> Name -> (Name.Name, Name)
225+(==>) moduleName package =
226+ ( Utf8.fromChars moduleName, package )
204
227
205−-- BINARY
206
228
207
229
208−instance Binary Name where
230+-- NEARBY NAMES
209− get =
210− liftM2 Name get get
211
231
212− put (Name author project) =
213− do put author
214− put project
215
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)
216
238
217−instance Binary Canonical where
239+ nameDistance (Name author2 project2) =
218− get =
240+ authorDist author2 + projectDist project2
219− liftM2 Canonical get get
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))
220
250
221− put (Canonical name version) =
251+
222− do put name
252+projectDistance :: [Char] -> Project -> Int
223− put version
253+projectDistance given possibility =
254+ abs (Suggest.distance given (Utf8.toChars possibility))
255+
256+
257+
258+-- INSTANCES
259+
260+
261+instance Eq Name where
262+ (==) (Name author1 project1) (Name author2 project2) =
263+ project1 == project2 && author1 == author2
264+
265+
266+instance Eq Canonical where
267+ (==) (Canonical package1 version1) (Canonical package2 version2) =
268+ version1 == version2 && package1 == package2
269+
270+
271+
272+-- BINARY
273+
274+
275+instance Binary Name where -- PERF try storing as a Word16
276+ get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
277+ put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
278+
279+
280+instance Binary Canonical where
281+ get = liftM2 Canonical get get
282+ put (Canonical a b) = put a >> put b
224
283
225
284
226
285
227-- JSON
286-- JSON
228
287
229
288
230−decoder :: Decode.Decoder BadName Name
289+decoder :: D.Decoder (Row, Col) Name
231decoder =
290decoder =
232− do str <- Decode.string
291+ D.customString parser (,)
233− case fromString str of
234− Right name ->
235− return name
236−
237− Left err ->
238− Decode.failure err
239
292
240
293
241−encode :: Name -> Encode.Value
294+encode :: Name -> E.Value
242encode name =
295encode name =
243− Encode.string (toString name)
296+ E.chars (toChars name)
297+
298+
299+keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name
300+keyDecoder toError =
301+ let
302+ keyParser =
303+ P.specialize (\(r,c) _ _ -> toError r c) parser
304+ in
305+ D.KeyDecoder keyParser toError
306+
307+
308+
309+-- PARSER
310+
311+
312+parser :: P.Parser (Row, Col) Name
313+parser =
314+ do author <- parseName isAlphaOrDigit isAlphaOrDigit
315+ P.word1 0x2F {-/-} (,)
316+ project <- parseName isLower isLowerOrDigit
317+ return (Name author project)
318+
319+
320+parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)
321+parseName isGoodStart isGoodInner =
322+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
323+ if pos >= end then
324+ eerr row col (,)
325+ else
326+ let !word = P.unsafeIndex pos in
327+ if not (isGoodStart word) then
328+ eerr row col (,)
329+ else
330+ let
331+ (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False
332+ !len = fromIntegral (minusPtr newPos pos)
333+ !newCol = col + len
334+ in
335+ if isGood && len < 256 then
336+ let !newState = P.State src newPos end indent row newCol in
337+ cok (Utf8.fromPtr pos newPos) newState
338+ else
339+ cerr row newCol (,)
340+
341+
342+isLower :: Word8 -> Bool
343+isLower word =
344+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
345+
346+
347+isLowerOrDigit :: Word8 -> Bool
348+isLowerOrDigit word =
349+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
350+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}
351+
352+
353+isAlphaOrDigit :: Word8 -> Bool
354+isAlphaOrDigit word =
355+ 0x61 {-a-} <= word && word <= 0x7A {-z-}
356+ || 0x41 {-A-} <= word && word <= 0x5A {-Z-}
357+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}
358+
359+
360+chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)
361+chompName isGoodChar pos end prevWasDash =
362+ if pos >= end then
363+ (# not prevWasDash, pos #)
364+ else
365+ let !word = P.unsafeIndex pos in
366+ if isGoodChar word then
367+ chompName isGoodChar (plusPtr pos 1) end False
368+ else if word == 0x2D {---} then
369+ if prevWasDash then
370+ (# False, pos #)
371+ else
372+ chompName isGoodChar (plusPtr pos 1) end True
373+ else
374+ (# True, pos #)
compiler/src/Elm/String.hsnew file+133
@@ -0,0 +1,133 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
3+module Elm.String
4+ ( String
5+ , toChars
6+ , toBuilder
7+ , Chunk(..)
8+ , fromChunks
9+ )
10+ where
11+
12+
13+import Prelude hiding (String)
14+import Data.Binary (Binary, get, put)
15+import Data.Bits ((.&.), shiftR)
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.Utf8 as Utf8
18+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
19+import GHC.Exts (RealWorld, Ptr)
20+import GHC.IO (stToIO, unsafeDupablePerformIO)
21+import GHC.ST (ST)
22+import GHC.Word (Word8)
23+
24+
25+
26+-- STRINGS
27+
28+
29+type String =
30+ Utf8.Utf8 ELM_STRING
31+
32+
33+data ELM_STRING
34+
35+
36+
37+-- HELPERS
38+
39+
40+toChars :: String -> [Char]
41+toChars =
42+ Utf8.toChars
43+
44+
45+{-# INLINE toBuilder #-}
46+toBuilder :: String -> B.Builder
47+toBuilder =
48+ Utf8.toBuilder
49+
50+
51+
52+-- FROM CHUNKS
53+
54+
55+data Chunk
56+ = Slice (Ptr Word8) Int
57+ | Escape Word8
58+ | CodePoint Int
59+
60+
61+fromChunks :: [Chunk] -> String
62+fromChunks chunks =
63+ unsafeDupablePerformIO (stToIO (
64+ do let !len = sum (map chunkToWidth chunks)
65+ mba <- newByteArray len
66+ writeChunks mba 0 chunks
67+ freeze mba
68+ ))
69+
70+
71+chunkToWidth :: Chunk -> Int
72+chunkToWidth chunk =
73+ case chunk of
74+ Slice _ len -> len
75+ Escape _ -> 2
76+ CodePoint c -> if c < 0xFFFF then 6 else 12
77+
78+
79+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
80+writeChunks mba offset chunks =
81+ case chunks of
82+ [] ->
83+ return ()
84+
85+ chunk : chunks ->
86+ case chunk of
87+ Slice ptr len ->
88+ do copyFromPtr ptr mba offset len
89+ let !newOffset = offset + len
90+ writeChunks mba newOffset chunks
91+
92+ Escape word ->
93+ do writeWord8 mba offset 0x5C {- \ -}
94+ writeWord8 mba (offset + 1) word
95+ let !newOffset = offset + 2
96+ writeChunks mba newOffset chunks
97+
98+ CodePoint code ->
99+ if code < 0xFFFF then
100+ do writeCode mba offset code
101+ let !newOffset = offset + 6
102+ writeChunks mba newOffset chunks
103+ else
104+ do let (hi,lo) = divMod (code - 0x10000) 0x400
105+ writeCode mba (offset ) (hi + 0xD800)
106+ writeCode mba (offset + 6) (lo + 0xDC00)
107+ let !newOffset = offset + 12
108+ writeChunks mba newOffset chunks
109+
110+
111+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112+writeCode mba offset code =
113+ do writeWord8 mba offset 0x5C {- \ -}
114+ writeWord8 mba (offset + 1) 0x75 {- u -}
115+ writeHex mba (offset + 2) (shiftR code 12)
116+ writeHex mba (offset + 3) (shiftR code 8)
117+ writeHex mba (offset + 4) (shiftR code 4)
118+ writeHex mba (offset + 5) code
119+
120+
121+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
122+writeHex mba !offset !bits =
123+ do let !n = fromIntegral bits .&. 0x0F
124+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
125+
126+
127+
128+-- BINARY
129+
130+
131+instance Binary (Utf8.Utf8 ELM_STRING) where
132+ get = Utf8.getVeryLong
133+ put = Utf8.putVeryLong
compiler/src/Elm/Version.hs+79−50
@@ -1,3 +1,5 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
1module Elm.Version
3module Elm.Version
2 ( Version(..)
4 ( Version(..)
3 , one
5 , one
@@ -7,24 +9,27 @@ module Elm.Version
7 , bumpMinor
9 , bumpMinor
8 , bumpMajor
10 , bumpMajor
9 , toChars
11 , toChars
10− , toString
12+ --
11− , fromString
12 , decoder
13 , decoder
13 , encode
14 , encode
15+ --
16+ , parser
14 )
17 )
15 where
18 where
16
19
17
20
18import Prelude hiding (max)
21import Prelude hiding (max)
19−import Control.Monad (liftM, liftM3)
22+import Control.Monad (liftM3)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
23import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Utf8 as Utf8
22import qualified Data.Version as Version
24import qualified Data.Version as Version
23−import Data.Word (Word16)
25+import Data.Word (Word8, Word16)
26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
24import qualified Paths_elm
27import qualified Paths_elm
25
28
26import qualified Json.Decode as D
29import qualified Json.Decode as D
27import qualified Json.Encode as E
30import qualified Json.Encode as E
31+import qualified Parse.Primitives as P
32+import Parse.Primitives (Row, Col)
28
33
29
34
30
35
@@ -86,58 +91,26 @@ bumpMajor (Version major _minor _patch) =
86
91
87
92
88
93
89−-- TO STRING
94+-- TO CHARS
90
95
91
96
92−toChars :: Version -> String
97+toChars :: Version -> [Char]
93−toChars vsn =
94− Utf8.toChars (toString vsn)
95−
96−
97−toString :: Version -> Utf8.String
98−toString (Version major minor patch) =
98+toChars (Version major minor patch) =
99− Utf8.join 0x2E {- . -}
99+ show major ++ '.' : show minor ++ '.' : show patch
100− [ Utf8.fromWord16 major
101− , Utf8.fromWord16 minor
102− , Utf8.fromWord16 patch
103− ]
104−
105−
106−
107−-- FROM STRING
108−
109−
110−fromString :: Utf8.String -> Maybe Version
111−fromString str =
112− case Utf8.split 0x2E {- . -} str of
113− [major, minor, patch] ->
114− Version
115− <$> Utf8.toWord16 major
116− <*> Utf8.toWord16 minor
117− <*> Utf8.toWord16 patch
118−
119− _ ->
120− Nothing
121
100
122
101
123
102
124-- JSON
103-- JSON
125
104
126
105
127−decoder :: D.Decoder Utf8.String Version
106+decoder :: D.Decoder (Row, Col) Version
128decoder =
107decoder =
129− do str <- D.string
108+ D.customString parser (,)
130− case fromString str of
131− Just version ->
132− return version
133−
134− Nothing ->
135− D.failure str
136
109
137
110
138encode :: Version -> E.Value
111encode :: Version -> E.Value
139encode version =
112encode version =
140− E.string (toString version)
113+ E.chars (toChars version)
141
114
142
115
143
116
@@ -147,21 +120,77 @@ encode version =
147instance Binary Version where
120instance Binary Version where
148 get =
121 get =
149 do word <- getWord8
122 do word <- getWord8
150− if word == 0
123+ if word == 255
151 then liftM3 Version get get get
124 then liftM3 Version get get get
152 else
125 else
153− do minor <- liftM fromIntegral getWord8
126+ do minor <- getWord8
154− patch <- liftM fromIntegral getWord8
127+ patch <- getWord8
155− return (Version (fromIntegral word) minor patch)
128+ return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch))
156
129
157 put (Version major minor patch) =
130 put (Version major minor patch) =
158− if major < 256 && minor < 256 && patch < 256 then
131+ if major < 255 && minor < 256 && patch < 256 then
159 do putWord8 (fromIntegral major)
132 do putWord8 (fromIntegral major)
160 putWord8 (fromIntegral minor)
133 putWord8 (fromIntegral minor)
161 putWord8 (fromIntegral patch)
134 putWord8 (fromIntegral patch)
162 else
135 else
163− do putWord8 0
136+ do putWord8 255
164 put major
137 put major
165 put minor
138 put minor
166 put patch
139 put patch
167
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+17−4
@@ -24,18 +24,31 @@ sandwich moduleName javascript =
24<head>
24<head>
25 <meta charset="UTF-8">
25 <meta charset="UTF-8">
26 <title>|] <> name <> [r|</title>
26 <title>|] <> name <> [r|</title>
27+ <style>body { padding: 0; margin: 0; }</style>
27</head>
28</head>
28
29
29<body>
30<body>
30−<div id="elm-df98db9626"></div>
31+
32+<pre id="elm"></pre>
33+
31<script>
34<script>
35+try {
32|] <> javascript <> [r|
36|] <> javascript <> [r|
33
37
34−var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm-df98db9626") });
38+ var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
35−if (document.getElementById("elm-df98db9626"))
39+}
40+catch (e)
36{
41{
37− document.getElementById("elm-df98db9626").innerText = 'This is a headless program, meaning there is nothing to show here.\n\nI started the program anyway though, and you can access it as `app` in the developer console.';
42+ // display initialization errors (e.g. bad flags, infinite recursion)
43+ var header = document.createElement("h1");
44+ header.style.fontFamily = "monospace";
45+ header.innerText = "Initialization Error";
46+ var pre = document.getElementById("elm");
47+ document.body.insertBefore(header, pre);
48+ pre.innerText = e;
49+ throw e;
38}
50}
39</script>
51</script>
52+
40</body>
53</body>
41</html>|]
54</html>|]
compiler/src/Generate/JavaScript.hs+97−87
@@ -1,8 +1,8 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
2module Generate.JavaScript
3− ( Output(..)
4− , generate
3+ ( generate
5 , generateForRepl
4 , generateForRepl
5+ , generateForReplEndpoint
6 )
6 )
7 where
7 where
8
8
@@ -20,11 +20,11 @@ import qualified Data.Utf8 as Utf8
20import qualified AST.Canonical as Can
20import qualified AST.Canonical as Can
21import qualified AST.Optimized as Opt
21import qualified AST.Optimized as Opt
22import qualified Data.Index as Index
22import qualified Data.Index as Index
23−import qualified Elm.Interface as I
24import qualified Elm.Kernel as K
23import qualified Elm.Kernel as K
25import qualified Elm.ModuleName as ModuleName
24import qualified Elm.ModuleName as ModuleName
26import qualified Generate.JavaScript.Builder as JS
25import qualified Generate.JavaScript.Builder as JS
27import qualified Generate.JavaScript.Expression as Expr
26import qualified Generate.JavaScript.Expression as Expr
27+import qualified Generate.JavaScript.Functions as Functions
28import qualified Generate.JavaScript.Name as JsName
28import qualified Generate.JavaScript.Name as JsName
29import qualified Generate.Mode as Mode
29import qualified Generate.Mode as Mode
30import qualified Reporting.Doc as D
30import qualified Reporting.Doc as D
@@ -33,33 +33,27 @@ import qualified Reporting.Render.Type.Localizer as L
33
33
34
34
35
35
36−-- GENERATE MAINS
36+-- GENERATE
37
37
38
38
39−data Output
39+type Graph = Map.Map Opt.Global Opt.Node
40− = None
40+type Mains = Map.Map ModuleName.Canonical Opt.Main
41− | Some Name.Name [Name.Name] B.Builder
42
41
43
42
44−generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
43+generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder
45−generate mode (Opt.Graph mains graph _) roots =
44+generate mode (Opt.GlobalGraph graph _) mains =
46 let
45 let
47− rootSet = Set.fromList roots
46+ state = Map.foldrWithKey (addMain mode graph) emptyState mains
48− rootMap = Map.restrictKeys mains rootSet
49 in
47 in
50− case map ModuleName._module (Map.keys rootMap) of
48+ "(function(scope){\n'use strict';"
51− [] ->
49+ <> Functions.functions
52− None
50+ <> perfNote mode
53−
54− name:names ->
55− let
56− state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
57− builder = perfNote mode <> stateToBuilder state <> toMainExports mode rootMap
51+ <> stateToBuilder state
58− in
52+ <> toMainExports mode mains
59− Some name names builder
53+ <> "}(this));"
60
54
61
55
62−addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
56+addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
63addMain mode graph home _ state =
57addMain mode graph home _ state =
64 addGlobal mode graph state (Opt.Global home "main")
58 addGlobal mode graph state (Opt.Global home "main")
65
59
@@ -85,34 +79,68 @@ perfNote mode =
85-- GENERATE FOR REPL
79-- GENERATE FOR REPL
86
80
87
81
88−generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder
82+generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
89−generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
83+generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
90 let
84 let
91 mode = Mode.Dev Nothing
85 mode = Mode.Dev Nothing
92 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
93 evalState = addGlobal mode graph debugState (Opt.Global home name)
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
94 in
88 in
89+ "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90+ <> Functions.functions
95− stateToBuilder evalState
91+ <> stateToBuilder evalState
96− <>
97− print ansi localizer home name (I._values iface ! name)
92+ <> print ansi localizer home name tipe
98
93
99
94
100−print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
95+print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
101−print ansi localizer home name (Can.Forall _ tipe) =
96+print ansi localizer home name tipe =
102 let
97 let
103 value = JsName.toBuilder (JsName.fromGlobal home name)
98 value = JsName.toBuilder (JsName.fromGlobal home name)
104 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
99 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
105 tipeDoc = RT.canToDoc localizer RT.None tipe
100 tipeDoc = RT.canToDoc localizer RT.None tipe
106 bool = if ansi then "true" else "false"
101 bool = if ansi then "true" else "false"
107 in
102 in
108− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
103+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
109− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
104+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
110− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
105+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
111− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
106+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
112− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
107+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
113− \} else {\n\
108+ \} else {\n\
114− \ _print(' : ' + _type);\n\
109+ \ _print(' : ' + _type);\n\
110+ \}\n"
111+
112+
113+
114+-- GENERATE FOR REPL ENDPOINT
115+
116+
117+generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118+generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119+ let
120+ name = maybe Name.replValueToPrint id maybeName
121+ mode = Mode.Dev Nothing
122+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123+ evalState = addGlobal mode graph debugState (Opt.Global home name)
124+ in
125+ Functions.functions
126+ <> stateToBuilder evalState
127+ <> postMessage localizer home maybeName tipe
128+
129+
130+postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131+postMessage localizer home maybeName tipe =
132+ let
133+ name = maybe Name.replValueToPrint id maybeName
134+ value = JsName.toBuilder (JsName.fromGlobal home name)
135+ toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136+ tipeDoc = RT.canToDoc localizer RT.None tipe
137+ toName n = "\"" <> Name.toBuilder n <> "\""
138+ in
139+ "self.postMessage({\n\
140+ \ name: " <> maybe "null" toName maybeName <> ",\n\
141+ \ value: " <> toString <> "(true, " <> value <> "),\n\
142+ \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
115− \}\n"
143+ \});\n"
116
144
117
145
118
146
@@ -146,9 +174,6 @@ prependBuilders revBuilders monolith =
146-- ADD DEPENDENCIES
174-- ADD DEPENDENCIES
147
175
148
176
149−type Graph = Map.Map Opt.Global Opt.Node
150−
151−
152addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
177addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
153addGlobal mode graph state@(State revKernels builders seen) global =
178addGlobal mode graph state@(State revKernels builders seen) global =
154 if Set.member global seen then
179 if Set.member global seen then
@@ -236,7 +261,7 @@ addKernel (State revKernels revBuilders seen) kernel =
236
261
237var :: Opt.Global -> Expr.Code -> JS.Stmt
262var :: Opt.Global -> Expr.Code -> JS.Stmt
238var (Opt.Global home name) code =
263var (Opt.Global home name) code =
239− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
264+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
240
265
241
266
242isDebugger :: Opt.Global -> Bool
267isDebugger :: Opt.Global -> Bool
@@ -267,7 +292,7 @@ generateCycle mode (Opt.Global home _) names values functions =
267 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
268 <> drawCycle names
293 <> drawCycle names
269 <> "\\n\\nThese errors are very tricky, so read "
294 <> "\\n\\nThese errors are very tricky, so read "
270− <> B.stringUtf8 (D.makeNakedLink "halting-problem")
295+ <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
271 <> " to learn how to fix it!"
296 <> " to learn how to fix it!"
272 ]
297 ]
273
298
@@ -276,10 +301,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
276generateCycleFunc mode home def =
301generateCycleFunc mode home def =
277 case def of
302 case def of
278 Opt.Def name expr ->
303 Opt.Def name expr ->
279− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
304+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
280
305
281 Opt.TailDef name args expr ->
306 Opt.TailDef name args expr ->
282− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
307+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
283
308
284
309
285generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
@@ -295,9 +320,9 @@ generateRealCycle home (name, _) =
295 realName = JsName.fromGlobal home name
320 realName = JsName.fromGlobal home name
296 in
321 in
297 JS.Block
322 JS.Block
298− [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
323+ [ JS.Var realName (JS.Call (JS.Ref safeName) [])
299 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
300− JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
325+ JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
301 ]
326 ]
302
327
303
328
@@ -325,7 +350,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
325addChunk mode chunk builder =
350addChunk mode chunk builder =
326 case chunk of
351 case chunk of
327 K.JS javascript ->
352 K.JS javascript ->
328− Utf8.toBuilder javascript <> builder
353+ B.byteString javascript <> builder
329
354
330 K.ElmVar home name ->
355 K.ElmVar home name ->
331 JsName.toBuilder (JsName.fromGlobal home name) <> builder
356 JsName.toBuilder (JsName.fromGlobal home name) <> builder
@@ -365,16 +390,13 @@ addChunk mode chunk builder =
365
390
366generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
367generateEnum mode global@(Opt.Global home name) index =
392generateEnum mode global@(Opt.Global home name) index =
368− let
393+ JS.Var (JsName.fromGlobal home name) $
369− definition =
370− case mode of
394+ case mode of
371− Mode.Dev _ ->
395+ Mode.Dev _ ->
372− Expr.codeToExpr (Expr.generateCtor mode global index 0)
396+ Expr.codeToExpr (Expr.generateCtor mode global index 0)
373
397
374− Mode.Prod _ ->
398+ Mode.Prod _ ->
375− JS.Int (Index.toMachine index)
399+ JS.Int (Index.toMachine index)
376− in
377− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
378
400
379
401
380
402
@@ -383,16 +405,13 @@ generateEnum mode global@(Opt.Global home name) index =
383
405
384generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
385generateBox mode global@(Opt.Global home name) =
407generateBox mode global@(Opt.Global home name) =
386− let
408+ JS.Var (JsName.fromGlobal home name) $
387− definition =
388− case mode of
409+ case mode of
389− Mode.Dev _ ->
410+ Mode.Dev _ ->
390− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
411+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
391
412
392− Mode.Prod _ ->
413+ Mode.Prod _ ->
393− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
414+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
394− in
395− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
396
415
397
416
398{-# NOINLINE identity #-}
417{-# NOINLINE identity #-}
@@ -407,14 +426,11 @@ identity =
407
426
408generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
409generatePort mode (Opt.Global home name) makePort converter =
428generatePort mode (Opt.Global home name) makePort converter =
410− let
429+ JS.Var (JsName.fromGlobal home name) $
411− definition =
412− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
430+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
413− [ JS.String (Name.toBuilder name)
431+ [ JS.String (Name.toBuilder name)
414− , Expr.codeToExpr (Expr.generate mode converter)
432+ , Expr.codeToExpr (Expr.generate mode converter)
415− ]
433+ ]
416− in
417− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
418
434
419
435
420
436
@@ -442,11 +458,9 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)
442
458
443generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
444generateLeaf home@(ModuleName.Canonical _ moduleName) name =
460generateLeaf home@(ModuleName.Canonical _ moduleName) name =
445− let
461+ JS.Var (JsName.fromGlobal home name) $
446− definition =
447− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
462+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
448− in
463+
449− JS.Var [ (JsName.fromGlobal home name, Just definition) ]
450
464
451
465
452{-# NOINLINE leaf #-}
466{-# NOINLINE leaf #-}
@@ -487,7 +501,7 @@ generateManagerHelp home effectsType =
487-- MAIN EXPORTS
501-- MAIN EXPORTS
488
502
489
503
490−toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
504+toMainExports :: Mode.Mode -> Mains -> B.Builder
491toMainExports mode mains =
505toMainExports mode mains =
492 let
506 let
493 export = JsName.fromKernel Name.platform "export"
507 export = JsName.fromKernel Name.platform "export"
@@ -520,7 +534,7 @@ generateExports mode (Trie maybeMain subs) =
520 <> List.foldl' (addSubTrie mode) "}" otherSubTries
534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
521
535
522
536
523−addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
537+addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
524addSubTrie mode end (name, trie) =
538addSubTrie mode end (name, trie) =
525 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
526
540
@@ -532,7 +546,7 @@ addSubTrie mode end (name, trie) =
532data Trie =
546data Trie =
533 Trie
547 Trie
534 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
535− , _subs :: Map.Map Utf8.String Trie
549+ , _subs :: Map.Map Name.Name Trie
536 }
550 }
537
551
538
552
@@ -543,14 +557,10 @@ emptyTrie =
543
557
544addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
545addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
546− let
547− segments =
548− Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
549− in
550− merge trie $ segmentsToTrie home segments main
560+ merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
551
561
552
562
553−segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
563+segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
554segmentsToTrie home segments main =
564segmentsToTrie home segments main =
555 case segments of
565 case segments of
556 [] ->
566 [] ->
compiler/src/Generate/JavaScript/Builder.hs+207−217
@@ -16,6 +16,7 @@ module Generate.JavaScript.Builder
16
16
17import Prelude hiding (lines)
17import Prelude hiding (lines)
18import qualified Data.List as List
18import qualified Data.List as List
19+import qualified Data.ByteString as BS
19import Data.ByteString.Builder as B
20import Data.ByteString.Builder as B
20import Data.Monoid ((<>))
21import Data.Monoid ((<>))
21import qualified Generate.JavaScript.Name as Name
22import qualified Generate.JavaScript.Name as Name
@@ -27,6 +28,19 @@ import qualified Json.Encode as Json
27-- EXPRESSIONS
28-- EXPRESSIONS
28
29
29
30
31+-- NOTE: I tried making this create a B.Builder directly.
32+--
33+-- The hope was that it'd allocate less and speed things up, but it seemed
34+-- to be neutral for perf.
35+--
36+-- The downside is that Generate.JavaScript.Expression inspects the
37+-- structure of Expr and Stmt on some occassions to try to strip out
38+-- unnecessary closures. I think these closures are already avoided
39+-- by other logic in code gen these days, but I am not 100% certain.
40+--
41+-- For this to be worth it, I think it would be necessary to avoid
42+-- returning tuples when generating expressions.
43+--
30data Expr
44data Expr
31 = String Builder
45 = String Builder
32 | Float Builder
46 | Float Builder
@@ -37,13 +51,13 @@ data Expr
37 | Array [Expr]
51 | Array [Expr]
38 | Object [(Name, Expr)]
52 | Object [(Name, Expr)]
39 | Ref Name
53 | Ref Name
40− | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
54+ | Access Expr Name -- foo.bar
41− | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
55+ | Index Expr Expr -- foo[bar]
42 | Prefix PrefixOp Expr
56 | Prefix PrefixOp Expr
43 | Infix InfixOp Expr Expr
57 | Infix InfixOp Expr Expr
44 | If Expr Expr Expr
58 | If Expr Expr Expr
45 | Assign LValue Expr
59 | Assign LValue Expr
46− | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
60+ | Call Expr [Expr]
47 | Function (Maybe Name) [Name] [Stmt]
61 | Function (Maybe Name) [Name] [Stmt]
48
62
49
63
@@ -58,20 +72,21 @@ data LValue
58
72
59
73
60data Stmt
74data Stmt
61− = Block [Stmt] -- {stmts}
75+ = Block [Stmt]
62− | EmptyStmt -- ;
76+ | EmptyStmt
63− | ExprStmt Expr -- expr;
77+ | ExprStmt Expr
64− | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
78+ | IfStmt Expr Stmt Stmt
65− | Switch Expr [Case] -- switch (e) clauses
79+ | Switch Expr [Case]
66− | While Expr Stmt -- while (e) do stmt
80+ | While Expr Stmt
67− | Break (Maybe Name) -- break lab;
81+ | Break (Maybe Name)
68− | Continue (Maybe Name) -- continue lab;
82+ | Continue (Maybe Name)
69− | Labelled Name Stmt -- lab: stmt
83+ | Labelled Name Stmt
70− | Try Stmt Name Stmt -- try stmt catch (x) stmt
84+ | Try Stmt Name Stmt
71− | Throw Expr -- throw expr;
85+ | Throw Expr
72− | Return (Maybe Expr) -- return expr;
86+ | Return Expr
87+ | Var Name Expr
73− | Var [(Name, Maybe Expr)] -- var x, y=42;
88+ | Vars [(Name, Expr)]
74− | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
89+ | FunctionStmt Name [Name] [Stmt]
75
90
76
91
77data Case
92data Case
@@ -84,37 +99,31 @@ data Case
84
99
85
100
86data InfixOp
101data InfixOp
87− = OpLT -- <
102+ = OpAdd -- +
88− | OpLEq -- <=
103+ | OpSub -- -
89− | OpGT -- >
90− | OpGEq -- >=
91− | OpIn -- in
92− | OpInstanceof -- instanceof
93− | OpEq -- ==
94− | OpNEq -- !=
95− | OpStrictEq -- ===
96− | OpStrictNEq -- !==
97− | OpLAnd -- &&
98− | OpLOr -- ||
99 | OpMul -- *
104 | OpMul -- *
100 | OpDiv -- /
105 | OpDiv -- /
101 | OpMod -- %
106 | OpMod -- %
102− | OpSub -- -
107+ | OpEq -- ===
108+ | OpNe -- !==
109+ | OpLt -- <
110+ | OpLe -- <=
111+ | OpGt -- >
112+ | OpGe -- >=
113+ | OpAnd -- &&
114+ | OpOr -- ||
115+ | OpBitwiseAnd -- &
116+ | OpBitwiseXor -- ^
117+ | OpBitwiseOr -- |
103− | OpLShift -- <<
118+ | OpLShift -- <<
104− | OpSpRShift -- >>
119+ | OpSpRShift -- >>
105− | OpZfRShift -- >>>
120+ | OpZfRShift -- >>>
106− | OpBAnd -- &
107− | OpBXor -- ^
108− | OpBOr -- |
109− | OpAdd -- +
110
121
111
122
112data PrefixOp
123data PrefixOp
113− = PrefixLNot -- !
124+ = PrefixNot -- !
114− | PrefixBNot -- ~
125+ | PrefixNegate -- -
115− | PrefixPlus -- +
126+ | PrefixComplement -- ~
116− | PrefixMinus -- -
117− | PrefixTypeof -- typeof
118
127
119
128
120
129
@@ -123,21 +132,40 @@ data PrefixOp
123
132
124stmtToBuilder :: Stmt -> Builder
133stmtToBuilder :: Stmt -> Builder
125stmtToBuilder stmts =
134stmtToBuilder stmts =
126− fromStmt "" stmts
135+ fromStmt levelZero stmts
127
136
128
137
129exprToBuilder :: Expr -> Builder
138exprToBuilder :: Expr -> Builder
130exprToBuilder expr =
139exprToBuilder expr =
131− snd $ fromExpr "" Whatever expr
140+ snd $ fromExpr levelZero Whatever expr
132
141
133
142
134
143
135−-- HELPERS
144+-- INDENT LEVEL
145+
146+
147+data Level =
148+ Level Builder Level
149+
150+
151+levelZero :: Level
152+levelZero =
153+ Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
154+
155+
156+makeLevel :: Int -> BS.ByteString -> Level
157+makeLevel level oldTabs =
158+ let
159+ tabs =
160+ if level <= BS.length oldTabs
161+ then oldTabs
162+ else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
163+ in
164+ Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
165+
136
166
137
167
138−deeper :: Builder -> Builder
168+-- HELPERS
139−deeper indent =
140− "\t" <> indent
141
169
142
170
143commaSep :: [Builder] -> Builder
171commaSep :: [Builder] -> Builder
@@ -145,52 +173,52 @@ commaSep builders =
145 mconcat (List.intersperse ", " builders)
173 mconcat (List.intersperse ", " builders)
146
174
147
175
148−commaNewlineSep :: Builder -> [Builder] -> Builder
176+commaNewlineSep :: Level -> [Builder] -> Builder
149−commaNewlineSep indent builders =
177+commaNewlineSep (Level _ (Level deeperIndent _)) builders =
150− mconcat (List.intersperse (",\n" <> deeper indent) builders)
178+ mconcat (List.intersperse (",\n" <> deeperIndent) builders)
151
179
152
180
153
181
154-- STATEMENTS
182-- STATEMENTS
155
183
156
184
157−fromStmtBlock :: Builder -> [Stmt] -> Builder
185+fromStmtBlock :: Level -> [Stmt] -> Builder
158−fromStmtBlock indent stmts =
186+fromStmtBlock level stmts =
159− mconcat (map (fromStmt indent) stmts)
187+ mconcat (map (fromStmt level) stmts)
160
188
161
189
162−fromStmt :: Builder -> Stmt -> Builder
190+fromStmt :: Level -> Stmt -> Builder
163−fromStmt indent statement =
191+fromStmt level@(Level indent nextLevel) statement =
164 case statement of
192 case statement of
165 Block stmts ->
193 Block stmts ->
166− fromStmtBlock indent stmts
194+ fromStmtBlock level stmts
167
195
168 EmptyStmt ->
196 EmptyStmt ->
169 mempty
197 mempty
170
198
171 ExprStmt expr ->
199 ExprStmt expr ->
172− indent <> snd (fromExpr indent Whatever expr) <> ";\n"
200+ indent <> snd (fromExpr level Whatever expr) <> ";\n"
173
201
174 IfStmt condition thenStmt elseStmt ->
202 IfStmt condition thenStmt elseStmt ->
175 mconcat
203 mconcat
176− [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
204+ [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
177− , fromStmt (deeper indent) thenStmt
205+ , fromStmt nextLevel thenStmt
178 , indent, "} else {\n"
206 , indent, "} else {\n"
179− , fromStmt (deeper indent) elseStmt
207+ , fromStmt nextLevel elseStmt
180 , indent, "}\n"
208 , indent, "}\n"
181 ]
209 ]
182
210
183 Switch expr clauses ->
211 Switch expr clauses ->
184 mconcat
212 mconcat
185− [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
213+ [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
186− , mconcat (map (fromClause (deeper indent)) clauses)
214+ , mconcat (map (fromClause nextLevel) clauses)
187 , indent, "}\n"
215 , indent, "}\n"
188 ]
216 ]
189
217
190 While expr stmt ->
218 While expr stmt ->
191 mconcat
219 mconcat
192− [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
220+ [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
193− , fromStmt (deeper indent) stmt
221+ , fromStmt nextLevel stmt
194 , indent, "}\n"
222 , indent, "}\n"
195 ]
223 ]
196
224
@@ -209,37 +237,37 @@ fromStmt indent statement =
209 Labelled label stmt ->
237 Labelled label stmt ->
210 mconcat
238 mconcat
211 [ indent, Name.toBuilder label, ":\n"
239 [ indent, Name.toBuilder label, ":\n"
212− , fromStmt indent stmt
240+ , fromStmt level stmt
213 ]
241 ]
214
242
215 Try tryStmt errorName catchStmt ->
243 Try tryStmt errorName catchStmt ->
216 mconcat
244 mconcat
217 [ indent, "try {\n"
245 [ indent, "try {\n"
218− , fromStmt (deeper indent) tryStmt
246+ , fromStmt nextLevel tryStmt
219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
220− , fromStmt (deeper indent) catchStmt
248+ , fromStmt nextLevel catchStmt
221 , indent, "}\n"
249 , indent, "}\n"
222 ]
250 ]
223
251
224 Throw expr ->
252 Throw expr ->
225− "throw " <> snd (fromExpr indent Whatever expr) <> ";"
253+ indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
226
254
227− Return Nothing ->
255+ Return expr ->
228− indent <> "return;\n"
256+ indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
229
257
230− Return (Just expr) ->
258+ Var name expr ->
231− indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
259+ indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
232
260
233− Var [] ->
261+ Vars [] ->
234 mempty
262 mempty
235
263
236− Var vars ->
264+ Vars vars ->
237− indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
265+ indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
238
266
239 FunctionStmt name args stmts ->
267 FunctionStmt name args stmts ->
240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
241 <>
269 <>
242− fromStmtBlock (deeper indent) stmts
270+ fromStmtBlock nextLevel stmts
243 <>
271 <>
244 indent <> "}\n"
272 indent <> "}\n"
245
273
@@ -248,30 +276,25 @@ fromStmt indent statement =
248-- SWITCH CLAUSES
276-- SWITCH CLAUSES
249
277
250
278
251−fromClause :: Builder -> Case -> Builder
279+fromClause :: Level -> Case -> Builder
252−fromClause indent clause =
280+fromClause level@(Level indent nextLevel) clause =
253 case clause of
281 case clause of
254 Case expr stmts ->
282 Case expr stmts ->
255− indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
283+ indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
256− <> fromStmtBlock (deeper indent) stmts
284+ <> fromStmtBlock nextLevel stmts
257
285
258 Default stmts ->
286 Default stmts ->
259 indent <> "default:\n"
287 indent <> "default:\n"
260− <> fromStmtBlock (deeper indent) stmts
288+ <> fromStmtBlock nextLevel stmts
261
289
262
290
263
291
264-- VAR DECLS
292-- VAR DECLS
265
293
266
294
267−varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
295+varToBuilder :: Level -> (Name, Expr) -> Builder
268−varToBuilder indent (name, maybeExpr) =
296+varToBuilder level (name, expr) =
269− case maybeExpr of
270− Nothing ->
271− Name.toBuilder name
272−
273− Just expr ->
274− Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
297+ Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
275
298
276
299
277
300
@@ -289,12 +312,11 @@ merge a b =
289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
290linesMap func xs =
313linesMap func xs =
291 let
314 let
292− pairs =
293− map func xs
315+ pairs = map func xs
294 in
316 in
295− ( any ((==) Many . fst) pairs
317+ ( any ((==) Many . fst) pairs
296− , map snd pairs
318+ , map snd pairs
297− )
319+ )
298
320
299
321
300data Grouping = Atomic | Whatever
322data Grouping = Atomic | Whatever
@@ -310,23 +332,23 @@ parensFor grouping builder =
310 builder
332 builder
311
333
312
334
313−fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
335+fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
314−fromExpr indent grouping expression =
336+fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
315 case expression of
337 case expression of
316 String string ->
338 String string ->
317− (One, "'" <> string <> "'")
339+ ( One, "'" <> string <> "'" )
318
340
319 Float float ->
341 Float float ->
320− (One, float)
342+ ( One, float )
321
343
322 Int n ->
344 Int n ->
323− (One, B.intDec n)
345+ ( One, B.intDec n )
324
346
325 Bool bool ->
347 Bool bool ->
326− (One, if bool then "true" else "false")
348+ ( One, if bool then "true" else "false" )
327
349
328 Null ->
350 Null ->
329− (One, "null")
351+ ( One, "null" )
330
352
331 Json json ->
353 Json json ->
332 ( One, Json.encodeUgly json )
354 ( One, Json.encodeUgly json )
@@ -334,111 +356,90 @@ fromExpr indent grouping expression =
334 Array exprs ->
356 Array exprs ->
335 (,) Many $
357 (,) Many $
336 let
358 let
337− (anyMany, builders) =
338− linesMap (fromExpr indent Whatever) exprs
359+ (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
339 in
360 in
340− if anyMany then
361+ if anyMany then
341− "[\n"
362+ "[\n"
342− <> deeper indent
363+ <> deeperIndent
343− <> commaNewlineSep indent builders
364+ <> commaNewlineSep level builders
344− <> "\n" <> indent <> "]"
365+ <> "\n" <> indent <> "]"
345−
346− else
366+ else
347− "[" <> commaSep builders <> "]"
367+ "[" <> commaSep builders <> "]"
348
368
349 Object fields ->
369 Object fields ->
350 (,) Many $
370 (,) Many $
351 let
371 let
352− deeperIndent =
353− deeper indent
354−
355− (anyMany, builders) =
356− linesMap (fromField deeperIndent) fields
372+ (anyMany, builders) = linesMap (fromField nextLevel) fields
357 in
373 in
358− if anyMany then
374+ if anyMany then
359− "{\n"
375+ "{\n"
360− <> deeperIndent
376+ <> deeperIndent
361− <> commaNewlineSep indent builders
377+ <> commaNewlineSep level builders
362− <> "\n" <> indent <> "}"
378+ <> "\n" <> indent <> "}"
363−
364− else
379+ else
365− "{" <> commaSep builders <> "}"
380+ "{" <> commaSep builders <> "}"
366
381
367 Ref name ->
382 Ref name ->
368− (One, Name.toBuilder name)
383+ ( One, Name.toBuilder name )
369
384
370 Access expr field ->
385 Access expr field ->
371− makeDot indent expr field
386+ makeDot level expr field
372
387
373 Index expr bracketedExpr ->
388 Index expr bracketedExpr ->
374− makeBracketed indent expr bracketedExpr
389+ makeBracketed level expr bracketedExpr
375
390
376 Prefix op expr ->
391 Prefix op expr ->
377 let
392 let
378− (lines, builder) =
379− fromExpr indent Atomic expr
393+ (lines, builder) = fromExpr level Atomic expr
380 in
394 in
381− ( lines
395+ ( lines
382− , parensFor grouping (fromPrefix op <> builder)
396+ , parensFor grouping (fromPrefix op <> builder)
383− )
397+ )
384
398
385 Infix op leftExpr rightExpr ->
399 Infix op leftExpr rightExpr ->
386 let
400 let
387− (leftLines, left) =
388− fromExpr indent Atomic leftExpr
401+ (leftLines , left ) = fromExpr level Atomic leftExpr
389−
390− (rightLines, right) =
391− fromExpr indent Atomic rightExpr
402+ (rightLines, right) = fromExpr level Atomic rightExpr
392 in
403 in
393− ( merge leftLines rightLines
404+ ( merge leftLines rightLines
394− , parensFor grouping (left <> fromInfix op <> right)
405+ , parensFor grouping (left <> fromInfix op <> right)
395− )
406+ )
396
407
397 If condExpr thenExpr elseExpr ->
408 If condExpr thenExpr elseExpr ->
398 let
409 let
399− condB = snd (fromExpr indent Atomic condExpr)
410+ condB = snd (fromExpr level Atomic condExpr)
400− thenB = snd (fromExpr indent Atomic thenExpr)
411+ thenB = snd (fromExpr level Atomic thenExpr)
401− elseB = snd (fromExpr indent Atomic elseExpr)
412+ elseB = snd (fromExpr level Atomic elseExpr)
402 in
413 in
403− ( Many
414+ ( Many
404− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
415+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
405− )
416+ )
406
417
407 Assign lValue expr ->
418 Assign lValue expr ->
408 let
419 let
409− (leftLines, left) =
410− fromLValue indent lValue
420+ (leftLines , left ) = fromLValue level lValue
411−
412− (rightLines, right) =
413− fromExpr indent Whatever expr
421+ (rightLines, right) = fromExpr level Whatever expr
414 in
422 in
415− ( merge leftLines rightLines
423+ ( merge leftLines rightLines
416− , parensFor grouping (left <> " = " <> right)
424+ , parensFor grouping (left <> " = " <> right)
417− )
425+ )
418
426
419 Call function args ->
427 Call function args ->
420 (,) Many $
428 (,) Many $
421 let
429 let
422− deeperIndent =
423− deeper indent
424−
425− funcB =
426− snd (fromExpr indent Atomic function)
430+ (_ , funcB) = fromExpr level Atomic function
427−
428− (anyMany, argsB) =
429− linesMap (fromExpr deeperIndent Whatever) args
431+ (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
430 in
432 in
431− if anyMany then
433+ if anyMany then
432− funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
434+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
433−
434− else
435+ else
435− funcB <> "(" <> commaSep argsB <> ")"
436+ funcB <> "(" <> commaSep argsB <> ")"
436
437
437 Function maybeName args stmts ->
438 Function maybeName args stmts ->
438 (,) Many $
439 (,) Many $
439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
440 <>
441 <>
441− fromStmtBlock (deeper indent) stmts
442+ fromStmtBlock nextLevel stmts
442 <>
443 <>
443 indent <> "}"
444 indent <> "}"
444
445
@@ -447,55 +448,50 @@ fromExpr indent grouping expression =
447-- FIELDS
448-- FIELDS
448
449
449
450
450−fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
451+fromField :: Level -> (Name, Expr) -> (Lines, Builder)
451−fromField indent (field, expr) =
452+fromField level (field, expr) =
452 let
453 let
453− (lines, builder) =
454− fromExpr indent Whatever expr
454+ (lines, builder) = fromExpr level Whatever expr
455 in
455 in
456− ( lines
456+ ( lines
457− , Name.toBuilder field <> ": " <> builder
457+ , Name.toBuilder field <> ": " <> builder
458− )
458+ )
459
459
460
460
461
461
462-- VALUES
462-- VALUES
463
463
464
464
465−fromLValue :: Builder -> LValue -> (Lines, Builder)
465+fromLValue :: Level -> LValue -> (Lines, Builder)
466−fromLValue indent lValue =
466+fromLValue level lValue =
467 case lValue of
467 case lValue of
468 LRef name ->
468 LRef name ->
469 (One, Name.toBuilder name)
469 (One, Name.toBuilder name)
470
470
471 LDot expr field ->
471 LDot expr field ->
472− makeDot indent expr field
472+ makeDot level expr field
473
473
474 LBracket expr bracketedExpr ->
474 LBracket expr bracketedExpr ->
475− makeBracketed indent expr bracketedExpr
475+ makeBracketed level expr bracketedExpr
476
476
477
477
478−makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
478+makeDot :: Level -> Expr -> Name -> (Lines, Builder)
479−makeDot indent expr field =
479+makeDot level expr field =
480 let
480 let
481− (lines, builder) =
482− fromExpr indent Atomic expr
481+ (lines, builder) = fromExpr level Atomic expr
483 in
482 in
484− (lines, builder <> "." <> Name.toBuilder field)
483+ (lines, builder <> "." <> Name.toBuilder field)
485
484
486
485
487−makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
486+makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
488−makeBracketed indent expr bracketedExpr =
487+makeBracketed level expr bracketedExpr =
489 let
488 let
490− (lines, builder) =
491− fromExpr indent Atomic expr
489+ (lines , builder ) = fromExpr level Atomic expr
492−
493− (bracketedLines, bracketedBuilder) =
490+ (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
494− fromExpr indent Whatever bracketedExpr
495 in
491 in
496− ( merge lines bracketedLines
492+ ( merge lines bracketedLines
497− , builder <> "[" <> bracketedBuilder <> "]"
493+ , builder <> "[" <> bracketedBuilder <> "]"
498− )
494+ )
499
495
500
496
501
497
@@ -505,36 +501,30 @@ makeBracketed indent expr bracketedExpr =
505fromPrefix :: PrefixOp -> Builder
501fromPrefix :: PrefixOp -> Builder
506fromPrefix op =
502fromPrefix op =
507 case op of
503 case op of
508− PrefixLNot -> "!"
504+ PrefixNot -> "!"
509− PrefixBNot -> "~"
505+ PrefixNegate -> "-"
510− PrefixPlus -> "+"
506+ PrefixComplement -> "~"
511− PrefixMinus -> "-"
512− PrefixTypeof -> "typeof "
513
507
514
508
515fromInfix :: InfixOp -> Builder
509fromInfix :: InfixOp -> Builder
516fromInfix op =
510fromInfix op =
517 case op of
511 case op of
518− OpLT -> " < "
512+ OpAdd -> " + "
519− OpLEq -> " <= "
513+ OpSub -> " - "
520− OpGT -> " > "
521− OpGEq -> " >= "
522− OpIn -> " in "
523− OpInstanceof -> " instanceof "
524− OpEq -> " == "
525− OpNEq -> " != "
526− OpStrictEq -> " === "
527− OpStrictNEq -> " !== "
528− OpLAnd -> " && "
529− OpLOr -> " || "
530 OpMul -> " * "
514 OpMul -> " * "
531 OpDiv -> " / "
515 OpDiv -> " / "
532 OpMod -> " % "
516 OpMod -> " % "
533− OpSub -> " - "
517+ OpEq -> " === "
518+ OpNe -> " !== "
519+ OpLt -> " < "
520+ OpLe -> " <= "
521+ OpGt -> " > "
522+ OpGe -> " >= "
523+ OpAnd -> " && "
524+ OpOr -> " || "
525+ OpBitwiseAnd -> " & "
526+ OpBitwiseXor -> " ^ "
527+ OpBitwiseOr -> " | "
534 OpLShift -> " << "
528 OpLShift -> " << "
535 OpSpRShift -> " >> "
529 OpSpRShift -> " >> "
536 OpZfRShift -> " >>> "
530 OpZfRShift -> " >>> "
537− OpBAnd -> " & "
538− OpBXor -> " ^ "
539− OpBOr -> " | "
540− OpAdd -> " + "
compiler/src/Generate/JavaScript/Expression.hs+46−45
@@ -22,6 +22,7 @@ import qualified Data.Utf8 as Utf8
22
22
23import qualified AST.Canonical as Can
23import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
24import qualified AST.Optimized as Opt
25+import qualified AST.Utils.Shader as Shader
25import qualified Data.Index as Index
26import qualified Data.Index as Index
26import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type as Type
27import qualified Elm.Compiler.Type.Extract as Extract
28import qualified Elm.Compiler.Type.Extract as Extract
@@ -32,6 +33,7 @@ import qualified Generate.JavaScript.Builder as JS
32import qualified Generate.JavaScript.Name as JsName
33import qualified Generate.JavaScript.Name as JsName
33import qualified Generate.Mode as Mode
34import qualified Generate.Mode as Mode
34import qualified Json.Encode as Encode
35import qualified Json.Encode as Encode
36+import Json.Encode ((==>))
35import qualified Optimize.DecisionTree as DT
37import qualified Optimize.DecisionTree as DT
36import qualified Reporting.Annotation as A
38import qualified Reporting.Annotation as A
37
39
@@ -128,8 +130,7 @@ generate mode expression =
128
130
129 Opt.Destruct (Opt.Destructor name path) body ->
131 Opt.Destruct (Opt.Destructor name path) body ->
130 let
132 let
131− pathExpr = generatePath mode path
132− pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
133+ pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
133 in
134 in
134 JsBlock $ pathDef : codeToStmtList (generate mode body)
135 JsBlock $ pathDef : codeToStmtList (generate mode body)
135
136
@@ -138,7 +139,7 @@ generate mode expression =
138
139
139 Opt.Accessor field ->
140 Opt.Accessor field ->
140 JsExpr $ JS.Function Nothing [JsName.dollar]
141 JsExpr $ JS.Function Nothing [JsName.dollar]
141− [ JS.Return $ Just $
142+ [ JS.Return $
142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
143 ]
144 ]
144
145
@@ -190,7 +191,7 @@ generate mode expression =
190 JS.Object (map toTranlation (Set.toList fields))
191 JS.Object (map toTranlation (Set.toList fields))
191 in
192 in
192 JsExpr $ JS.Object $
193 JsExpr $ JS.Object $
193− [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
194+ [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
196 ]
197 ]
@@ -211,7 +212,7 @@ codeToExpr code =
211 JsExpr expr ->
212 JsExpr expr ->
212 expr
213 expr
213
214
214− JsBlock [ JS.Return (Just expr) ] ->
215+ JsBlock [ JS.Return expr ] ->
215 expr
216 expr
216
217
217 JsBlock stmts ->
218 JsBlock stmts ->
@@ -225,7 +226,7 @@ codeToStmtList code =
225 stmts
226 stmts
226
227
227 JsExpr expr ->
228 JsExpr expr ->
228− [ JS.Return (Just expr) ]
229+ [ JS.Return expr ]
229
230
230 JsBlock stmts ->
231 JsBlock stmts ->
231 stmts
232 stmts
@@ -238,7 +239,7 @@ codeToStmt code =
238 JS.Block stmts
239 JS.Block stmts
239
240
240 JsExpr expr ->
241 JsExpr expr ->
241− JS.Return (Just expr)
242+ JS.Return expr
242
243
243 JsBlock [stmt] ->
244 JsBlock [stmt] ->
244 stmt
245 stmt
@@ -482,17 +483,17 @@ generateBitwiseCall home name args =
482 case args of
483 case args of
483 [arg] ->
484 [arg] ->
484 case name of
485 case name of
485− "complement" -> JS.Prefix JS.PrefixBNot arg
486+ "complement" -> JS.Prefix JS.PrefixComplement arg
486 _ -> generateGlobalCall home name args
487 _ -> generateGlobalCall home name args
487
488
488 [left,right] ->
489 [left,right] ->
489 case name of
490 case name of
490− "and" -> JS.Infix JS.OpBAnd left right
491+ "and" -> JS.Infix JS.OpBitwiseAnd left right
491− "or" -> JS.Infix JS.OpBOr left right
492+ "or" -> JS.Infix JS.OpBitwiseOr left right
492− "xor" -> JS.Infix JS.OpBXor left right
493+ "xor" -> JS.Infix JS.OpBitwiseXor left right
493− "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left
494− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
495− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
496+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
496 _ -> generateGlobalCall home name args
497 _ -> generateGlobalCall home name args
497
498
498 _ ->
499 _ ->
@@ -505,10 +506,10 @@ generateBasicsCall mode home name args =
505 [elmArg] ->
506 [elmArg] ->
506 let arg = generateJsExpr mode elmArg in
507 let arg = generateJsExpr mode elmArg in
507 case name of
508 case name of
508− "not" -> JS.Prefix JS.PrefixLNot arg
509+ "not" -> JS.Prefix JS.PrefixNot arg
509− "negate" -> JS.Prefix JS.PrefixMinus arg
510+ "negate" -> JS.Prefix JS.PrefixNegate arg
510 "toFloat" -> arg
511 "toFloat" -> arg
511− "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
512+ "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
512 _ -> generateGlobalCall home name [arg]
513 _ -> generateGlobalCall home name [arg]
513
514
514 [elmLeft, elmRight] ->
515 [elmLeft, elmRight] ->
@@ -528,16 +529,16 @@ generateBasicsCall mode home name args =
528 "sub" -> JS.Infix JS.OpSub left right
529 "sub" -> JS.Infix JS.OpSub left right
529 "mul" -> JS.Infix JS.OpMul left right
530 "mul" -> JS.Infix JS.OpMul left right
530 "fdiv" -> JS.Infix JS.OpDiv left right
531 "fdiv" -> JS.Infix JS.OpDiv left right
531− "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532+ "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
532 "eq" -> equal left right
533 "eq" -> equal left right
533 "neq" -> notEqual left right
534 "neq" -> notEqual left right
534− "lt" -> cmp JS.OpLT JS.OpLT 0 left right
535+ "lt" -> cmp JS.OpLt JS.OpLt 0 left right
535− "gt" -> cmp JS.OpGT JS.OpGT 0 left right
536+ "gt" -> cmp JS.OpGt JS.OpGt 0 left right
536− "le" -> cmp JS.OpLEq JS.OpLT 1 left right
537+ "le" -> cmp JS.OpLe JS.OpLt 1 left right
537− "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
538+ "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
538− "or" -> JS.Infix JS.OpLOr left right
539+ "or" -> JS.Infix JS.OpOr left right
539− "and" -> JS.Infix JS.OpLAnd left right
540+ "and" -> JS.Infix JS.OpAnd left right
540− "xor" -> JS.Infix JS.OpStrictNEq left right
541+ "xor" -> JS.Infix JS.OpNe left right
541 "remainderBy" -> JS.Infix JS.OpMod right left
542 "remainderBy" -> JS.Infix JS.OpMod right left
542 _ -> generateGlobalCall home name [left, right]
543 _ -> generateGlobalCall home name [left, right]
543
544
@@ -558,7 +559,7 @@ notEqual left right =
558 if isLiteral left || isLiteral right then
559 if isLiteral left || isLiteral right then
559 strictNEq left right
560 strictNEq left right
560 else
561 else
561− JS.Prefix JS.PrefixLNot $
562+ JS.Prefix JS.PrefixNot $
562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
563
564
564
565
@@ -647,42 +648,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr
647strictEq left right =
648strictEq left right =
648 case left of
649 case left of
649 JS.Int 0 ->
650 JS.Int 0 ->
650− JS.Prefix JS.PrefixLNot right
651+ JS.Prefix JS.PrefixNot right
651
652
652 JS.Bool bool ->
653 JS.Bool bool ->
653− if bool then right else JS.Prefix JS.PrefixLNot right
654+ if bool then right else JS.Prefix JS.PrefixNot right
654
655
655 _ ->
656 _ ->
656 case right of
657 case right of
657 JS.Int 0 ->
658 JS.Int 0 ->
658− JS.Prefix JS.PrefixLNot left
659+ JS.Prefix JS.PrefixNot left
659
660
660 JS.Bool bool ->
661 JS.Bool bool ->
661− if bool then left else JS.Prefix JS.PrefixLNot left
662+ if bool then left else JS.Prefix JS.PrefixNot left
662
663
663 _ ->
664 _ ->
664− JS.Infix JS.OpStrictEq left right
665+ JS.Infix JS.OpEq left right
665
666
666
667
667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
668strictNEq left right =
669strictNEq left right =
669 case left of
670 case left of
670 JS.Int 0 ->
671 JS.Int 0 ->
671− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
672+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
672
673
673 JS.Bool bool ->
674 JS.Bool bool ->
674− if bool then JS.Prefix JS.PrefixLNot right else right
675+ if bool then JS.Prefix JS.PrefixNot right else right
675
676
676 _ ->
677 _ ->
677 case right of
678 case right of
678 JS.Int 0 ->
679 JS.Int 0 ->
679− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
680+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
680
681
681 JS.Bool bool ->
682 JS.Bool bool ->
682− if bool then JS.Prefix JS.PrefixLNot left else left
683+ if bool then JS.Prefix JS.PrefixNot left else left
683
684
684 _ ->
685 _ ->
685− JS.Infix JS.OpStrictNEq left right
686+ JS.Infix JS.OpNe left right
686
687
687
688
688
689
@@ -695,13 +696,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm
695generateTailCall mode name args =
696generateTailCall mode name args =
696 let
697 let
697 toTempVars (argName, arg) =
698 toTempVars (argName, arg) =
698− ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
699+ ( JsName.makeTemp argName, generateJsExpr mode arg )
699
700
700 toRealVars (argName, _) =
701 toRealVars (argName, _) =
701 JS.ExprStmt $
702 JS.ExprStmt $
702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
703 in
704 in
704− JS.Var (map toTempVars args)
705+ JS.Vars (map toTempVars args)
705 : map toRealVars args
706 : map toRealVars args
706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
707
708
@@ -714,10 +715,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
714generateDef mode def =
715generateDef mode def =
715 case def of
716 case def of
716 Opt.Def name body ->
717 Opt.Def name body ->
717− JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
718+ JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
718
719
719 Opt.TailDef name argNames body ->
720 Opt.TailDef name argNames body ->
720− JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
721+ JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
721
722
722
723
723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
@@ -850,7 +851,7 @@ generateDecider mode label root decisionTree =
850
851
851 Opt.Chain testChain success failure ->
852 Opt.Chain testChain success failure ->
852 [ JS.IfStmt
853 [ JS.IfStmt
853− (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
854+ (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
854 (JS.Block $ generateDecider mode label root success)
855 (JS.Block $ generateDecider mode label root success)
855 (JS.Block $ generateDecider mode label root failure)
856 (JS.Block $ generateDecider mode label root failure)
856 ]
857 ]
@@ -892,7 +893,7 @@ generateIfTest mode root (path, test) =
892 value
893 value
893
894
894 DT.IsBool False ->
895 DT.IsBool False ->
895− JS.Prefix JS.PrefixLNot value
896+ JS.Prefix JS.PrefixNot value
896
897
897 DT.IsInt int ->
898 DT.IsInt int ->
898 strictEq value (JS.Int int)
899 strictEq value (JS.Int int)
@@ -910,7 +911,7 @@ generateIfTest mode root (path, test) =
910 JS.Access value (JsName.fromLocal "b")
911 JS.Access value (JsName.fromLocal "b")
911
912
912 DT.IsNil ->
913 DT.IsNil ->
913− JS.Prefix JS.PrefixLNot $
914+ JS.Prefix JS.PrefixNot $
914 JS.Access value (JsName.fromLocal "b")
915 JS.Access value (JsName.fromLocal "b")
915
916
916 DT.IsTuple ->
917 DT.IsTuple ->
@@ -1064,6 +1065,6 @@ toDebugMetadata mode msgType =
1064
1065
1065 Mode.Dev (Just interfaces) ->
1066 Mode.Dev (Just interfaces) ->
1066 JS.Json $ Encode.object $
1067 JS.Json $ Encode.object $
1067− [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1068+ [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1068− , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
1069+ , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
1069 ]
1070 ]
compiler/src/Generate/JavaScript/Functions.hs+2−3
@@ -1,6 +1,5 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−module Generate.Functions
2+module Generate.JavaScript.Functions
4 ( functions
3 ( functions
5 )
4 )
6 where
5 where
compiler/src/Generate/JavaScript/Name.hs+22−12
@@ -62,19 +62,13 @@ fromLocal name =
62
62
63
63
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
65−fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =
65+fromGlobal home name =
66− Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
67− <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
68− <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
69− <> "$" <> Name.toBuilder name
66+ Name $ homeToBuilder home <> usd <> Name.toBuilder name
70
67
71
68
72fromCycle :: ModuleName.Canonical -> Name.Name -> Name
69fromCycle :: ModuleName.Canonical -> Name.Name -> Name
73−fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =
70+fromCycle home name =
74− Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
75− <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
76− <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
77− <> "$cyclic$" <> Name.toBuilder name
71+ Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name
78
72
79
73
80fromKernel :: Name.Name -> Name.Name -> Name
74fromKernel :: Name.Name -> Name.Name -> Name
@@ -82,6 +76,17 @@ fromKernel home name =
82 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
76 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
83
77
84
78
79+{-# INLINE homeToBuilder #-}
80+homeToBuilder :: ModuleName.Canonical -> B.Builder
81+homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =
82+ usd <>
83+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
84+ <> usd <>
85+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
86+ <> usd <>
87+ Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
88+
89+
85
90
86-- TEMPORARY NAMES
91-- TEMPORARY NAMES
87
92
@@ -98,7 +103,7 @@ makeA n =
98
103
99makeLabel :: Name.Name -> Int -> Name
104makeLabel :: Name.Name -> Int -> Name
100makeLabel name index =
105makeLabel name index =
101− Name (Name.toBuilder name <> "$" <> B.intDec index)
106+ Name (Name.toBuilder name <> usd <> B.intDec index)
102
107
103
108
104makeTemp :: Name.Name -> Name
109makeTemp :: Name.Name -> Name
@@ -108,7 +113,12 @@ makeTemp name =
108
113
109dollar :: Name
114dollar :: Name
110dollar =
115dollar =
116+ Name usd
117+
118+
119+usd :: B.Builder
120+usd =
111− Name (Name.toBuilder Name.dollar)
121+ Name.toBuilder Name.dollar
112
122
113
123
114
124
compiler/src/Generate/Mode.hs+2−3
@@ -41,15 +41,14 @@ type ShortFieldNames =
41 Map.Map Name.Name JsName.Name
41 Map.Map Name.Name JsName.Name
42
42
43
43
44−shortenFieldNames :: Opt.Graph -> ShortFieldNames
44+shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames
45−shortenFieldNames (Opt.Graph _ _ frequencies) =
45+shortenFieldNames (Opt.GlobalGraph _ frequencies) =
46 Map.foldr addToShortNames Map.empty $
46 Map.foldr addToShortNames Map.empty $
47 Map.foldrWithKey addToBuckets Map.empty frequencies
47 Map.foldrWithKey addToBuckets Map.empty frequencies
48
48
49
49
50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]
51addToBuckets field frequency buckets =
51addToBuckets field frequency buckets =
52− -- TODO try using an IntMap for buckets
53 Map.insertWith (++) frequency [field] buckets
52 Map.insertWith (++) frequency [field] buckets
54
53
55
54
compiler/src/Json/Decode.hs+333−180
@@ -2,69 +2,112 @@
2{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
2{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
3module Json.Decode
3module Json.Decode
4 ( fromByteString
4 ( fromByteString
5− , fromFile
6 , Decoder
5 , Decoder
7 , string
6 , string
7+ , customString
8 , bool
8 , bool
9 , int
9 , int
10− , list, pair
10+ , list
11+ , nonEmptyList
12+ , pair
13+ --
14+ , KeyDecoder(..)
15+ , dict
11− , dict, pairs, field
16+ , pairs
17+ , field
18+ --
12 , oneOf
19 , oneOf
13 , failure
20 , failure
14 , mapError
21 , mapError
22+ --
23+ , Error(..)
24+ , Problem(..)
25+ , DecodeExpectation(..)
26+ , ParseError(..)
27+ , StringProblem(..)
15 )
28 )
16 where
29 where
17
30
18
31
19−import qualified Data.ByteString as B
32+import qualified Data.ByteString.Internal as B
20−import qualified Data.List as List
21import qualified Data.Map as Map
33import qualified Data.Map as Map
22−import qualified Data.Utf8 as Utf8
34+import qualified Data.NonEmptyList as NE
23−import Data.Word (Word8, Word16)
35+import Data.Word (Word8)
24import Foreign.Ptr (Ptr, plusPtr, minusPtr)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
25
38
39+import qualified Json.String as Json
26import qualified Parse.Keyword as K
40import qualified Parse.Keyword as K
27import qualified Parse.Primitives as P
41import qualified Parse.Primitives as P
42+import Parse.Primitives (Row, Col)
28−import qualified Reporting.Error.Json as E
43+import qualified Reporting.Annotation as A
29
44
30
45
31
46
32-- RUNNERS
47-- RUNNERS
33
48
34
49
35−fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
50+fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
36−fromByteString decoder src =
51+fromByteString (Decoder decode) src =
37− fromAST decoder (P.fromByteString pFile src)
52+ case P.fromByteString pFile BadEnd src of
53+ Right ast ->
54+ decode ast Right (Left . DecodeProblem src)
38
55
56+ Left problem ->
57+ Left (ParseProblem src problem)
39
58
40−fromFile :: Decoder e a -> FilePath -> IO (Either (E.Error e) a)
41−fromFile decoder path =
42− fromAST decoder <$> P.fromFile pFile path
43
59
44
60
45−fromAST :: Decoder e a -> P.Result E.Context E.ParseExpectation AST -> Either (E.Error e) a
61+-- DECODERS
46−fromAST (Decoder decode) parserResult =
47− case parserResult of
48− P.Ok ast _ ->
49− decode ast Right (Left . E.DecodeProblem)
50
62
51− P.Err row col ctx expectation ->
52− Left (E.ParseProblem row col ctx expectation)
53
63
64+newtype Decoder x a =
65+ Decoder
66+ (
67+ forall b.
68+ AST
69+ -> (a -> b)
70+ -> (Problem x -> b)
71+ -> b
72+ )
54
73
55
74
56−-- DECODERS
75+
76+-- ERRORS
77+
78+
79+data Error x
80+ = DecodeProblem B.ByteString (Problem x)
81+ | ParseProblem B.ByteString ParseError
82+
83+
84+
85+-- DECODE PROBLEMS
57
86
58
87
59−newtype Decoder e a =
88+data Problem x
60− Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)
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
61
104
62
105
63
106
64-- INSTANCES
107-- INSTANCES
65
108
66
109
67−instance Functor (Decoder e) where
110+instance Functor (Decoder x) where
68 {-# INLINE fmap #-}
111 {-# INLINE fmap #-}
69 fmap func (Decoder decodeA) =
112 fmap func (Decoder decodeA) =
70 Decoder $ \ast ok err ->
113 Decoder $ \ast ok err ->
@@ -74,7 +117,7 @@ instance Functor (Decoder e) where
74 decodeA ast ok' err
117 decodeA ast ok' err
75
118
76
119
77−instance Applicative (Decoder e) where
120+instance Applicative (Decoder x) where
78 {-# INLINE pure #-}
121 {-# INLINE pure #-}
79 pure = return
122 pure = return
80
123
@@ -91,7 +134,7 @@ instance Applicative (Decoder e) where
91 decodeFunc ast okF err
134 decodeFunc ast okF err
92
135
93
136
94−instance Monad (Decoder e) where
137+instance Monad (Decoder x) where
95 {-# INLINE return #-}
138 {-# INLINE return #-}
96 return a =
139 return a =
97 Decoder $ \_ ok _ ->
140 Decoder $ \_ ok _ ->
@@ -112,24 +155,37 @@ instance Monad (Decoder e) where
112-- STRINGS
155-- STRINGS
113
156
114
157
115−string :: Decoder e Utf8.String
158+string :: Decoder x Json.String
116string =
159string =
117− Decoder $ \ast ok err ->
160+ Decoder $ \(A.At region ast) ok err ->
118 case ast of
161 case ast of
119− String bits ->
162+ String snippet ->
120− ok bits
163+ ok (Json.fromSnippet snippet)
121
164
122 _ ->
165 _ ->
166+ err (Expecting region TString)
167+
168+
169+customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170+customString parser toBadEnd =
171+ Decoder $ \(A.At region ast) ok err ->
172+ case ast of
173+ String snippet ->
174+ case P.fromSnippet parser toBadEnd snippet of
175+ Right a -> ok a
176+ Left x -> err (Failure region x)
177+
178+ _ ->
123− err (E.Expecting E.TString)
179+ err (Expecting region TString)
124
180
125
181
126
182
127-- BOOL
183-- BOOL
128
184
129
185
130−bool :: Decoder e Bool
186+bool :: Decoder x Bool
131bool =
187bool =
132− Decoder $ \ast ok err ->
188+ Decoder $ \(A.At region ast) ok err ->
133 case ast of
189 case ast of
134 TRUE ->
190 TRUE ->
135 ok True
191 ok True
@@ -138,40 +194,40 @@ bool =
138 ok False
194 ok False
139
195
140 _ ->
196 _ ->
141− err (E.Expecting E.TBool)
197+ err (Expecting region TBool)
142
198
143
199
144
200
145-- INT
201-- INT
146
202
147
203
148−int :: Decoder e Int
204+int :: Decoder x Int
149int =
205int =
150− Decoder $ \ast ok err ->
206+ Decoder $ \(A.At region ast) ok err ->
151 case ast of
207 case ast of
152 Int n ->
208 Int n ->
153 ok n
209 ok n
154
210
155 _ ->
211 _ ->
156− err (E.Expecting E.TInt)
212+ err (Expecting region TInt)
157
213
158
214
159
215
160−-- ARRAYS
216+-- LISTS
161
217
162
218
163−list :: Decoder e a -> Decoder e [a]
219+list :: Decoder x a -> Decoder x [a]
164list decoder =
220list decoder =
165− Decoder $ \ast ok err ->
221+ Decoder $ \(A.At region ast) ok err ->
166 case ast of
222 case ast of
167 Array asts ->
223 Array asts ->
168 listHelp decoder ok err 0 asts []
224 listHelp decoder ok err 0 asts []
169
225
170 _ ->
226 _ ->
171− err (E.Expecting E.TArray)
227+ err (Expecting region TArray)
172
228
173
229
174−listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
230+listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
175listHelp decoder@(Decoder decodeA) ok err !i asts revs =
231listHelp decoder@(Decoder decodeA) ok err !i asts revs =
176 case asts of
232 case asts of
177 [] ->
233 [] ->
@@ -179,24 +235,40 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
179
235
180 ast:asts ->
236 ast:asts ->
181 let
237 let
182− ok' a = listHelp decoder ok err (i+1) asts (a:revs)
238+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)
183− err' e = err (E.Index i e)
239+ err' prob = err (Index i prob)
184 in
240 in
185 decodeA ast ok' err'
241 decodeA ast ok' err'
186
242
187
243
244+
245+-- NON-EMPTY LISTS
246+
247+
248+nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249+nonEmptyList decoder x =
250+ do values <- list decoder
251+ case values of
252+ v:vs -> return (NE.List v vs)
253+ [] -> failure x
254+
255+
256+
257+-- PAIR
258+
259+
188−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
260+pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
189pair (Decoder decodeA) (Decoder decodeB) =
261pair (Decoder decodeA) (Decoder decodeB) =
190− Decoder $ \ast ok err ->
262+ Decoder $ \(A.At region ast) ok err ->
191 case ast of
263 case ast of
192 Array vs ->
264 Array vs ->
193 case vs of
265 case vs of
194 [astA,astB] ->
266 [astA,astB] ->
195 let
267 let
196− err0 e = err (E.Index 0 e)
268+ err0 e = err (Index 0 e)
197 ok0 a =
269 ok0 a =
198 let
270 let
199− err1 e = err (E.Index 1 e)
271+ err1 e = err (Index 1 e)
200 ok1 b = ok (a,b)
272 ok1 b = ok (a,b)
201 in
273 in
202 decodeB astB ok1 err1
274 decodeB astB ok1 err1
@@ -204,70 +276,103 @@ pair (Decoder decodeA) (Decoder decodeB) =
204 decodeA astA ok0 err0
276 decodeA astA ok0 err0
205
277
206 _ ->
278 _ ->
207− err (E.Expecting (E.TArrayPair (length vs)))
279+ err (Expecting region (TArrayPair (length vs)))
208
280
209 _ ->
281 _ ->
210− err (E.Expecting E.TArray)
282+ err (Expecting region TArray)
211
283
212
284
213
285
214−-- OBJECT
286+-- OBJECTS
215
287
216
288
217−dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
289+data KeyDecoder x a =
218−dict decoder =
290+ KeyDecoder (P.Parser x a) (Row -> Col -> x)
219− Map.fromList <$> pairs decoder
220
291
221
292
293+dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
294+dict keyDecoder valueDecoder =
295+ Map.fromList <$> pairs keyDecoder valueDecoder
296+
297+
222−pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
298+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
223−pairs decoder =
299+pairs keyDecoder valueDecoder =
224− Decoder $ \ast ok err ->
300+ Decoder $ \(A.At region ast) ok err ->
225 case ast of
301 case ast of
226 Object kvs ->
302 Object kvs ->
227− pairsHelp decoder ok err kvs []
303+ pairsHelp keyDecoder valueDecoder ok err kvs []
228
304
229 _ ->
305 _ ->
230− err (E.Expecting E.TObject)
306+ err (Expecting region TObject)
231
307
232
308
233−pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
309+pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
234−pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
310+pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
235 case kvs of
311 case kvs of
236 [] ->
312 [] ->
237 ok (reverse revs)
313 ok (reverse revs)
238
314
239− (key, ast) : kvs ->
315+ (snippet, ast) : kvs ->
240− let
316+ case P.fromSnippet keyParser toBadEnd snippet of
317+ Left x ->
318+ err (Failure (snippetToRegion snippet) x)
319+
320+ Right key ->
321+ let
241− ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
322+ ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
242− err' e = err (E.Field key e)
323+ err' prob =
324+ let (P.Snippet fptr off len _ _) = snippet in
325+ err (Field (B.PS fptr off len) prob)
243− in
326+ in
244− decodeA ast ok' err'
327+ 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+
245
334
246
335
336+-- FIELDS
337+
338+
247−field :: Utf8.String -> Decoder e a -> Decoder e a
339+field :: B.ByteString -> Decoder x a -> Decoder x a
248field key (Decoder decodeA) =
340field key (Decoder decodeA) =
249− Decoder $ \ast ok err ->
341+ Decoder $ \(A.At region ast) ok err ->
250 case ast of
342 case ast of
251 Object kvs ->
343 Object kvs ->
252− case List.lookup key kvs of
344+ case findField key kvs of
253− Just v ->
345+ Just value ->
254 let
346 let
347+ err' prob =
255− err' e = err (E.Field key e)
348+ err (Field key prob)
256 in
349 in
257− decodeA v ok err'
350+ decodeA value ok err'
258
351
259 Nothing ->
352 Nothing ->
260− err (E.Expecting (E.TObjectWith key))
353+ err (Expecting region (TObjectWith key))
261
354
262 _ ->
355 _ ->
263− err (E.Expecting E.TObject)
356+ err (Expecting region TObject)
357+
358+
359+findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
360+findField key pairs =
361+ case pairs of
362+ [] ->
363+ Nothing
364+
365+ (P.Snippet fptr off len _ _, value) : remainingPairs ->
366+ if key == B.PS fptr off len
367+ then Just value
368+ else findField key remainingPairs
264
369
265
370
266
371
267-- ONE OF
372-- ONE OF
268
373
269
374
270−oneOf :: [Decoder e a] -> Decoder e a
375+oneOf :: [Decoder x a] -> Decoder x a
271oneOf decoders =
376oneOf decoders =
272 Decoder $ \ast ok err ->
377 Decoder $ \ast ok err ->
273 case decoders of
378 case decoders of
@@ -282,71 +387,75 @@ oneOf decoders =
282 error "Ran into (Json.Decode.oneOf [])"
387 error "Ran into (Json.Decode.oneOf [])"
283
388
284
389
285−oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
390+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
286−oneOfHelp ast ok err decoders e es =
391+oneOfHelp ast ok err decoders p ps =
287 case decoders of
392 case decoders of
288 Decoder decodeA : decoders ->
393 Decoder decodeA : decoders ->
289 let
394 let
290− err' e' =
395+ err' p' =
291− oneOfHelp ast ok err decoders e' (e:es)
396+ oneOfHelp ast ok err decoders p' (p:ps)
292 in
397 in
293 decodeA ast ok err'
398 decodeA ast ok err'
294
399
295 [] ->
400 [] ->
296− err (oneOfError [] e es)
401+ err (oneOfError [] p ps)
297
402
298
403
299−oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
404+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
300−oneOfError errors err es =
405+oneOfError problems prob ps =
301− case es of
406+ case ps of
302 [] ->
407 [] ->
303− E.OneOf err errors
408+ OneOf prob problems
304
409
305− e:es ->
410+ p:ps ->
306− oneOfError (err:errors) e es
411+ oneOfError (prob:problems) p ps
307
412
308
413
309
414
310-- FAILURE
415-- FAILURE
311
416
312
417
313−failure :: e -> Decoder e a
418+failure :: x -> Decoder x a
314−failure e =
419+failure x =
315− Decoder $ \_ _ err ->
420+ Decoder $ \(A.At region _) _ err ->
316− err (E.Failure e)
421+ err (Failure region x)
317
422
318
423
319
424
320-- ERRORS
425-- ERRORS
321
426
322
427
323−mapError :: (e -> e') -> Decoder e a -> Decoder e' a
428+mapError :: (x -> y) -> Decoder x a -> Decoder y a
324mapError func (Decoder decodeA) =
429mapError func (Decoder decodeA) =
325 Decoder $ \ast ok err ->
430 Decoder $ \ast ok err ->
326 let
431 let
327− err' e = err (mapErrorHelp func e)
432+ err' prob = err (mapErrorHelp func prob)
328 in
433 in
329 decodeA ast ok err'
434 decodeA ast ok err'
330
435
331
436
332−mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
437+mapErrorHelp :: (x -> y) -> Problem x -> Problem y
333−mapErrorHelp func err =
438+mapErrorHelp func problem =
334− case err of
439+ case problem of
335− E.Field k e -> E.Field k (mapErrorHelp func e)
440+ Field k p -> Field k (mapErrorHelp func p)
336− E.Index i e -> E.Index i (mapErrorHelp func e)
441+ Index i p -> Index i (mapErrorHelp func p)
337− E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
442+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
338− E.Failure e -> E.Failure (func e)
443+ Failure r x -> Failure r (func x)
339− E.Expecting e -> E.Expecting e
444+ Expecting r e -> Expecting r e
340
445
341
446
342
447
343-- AST
448-- AST
344
449
345
450
346−data AST
451+type AST =
452+ A.Located AST_
453+
454+
455+data AST_
347 = Array [AST]
456 = Array [AST]
348− | Object [(Utf8.String, AST)]
457+ | Object [(P.Snippet, AST)]
349− | String Utf8.String
458+ | String P.Snippet
350 | Int Int
459 | Int Int
351 | TRUE
460 | TRUE
352 | FALSE
461 | FALSE
@@ -358,7 +467,33 @@ data AST
358
467
359
468
360type Parser a =
469type Parser a =
361− P.Parser E.Context E.ParseExpectation a
470+ P.Parser ParseError a
471+
472+
473+data ParseError
474+ = Start Row Col
475+ | ObjectField Row Col
476+ | ObjectColon Row Col
477+ | ObjectEnd Row Col
478+ | ArrayEnd Row Col
479+ | StringProblem StringProblem Row Col
480+ | NoLeadingZeros Row Col
481+ | NoFloats Row Col
482+ | BadEnd Row Col
483+
484+-- PIndex Int ParseError Row Col
485+-- PField Json.String ParseError Row Col
486+
487+
488+data StringProblem
489+ = BadStringEnd
490+ | BadStringControlChar
491+ | BadStringEscapeChar
492+ | BadStringEscapeHex
493+
494+
495+
496+-- PARSE AST
362
497
363
498
364pFile :: Parser AST
499pFile :: Parser AST
@@ -366,69 +501,60 @@ pFile =
366 do spaces
501 do spaces
367 value <- pValue
502 value <- pValue
368 spaces
503 spaces
369− endOfFile
370 return value
504 return value
371
505
372
506
373pValue :: Parser AST
507pValue :: Parser AST
374pValue =
508pValue =
509+ P.addLocation $
375− P.oneOf E.Value
510+ P.oneOf Start
376− [ fmap String pString
511+ [ String <$> pString Start
377 , pObject
512 , pObject
378 , pArray
513 , pArray
379 , pInt
514 , pInt
380− , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
515+ , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
381− , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
516+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
382− , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
517+ , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
383 ]
518 ]
384
519
385
520
386−endOfFile :: Parser ()
387−endOfFile =
388− P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->
389− if pos < end then
390− eerr row col ctx E.EndOfFile
391− else
392− eok () state
393−
394−
395
521
396-- OBJECT
522-- OBJECT
397
523
398
524
399−pObject :: Parser AST
525+pObject :: Parser AST_
400pObject =
526pObject =
401− do P.word1 0x7B {- { -} E.ObjectStart
527+ do P.word1 0x7B {- { -} Start
402 spaces
528 spaces
403− P.oneOf E.ObjectMore
529+ P.oneOf ObjectField
404 [ do entry <- pField
530 [ do entry <- pField
405 spaces
531 spaces
406 pObjectHelp [entry]
532 pObjectHelp [entry]
407− , do P.word1 0x7D {-}-} E.ObjectEnd
533+ , do P.word1 0x7D {-}-} ObjectEnd
408 return (Object [])
534 return (Object [])
409 ]
535 ]
410
536
411
537
412−pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
538+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
413pObjectHelp revEntries =
539pObjectHelp revEntries =
414− P.oneOf E.ObjectMore
540+ P.oneOf ObjectEnd
415 [
541 [
416− do P.word1 0x2C {-,-} E.ObjectMore
542+ do P.word1 0x2C {-,-} ObjectEnd
417 spaces
543 spaces
418 entry <- pField
544 entry <- pField
419 spaces
545 spaces
420 pObjectHelp (entry:revEntries)
546 pObjectHelp (entry:revEntries)
421 ,
547 ,
422− do P.word1 0x7D {-}-} E.ObjectEnd
548+ do P.word1 0x7D {-}-} ObjectEnd
423 return (Object (reverse revEntries))
549 return (Object (reverse revEntries))
424 ]
550 ]
425
551
426
552
427−pField :: Parser (Utf8.String, AST)
553+pField :: Parser (P.Snippet, AST)
428pField =
554pField =
429− do key <- pString
555+ do key <- pString ObjectField
430 spaces
556 spaces
431− P.word1 0x3A {-:-} E.Colon
557+ P.word1 0x3A {-:-} ObjectColon
432 spaces
558 spaces
433 value <- pValue
559 value <- pValue
434 return (key, value)
560 return (key, value)
@@ -438,30 +564,30 @@ pField =
438-- ARRAY
564-- ARRAY
439
565
440
566
441−pArray :: Parser AST
567+pArray :: Parser AST_
442pArray =
568pArray =
443− do P.word1 0x5B {-[-} E.ArrayStart
569+ do P.word1 0x5B {-[-} Start
444 spaces
570 spaces
445− P.oneOf E.ArrayMore
571+ P.oneOf Start
446 [ do entry <- pValue
572 [ do entry <- pValue
447 spaces
573 spaces
448 pArrayHelp 1 [entry]
574 pArrayHelp 1 [entry]
449− , do P.word1 0x5D {-]-} E.ArrayEnd
575+ , do P.word1 0x5D {-]-} ArrayEnd
450 return (Array [])
576 return (Array [])
451 ]
577 ]
452
578
453
579
454−pArrayHelp :: Int -> [AST] -> Parser AST
580+pArrayHelp :: Int -> [AST] -> Parser AST_
455pArrayHelp !len revEntries =
581pArrayHelp !len revEntries =
456− P.oneOf E.ArrayMore
582+ P.oneOf ArrayEnd
457 [
583 [
458− do P.word1 0x2C {-,-} E.ArrayMore
584+ do P.word1 0x2C {-,-} ArrayEnd
459 spaces
585 spaces
460 entry <- pValue
586 entry <- pValue
461 spaces
587 spaces
462 pArrayHelp (len + 1) (entry:revEntries)
588 pArrayHelp (len + 1) (entry:revEntries)
463 ,
589 ,
464− do P.word1 0x5D {-]-} E.ArrayEnd
590+ do P.word1 0x5D {-]-} ArrayEnd
465 return (Array (reverse revEntries))
591 return (Array (reverse revEntries))
466 ]
592 ]
467
593
@@ -470,41 +596,44 @@ pArrayHelp !len revEntries =
470-- STRING
596-- STRING
471
597
472
598
473−pString :: Parser Utf8.String
599+pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
474−pString =
600+pString start =
475− P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
601+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
476 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
477
603
478 let
604 let
479 !pos1 = plusPtr pos 1
605 !pos1 = plusPtr pos 1
606+ !col1 = col + 1
480
607
481 (# status, newPos, newRow, newCol #) =
608 (# status, newPos, newRow, newCol #) =
482− pStringHelp pos1 end row (col + 1)
609+ pStringHelp pos1 end row col1
483 in
610 in
484 case status of
611 case status of
485 GoodString ->
612 GoodString ->
486 let
613 let
614+ !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615+ !len = minusPtr newPos pos1 - 1
616+ !snp = P.Snippet src off len row col1
487− !newState = P.State newPos end indent newRow newCol ctx
617+ !newState = P.State src newPos end indent newRow newCol
488− !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
489 in
618 in
490− cok content newState
619+ cok snp newState
491
620
492− BadStringEnd ->
621+ BadString problem ->
493− cerr newRow newCol ctx E.StringEnd
622+ cerr newRow newCol (StringProblem problem)
494
623
495 else
624 else
496− eerr row col ctx E.StringStart
625+ eerr row col start
497
626
498
627
499data StringStatus
628data StringStatus
500 = GoodString
629 = GoodString
501− | BadStringEnd
630+ | BadString StringProblem
502
631
503
632
504−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
633+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
505pStringHelp pos end row col =
634pStringHelp pos end row col =
506 if pos >= end then
635 if pos >= end then
507− (# BadStringEnd, pos, row, col #)
636+ (# BadString BadStringEnd, pos, row, col #)
508
637
509 else
638 else
510 case P.unsafeIndex pos of
639 case P.unsafeIndex pos of
@@ -512,26 +641,50 @@ pStringHelp pos end row col =
512 (# GoodString, plusPtr pos 1, row, col + 1 #)
641 (# GoodString, plusPtr pos 1, row, col + 1 #)
513
642
514 0x0A {-\n-} ->
643 0x0A {-\n-} ->
515− (# BadStringEnd, pos, row, col #)
644+ (# BadString BadStringEnd, pos, row, col #)
516
645
517 0x5C {-\-} ->
646 0x5C {-\-} ->
518− let
519− !pos1 = plusPtr pos 1
647+ let !pos1 = plusPtr pos 1 in
520− in
521− if pos1 < end then
648+ if pos1 >= end then
522−
649+ (# BadString BadStringEnd, pos1, row + 1, col #)
523− let
524− !word = P.unsafeIndex pos1
525− !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
526− in
527− pStringHelp newPos end row (col + 2)
528−
529 else
650 else
530− (# BadStringEnd, pos1, row + 1, col #)
651+ case P.unsafeIndex pos1 of
652+ 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653+ 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654+ 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655+ 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
656+ 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
657+ 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
658+ 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
659+ 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
660+ 0x75 {-u-} ->
661+ let !pos6 = plusPtr pos 6 in
662+ if pos6 <= end
663+ && isHex (P.unsafeIndex (plusPtr pos 2))
664+ && isHex (P.unsafeIndex (plusPtr pos 3))
665+ && isHex (P.unsafeIndex (plusPtr pos 4))
666+ && isHex (P.unsafeIndex (plusPtr pos 5))
667+ then
668+ pStringHelp pos6 end row (col + 6)
669+ else
670+ (# BadString BadStringEscapeHex, pos, row, col #)
671+
672+ _ ->
673+ (# BadString BadStringEscapeChar, pos, row, col #)
531
674
532 word ->
675 word ->
676+ if word < 0x20 then
677+ (# BadString BadStringControlChar, pos, row, col #)
678+ else
533− let !newPos = plusPtr pos (P.getCharWidth pos end word) in
679+ let !newPos = plusPtr pos (P.getCharWidth word) in
534− pStringHelp newPos end row (col + 1)
680+ pStringHelp newPos end row (col + 1)
681+
682+
683+isHex :: Word8 -> Bool
684+isHex word =
685+ 0x30 {-0-} <= word && word <= 0x39 {-9-}
686+ || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687+ || 0x41 {-A-} <= word && word <= 0x46 {-F-}
535
688
536
689
537
690
@@ -540,7 +693,7 @@ pStringHelp pos end row col =
540
693
541spaces :: Parser ()
694spaces :: Parser ()
542spaces =
695spaces =
543− P.Parser $ \state@(P.State pos end indent row col ctx) cok eok _ _ ->
696+ P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
544 let
697 let
545 (# newPos, newRow, newCol #) =
698 (# newPos, newRow, newCol #) =
546 eatSpaces pos end row col
699 eatSpaces pos end row col
@@ -550,12 +703,12 @@ spaces =
550 else
703 else
551 let
704 let
552 !newState =
705 !newState =
553− P.State newPos end indent newRow newCol ctx
706+ P.State src newPos end indent newRow newCol
554 in
707 in
555 cok () newState
708 cok () newState
556
709
557
710
558−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
711+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
559eatSpaces pos end row col =
712eatSpaces pos end row col =
560 if pos >= end then
713 if pos >= end then
561 (# pos, row, col #)
714 (# pos, row, col #)
@@ -574,29 +727,29 @@ eatSpaces pos end row col =
574-- INTS
727-- INTS
575
728
576
729
577−pInt :: Parser AST
730+pInt :: Parser AST_
578pInt =
731pInt =
579− P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
732+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
580 if pos >= end then
733 if pos >= end then
581− eerr row col ctx E.IntStart
734+ eerr row col Start
582
735
583 else
736 else
584 let !word = P.unsafeIndex pos in
737 let !word = P.unsafeIndex pos in
585 if not (isDecimalDigit word) then
738 if not (isDecimalDigit word) then
586− eerr row col ctx E.IntStart
739+ eerr row col Start
587
740
588 else if word == 0x30 {-0-} then
741 else if word == 0x30 {-0-} then
589
742
590 let
743 let
591 !pos1 = plusPtr pos 1
744 !pos1 = plusPtr pos 1
592− !newState = P.State pos1 end indent row (col + 1) ctx
745+ !newState = P.State src pos1 end indent row (col + 1)
593 in
746 in
594 if pos1 < end then
747 if pos1 < end then
595 let !word1 = P.unsafeIndex pos1 in
748 let !word1 = P.unsafeIndex pos1 in
596 if isDecimalDigit word1 then
749 if isDecimalDigit word1 then
597− cerr row (col + 1) ctx E.NoLeadingZeros
750+ cerr row (col + 1) NoLeadingZeros
598 else if word1 == 0x2E {-.-} then
751 else if word1 == 0x2E {-.-} then
599− cerr row (col + 1) ctx E.NoFloats
752+ cerr row (col + 1) NoFloats
600 else
753 else
601 cok (Int 0) newState
754 cok (Int 0) newState
602 else
755 else
@@ -613,12 +766,12 @@ pInt =
613 GoodInt ->
766 GoodInt ->
614 let
767 let
615 !newState =
768 !newState =
616− P.State newPos end indent row (col + len) ctx
769+ P.State src newPos end indent row (col + len)
617 in
770 in
618 cok (Int n) newState
771 cok (Int n) newState
619
772
620 BadIntEnd ->
773 BadIntEnd ->
621− cerr row (col + len) ctx E.NoFloats
774+ cerr row (col + len) NoFloats
622
775
623
776
624data IntStatus = GoodInt | BadIntEnd
777data IntStatus = GoodInt | BadIntEnd
compiler/src/Json/Encode.hs+37−21
@@ -10,6 +10,7 @@ module Json.Encode
10 , object
10 , object
11 , string
11 , string
12 , name
12 , name
13+ , chars
13 , bool
14 , bool
14 , int
15 , int
15 , number
16 , number
@@ -32,6 +33,7 @@ import qualified Data.Name as Name
32import qualified Data.Utf8 as Utf8
33import qualified Data.Utf8 as Utf8
33
34
34import qualified File
35import qualified File
36+import qualified Json.String as Json
35
37
36
38
37
39
@@ -40,7 +42,7 @@ import qualified File
40
42
41data Value
43data Value
42 = Array [Value]
44 = Array [Value]
43− | Object [(Utf8.String, Value)]
45+ | Object [(Json.String, Value)]
44 | String B.Builder
46 | String B.Builder
45 | Boolean Bool
47 | Boolean Bool
46 | Integer Int
48 | Integer Int
@@ -53,14 +55,14 @@ array =
53 Array
55 Array
54
56
55
57
56−object :: [(Utf8.String,Value)] -> Value
58+object :: [(Json.String, Value)] -> Value
57object =
59object =
58 Object
60 Object
59
61
60
62
61−string :: Utf8.String -> Value
63+string :: Json.String -> Value
62string str =
64string str =
63− String (encodeUtf8 str)
65+ String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')
64
66
65
67
66name :: Name.Name -> Value
68name :: Name.Name -> Value
@@ -88,7 +90,7 @@ null =
88 Null
90 Null
89
91
90
92
91−dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value
93+dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
92dict encodeKey encodeValue pairs =
94dict encodeKey encodeValue pairs =
93 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
95 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
94
96
@@ -99,12 +101,35 @@ list encodeEntry entries =
99
101
100
102
101
103
104+-- CHARS
105+
106+
107+chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
108+chars chrs =
109+ String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
110+
111+
112+escape :: [Char] -> [Char]
113+escape chrs =
114+ case chrs of
115+ [] ->
116+ []
117+
118+ c:cs
119+ | c == '\r' -> '\\' : 'r' : escape cs
120+ | c == '\n' -> '\\' : 'n' : escape cs
121+ | c == '\"' -> '\\' : '"' : escape cs
122+ | c == '\\' -> '\\' : '\\' : escape cs
123+ | otherwise -> c : escape cs
124+
125+
126+
102-- HELPERS
127-- HELPERS
103
128
104
129
105−(==>) :: a -> b -> (a, b)
130+(==>) :: [Char] -> value -> (Json.String, value)
106−(==>) a b =
131+(==>) key value =
107− (a, b)
132+ (Json.fromChars key, value)
108
133
109
134
110
135
@@ -144,7 +169,7 @@ encodeUgly value =
144 Object (first : rest) ->
169 Object (first : rest) ->
145 let
170 let
146 encodeEntry char (key, entry) =
171 encodeEntry char (key, entry) =
147− B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry
172+ B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
148 in
173 in
149 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
150
175
@@ -205,15 +230,6 @@ encodeHelp indent value =
205
230
206
231
207
232
208−-- ENCODE UTF-8
209−
210−
211−encodeUtf8 :: Utf8.String -> B.Builder
212−encodeUtf8 str =
213− B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'
214−
215−
216−
217-- ENCODE ARRAY
233-- ENCODE ARRAY
218
234
219
235
@@ -236,7 +252,7 @@ arrayClose =
236-- ENCODE OBJECT
252-- ENCODE OBJECT
237
253
238
254
239−encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder
255+encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
240encodeObject =
256encodeObject =
241 encodeSequence objectOpen objectClose encodeField
257 encodeSequence objectOpen objectClose encodeField
242
258
@@ -251,9 +267,9 @@ objectClose =
251 B.char7 '}'
267 B.char7 '}'
252
268
253
269
254−encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder
270+encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
255encodeField indent (key, value) =
271encodeField indent (key, value) =
256− encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value
272+ B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value
257
273
258
274
259
275
compiler/src/Json/String.hsnew file+192
@@ -0,0 +1,192 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
3+module Json.String
4+ ( String
5+ , isEmpty
6+ --
7+ , fromPtr
8+ , fromName
9+ , fromChars
10+ , fromSnippet
11+ , fromComment
12+ --
13+ , toChars
14+ , toBuilder
15+ )
16+ where
17+
18+
19+import Prelude hiding (String)
20+import qualified Data.ByteString.Builder as B
21+import qualified Data.Coerce as Coerce
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
24+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
25+import Data.Word (Word8)
26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27+import Foreign.ForeignPtr (withForeignPtr)
28+import GHC.Exts (RealWorld)
29+import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
30+import GHC.ST (ST)
31+
32+import qualified Parse.Primitives as P
33+
34+
35+
36+-- JSON STRINGS
37+
38+
39+-- INVARIANT: any Json.String is appropriately escaped already
40+-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
41+--
42+type String =
43+ Utf8.Utf8 JSON_STRING
44+
45+
46+data JSON_STRING
47+
48+
49+isEmpty :: String -> Bool
50+isEmpty =
51+ Utf8.isEmpty
52+
53+
54+
55+-- FROM
56+
57+
58+fromPtr :: Ptr Word8 -> Ptr Word8 -> String
59+fromPtr =
60+ Utf8.fromPtr
61+
62+
63+fromChars :: [Char] -> String
64+fromChars =
65+ Utf8.fromChars
66+
67+
68+fromSnippet :: P.Snippet -> String
69+fromSnippet =
70+ Utf8.fromSnippet
71+
72+
73+fromName :: Name.Name -> String
74+fromName =
75+ Coerce.coerce
76+
77+
78+
79+-- TO
80+
81+
82+toChars :: String -> [Char]
83+toChars =
84+ Utf8.toChars
85+
86+
87+{-# INLINE toBuilder #-}
88+toBuilder :: String -> B.Builder
89+toBuilder =
90+ Utf8.toBuilder
91+
92+
93+
94+-- FROM COMMENT
95+
96+
97+fromComment :: P.Snippet -> String
98+fromComment (P.Snippet fptr off len _ _) =
99+ unsafePerformIO $ withForeignPtr fptr $ \ptr ->
100+ let
101+ !pos = plusPtr ptr off
102+ !end = plusPtr pos len
103+ !str = fromChunks (chompChunks pos end pos [])
104+ in
105+ return str
106+
107+
108+chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
109+chompChunks pos end start revChunks =
110+ if pos >= end then
111+ reverse (addSlice start end revChunks)
112+ else
113+ let
114+ !word = P.unsafeIndex pos
115+ in
116+ case word of
117+ 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
118+ 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
119+ 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120+ 0x0D {-\r-} ->
121+ let
122+ !newPos = plusPtr pos 1
123+ in
124+ chompChunks newPos end newPos (addSlice start pos revChunks)
125+
126+ _ ->
127+ let
128+ !width = P.getCharWidth word
129+ !newPos = plusPtr pos width
130+ in
131+ chompChunks newPos end start revChunks
132+
133+
134+chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
135+chompEscape escape pos end start revChunks =
136+ let
137+ !pos1 = plusPtr pos 1
138+ in
139+ chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)
140+
141+
142+addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
143+addSlice start end revChunks =
144+ if start == end
145+ then revChunks
146+ else Slice start (minusPtr end start) : revChunks
147+
148+
149+
150+-- FROM CHUNKS
151+
152+
153+data Chunk
154+ = Slice (Ptr Word8) Int
155+ | Escape Word8
156+
157+
158+fromChunks :: [Chunk] -> String
159+fromChunks chunks =
160+ unsafeDupablePerformIO (stToIO (
161+ do let !len = sum (map chunkToWidth chunks)
162+ mba <- newByteArray len
163+ writeChunks mba 0 chunks
164+ freeze mba
165+ ))
166+
167+
168+chunkToWidth :: Chunk -> Int
169+chunkToWidth chunk =
170+ case chunk of
171+ Slice _ len -> len
172+ Escape _ -> 2
173+
174+
175+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
176+writeChunks mba offset chunks =
177+ case chunks of
178+ [] ->
179+ return ()
180+
181+ chunk : chunks ->
182+ case chunk of
183+ Slice ptr len ->
184+ do copyFromPtr ptr mba offset len
185+ let !newOffset = offset + len
186+ writeChunks mba newOffset chunks
187+
188+ Escape word ->
189+ do writeWord8 mba offset 0x5C {- \ -}
190+ writeWord8 mba (offset + 1) word
191+ let !newOffset = offset + 2
192+ writeChunks mba newOffset chunks
compiler/src/Nitpick/Debug.hs+6−18
@@ -1,33 +1,21 @@
1module Nitpick.Debug
1module Nitpick.Debug
2− ( findDebugUses
2+ ( hasDebugUses
3 )
3 )
4 where
4 where
5
5
6
6
7−import qualified Data.Map as Map
7+import qualified Data.Map.Utils as Map
8−import qualified Data.Name as Name
9−import qualified Data.Set as Set
10
8
11import qualified AST.Optimized as Opt
9import qualified AST.Optimized as Opt
12−import qualified Elm.ModuleName as ModuleName
13−import qualified Elm.Package as Pkg
14
10
15
11
16
12
17−-- FIND DEBUG USES
13+-- HAS DEBUG USES
18
14
19
15
20−findDebugUses :: Pkg.Name -> Opt.Graph -> [Name.Name]
16+hasDebugUses :: Opt.LocalGraph -> Bool
21−findDebugUses pkg (Opt.Graph _ graph _) =
17+hasDebugUses (Opt.LocalGraph _ graph _) =
22− Set.toList $ Map.foldrWithKey (addDebugUses pkg) Set.empty graph
23−
24−
25−addDebugUses :: Pkg.Name -> Opt.Global -> Opt.Node -> Set.Set Name.Name -> Set.Set Name.Name
26−addDebugUses here (Opt.Global (ModuleName.Canonical pkg home) _) node uses =
27− if pkg == here && nodeHasDebug node then
18+ Map.any nodeHasDebug graph
28− Set.insert home uses
29− else
30− uses
31
19
32
20
33nodeHasDebug :: Opt.Node -> Bool
21nodeHasDebug :: Opt.Node -> Bool
compiler/src/Nitpick/PatternMatches.hs+10−9
@@ -21,11 +21,12 @@ 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.Utf8 as Utf8
24+import qualified Data.NonEmptyList as NE
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
29import qualified Reporting.Annotation as A
30import qualified Reporting.Annotation as A
30
31
31
32
@@ -40,8 +41,8 @@ data Pattern
40
41
41
42
42data Literal
43data Literal
43− = Chr Utf8.String
44+ = Chr ES.String
44− | Str Utf8.String
45+ | Str ES.String
45 | Int Int
46 | Int Int
46 deriving (Eq)
47 deriving (Eq)
47
48
@@ -202,14 +203,14 @@ data Context
202-- CHECK
203-- CHECK
203
204
204
205
205−check :: Can.Module -> Either [Error] ()
206+check :: Can.Module -> Either (NE.List Error) ()
206−check (Can.Module _ _ decls _ _ _ _) =
207+check (Can.Module _ _ _ decls _ _ _ _) =
207 case checkDecls decls [] of
208 case checkDecls decls [] of
208 [] ->
209 [] ->
209 Right ()
210 Right ()
210
211
211− errors ->
212+ e:es ->
212− Left errors
213+ Left (NE.List e es)
213
214
214
215
215
216
@@ -222,8 +223,8 @@ checkDecls decls errors =
222 Can.Declare def subDecls ->
223 Can.Declare def subDecls ->
223 checkDef def $ checkDecls subDecls errors
224 checkDef def $ checkDecls subDecls errors
224
225
225− Can.DeclareRec defs subDecls ->
226+ Can.DeclareRec def defs subDecls ->
226− foldr checkDef (checkDecls subDecls errors) defs
227+ checkDef def (foldr checkDef (checkDecls subDecls errors) defs)
227
228
228 Can.SaveTheEnvironment ->
229 Can.SaveTheEnvironment ->
229 errors
230 errors
compiler/src/Optimize/DecisionTree.hs+5−5
@@ -27,11 +27,11 @@ import qualified Data.List as List
27import qualified Data.Maybe as Maybe
27import qualified Data.Maybe as Maybe
28import qualified Data.Name as Name
28import qualified Data.Name as Name
29import qualified Data.Set as Set
29import qualified Data.Set as Set
30−import qualified Data.Utf8 as Utf8
31
30
32import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
33import qualified Data.Index as Index
32import qualified Data.Index as Index
34import qualified Elm.ModuleName as ModuleName
33import qualified Elm.ModuleName as ModuleName
34+import qualified Elm.String as ES
35import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
36
36
37
37
@@ -77,8 +77,8 @@ data Test
77 | IsNil
77 | IsNil
78 | IsTuple
78 | IsTuple
79 | IsInt Int
79 | IsInt Int
80− | IsChr Utf8.String
80+ | IsChr ES.String
81− | IsStr Utf8.String
81+ | IsStr ES.String
82 | IsBool Bool
82 | IsBool Bool
83 deriving (Eq, Ord)
83 deriving (Eq, Ord)
84
84
@@ -618,7 +618,7 @@ instance Binary Test where
618 5 -> liftM IsStr get
618 5 -> liftM IsStr get
619 6 -> liftM IsInt get
619 6 -> liftM IsInt get
620 7 -> liftM IsBool get
620 7 -> liftM IsBool get
621− _ -> error "problem getting DecisionTree.Test binary"
621+ _ -> fail "problem getting DecisionTree.Test binary"
622
622
623
623
624instance Binary Path where
624instance Binary Path where
@@ -634,4 +634,4 @@ instance Binary Path where
634 0 -> liftM2 Index get get
634 0 -> liftM2 Index get get
635 1 -> liftM Unbox get
635 1 -> liftM Unbox get
636 2 -> pure Empty
636 2 -> pure Empty
637− _ -> error "problem getting DecisionTree.Path binary"
637+ _ -> fail "problem getting DecisionTree.Path binary"
compiler/src/Optimize/Module.hs+35−38
@@ -40,13 +40,13 @@ type Annotations =
40 Map.Map Name.Name Can.Annotation
40 Map.Map Name.Name Can.Annotation
41
41
42
42
43−optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.Graph
43+optimize :: 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 $
48 addAliases home aliases $
48 addAliases home aliases $
49− Opt.Graph Map.empty Map.empty Map.empty
49+ Opt.LocalGraph Nothing Map.empty Map.empty
50
50
51
51
52
52
@@ -57,9 +57,9 @@ type Nodes =
57 Map.Map Opt.Global Opt.Node
57 Map.Map Opt.Global Opt.Node
58
58
59
59
60−addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.Graph -> Opt.Graph
60+addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph
61−addUnions home unions (Opt.Graph mains nodes fields) =
61+addUnions home unions (Opt.LocalGraph main nodes fields) =
62− Opt.Graph mains (Map.foldr (addUnion home) nodes unions) fields
62+ Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields
63
63
64
64
65addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
65addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes
@@ -83,13 +83,13 @@ addCtorNode home opts nodes (Can.Ctor name index numArgs _) =
83-- ALIAS
83-- ALIAS
84
84
85
85
86−addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.Graph -> Opt.Graph
86+addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
87addAliases home aliases graph =
87addAliases home aliases graph =
88 Map.foldrWithKey (addAlias home) graph aliases
88 Map.foldrWithKey (addAlias home) graph aliases
89
89
90
90
91−addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
91+addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph
92−addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts) =
92+addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) =
93 case tipe of
93 case tipe of
94 Can.TRecord fields Nothing ->
94 Can.TRecord fields Nothing ->
95 let
95 let
@@ -100,8 +100,8 @@ addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts)
100 node =
100 node =
101 Opt.Define function Set.empty
101 Opt.Define function Set.empty
102 in
102 in
103− Opt.Graph
103+ Opt.LocalGraph
104− mains
104+ main
105 (Map.insert (Opt.Global home name) node nodes)
105 (Map.insert (Opt.Global home name) node nodes)
106 (Map.foldrWithKey addRecordCtorField fieldCounts fields)
106 (Map.foldrWithKey addRecordCtorField fieldCounts fields)
107
107
@@ -118,8 +118,8 @@ addRecordCtorField name _ fields =
118-- ADD EFFECTS
118-- ADD EFFECTS
119
119
120
120
121−addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
121+addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph
122−addEffects home effects graph@(Opt.Graph mains nodes fields) =
122+addEffects home effects graph@(Opt.LocalGraph main nodes fields) =
123 case effects of
123 case effects of
124 Can.NoEffects ->
124 Can.NoEffects ->
125 graph
125 graph
@@ -148,10 +148,10 @@ addEffects home effects graph@(Opt.Graph mains nodes fields) =
148 Map.insert sub link $
148 Map.insert sub link $
149 Map.insert fx (Opt.Manager Opt.Fx) nodes
149 Map.insert fx (Opt.Manager Opt.Fx) nodes
150 in
150 in
151− Opt.Graph mains newNodes fields
151+ Opt.LocalGraph main newNodes fields
152
152
153
153
154−addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.Graph -> Opt.Graph
154+addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph
155addPort home name port_ graph =
155addPort home name port_ graph =
156 case port_ of
156 case port_ of
157 Can.Incoming _ payloadType _ ->
157 Can.Incoming _ payloadType _ ->
@@ -173,10 +173,10 @@ addPort home name port_ graph =
173-- HELPER
173-- HELPER
174
174
175
175
176−addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.Graph -> Opt.Graph
176+addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph
177−addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
177+addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
178− Opt.Graph
178+ Opt.LocalGraph
179− mains
179+ main
180 (Map.insert name node nodes)
180 (Map.insert name node nodes)
181 (Map.unionWith (+) fields fieldCounts)
181 (Map.unionWith (+) fields fieldCounts)
182
182
@@ -185,19 +185,20 @@ addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
185-- ADD DECLS
185-- ADD DECLS
186
186
187
187
188−addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
188+addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
189addDecls home annotations decls graph =
189addDecls home annotations decls graph =
190 case decls of
190 case decls of
191 Can.Declare def subDecls ->
191 Can.Declare def subDecls ->
192 addDecls home annotations subDecls =<< addDef home annotations def graph
192 addDecls home annotations subDecls =<< addDef home annotations def graph
193
193
194− Can.DeclareRec defs subDecls ->
194+ Can.DeclareRec d ds subDecls ->
195+ let defs = d:ds in
195 case findMain defs of
196 case findMain defs of
196 Nothing ->
197 Nothing ->
197 addDecls home annotations subDecls (addRecDefs home defs graph)
198 addDecls home annotations subDecls (addRecDefs home defs graph)
198
199
199 Just region ->
200 Just region ->
200− Result.throw $ E.BadCycle region (map defToName defs)
201+ Result.throw $ E.BadCycle region (defToName d) (map defToName ds)
201
202
202 Can.SaveTheEnvironment ->
203 Can.SaveTheEnvironment ->
203 Result.ok graph
204 Result.ok graph
@@ -212,10 +213,10 @@ findMain defs =
212 def:rest ->
213 def:rest ->
213 case def of
214 case def of
214 Can.Def (A.At region name) _ _ ->
215 Can.Def (A.At region name) _ _ ->
215− if name == Name.main then Just region else findMain rest
216+ if name == Name._main then Just region else findMain rest
216
217
217 Can.TypedDef (A.At region name) _ _ _ _ ->
218 Can.TypedDef (A.At region name) _ _ _ _ ->
218− if name == Name.main then Just region else findMain rest
219+ if name == Name._main then Just region else findMain rest
219
220
220
221
221defToName :: Can.Def -> Name.Name
222defToName :: Can.Def -> Name.Name
@@ -229,7 +230,7 @@ defToName def =
229-- ADD DEFS
230-- ADD DEFS
230
231
231
232
232−addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph
233+addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
233addDef home annotations def graph =
234addDef home annotations def graph =
234 case def of
235 case def of
235 Can.Def (A.At region name) args body ->
236 Can.Def (A.At region name) args body ->
@@ -241,21 +242,17 @@ addDef home annotations def graph =
241 addDefHelp region annotations home name (map fst typedArgs) body graph
242 addDefHelp region annotations home name (map fst typedArgs) body graph
242
243
243
244
244−addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
245+addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
245−addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
246+addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
246− if name /= Name.main then
247+ if name /= Name._main then
247 Result.ok (addDefNode home name args body Set.empty graph)
248 Result.ok (addDefNode home name args body Set.empty graph)
248 else
249 else
249 let
250 let
250 (Can.Forall _ tipe) = annotations ! name
251 (Can.Forall _ tipe) = annotations ! name
251
252
252 addMain (deps, fields, main) =
253 addMain (deps, fields, main) =
253− let
254− newMains = Map.insert home main mains
255− newFields = Map.unionWith (+) fields fieldCounts
256− in
257 addDefNode home name args body deps $
254 addDefNode home name args body deps $
258− Opt.Graph newMains nodes newFields
255+ Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)
259 in
256 in
260 case Type.deepDealias tipe of
257 case Type.deepDealias tipe of
261 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
258 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
@@ -275,7 +272,7 @@ addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes f
275 Result.throw (E.BadType region tipe)
272 Result.throw (E.BadType region tipe)
276
273
277
274
278−addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
275+addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph
279addDefNode home name args body mainDeps graph =
276addDefNode home name args body mainDeps graph =
280 let
277 let
281 (deps, fields, def) =
278 (deps, fields, def) =
@@ -304,8 +301,8 @@ data State =
304 }
301 }
305
302
306
303
307−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
304+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph
308−addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =
305+addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
309 let
306 let
310 names = reverse (map toName defs)
307 names = reverse (map toName defs)
311 cycleName = Opt.Global home (Name.fromManyNames names)
308 cycleName = Opt.Global home (Name.fromManyNames names)
@@ -316,8 +313,8 @@ addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =
316 Names.run $
313 Names.run $
317 foldM (addRecDef cycle) (State [] []) defs
314 foldM (addRecDef cycle) (State [] []) defs
318 in
315 in
319− Opt.Graph
316+ Opt.LocalGraph
320− mains
317+ main
321 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
318 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
322 (Map.unionWith (+) fields fieldCounts)
319 (Map.unionWith (+) fields fieldCounts)
323
320
compiler/src/Optimize/Names.hs+1−7
@@ -24,7 +24,6 @@ import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
24import qualified AST.Optimized as Opt
25import qualified Data.Index as Index
25import qualified Data.Index as Index
26import qualified Elm.ModuleName as ModuleName
26import qualified Elm.ModuleName as ModuleName
27−import qualified Elm.Package as Pkg
28import qualified Reporting.Annotation as A
27import qualified Reporting.Annotation as A
29
28
30
29
@@ -58,12 +57,7 @@ generate =
58registerKernel :: Name.Name -> a -> Tracker a
57registerKernel :: Name.Name -> a -> Tracker a
59registerKernel home value =
58registerKernel home value =
60 Tracker $ \uid deps fields ok ->
59 Tracker $ \uid deps fields ok ->
61− ok uid (Set.insert (toKernelGlobal home) deps) fields value
60+ ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value
62−
63−
64−toKernelGlobal :: Name.Name -> Opt.Global
65−toKernelGlobal home =
66− Opt.Global (ModuleName.Canonical Pkg.kernel home) Name.dollar
67
61
68
62
69registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr
63registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr
compiler/src/Optimize/Port.hs+3−3
@@ -58,7 +58,7 @@ toEncoder tipe =
58 | name == Name.array -> encodeArray arg
58 | name == Name.array -> encodeArray arg
59
59
60 _ ->
60 _ ->
61− error "toEncoder: bad union type"
61+ error "toEncoder: bad custom type"
62
62
63 Can.TRecord _ (Just _) ->
63 Can.TRecord _ (Just _) ->
64 error "toEncoder: bad record"
64 error "toEncoder: bad record"
@@ -68,7 +68,7 @@ toEncoder tipe =
68 encodeField (name, Can.FieldType _ fieldType) =
68 encodeField (name, Can.FieldType _ fieldType) =
69 do encoder <- toEncoder fieldType
69 do encoder <- toEncoder fieldType
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
71− return $ Opt.Tuple (Opt.Str (Name.toUtf8 name)) value Nothing
71+ return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
72 in
72 in
73 do object <- encode "object"
73 do object <- encode "object"
74 keyValuePairs <- traverse encodeField (Map.toList fields)
74 keyValuePairs <- traverse encodeField (Map.toList fields)
@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =
309 return $
309 return $
310 Opt.Call andThen
310 Opt.Call andThen
311 [ Opt.Function [key] decoder
311 [ Opt.Function [key] decoder
312− , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]
312+ , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
313 ]
313 ]
314
314
315
315
compiler/src/Parse/Declaration.hs+180−131
@@ -16,11 +16,11 @@ import qualified Parse.Expression as Expr
16import qualified Parse.Pattern as Pattern
16import qualified Parse.Pattern as Pattern
17import qualified Parse.Keyword as Keyword
17import qualified Parse.Keyword as Keyword
18import qualified Parse.Number as Number
18import qualified Parse.Number as Number
19+import qualified Parse.Space as Space
19import qualified Parse.Symbol as Symbol
20import qualified Parse.Symbol as Symbol
20import qualified Parse.Type as Type
21import qualified Parse.Type as Type
21import qualified Parse.Variable as Var
22import qualified Parse.Variable as Var
22−import Parse.Utils
23−import Parse.Primitives hiding (Parser, State)
23+import Parse.Primitives hiding (State)
24import qualified Parse.Primitives as P
24import qualified Parse.Primitives as P
25import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Syntax as E
26import qualified Reporting.Error.Syntax as E
@@ -31,141 +31,182 @@ import qualified Reporting.Error.Syntax as E
31
31
32
32
33data Decl
33data Decl
34− = Value (A.Located Src.Value)
34+ = Value (Maybe Src.Comment) (A.Located Src.Value)
35− | Union (A.Located Src.Union)
35+ | Union (Maybe Src.Comment) (A.Located Src.Union)
36− | Alias (A.Located Src.Alias)
36+ | Alias (Maybe Src.Comment) (A.Located Src.Alias)
37− | Port Src.Port
37+ | Port (Maybe Src.Comment) Src.Port
38
38
39
39
40−declaration :: SParser Decl
40+declaration :: Space.Parser E.Decl Decl
41declaration =
41declaration =
42+ do maybeDocs <- chompDocComment
42− do start <- getPosition
43+ start <- getPosition
43− oneOf E.XXX
44+ oneOf E.DeclStart
44− [ typeDecl start
45+ [ typeDecl maybeDocs start
45− , portDecl
46+ , portDecl maybeDocs
46− , valueDecl start
47+ , valueDecl maybeDocs start
47 ]
48 ]
48
49
49
50
50
51
52+-- DOC COMMENT
53+
54+
55+chompDocComment :: Parser E.Decl (Maybe Src.Comment)
56+chompDocComment =
57+ oneOfWithFallback
58+ [
59+ do docComment <- Space.docComment E.DeclStart E.DeclSpace
60+ Space.chomp E.DeclSpace
61+ Space.checkFreshLine E.DeclFreshLineAfterDocComment
62+ return (Just docComment)
63+ ]
64+ Nothing
65+
66+
67+
51-- DEFINITION and ANNOTATION
68-- DEFINITION and ANNOTATION
52
69
53
70
54{-# INLINE valueDecl #-}
71{-# INLINE valueDecl #-}
55−valueDecl :: A.Position -> SParser Decl
72+valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
56−valueDecl start =
73+valueDecl maybeDocs start =
57− do name <- Var.lower
74+ do name <- Var.lower E.DeclStart
58 end <- getPosition
75 end <- getPosition
59− spaces
76+ specialize (E.DeclDef name) $
77+ do Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
60− oneOf E.XXX
78+ oneOf E.DeclDefEquals
61− [
79+ [
62− do word1 0x3A {-:-} E.XXX
80+ do word1 0x3A {-:-} E.DeclDefEquals
63− pushContext start (E.Annotation name)
81+ Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
64− spaces
65− (tipe, _, space) <- Type.expression
82+ (tipe, _) <- specialize E.DeclDefType Type.expression
66− popContext ()
83+ Space.checkFreshLine E.DeclDefNameRepeat
67− checkAligned space
68− defName <- matchingName name
84+ defName <- chompMatchingName name
69− let (A.At (A.Region defStart _) _) = defName
85+ Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
70− pushContext defStart (E.Definition name)
71− spaces
72− decl <- valueHelp start defName (Just tipe) []
86+ chompDefArgsAndBody maybeDocs start defName (Just tipe) []
73− popContext decl
74− ,
87+ ,
75− do pushContext start (E.Definition name)
76− decl <- valueHelp start (A.at start end name) Nothing []
88+ chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []
77− popContext decl
78− ]
89+ ]
79−
90+
80−
91+
81−valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl
92+chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
82−valueHelp start name tipe revArgs =
93+chompDefArgsAndBody maybeDocs start name tipe revArgs =
83− oneOf E.XXX
94+ oneOf E.DeclDefEquals
84− [ do arg <- Pattern.term
95+ [ do arg <- specialize E.DeclDefArg Pattern.term
85− spaces
96+ Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
86− valueHelp start name tipe (arg : revArgs)
97+ chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs)
87− , do word1 0x3D {-=-} E.XXX
98+ , do word1 0x3D {-=-} E.DeclDefEquals
88− spaces
99+ Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody
89− (body, end, space) <- Expr.expression
100+ (body, end) <- specialize E.DeclDefBody Expr.expression
90− let value = A.at start end (Src.Value name (reverse revArgs) body tipe)
101+ let value = Src.Value name (reverse revArgs) body tipe
102+ let avalue = A.at start end value
91− return ( Value value, end, space )
103+ return (Value maybeDocs avalue, end)
92 ]
104 ]
93
105
94
106
95−matchingName :: Name.Name -> Parser (A.Located Name.Name)
107+chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
96−matchingName expectedName =
108+chompMatchingName expectedName =
109+ let
97− let (P.Parser parserL) = Var.lower in
110+ (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
111+ in
98− P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
112+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
99 let
113 let
100− cokL name newState@(P.State _ _ _ er ec _) =
114+ cokL name newState@(P.State _ _ _ _ er ec) =
101 if expectedName == name
115 if expectedName == name
102 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
103− else cerr sr sc ctx (E.MatchingName expectedName)
117+ else cerr sr sc (E.DeclDefNameMatch name)
104
118
105− eokL name newState@(P.State _ _ _ er ec _) =
119+ eokL name newState@(P.State _ _ _ _ er ec) =
106 if expectedName == name
120 if expectedName == name
107 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
108− else eerr sr sc ctx (E.MatchingName expectedName)
122+ else eerr sr sc (E.DeclDefNameMatch name)
109 in
123 in
110 parserL state cokL eokL cerr eerr
124 parserL state cokL eokL cerr eerr
111
125
112
126
113
127
114−-- TYPE ALIAS and UNION TYPES
128+-- TYPE DECLARATIONS
115
129
116
130
117{-# INLINE typeDecl #-}
131{-# INLINE typeDecl #-}
118−typeDecl :: A.Position -> SParser Decl
132+typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
119−typeDecl start =
133+typeDecl maybeDocs start =
120− do Keyword.type_
134+ inContext E.DeclType (Keyword.type_ E.DeclStart) $
121− spaces
135+ do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
122− oneOf E.XXX
136+ oneOf E.DT_Name
123− [
137+ [
124− inContext E.TypeAlias Keyword.alias_ $
138+ inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $
125− do spaces
139+ do Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
126− (name, args) <- nameArgsEquals
140+ (name, args) <- chompAliasNameToEquals
127− (tipe, end, pos) <- Type.expression
141+ (tipe, end) <- specialize E.AliasBody Type.expression
128− let alias = A.at start end (Src.Alias name args tipe)
142+ let alias = A.at start end (Src.Alias name args tipe)
129− return (Alias alias, end, pos)
143+ return (Alias maybeDocs alias, end)
130− ,
144+ ,
131− do pushContext start E.TypeUnion
145+ specialize E.DT_Union $
132− (name, args) <- nameArgsEquals
146+ do (name, args) <- chompCustomNameToEquals
133− (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
147+ (firstVariant, firstEnd) <- Type.variant
134− (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
148+ (variants, end) <- chompVariants [firstVariant] firstEnd
135− let union = A.at start end (Src.Union name args ctors)
149+ let union = A.at start end (Src.Union name args variants)
136− popContext (Union union, end, pos)
150+ return (Union maybeDocs union, end)
151+ ]
152+
153+
154+
155+-- TYPE ALIASES
156+
157+
158+chompAliasNameToEquals :: Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])
159+chompAliasNameToEquals =
160+ do name <- addLocation (Var.upper E.AliasName)
161+ Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
162+ chompAliasNameToEqualsHelp name []
163+
164+
165+chompAliasNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])
166+chompAliasNameToEqualsHelp name args =
167+ oneOf E.AliasEquals
168+ [ do arg <- addLocation (Var.lower E.AliasEquals)
169+ Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
170+ chompAliasNameToEqualsHelp name (arg:args)
171+ , do word1 0x3D {-=-} E.AliasEquals
172+ Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody
173+ return ( name, reverse args )
137− ]
174+ ]
138
175
139
176
140−nameArgsEquals :: Parser (A.Located Name.Name, [A.Located Name.Name])
141−nameArgsEquals =
142− do name <- addLocation Var.upper
143− spaces
144− nameArgsEqualsHelp name []
145
177
178+-- CUSTOM TYPES
146
179
180+
181+chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
182+chompCustomNameToEquals =
183+ do name <- addLocation (Var.upper E.CT_Name)
184+ Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
185+ chompCustomNameToEqualsHelp name []
186+
187+
147−nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])
188+chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
148−nameArgsEqualsHelp name args =
189+chompCustomNameToEqualsHelp name args =
149− oneOf E.XXX
190+ oneOf E.CT_Equals
150− [ do arg <- addLocation Var.lower
191+ [ do arg <- addLocation (Var.lower E.CT_Equals)
151− spaces
192+ Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
152− nameArgsEqualsHelp name (arg:args)
193+ chompCustomNameToEqualsHelp name (arg:args)
153− , do word1 0x3D {-=-} E.XXX
194+ , do word1 0x3D {-=-} E.CT_Equals
154− spaces
195+ Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals
155 return ( name, reverse args )
196 return ( name, reverse args )
156 ]
197 ]
157
198
158
199
159−chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]
200+chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])]
160−chompConstructors ctors end pos =
201+chompVariants variants end =
161− oneOf E.XXX
202+ oneOfWithFallback
162− [ do checkSpace pos
203+ [ do Space.checkIndent end E.CT_IndentBar
163− word1 0x7C {-|-} E.XXX
204+ word1 0x7C {-|-} E.CT_Bar
164− spaces
205+ Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar
165− (ctor, newEnd, newSpace) <- Type.unionConstructor
206+ (variant, newEnd) <- Type.variant
166− chompConstructors (ctor:ctors) newEnd newSpace
207+ chompVariants (variant:variants) newEnd
167− , return ( reverse ctors, end, pos )
168 ]
208 ]
209+ (reverse variants, end)
169
210
170
211
171
212
@@ -173,16 +214,19 @@ chompConstructors ctors end pos =
173
214
174
215
175{-# INLINE portDecl #-}
216{-# INLINE portDecl #-}
176−portDecl :: SParser Decl
217+portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
177−portDecl =
218+portDecl maybeDocs =
178− inContext E.Port Keyword.port_ $
219+ inContext E.Port (Keyword.port_ E.DeclStart) $
179− do spaces
220+ do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
180− name <- addLocation Var.lower
221+ name <- addLocation (Var.lower E.PortName)
181− spaces
222+ Space.chompAndCheckIndent E.PortSpace E.PortIndentColon
182− word1 0x3A {-:-} E.XXX
223+ word1 0x3A {-:-} E.PortColon
183− spaces
224+ Space.chompAndCheckIndent E.PortSpace E.PortIndentType
184− (tipe, end, pos) <- Type.expression
225+ (tipe, end) <- specialize E.PortType Type.expression
226+ return
185− return ( Port (Src.Port name tipe), end, pos )
227+ ( Port maybeDocs (Src.Port name tipe)
228+ , end
229+ )
186
230
187
231
188
232
@@ -191,27 +235,32 @@ portDecl =
191
235
192-- INVARIANT: always chomps to a freshline
236-- INVARIANT: always chomps to a freshline
193--
237--
194−infix_ :: Parser (A.Located Src.Binop)
238+infix_ :: Parser E.Module (A.Located Src.Infix)
195infix_ =
239infix_ =
240+ let
241+ err = E.Infix
242+ _err = \_ -> E.Infix
243+ in
196 do start <- getPosition
244 do start <- getPosition
197− inContext E.Infix Keyword.infix_ $
245+ Keyword.infix_ err
198− do spaces
246+ Space.chompAndCheckIndent _err err
199− associativity <-
247+ associativity <-
200− oneOf E.XXX
248+ oneOf err
201− [ Keyword.left_ >> return Binop.Left
249+ [ Keyword.left_ err >> return Binop.Left
202− , Keyword.right_ >> return Binop.Right
250+ , Keyword.right_ err >> return Binop.Right
203− , Keyword.non_ >> return Binop.Non
251+ , Keyword.non_ err >> return Binop.Non
204− ]
252+ ]
205− spaces
253+ Space.chompAndCheckIndent _err err
206− precedence <- Number.precedence
254+ precedence <- Number.precedence err
207− spaces
255+ Space.chompAndCheckIndent _err err
208− word1 0x28 {-(-} E.XXX
256+ word1 0x28 {-(-} err
209− op <- Symbol.binop
257+ op <- Symbol.operator err _err
210− word1 0x29 {-)-} E.XXX
258+ word1 0x29 {-)-} err
211− spaces
259+ Space.chompAndCheckIndent _err err
212− word1 0x3D {-=-} E.XXX
260+ word1 0x3D {-=-} err
213− spaces
261+ Space.chompAndCheckIndent _err err
214− name <- Var.lower
262+ name <- Var.lower err
215− end <- getPosition
263+ end <- getPosition
264+ Space.chomp _err
216− checkFreshLine =<< whitespace
265+ Space.checkFreshLine err
217− return (A.at start end (Src.Binop op associativity precedence name))
266+ return (A.at start end (Src.Infix op associativity precedence name))
compiler/src/Parse/Docs.hsdeleted−275
@@ -1,275 +0,0 @@
1−module Parse.Docs
2− ( Docs(..)
3− , parser
4− )
5− where
6−
7−
8−
9−-- DOCS
10−
11−
12−data Docs =
13− Docs
14− { _exposed :: [A.Located Name.Name]
15− , _overview :: Utf8.String
16− , _listed :: [A.Located Name.Name]
17− , _comments :: Map.Map Name.Name Utf8.String
18− }
19−
20−
21−
22−-- PARSER
23−
24−
25−parser :: Parser Docs
26−parser =
27− error "TODO implement docs parser"
28−
29−
30−chompUntilDocs :: Parser Bool
31−chompUntilDocs =
32− P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->
33− let
34− (# isStart, newOffset, newRow, newCol #) =
35− eatDocs fp offset terminal row col
36−
37− !newState =
38− P.State fp newOffset terminal indent newRow newCol ctx
39− in
40− cok isStart newState
41−
42−
43−eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)
44−eatDocs fp offset terminal row col =
45− if offset >= terminal then
46− (# False, offset, row, col #)
47−
48− else if isDocsStart fp offset terminal then
49− (# True, offset + 5, row, col + 5 #)
50−
51− else
52− let !word = P.unsafeIndex fp offset in
53− if word == 0x0A {- \n -} then
54− eatDocs fp (offset + 1) terminal (row + 1) 1
55−
56− else
57− let !newOffset = offset + P.getCharWidth fp offset terminal word in
58− eatDocs fp newOffset terminal row (col + 1)
59−
60−
61−isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool
62−isDocsStart =
63− let (B.PS dfp doff dlen) = docsStart in
64− P.isSubstring dfp doff dlen
65−
66−
67−{-# NOINLINE docsStart #-}
68−docsStart :: B.ByteString
69−docsStart =
70− "@docs"
71−
72−
73−chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
74−chompOverview names =
75− do isDocs <- chompUntilDocs
76− if isDocs
77− then chompOverviewHelp names
78− else return names
79−
80−
81−chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
82−chompOverviewHelp names =
83− do pos <- getPosition
84− (SPos spos) <- whitespace
85− if pos == spos
86− then chompOverview names
87− else chompOverview =<< chompDocs names
88−
89−
90−chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
91−chompDocs names =
92− do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])
93− spos <- whitespace
94− oneOf SE.XXX
95− [ do checkSpace spos
96− word1 0x2C {-,-} SE.XXX
97− spaces
98− chompDocs (name:names)
99− , return (name:names)
100− ]
101−
102−
103−chompBinop :: Parser Name.Name
104−chompBinop =
105− do word1 0x28 {-(-} SE.XXX
106− name <- Symbol.binop
107− word1 0x29 {-)-} SE.XXX
108− return name
109−
110−
111−
112−
113−-- CHECK NAMES
114−
115−
116−type Result i w a =
117− Result.Result i w E.Error a
118−
119−
120−type Dups =
121− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
122−
123−
124−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
125−checkNames exports names =
126− do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
127− let overlap = Map.size (Map.intersection docs exports)
128− if Map.size exports == overlap && overlap == Map.size docs
129− then Result.ok ()
130− else
131− do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
132− _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
133− Result.ok ()
134−
135−
136−addName :: Dups -> A.Located Name.Name -> Dups
137−addName dict (A.At region name) =
138− Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
139−
140−
141−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region
142−isUnique name regions =
143− case regions of
144− OneOrMore.One region ->
145− Result.ok region
146−
147− OneOrMore.More _ _ ->
148− let (r1:r2:_) = OneOrMore.toList regions in
149− Result.throw (E.Duplicate name r1 r2)
150−
151−
152−onlyInDocs :: Name.Name -> A.Region -> Result i w a
153−onlyInDocs name region =
154− Result.throw $ E.OnlyInDocs name region
155−
156−
157−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
158−onlyInExports name (A.At region _) =
159− Result.throw $ E.OnlyInExports name region
160−
161−
162−
163−-- CHECK EXPORTS
164−
165−
166−data Info =
167− Info
168− { _iComments :: Map.Map Name.Name Comment
169− , _iValues :: Types
170− , _iUnions :: Map.Map Name.Name Can.Union
171− , _iAliases :: Map.Map Name.Name Can.Alias
172− , _iBinops :: Map.Map Name.Name Can.Binop
173− , _iEffects :: Can.Effects
174− }
175−
176−
177−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
178−checkExport info name (A.At region export) =
179− case export of
180− Can.ExportValue ->
181− do tipe <- getType name info
182− comment <- getComment region name info
183− Result.ok $ \m ->
184− m { _values = Map.insert name (Value comment tipe) (_values m) }
185−
186− Can.ExportBinop ->
187− do let (Can.Binop_ assoc prec realName) = _iBinops info ! name
188− tipe <- getType realName info
189− comment <- getComment region realName info
190− Result.ok $ \m ->
191− m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }
192−
193− Can.ExportAlias ->
194− do let (Can.Alias tvars tipe) = _iAliases info ! name
195− comment <- getComment region name info
196− Result.ok $ \m ->
197− m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }
198−
199− Can.ExportUnionOpen ->
200− do let (Can.Union tvars ctors _ _) = _iUnions info ! name
201− comment <- getComment region name info
202− Result.ok $ \m ->
203− m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }
204−
205− Can.ExportUnionClosed ->
206− do let (Can.Union tvars _ _ _) = _iUnions info ! name
207− comment <- getComment region name info
208− Result.ok $ \m ->
209− m { _unions = Map.insert name (Union comment tvars []) (_unions m) }
210−
211− Can.ExportPort ->
212− do tipe <- getType name info
213− comment <- getComment region name info
214− Result.ok $ \m ->
215− m { _values = Map.insert name (Value comment tipe) (_values m) }
216−
217−
218−getComment :: A.Region -> Name.Name -> Info -> Result i w Comment
219−getComment region name info =
220− case Map.lookup name (_iComments info) of
221− Nothing ->
222− Result.throw (E.NoComment name region)
223−
224− Just comment ->
225− Result.ok comment
226−
227−
228−getType :: Name.Name -> Info -> Result i w Type.Type
229−getType name info =
230− case _iValues info ! name of
231− A.At defRegion Nothing ->
232− Result.throw (E.NoAnnotation name defRegion)
233−
234− A.At _ (Just tipe) ->
235− Result.ok (Extract.fromType tipe)
236−
237−
238−dector :: Can.Ctor -> (Name.Name, [Type.Type])
239−dector (Can.Ctor name _ _ args) =
240− ( name, map Extract.fromType args )
241−
242−
243−
244−-- GATHER TYPES
245−
246−
247−type Types =
248− Map.Map Name.Name (A.Located (Maybe Can.Type))
249−
250−
251−gatherTypes :: Can.Decls -> Types -> Types
252−gatherTypes decls types =
253− case decls of
254− Can.Declare def subDecls ->
255− gatherTypes subDecls (addDef types def)
256−
257− Can.DeclareRec defs subDecls ->
258− gatherTypes subDecls (List.foldl' addDef types defs)
259−
260− Can.SaveTheEnvironment ->
261− types
262−
263−
264−addDef :: Types -> Can.Def -> Types
265−addDef types def =
266− case def of
267− Can.Def (A.At region name) _ _ ->
268− Map.insert name (A.At region Nothing) types
269−
270− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
271− let
272− tipe =
273− foldr Can.TLambda resultType (map snd typedArgs)
274− in
275− Map.insert name (A.At region (Just tipe)) types
compiler/src/Parse/Expression.hs+330−341
@@ -7,19 +7,18 @@ module Parse.Expression
7
7
8
8
9import qualified Data.Name as Name
9import qualified Data.Name as Name
10−import Data.Word (Word16)
11
10
12import qualified AST.Source as Src
11import qualified AST.Source as Src
13import qualified Parse.Keyword as Keyword
12import qualified Parse.Keyword as Keyword
14import qualified Parse.Number as Number
13import qualified Parse.Number as Number
15import qualified Parse.Pattern as Pattern
14import qualified Parse.Pattern as Pattern
16import qualified Parse.Shader as Shader
15import qualified Parse.Shader as Shader
16+import qualified Parse.Space as Space
17import qualified Parse.Symbol as Symbol
17import qualified Parse.Symbol as Symbol
18import qualified Parse.Type as Type
18import qualified Parse.Type as Type
19−import qualified Parse.Utf8 as Utf8
19+import qualified Parse.String as String
20import qualified Parse.Variable as Var
20import qualified Parse.Variable as Var
21−import Parse.Utils
22−import Parse.Primitives hiding (Parser, State)
21+import Parse.Primitives hiding (State)
23import qualified Parse.Primitives as P
22import qualified Parse.Primitives as P
24import qualified Reporting.Annotation as A
23import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Syntax as E
24import qualified Reporting.Error.Syntax as E
@@ -29,10 +28,10 @@ import qualified Reporting.Error.Syntax as E
29-- TERMS
28-- TERMS
30
29
31
30
32−term :: Parser Src.Expr
31+term :: Parser E.Expr Src.Expr
33term =
32term =
34 do start <- getPosition
33 do start <- getPosition
35− oneOf E.XXX
34+ oneOf E.Start
36 [ variable start >>= accessible start
35 [ variable start >>= accessible start
37 , string start
36 , string start
38 , number start
37 , number start
@@ -45,90 +44,80 @@ term =
45 ]
44 ]
46
45
47
46
48−string :: A.Position -> Parser Src.Expr
47+string :: A.Position -> Parser E.Expr Src.Expr
49string start =
48string start =
50− do str <- Utf8.string
49+ do str <- String.string E.Start E.String
51− end <- getPosition
52− return (A.at start end (Src.Str str))
50+ addEnd start (Src.Str str)
53
51
54
52
55−character :: A.Position -> Parser Src.Expr
53+character :: A.Position -> Parser E.Expr Src.Expr
56character start =
54character start =
57− do chr <- Utf8.character
55+ do chr <- String.character E.Start E.Char
58− end <- getPosition
59− return (A.at start end (Src.Chr chr))
56+ addEnd start (Src.Chr chr)
60
57
61
58
62−number :: A.Position -> Parser Src.Expr
59+number :: A.Position -> Parser E.Expr Src.Expr
63number start =
60number start =
64− do nmbr <- Number.number
61+ do nmbr <- Number.number E.Start E.Number
65− end <- getPosition
62+ addEnd start $
66− return $ A.at start end $
67 case nmbr of
63 case nmbr of
68− Number.Int int ->
64+ Number.Int int -> Src.Int int
69− Src.Int int
65+ Number.Float float -> Src.Float float
70
66
71− Number.Float float ->
72− Src.Float float
73
67
74−
75−accessor :: A.Position -> Parser Src.Expr
68+accessor :: A.Position -> Parser E.Expr Src.Expr
76accessor start =
69accessor start =
77− do word1 0x2E {-.-} E.XXX
70+ do word1 0x2E {-.-} E.Dot
78− field <- Var.lower
71+ field <- Var.lower E.Access
79− end <- getPosition
80− return (A.at start end (Src.Accessor field))
72+ addEnd start (Src.Accessor field)
81
73
82
74
83−variable :: A.Position -> Parser Src.Expr
75+variable :: A.Position -> Parser E.Expr Src.Expr
84variable start =
76variable start =
85− do var <- Var.foreignAlpha
77+ do var <- Var.foreignAlpha E.Start
86− end <- getPosition
87− return (A.at start end var)
78+ addEnd start var
88
79
89
80
90−accessible :: A.Position -> Src.Expr -> Parser Src.Expr
81+accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr
91accessible start expr =
82accessible start expr =
92− oneOf E.XXX
83+ oneOfWithFallback
93− [ do word1 0x2E {-.-} E.XXX
84+ [ do word1 0x2E {-.-} E.Dot
94 pos <- getPosition
85 pos <- getPosition
95− field <- Var.lower
86+ field <- Var.lower E.Access
96 end <- getPosition
87 end <- getPosition
88+ accessible start $
97− let newExpr = A.at start end (Src.Access expr (A.at pos end field))
89+ A.at start end (Src.Access expr (A.at pos end field))
98− accessible start newExpr
99− , return expr
100 ]
90 ]
91+ expr
101
92
102
93
103
94
104-- LISTS
95-- LISTS
105
96
106
97
107−list :: A.Position -> Parser Src.Expr
98+list :: A.Position -> Parser E.Expr Src.Expr
108list start =
99list start =
109− inContext E.ExprList (word1 0x5B {-[-} E.XXX) $
100+ inContext E.List (word1 0x5B {-[-} E.Start) $
110− do spaces
101+ do Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen
111− oneOf E.XXX
102+ oneOf E.ListOpen
112− [ do (entry, _, pos) <- expression
103+ [ do (entry, end) <- specialize E.ListExpr expression
113− checkSpace pos
104+ Space.checkIndent end E.ListIndentEnd
114− listHelp start [entry]
105+ chompListEnd start [entry]
115− , do word1 0x5D {-]-} E.XXX
106+ , do word1 0x5D {-]-} E.ListOpen
116− end <- getPosition
117− return (A.at start end (Src.List []))
107+ addEnd start (Src.List [])
118 ]
108 ]
119
109
120
110
121−listHelp :: A.Position -> [Src.Expr] -> Parser Src.Expr
111+chompListEnd :: A.Position -> [Src.Expr] -> Parser E.List Src.Expr
122−listHelp start entries =
112+chompListEnd start entries =
123− oneOf E.XXX
113+ oneOf E.ListEnd
124− [ do word1 0x2C {-,-} E.XXX
114+ [ do word1 0x2C {-,-} E.ListEnd
125− spaces
115+ Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr
126− (entry, _, pos) <- expression
116+ (entry, end) <- specialize E.ListExpr expression
127− checkSpace pos
117+ Space.checkIndent end E.ListIndentEnd
128− listHelp start (entry:entries)
118+ chompListEnd start (entry:entries)
129− , do word1 0x5D {-]-} E.XXX
119+ , do word1 0x5D {-]-} E.ListEnd
130− end <- getPosition
131− return (A.at start end (Src.List (reverse entries)))
120+ addEnd start (Src.List (reverse entries))
132 ]
121 ]
133
122
134
123
@@ -136,52 +125,66 @@ listHelp start entries =
136-- TUPLES
125-- TUPLES
137
126
138
127
139−tuple :: A.Position -> Parser Src.Expr
128+tuple :: A.Position -> Parser E.Expr Src.Expr
140−tuple start =
129+tuple start@(A.Position row col) =
141− inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $
130+ inContext E.Tuple (word1 0x28 {-(-} E.Start) $
142− do pos <- getPosition
131+ do before <- getPosition
143− spos <- whitespace
132+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1
144− oneOf E.XXX
145− [ do noSpace pos spos
146− word2 0x2D 0x29 {--)-} E.XXX
147− end <- getPosition
133+ after <- getPosition
148− return $ A.at start end (Src.Op "-")
134+ if before /= after
149−
135+ then
150− , do checkSpace spos
151− (entry, _, spos2) <- expression
136+ do (entry, end) <- specialize E.TupleExpr expression
152− checkSpace spos2
137+ Space.checkIndent end E.TupleIndentEnd
153− tupleHelp start entry []
138+ chompTupleEnd start entry []
154−
139+ else
155− , do noSpace pos spos
140+ oneOf E.TupleIndentExpr1
156− op <- Symbol.binop
141+ [
142+ do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved
143+ if op == "-"
144+ then
145+ oneOf E.TupleOperatorClose
146+ [
157− word1 0x29 {-)-} E.XXX
147+ do word1 0x29 {-)-} E.TupleOperatorClose
158− end <- getPosition
148+ addEnd start (Src.Op op)
159− return $ A.at start end (Src.Op op)
149+ ,
160−
150+ do (entry, end) <-
161− , do noSpace pos spos
151+ specialize E.TupleExpr $
152+ do negatedExpr@(A.At (A.Region _ end) _) <- term
153+ Space.chomp E.Space
154+ let exprStart = A.Position row (col + 2)
155+ let expr = A.at exprStart end (Src.Negate negatedExpr)
156+ chompExprEnd exprStart (State [] expr [] end)
157+ Space.checkIndent end E.TupleIndentEnd
158+ chompTupleEnd start entry []
159+ ]
160+ else
162− word1 0x29 {-)-} E.XXX
161+ do word1 0x29 {-)-} E.TupleOperatorClose
163− end <- getPosition
162+ addEnd start (Src.Op op)
163+ ,
164+ do word1 0x29 {-)-} E.TupleIndentExpr1
164− return (A.at start end Src.Unit)
165+ addEnd start Src.Unit
165−
166+ ,
167+ do (entry, end) <- specialize E.TupleExpr expression
168+ Space.checkIndent end E.TupleIndentEnd
169+ chompTupleEnd start entry []
166− ]
170+ ]
167−
171+
168−
172+
169−tupleHelp :: A.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr
173+chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr
170−tupleHelp start firstExpr revExprs =
174+chompTupleEnd start firstExpr revExprs =
171− oneOf E.XXX
175+ oneOf E.TupleEnd
172− [ do word1 0x2C {-,-} E.XXX
176+ [ do word1 0x2C {-,-} E.TupleEnd
173− spaces
177+ Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN
174− (entry, _, pos) <- expression
178+ (entry, end) <- specialize E.TupleExpr expression
175− checkSpace pos
179+ Space.checkIndent end E.TupleIndentEnd
176− tupleHelp start firstExpr (entry : revExprs)
180+ chompTupleEnd start firstExpr (entry : revExprs)
177− , do word1 0x29 {-)-} E.XXX
181+ , do word1 0x29 {-)-} E.TupleEnd
178− end <- getPosition
179 case reverse revExprs of
182 case reverse revExprs of
180 [] ->
183 [] ->
181 return firstExpr
184 return firstExpr
182
185
183− secondExpr : others ->
186+ secondExpr : otherExprs ->
184− return (A.at start end (Src.Tuple firstExpr secondExpr others))
187+ addEnd start (Src.Tuple firstExpr secondExpr otherExprs)
185 ]
188 ]
186
189
187
190
@@ -189,30 +192,27 @@ tupleHelp start firstExpr revExprs =
189-- RECORDS
192-- RECORDS
190
193
191
194
192−record :: A.Position -> Parser Src.Expr
195+record :: A.Position -> Parser E.Expr Src.Expr
193record start =
196record start =
194− inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $
197+ inContext E.Record (word1 0x7B {- { -} E.Start) $
195− do spaces
198+ do Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen
196− oneOf E.XXX
199+ oneOf E.RecordOpen
197− [ do word1 0x7D {-}-} E.XXX
200+ [ do word1 0x7D {-}-} E.RecordOpen
198− end <- getPosition
199− return (A.at start end (Src.Record []))
201+ addEnd start (Src.Record [])
200− , do starter <- addLocation Var.lower
202+ , do starter <- addLocation (Var.lower E.RecordField)
201− spaces
203+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
202− oneOf E.XXX
204+ oneOf E.RecordEquals
203− [ do word1 0x7C {-|-} E.XXX
205+ [ do word1 0x7C {-|-} E.RecordEquals
204− spaces
206+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
205 firstField <- chompField
207 firstField <- chompField
206 fields <- chompFields [firstField]
208 fields <- chompFields [firstField]
207− end <- getPosition
208− return (A.at start end (Src.Update starter fields))
209+ addEnd start (Src.Update starter fields)
209− , do word1 0x3D {-=-} E.XXX
210+ , do word1 0x3D {-=-} E.RecordEquals
210− spaces
211+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
211− (value, _, nextPos) <- expression
212+ (value, end) <- specialize E.RecordExpr expression
212− checkSpace nextPos
213+ Space.checkIndent end E.RecordIndentEnd
213 fields <- chompFields [(starter, value)]
214 fields <- chompFields [(starter, value)]
214− end <- getPosition
215− return (A.at start end (Src.Record fields))
215+ addEnd start (Src.Record fields)
216 ]
216 ]
217 ]
217 ]
218
218
@@ -220,26 +220,26 @@ record start =
220type Field = ( A.Located Name.Name, Src.Expr )
220type Field = ( A.Located Name.Name, Src.Expr )
221
221
222
222
223−chompFields :: [Field] -> Parser [Field]
223+chompFields :: [Field] -> Parser E.Record [Field]
224chompFields fields =
224chompFields fields =
225− oneOf E.XXX
225+ oneOf E.RecordEnd
226− [ do word1 0x2C {-,-} E.XXX
226+ [ do word1 0x2C {-,-} E.RecordEnd
227− spaces
227+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
228 f <- chompField
228 f <- chompField
229 chompFields (f : fields)
229 chompFields (f : fields)
230− , do word1 0x7D {-}-} E.XXX
230+ , do word1 0x7D {-}-} E.RecordEnd
231 return (reverse fields)
231 return (reverse fields)
232 ]
232 ]
233
233
234
234
235−chompField :: Parser Field
235+chompField :: Parser E.Record Field
236chompField =
236chompField =
237− do key <- addLocation Var.lower
237+ do key <- addLocation (Var.lower E.RecordField)
238− spaces
238+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
239− word1 0x3D {-=-} E.XXX
239+ word1 0x3D {-=-} E.RecordEquals
240− spaces
240+ Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
241− (value, _, pos) <- expression
241+ (value, end) <- specialize E.RecordExpr expression
242− checkSpace pos
242+ Space.checkIndent end E.RecordIndentEnd
243 return (key, value)
243 return (key, value)
244
244
245
245
@@ -247,22 +247,18 @@ chompField =
247-- EXPRESSIONS
247-- EXPRESSIONS
248
248
249
249
250−type ExprParser =
250+expression :: Space.Parser E.Expr Src.Expr
251− SParser Src.Expr
252−
253−
254−expression :: ExprParser
255expression =
251expression =
256 do start <- getPosition
252 do start <- getPosition
257− oneOf E.XXX
253+ oneOf E.Start
258 [ let_ start
254 [ let_ start
259 , if_ start
255 , if_ start
260 , case_ start
256 , case_ start
261 , function start
257 , function start
262 , do expr <- possiblyNegativeTerm start
258 , do expr <- possiblyNegativeTerm start
263 end <- getPosition
259 end <- getPosition
264− space <- whitespace
260+ Space.chomp E.Space
265− exprHelp start (State [] expr [] end space)
261+ chompExprEnd start (State [] expr [] end)
266 ]
262 ]
267
263
268
264
@@ -272,77 +268,77 @@ data State =
272 , _expr :: !Src.Expr
268 , _expr :: !Src.Expr
273 , _args :: ![Src.Expr]
269 , _args :: ![Src.Expr]
274 , _end :: !A.Position
270 , _end :: !A.Position
275− , _pos :: !SPos
276 }
271 }
277
272
278
273
279−exprHelp :: A.Position -> State -> ExprParser
274+chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr
280−exprHelp start (State ops expr args end pos) =
275+chompExprEnd start (State ops expr args end) =
281− oneOf E.XXX
276+ oneOfWithFallback
282 [ -- argument
277 [ -- argument
283− do checkSpace pos
278+ do Space.checkIndent end E.Start
284 arg <- term
279 arg <- term
285 newEnd <- getPosition
280 newEnd <- getPosition
286− newPos <- whitespace
281+ Space.chomp E.Space
287− exprHelp start (State ops expr (arg:args) newEnd newPos)
282+ chompExprEnd start (State ops expr (arg:args) newEnd)
288−
283+
289− , -- infix operator
284+ , -- operator
290− do checkSpace pos
285+ do Space.checkIndent end E.Start
291− opStart <- getPosition
292− opName <- Symbol.binop
293− opEnd <- getPosition
294− let op = A.at opStart opEnd opName
286+ op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)
295− spos <- whitespace
287+ Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)
296− checkSpace spos
297 newStart <- getPosition
288 newStart <- getPosition
298 if "-" == opName && end /= opStart && opEnd == newStart
289 if "-" == opName && end /= opStart && opEnd == newStart
299 then
290 then
300 -- negative terms
291 -- negative terms
301− do rawTerm <- term
292+ do negatedExpr <- term
302 newEnd <- getPosition
293 newEnd <- getPosition
303− newPos <- whitespace
294+ Space.chomp E.Space
304− let arg = A.at opStart newEnd (Src.Negate rawTerm)
295+ let arg = A.at opStart newEnd (Src.Negate negatedExpr)
305− exprHelp start (State ops expr (arg:args) newEnd newPos)
296+ chompExprEnd start (State ops expr (arg:args) newEnd)
306 else
297 else
307− oneOf E.XXX
298+ let err = E.OperatorRight opName in
299+ oneOf err
308 [ -- term
300 [ -- term
309 do newExpr <- possiblyNegativeTerm newStart
301 do newExpr <- possiblyNegativeTerm newStart
310 newEnd <- getPosition
302 newEnd <- getPosition
311− newPos <- whitespace
303+ Space.chomp E.Space
312 let newOps = (toCall expr args, op) : ops
304 let newOps = (toCall expr args, op) : ops
313− exprHelp start (State newOps newExpr [] newEnd newPos)
305+ chompExprEnd start (State newOps newExpr [] newEnd)
314
306
315 , -- final term
307 , -- final term
316− do (newLast, newEnd, newPos) <-
308+ do (newLast, newEnd) <-
317− oneOf E.XXX
309+ oneOf err
318 [ let_ newStart
310 [ let_ newStart
319 , case_ newStart
311 , case_ newStart
320 , if_ newStart
312 , if_ newStart
321 , function newStart
313 , function newStart
322 ]
314 ]
323 let newOps = (toCall expr args, op) : ops
315 let newOps = (toCall expr args, op) : ops
324− let finalExpr = A.at start newEnd (Src.Binops (reverse newOps) newLast)
316+ let finalExpr = Src.Binops (reverse newOps) newLast
325− return ( finalExpr, newEnd, newPos )
317+ return ( A.at start newEnd finalExpr, newEnd )
326 ]
318 ]
327
319
320+ ]
328− , -- done
321+ -- done
329− let finalExpr = toCall expr args in
322+ (
330 case ops of
323 case ops of
331 [] ->
324 [] ->
332− return ( finalExpr, end, pos )
325+ ( toCall expr args
326+ , end
327+ )
333
328
334 _ ->
329 _ ->
335− return ( A.at start end (Src.Binops (reverse ops) finalExpr), end, pos )
330+ ( A.at start end (Src.Binops (reverse ops) (toCall expr args))
336− ]
331+ , end
332+ )
333+ )
337
334
338
335
339−possiblyNegativeTerm :: A.Position -> Parser Src.Expr
336+possiblyNegativeTerm :: A.Position -> Parser E.Expr Src.Expr
340possiblyNegativeTerm start =
337possiblyNegativeTerm start =
341− oneOf E.XXX
338+ oneOf E.Start
342− [ do word1 0x2D {---} E.XXX
339+ [ do word1 0x2D {---} E.Start
343 expr <- term
340 expr <- term
344− end <- getPosition
345− return (A.at start end (Src.Negate expr))
341+ addEnd start (Src.Negate expr)
346 , term
342 , term
347 ]
343 ]
348
344
@@ -361,30 +357,32 @@ toCall func revArgs =
361-- IF EXPRESSION
357-- IF EXPRESSION
362
358
363
359
364−if_ :: A.Position -> ExprParser
360+if_ :: A.Position -> Space.Parser E.Expr Src.Expr
365if_ start =
361if_ start =
366− inContext E.ExprIf Keyword.if_ $
362+ inContext E.If (Keyword.if_ E.Start) $
367− ifHelp start []
363+ chompIfEnd start []
368−
364+
369−
365+
370−ifHelp :: A.Position -> [(Src.Expr, Src.Expr)] -> ExprParser
366+chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr
371−ifHelp start branches =
367+chompIfEnd start branches =
372− do spaces
368+ do Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition
373− (condition, _, condPos) <- expression
369+ (condition, condEnd) <- specialize E.IfCondition expression
374− checkSpace condPos
370+ Space.checkIndent condEnd E.IfIndentThen
375− Keyword.then_
371+ Keyword.then_ E.IfThen
376− spaces
372+ Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch
377− (thenBranch, _, thenPos) <- expression
373+ (thenBranch, thenEnd) <- specialize E.IfThenBranch expression
378− checkSpace thenPos
374+ Space.checkIndent thenEnd E.IfIndentElse
379− Keyword.else_
375+ Keyword.else_ E.IfElse
380− spaces
376+ Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch
381 let newBranches = (condition, thenBranch) : branches
377 let newBranches = (condition, thenBranch) : branches
382− oneOf E.XXX
378+ oneOf E.IfElseBranchStart
379+ [
383− [ do Keyword.if_
380+ do Keyword.if_ E.IfElseBranchStart
384− ifHelp start newBranches
381+ chompIfEnd start newBranches
382+ ,
385− , do (elseBranch, elseEnd, elseSpace) <- expression
383+ do (elseBranch, elseEnd) <- specialize E.IfElseBranch expression
386− let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)
384+ let ifExpr = Src.If (reverse newBranches) elseBranch
387− return ( ifExpr, elseEnd, elseSpace )
385+ return ( A.at start elseEnd ifExpr, elseEnd )
388 ]
386 ]
389
387
390
388
@@ -392,27 +390,27 @@ ifHelp start branches =
392-- LAMBDA EXPRESSION
390-- LAMBDA EXPRESSION
393
391
394
392
395−function :: A.Position -> ExprParser
393+function :: A.Position -> Space.Parser E.Expr Src.Expr
396function start =
394function start =
397− inContext E.ExprFunc (word1 0x5C {-\-} E.XXX) $
395+ inContext E.Func (word1 0x5C {-\-} E.Start) $
398− do spaces
396+ do Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg
399− arg <- Pattern.term
397+ arg <- specialize E.FuncArg Pattern.term
400− spaces
398+ Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
401− revArgs <- gatherArgs [arg]
399+ revArgs <- chompArgs [arg]
402− spaces
400+ Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody
403− (body, end, space) <- expression
401+ (body, end) <- specialize E.FuncBody expression
404− let func = A.at start end (Src.Lambda (reverse revArgs) body)
402+ let funcExpr = Src.Lambda (reverse revArgs) body
405− return ( func, end, space )
403+ return (A.at start end funcExpr, end)
406−
404+
407−
405+
408−gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]
406+chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern]
409−gatherArgs args =
407+chompArgs revArgs =
410− oneOf E.XXX
408+ oneOf E.FuncArrow
411− [ do arg <- Pattern.term
409+ [ do arg <- specialize E.FuncArg Pattern.term
412− spaces
410+ Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow
413− gatherArgs (arg:args)
411+ chompArgs (arg:revArgs)
414− , do word2 0x2D 0x3E {-->-} E.XXX
412+ , do word2 0x2D 0x3E {-->-} E.FuncArrow
415− return args
413+ return revArgs
416 ]
414 ]
417
415
418
416
@@ -420,90 +418,84 @@ gatherArgs args =
420-- CASE EXPRESSIONS
418-- CASE EXPRESSIONS
421
419
422
420
423−case_ :: A.Position -> ExprParser
421+case_ :: A.Position -> Space.Parser E.Expr Src.Expr
424case_ start =
422case_ start =
425− inContext E.ExprCase Keyword.case_ $
423+ inContext E.Case (Keyword.case_ E.Start) $
426− do spaces
424+ do Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr
427− (switcher, _, switcherPos) <- expression
425+ (expr, exprEnd) <- specialize E.CaseExpr expression
428− checkSpace switcherPos
426+ Space.checkIndent exprEnd E.CaseIndentOf
429− Keyword.of_
427+ Keyword.of_ E.CaseOf
430− spaces
428+ Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern
431− oldIndent <- getIndent
429+ withIndent $
432− newIndent <- getCol
433− setIndent newIndent
434− (firstBranch, firstEnd, firstPos) <- branchHelp
430+ do (firstBranch, firstEnd) <- chompBranch
435− (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos
431+ (branches, end) <- chompCaseEnd [firstBranch] firstEnd
436− setIndent oldIndent
437− return
432+ return
438− ( A.at start end (Src.Case switcher branches)
433+ ( A.at start end (Src.Case expr branches)
439− , end
434+ , end
440− , pos
441− )
435+ )
442−
436+
443−
437+
444−branchHelp :: SParser (Src.Pattern, Src.Expr)
438+chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr)
445−branchHelp =
439+chompBranch =
446− do (pattern, patternPos) <- Pattern.expression
440+ do (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression
447− checkSpace patternPos
441+ Space.checkIndent patternEnd E.CaseIndentArrow
448− word2 0x2D 0x3E {-->-} E.XXX
442+ word2 0x2D 0x3E {-->-} E.CaseArrow
449− spaces
443+ Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch
450− (branchExpr, end, pos) <- expression
444+ (branchExpr, end) <- specialize E.CaseBranch expression
451− return ( (pattern, branchExpr), end, pos )
445+ return ( (pattern, branchExpr), end )
452−
446+
453−
447+
454−caseHelp :: [(Src.Pattern, Src.Expr)] -> A.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]
448+chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)]
455−caseHelp branches end pos =
449+chompCaseEnd branches end =
456− oneOf E.XXX
450+ oneOfWithFallback
457− [ do checkAligned pos
451+ [ do Space.checkAligned E.CasePatternAlignment
458− (branch, newEnd, newPos) <- branchHelp
452+ (branch, newEnd) <- chompBranch
459− caseHelp (branch:branches) newEnd newPos
453+ chompCaseEnd (branch:branches) newEnd
460− , return ( reverse branches, end, pos )
461 ]
454 ]
455+ (reverse branches, end)
462
456
463
457
464
458
465-- LET EXPRESSION
459-- LET EXPRESSION
466
460
467
461
468−let_ :: A.Position -> ExprParser
462+let_ :: A.Position -> Space.Parser E.Expr Src.Expr
469let_ start =
463let_ start =
470− do oldIndent <- getIndent
471− letIndent <- getCol
472− Keyword.let_
464+ inContext E.Let (Keyword.let_ E.Start) $
473− pushContext start E.ExprLet
465+ do (defs, defsEnd) <-
474− setIndent letIndent
466+ withBacksetIndent 3 $
475− spaces
467+ do Space.chompAndCheckIndent E.LetSpace E.LetIndentDef
476− defIndent <- getCol
468+ withIndent $
477− setIndent defIndent
469+ do (def, end) <- chompLetDef
478− (def, end, space) <- letDef
470+ chompLetDefs [def] end
479− letHelp start oldIndent [def] end space
471+
480−
472+ Space.checkIndent defsEnd E.LetIndentIn
481−
482−letHelp :: A.Position -> Word16 -> [A.Located Src.Def] -> A.Position -> SPos -> ExprParser
483−letHelp start oldIndent revDefs end pos =
484− oneOf E.XXX
485− [ do checkAligned pos
486− (def, newEnd, newPos) <- letDef
487− letHelp start oldIndent (def:revDefs) newEnd newPos
488−
489− , do setIndent oldIndent
490− checkSpace pos
491− Keyword.in_
473+ Keyword.in_ E.LetIn
492− popContext ()
474+ Space.chompAndCheckIndent E.LetSpace E.LetIndentBody
493− spaces
494− (body, newEnd, newPos) <- expression
475+ (body, end) <- specialize E.LetBody expression
476+ return
495− let letExpr = A.at start end (Src.Let (reverse revDefs) body)
477+ ( A.at start end (Src.Let defs body)
496− return ( letExpr, newEnd, newPos )
478+ , end
479+ )
480+
481+
482+chompLetDefs :: [A.Located Src.Def] -> A.Position -> Space.Parser E.Let [A.Located Src.Def]
483+chompLetDefs revDefs end =
484+ oneOfWithFallback
485+ [ do Space.checkAligned E.LetDefAlignment
486+ (def, newEnd) <- chompLetDef
487+ chompLetDefs (def:revDefs) newEnd
497 ]
488 ]
489+ (reverse revDefs, end)
498
490
499
491
500
492
501-- LET DEFINITIONS
493-- LET DEFINITIONS
502
494
503
495
504−letDef :: SParser (A.Located Src.Def)
496+chompLetDef :: Space.Parser E.Let (A.Located Src.Def)
505−letDef =
497+chompLetDef =
506− oneOf E.XXX
498+ oneOf E.LetDefName
507 [ definition
499 [ definition
508 , destructure
500 , destructure
509 ]
501 ]
@@ -513,61 +505,57 @@ letDef =
513-- DEFINITION
505-- DEFINITION
514
506
515
507
516−definition :: SParser (A.Located Src.Def)
508+definition :: Space.Parser E.Let (A.Located Src.Def)
517definition =
509definition =
518− do start <- getPosition
510+ do aname@(A.At (A.Region start _) name) <- addLocation (Var.lower E.LetDefName)
519− name <- Var.lower
511+ specialize (E.LetDef name) $
520− end <- getPosition
512+ do Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
521− spaces
522− oneOf E.XXX
513+ oneOf E.DefEquals
523− [
514+ [
524− do word1 0x3A {-:-} E.XXX
515+ do word1 0x3A {-:-} E.DefEquals
525− pushContext start (E.Annotation name)
516+ Space.chompAndCheckIndent E.DefSpace E.DefIndentType
526− spaces
527− (tipe, _, space) <- Type.expression
517+ (tipe, _) <- specialize E.DefType Type.expression
528− popContext ()
529− checkAligned space
518+ Space.checkAligned E.DefAlignment
530− defName <- matchingName name
519+ defName <- chompMatchingName name
531− let (A.At (A.Region defStart _) _) = defName
520+ Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
532− pushContext defStart (E.Definition name)
533− spaces
534− def <- definitionHelp start defName (Just tipe) []
521+ chompDefArgsAndBody start defName (Just tipe) []
535− popContext def
536− ,
522+ ,
537− do pushContext start (E.Definition name)
523+ chompDefArgsAndBody start aname Nothing []
538− def <- definitionHelp start (A.at start end name) Nothing []
539− popContext def
540− ]
524+ ]
541−
525+
542−
526+
543−definitionHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser (A.Located Src.Def)
527+chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.Def (A.Located Src.Def)
544−definitionHelp start name tipe revArgs =
528+chompDefArgsAndBody start name tipe revArgs =
545− oneOf E.XXX
529+ oneOf E.DefEquals
546− [ do arg <- Pattern.term
530+ [ do arg <- specialize E.DefArg Pattern.term
547− spaces
531+ Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals
548− definitionHelp start name tipe (arg : revArgs)
532+ chompDefArgsAndBody start name tipe (arg : revArgs)
549− , do word1 0x3D {-=-} E.XXX
533+ , do word1 0x3D {-=-} E.DefEquals
550− spaces
534+ Space.chompAndCheckIndent E.DefSpace E.DefIndentBody
551− (body, end, space) <- expression
535+ (body, end) <- specialize E.DefBody expression
536+ return
552− let def = A.at start end (Src.Define name (reverse revArgs) body tipe)
537+ ( A.at start end (Src.Define name (reverse revArgs) body tipe)
553− return ( def, end, space )
538+ , end
539+ )
554 ]
540 ]
555
541
556
542
557−matchingName :: Name.Name -> Parser (A.Located Name.Name)
543+chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)
558−matchingName expectedName =
544+chompMatchingName expectedName =
545+ let
559− let (P.Parser parserL) = Var.lower in
546+ (P.Parser parserL) = Var.lower E.DefNameRepeat
547+ in
560− P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
548+ P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
561 let
549 let
562− cokL name newState@(P.State _ _ _ er ec _) =
550+ cokL name newState@(P.State _ _ _ _ er ec) =
563 if expectedName == name
551 if expectedName == name
564 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
552 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
565− else cerr sr sc ctx (E.MatchingName expectedName)
553+ else cerr sr sc (E.DefNameMatch name)
566
554
567− eokL name newState@(P.State _ _ _ er ec _) =
555+ eokL name newState@(P.State _ _ _ _ er ec) =
568 if expectedName == name
556 if expectedName == name
569 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
557 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
570− else eerr sr sc ctx (E.MatchingName expectedName)
558+ else eerr sr sc (E.DefNameMatch name)
571 in
559 in
572 parserL state cokL eokL cerr eerr
560 parserL state cokL eokL cerr eerr
573
561
@@ -577,12 +565,13 @@ matchingName expectedName =
577-- DESTRUCTURE
565-- DESTRUCTURE
578
566
579
567
580−destructure :: SParser (A.Located Src.Def)
568+destructure :: Space.Parser E.Let (A.Located Src.Def)
581destructure =
569destructure =
570+ specialize E.LetDestruct $
582 do start <- getPosition
571 do start <- getPosition
583− pattern <- Pattern.term
572+ pattern <- specialize E.DestructPattern Pattern.term
584− spaces
573+ Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals
585− word1 0x3D {-=-} E.XXX
574+ word1 0x3D {-=-} E.DestructEquals
586− spaces
575+ Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody
587− (expr, end, space) <- expression
576+ (expr, end) <- specialize E.DestructBody expression
588− return ( A.at start end (Src.Destruct pattern expr), end, space )
577+ return ( A.at start end (Src.Destruct pattern expr), end )
compiler/src/Parse/Keyword.hs+83−84
@@ -16,112 +16,111 @@ module Parse.Keyword
16import Foreign.Ptr (plusPtr)
16import Foreign.Ptr (plusPtr)
17import Data.Word (Word8)
17import Data.Word (Word8)
18
18
19−import Parse.Utils (Parser)
19+import 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
22−import qualified Reporting.Error.Syntax as E
23
22
24
23
25
24
26-- DECLARATIONS
25-- DECLARATIONS
27
26
28
27
29−type_ :: Parser ()
28+type_ :: (Row -> Col -> x) -> Parser x ()
30−type_ = k4 0x74 0x79 0x70 0x65 E.KeywordType
29+type_ tx = k4 0x74 0x79 0x70 0x65 tx
31
30
32−alias_ :: Parser ()
31+alias_ :: (Row -> Col -> x) -> Parser x ()
33−alias_ = k5 0x61 0x6C 0x69 0x61 0x73 E.KeywordAlias
32+alias_ tx = k5 0x61 0x6C 0x69 0x61 0x73 tx
34
33
35−port_ :: Parser ()
34+port_ :: (Row -> Col -> x) -> Parser x ()
36−port_ = k4 0x70 0x6F 0x72 0x74 E.KeywordPort
35+port_ tx = k4 0x70 0x6F 0x72 0x74 tx
37
36
38
37
39
38
40-- IF EXPRESSIONS
39-- IF EXPRESSIONS
41
40
42
41
43−if_ :: Parser ()
42+if_ :: (Row -> Col -> x) -> Parser x ()
44−if_ = k2 0x69 0x66 E.KeywordIf
43+if_ tx = k2 0x69 0x66 tx
45
44
46−then_ :: Parser ()
45+then_ :: (Row -> Col -> x) -> Parser x ()
47−then_ = k4 0x74 0x68 0x65 0x6E E.KeywordThen
46+then_ tx = k4 0x74 0x68 0x65 0x6E tx
48
47
49−else_ :: Parser ()
48+else_ :: (Row -> Col -> x) -> Parser x ()
50−else_ = k4 0x65 0x6C 0x73 0x65 E.KeywordElse
49+else_ tx = k4 0x65 0x6C 0x73 0x65 tx
51
50
52
51
53
52
54-- CASE EXPRESSIONS
53-- CASE EXPRESSIONS
55
54
56
55
57−case_ :: Parser ()
56+case_ :: (Row -> Col -> x) -> Parser x ()
58−case_ = k4 0x63 0x61 0x73 0x65 E.KeywordCase
57+case_ tx = k4 0x63 0x61 0x73 0x65 tx
59
58
60−of_ :: Parser ()
59+of_ :: (Row -> Col -> x) -> Parser x ()
61−of_ = k2 0x6F 0x66 E.KeywordOf
60+of_ tx = k2 0x6F 0x66 tx
62
61
63
62
64
63
65-- LET EXPRESSIONS
64-- LET EXPRESSIONS
66
65
67
66
68−let_ :: Parser ()
67+let_ :: (Row -> Col -> x) -> Parser x ()
69−let_ = k3 0x6C 0x65 0x74 E.KeywordLet
68+let_ tx = k3 0x6C 0x65 0x74 tx
70
69
71−in_ :: Parser ()
70+in_ :: (Row -> Col -> x) -> Parser x ()
72−in_ = k2 0x69 0x6E E.KeywordIn
71+in_ tx = k2 0x69 0x6E tx
73
72
74
73
75
74
76-- INFIXES
75-- INFIXES
77
76
78
77
79−infix_ :: Parser ()
78+infix_ :: (Row -> Col -> x) -> Parser x ()
80−infix_ = k5 0x69 0x6E 0x66 0x69 0x78 E.KeywordInfix
79+infix_ tx = k5 0x69 0x6E 0x66 0x69 0x78 tx
81
80
82−left_ :: Parser ()
81+left_ :: (Row -> Col -> x) -> Parser x ()
83−left_ = k4 0x6C 0x65 0x66 0x74 E.Associativity
82+left_ tx = k4 0x6C 0x65 0x66 0x74 tx
84
83
85−right_ :: Parser ()
84+right_ :: (Row -> Col -> x) -> Parser x ()
86−right_ = k5 0x72 0x69 0x67 0x68 0x74 E.Associativity
85+right_ tx = k5 0x72 0x69 0x67 0x68 0x74 tx
87
86
88−non_ :: Parser ()
87+non_ :: (Row -> Col -> x) -> Parser x ()
89−non_ = k3 0x6E 0x6F 0x6E E.Associativity
88+non_ tx = k3 0x6E 0x6F 0x6E tx
90
89
91
90
92
91
93-- IMPORTS
92-- IMPORTS
94
93
95
94
96−module_ :: Parser ()
95+module_ :: (Row -> Col -> x) -> Parser x ()
97−module_ = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 E.KeywordModule
96+module_ tx = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 tx
98
97
99−import_ :: Parser ()
98+import_ :: (Row -> Col -> x) -> Parser x ()
100−import_ = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 E.KeywordImport
99+import_ tx = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 tx
101
100
102−exposing_ :: Parser ()
101+exposing_ :: (Row -> Col -> x) -> Parser x ()
103−exposing_ = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 E.KeywordExposing
102+exposing_ tx = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 tx
104
103
105−as_ :: Parser ()
104+as_ :: (Row -> Col -> x) -> Parser x ()
106−as_ = k2 0x61 0x73 E.KeywordAs
105+as_ tx = k2 0x61 0x73 tx
107
106
108
107
109
108
110-- EFFECTS
109-- EFFECTS
111
110
112
111
113−effect_ :: Parser ()
112+effect_ :: (Row -> Col -> x) -> Parser x ()
114−effect_ = k6 0x65 0x66 0x66 0x65 0x63 0x74 E.EffectStuff
113+effect_ tx = k6 0x65 0x66 0x66 0x65 0x63 0x74 tx
115
114
116−where_ :: Parser ()
115+where_ :: (Row -> Col -> x) -> Parser x ()
117−where_ = k5 0x77 0x68 0x65 0x72 0x65 E.EffectStuff
116+where_ tx = k5 0x77 0x68 0x65 0x72 0x65 tx
118
117
119−command_ :: Parser ()
118+command_ :: (Row -> Col -> x) -> Parser x ()
120−command_ = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 E.EffectStuff
119+command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx
121
120
122−subscription_ :: Parser ()
121+subscription_ :: (Row -> Col -> x) -> Parser x ()
123−subscription_ =
122+subscription_ toError =
124− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
123+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
125 let !pos12 = plusPtr pos 12 in
124 let !pos12 = plusPtr pos 12 in
126 if pos12 <= end
125 if pos12 <= end
127 && P.unsafeIndex ( pos ) == 0x73
126 && P.unsafeIndex ( pos ) == 0x73
@@ -138,32 +137,32 @@ subscription_ =
138 && P.unsafeIndex (plusPtr pos 11) == 0x6E
137 && P.unsafeIndex (plusPtr pos 11) == 0x6E
139 && Var.getInnerWidth pos12 end == 0
138 && Var.getInnerWidth pos12 end == 0
140 then
139 then
141− let !s = P.State pos12 end indent row (col + 12) ctx in cok () s
140+ let !s = P.State src pos12 end indent row (col + 12) in cok () s
142 else
141 else
143− eerr row col ctx E.EffectStuff
142+ eerr row col toError
144
143
145
144
146
145
147-- KEYWORDS
146-- KEYWORDS
148
147
149
148
150−k2 :: Word8 -> Word8 -> x -> P.Parser c x ()
149+k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
151−k2 w1 w2 x =
150+k2 w1 w2 toError =
152− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
151+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
153 let !pos2 = plusPtr pos 2 in
152 let !pos2 = plusPtr pos 2 in
154 if pos2 <= end
153 if pos2 <= end
155 && P.unsafeIndex ( pos ) == w1
154 && P.unsafeIndex ( pos ) == w1
156 && P.unsafeIndex (plusPtr pos 1) == w2
155 && P.unsafeIndex (plusPtr pos 1) == w2
157 && Var.getInnerWidth pos2 end == 0
156 && Var.getInnerWidth pos2 end == 0
158 then
157 then
159− let !s = P.State pos2 end indent row (col + 2) ctx in cok () s
158+ let !s = P.State src pos2 end indent row (col + 2) in cok () s
160 else
159 else
161− eerr row col ctx x
160+ eerr row col toError
162
161
163
162
164−k3 :: Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
163+k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
165−k3 w1 w2 w3 x =
164+k3 w1 w2 w3 toError =
166− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
165+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
167 let !pos3 = plusPtr pos 3 in
166 let !pos3 = plusPtr pos 3 in
168 if pos3 <= end
167 if pos3 <= end
169 && P.unsafeIndex ( pos ) == w1
168 && P.unsafeIndex ( pos ) == w1
@@ -171,14 +170,14 @@ k3 w1 w2 w3 x =
171 && P.unsafeIndex (plusPtr pos 2) == w3
170 && P.unsafeIndex (plusPtr pos 2) == w3
172 && Var.getInnerWidth pos3 end == 0
171 && Var.getInnerWidth pos3 end == 0
173 then
172 then
174− let !s = P.State pos3 end indent row (col + 3) ctx in cok () s
173+ let !s = P.State src pos3 end indent row (col + 3) in cok () s
175 else
174 else
176− eerr row col ctx x
175+ eerr row col toError
177
176
178
177
179−k4 :: Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
178+k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
180−k4 w1 w2 w3 w4 x =
179+k4 w1 w2 w3 w4 toError =
181− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
180+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
182 let !pos4 = plusPtr pos 4 in
181 let !pos4 = plusPtr pos 4 in
183 if pos4 <= end
182 if pos4 <= end
184 && P.unsafeIndex ( pos ) == w1
183 && P.unsafeIndex ( pos ) == w1
@@ -187,14 +186,14 @@ k4 w1 w2 w3 w4 x =
187 && P.unsafeIndex (plusPtr pos 3) == w4
186 && P.unsafeIndex (plusPtr pos 3) == w4
188 && Var.getInnerWidth pos4 end == 0
187 && Var.getInnerWidth pos4 end == 0
189 then
188 then
190− let !s = P.State pos4 end indent row (col + 4) ctx in cok () s
189+ let !s = P.State src pos4 end indent row (col + 4) in cok () s
191 else
190 else
192− eerr row col ctx x
191+ eerr row col toError
193
192
194
193
195−k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
194+k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
196−k5 w1 w2 w3 w4 w5 x =
195+k5 w1 w2 w3 w4 w5 toError =
197− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
196+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
198 let !pos5 = plusPtr pos 5 in
197 let !pos5 = plusPtr pos 5 in
199 if pos5 <= end
198 if pos5 <= end
200 && P.unsafeIndex ( pos ) == w1
199 && P.unsafeIndex ( pos ) == w1
@@ -204,14 +203,14 @@ k5 w1 w2 w3 w4 w5 x =
204 && P.unsafeIndex (plusPtr pos 4) == w5
203 && P.unsafeIndex (plusPtr pos 4) == w5
205 && Var.getInnerWidth pos5 end == 0
204 && Var.getInnerWidth pos5 end == 0
206 then
205 then
207− let !s = P.State pos5 end indent row (col + 5) ctx in cok () s
206+ let !s = P.State src pos5 end indent row (col + 5) in cok () s
208 else
207 else
209− eerr row col ctx x
208+ eerr row col toError
210
209
211
210
212−k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
211+k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
213−k6 w1 w2 w3 w4 w5 w6 x =
212+k6 w1 w2 w3 w4 w5 w6 toError =
214− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
213+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
215 let !pos6 = plusPtr pos 6 in
214 let !pos6 = plusPtr pos 6 in
216 if pos6 <= end
215 if pos6 <= end
217 && P.unsafeIndex ( pos ) == w1
216 && P.unsafeIndex ( pos ) == w1
@@ -222,14 +221,14 @@ k6 w1 w2 w3 w4 w5 w6 x =
222 && P.unsafeIndex (plusPtr pos 5) == w6
221 && P.unsafeIndex (plusPtr pos 5) == w6
223 && Var.getInnerWidth pos6 end == 0
222 && Var.getInnerWidth pos6 end == 0
224 then
223 then
225− let !s = P.State pos6 end indent row (col + 6) ctx in cok () s
224+ let !s = P.State src pos6 end indent row (col + 6) in cok () s
226 else
225 else
227− eerr row col ctx x
226+ eerr row col toError
228
227
229
228
230−k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
229+k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
231−k7 w1 w2 w3 w4 w5 w6 w7 x =
230+k7 w1 w2 w3 w4 w5 w6 w7 toError =
232− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
231+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
233 let !pos7 = plusPtr pos 7 in
232 let !pos7 = plusPtr pos 7 in
234 if pos7 <= end
233 if pos7 <= end
235 && P.unsafeIndex ( pos ) == w1
234 && P.unsafeIndex ( pos ) == w1
@@ -241,14 +240,14 @@ k7 w1 w2 w3 w4 w5 w6 w7 x =
241 && P.unsafeIndex (plusPtr pos 6) == w7
240 && P.unsafeIndex (plusPtr pos 6) == w7
242 && Var.getInnerWidth pos7 end == 0
241 && Var.getInnerWidth pos7 end == 0
243 then
242 then
244− let !s = P.State pos7 end indent row (col + 7) ctx in cok () s
243+ let !s = P.State src pos7 end indent row (col + 7) in cok () s
245 else
244 else
246− eerr row col ctx x
245+ eerr row col toError
247
246
248
247
249−k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()
248+k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()
250−k8 w1 w2 w3 w4 w5 w6 w7 w8 x =
249+k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =
251− P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
250+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->
252 let !pos8 = plusPtr pos 8 in
251 let !pos8 = plusPtr pos 8 in
253 if pos8 <= end
252 if pos8 <= end
254 && P.unsafeIndex ( pos ) == w1
253 && P.unsafeIndex ( pos ) == w1
@@ -261,6 +260,6 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 x =
261 && P.unsafeIndex (plusPtr pos 7) == w8
260 && P.unsafeIndex (plusPtr pos 7) == w8
262 && Var.getInnerWidth pos8 end == 0
261 && Var.getInnerWidth pos8 end == 0
263 then
262 then
264− let !s = P.State pos8 end indent row (col + 8) ctx in cok () s
263+ let !s = P.State src pos8 end indent row (col + 8) in cok () s
265 else
264 else
266− eerr row col ctx x
265+ eerr row col toError
compiler/src/Parse/Module.hs+330−259

This diff is too big to show here.

compiler/src/Parse/Number.hs+37−34

This diff is too big to show here.

compiler/src/Parse/Pattern.hs+138−130

This diff is too big to show here.

compiler/src/Parse/Primitives.hs+199−123

This diff is too big to show here.

compiler/src/Parse/Repl.hsdeleted−117

This diff is too big to show here.

compiler/src/Parse/Shader.hs+25−24

This diff is too big to show here.

compiler/src/Parse/Space.hsnew file+273

This diff is too big to show here.

compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hsrenamed+104−94

This diff is too big to show here.

compiler/src/Parse/Symbol.hs+22−37

This diff is too big to show here.

compiler/src/Parse/Type.hs+101−103

This diff is too big to show here.

compiler/src/Parse/Utils.hsdeleted−259

This diff is too big to show here.

compiler/src/Parse/Variable.hs+54−49

This diff is too big to show here.

compiler/src/Reporting/Annotation.hs+1−1

This diff is too big to show here.

compiler/src/Reporting/Doc.hs+96−54

This diff is too big to show here.

compiler/src/Reporting/Error.hs+175−22

This diff is too big to show here.

compiler/src/Reporting/Error/Canonicalize.hs+115−127

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hs+132−23

This diff is too big to show here.

compiler/src/Reporting/Error/Import.hsnew file+162

This diff is too big to show here.

compiler/src/Reporting/Error/Json.hs+280−270

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hs+6−6

This diff is too big to show here.

compiler/src/Reporting/Error/Pattern.hs+9−8

This diff is too big to show here.

compiler/src/Reporting/Error/Syntax.hs+5688−627

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+7−27

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

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

This diff is too big to show here.

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

The content is the same.

elm.cabal+69−98

This diff is too big to show here.

hints/bad-recursion.mdnew file+133

This diff is too big to show here.

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

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/implicit-casts.mdnew file+50

This diff is too big to show here.

hints/import-cycles.mdnew file+184

This diff is too big to show here.

hints/imports.mdnew file+126

This diff is too big to show here.

hints/infinite-type.mdnew file+42

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.mdnew file+139

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/port-modules.mdnew file+32

This diff is too big to show here.

hints/recursive-alias.mdnew file+162

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.mdnew file+70

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.mdnew file+60

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.xml+5−3

This diff is too big to show here.

installers/mac/README.mdnew file+93

This diff is too big to show here.

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

Binary file not shown.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/PUBLISHING.md+29−141

This diff is too big to show here.

installers/npm/README.md+30−23

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/index.jsdeleted−21

This diff is too big to show here.

installers/npm/install.jsnew file+4

This diff is too big to show here.

installers/npm/package.json+13−15

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+76

This diff is too big to show here.

installers/win/Nsisfile.nsi+16−16

This diff is too big to show here.

installers/win/README.md+18−3

This diff is too big to show here.

installers/win/file.icodeleted

Binary file not shown.

installers/win/inst.dat+1−2

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+1−2

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifdeleted

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+20−15

This diff is too big to show here.

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

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Bump.hs+158−8

This diff is too big to show here.

terminal/src/Develop.hs+70−77

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hs+348−6

This diff is too big to show here.

terminal/src/Init.hs+40−36

This diff is too big to show here.

terminal/src/Install.hs+401−14

This diff is too big to show here.

terminal/src/Main.hs+32−36

This diff is too big to show here.

terminal/src/Make.hs+257−32

This diff is too big to show here.

terminal/src/Publish.hs+529−8

This diff is too big to show here.

terminal/src/Repl.hs+522−197

This diff is too big to show here.

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

This diff is too big to show here.

worker/elm.cabalnew file+210

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hsnew file+73

This diff is too big to show here.