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

Binary file not shown.

LICENSE+25−6
@@ -1,11 +1,30 @@
1−Copyright 2012-present Evan Czaplicki
1+Copyright (c) 2012-present, Evan Czaplicki
2
2
3−Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
3+All rights reserved.
4
4
5−1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
6
7
8+ * Redistributions of source code must retain the above copyright
7−2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9+ notice, this list of conditions and the following disclaimer.
8
10
9−3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
10
15
11−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
16+ * Neither the name of Evan Czaplicki nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+5−10
@@ -1,22 +1,17 @@
1−# Elm
1+# The Elm Compiler
2
2
3−A delightful language for reliable webapps.
3+Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
4
4
5−Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6−
7−
8−<br>
9
5
10## Install
6## Install
11
7
12−✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
8+Follow [these instructions][installer]!
13
9
14−For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
10+ [installer]: https://guide.elm-lang.org/install.html
15
11
16−<br>
17
12
18## Help
13## Help
19
14
20If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
15If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
21
16
22−[slack]: http://elmlang.herokuapp.com/
17+[slack]: http://elmlang.herokuapp.com/
builder/src/BackgroundWriter.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module BackgroundWriter
3− ( Scope
4− , withScope
5− , writeBinary
6− )
7− where
8−
9−
10−import Control.Concurrent (forkIO)
11−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12−import qualified Data.Binary as Binary
13−import Data.Foldable (traverse_)
14−
15−import qualified File
16−
17−
18−
19−-- BACKGROUND WRITER
20−
21−
22−newtype Scope =
23− Scope (MVar [MVar ()])
24−
25−
26−withScope :: (Scope -> IO a) -> IO a
27−withScope callback =
28− do workList <- newMVar []
29− result <- callback (Scope workList)
30− mvars <- takeMVar workList
31− traverse_ takeMVar mvars
32− return result
33−
34−
35−writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36−writeBinary (Scope workList) path value =
37− do mvar <- newEmptyMVar
38− _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39− oldWork <- takeMVar workList
40− let !newWork = mvar:oldWork
41− putMVar workList newWork
42−
builder/src/Build.hsdeleted−1251
@@ -1,1251 +0,0 @@
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.hsdeleted−37
@@ -1,37 +0,0 @@
1−module Deps.Bump
2− ( getPossibilities
3− )
4− where
5−
6−
7−import qualified Data.List as List
8−
9−import qualified Deps.Registry as Registry
10−import qualified Elm.Magnitude as M
11−import qualified Elm.Version as V
12−
13−
14−
15−-- GET POSSIBILITIES
16−
17−
18−getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]
19−getPossibilities (Registry.KnownVersions latest previous) =
20− let
21− allVersions = reverse (latest:previous)
22− minorPoints = map last (List.groupBy sameMajor allVersions)
23− patchPoints = map last (List.groupBy sameMinor allVersions)
24− in
25− (latest, V.bumpMajor latest, M.MAJOR)
26− : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
27− ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
28−
29−
30−sameMajor :: V.Version -> V.Version -> Bool
31−sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =
32− major1 == major2
33−
34−
35−sameMinor :: V.Version -> V.Version -> Bool
36−sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =
37− major1 == major2 && minor1 == minor2
builder/src/Deps/Diff.hs+8−11
@@ -18,8 +18,7 @@ import qualified Data.List as List
18import qualified Data.Map as Map
18import qualified Data.Map as Map
19import qualified Data.Name as Name
19import qualified Data.Name as Name
20import qualified Data.Set as Set
20import qualified Data.Set as Set
21−import qualified System.Directory as Dir
21+import qualified Data.Utf8 as Utf8
22−import System.FilePath ((</>))
23
22
24import qualified Deps.Website as Website
23import qualified Deps.Website as Website
25import qualified Elm.Compiler.Type as Type
24import qualified Elm.Compiler.Type as Type
@@ -204,7 +203,7 @@ isSameName :: Name.Name -> Name.Name -> Bool
204isSameName oldFullName newFullName =
203isSameName oldFullName newFullName =
205 let
204 let
206 dedot name =
205 dedot name =
207− reverse (Name.splitDots name)
206+ reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))
208 in
207 in
209 case ( dedot oldFullName, dedot newFullName ) of
208 case ( dedot oldFullName, dedot newFullName ) of
210 (oldName:[], newName:_) ->
209 (oldName:[], newName:_) ->
@@ -357,13 +356,12 @@ changeMagnitude (Changes added changed removed) =
357
356
358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
357getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359getDocs cache manager name version =
358getDocs cache manager name version =
360− do let home = Stuff.package cache name version
359+ do let path = Stuff.metadata cache name version "docs.json"
361− let path = home </> "docs.json"
362 exists <- File.exists path
360 exists <- File.exists path
363 if exists
361 if exists
364 then
362 then
365− do bytes <- File.readUtf8 path
363+ do result <- D.fromFile Docs.decoder path
366− case D.fromByteString Docs.decoder bytes of
364+ case result of
367 Right docs ->
365 Right docs ->
368 return $ Right docs
366 return $ Right docs
369
367
@@ -372,12 +370,11 @@ getDocs cache manager name version =
372 return $ Left Exit.DP_Cache
370 return $ Left Exit.DP_Cache
373 else
371 else
374 do let url = Website.metadata name version "docs.json"
372 do let url = Website.metadata name version "docs.json"
375− Http.get manager url [] Exit.DP_Http $ \body ->
373+ Http.post manager url [] Exit.DP_Http $ \body ->
376 case D.fromByteString Docs.decoder body of
374 case D.fromByteString Docs.decoder body of
377 Right docs ->
375 Right docs ->
378− do Dir.createDirectoryIfMissing True home
379− File.writeUtf8 path body
376+ do File.writeUtf8 path body
380 return $ Right docs
377 return $ Right docs
381
378
382 Left _ ->
379 Left _ ->
383− return $ Left $ Exit.DP_Data url body
380+ return $ Left Exit.DP_Data
builder/src/Deps/Plan.hsnew file+64
@@ -0,0 +1,64 @@
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+73−40
@@ -16,8 +16,11 @@ module Deps.Registry
16import Prelude hiding (read)
16import Prelude hiding (read)
17import Control.Monad (liftM2)
17import Control.Monad (liftM2)
18import Data.Binary (Binary, get, put)
18import Data.Binary (Binary, get, put)
19+import Data.Function (on)
19import qualified Data.List as List
20import qualified Data.List as List
20import qualified Data.Map.Strict as Map
21import qualified Data.Map.Strict as Map
22+import qualified Data.Name as Name
23+import qualified Data.Utf8 as Utf8
21
24
22import qualified Deps.Website as Website
25import qualified Deps.Website as Website
23import qualified Elm.Package as Pkg
26import qualified Elm.Package as Pkg
@@ -25,8 +28,8 @@ import qualified Elm.Version as V
25import qualified File
28import qualified File
26import qualified Http
29import qualified Http
27import qualified Json.Decode as D
30import qualified Json.Decode as D
28−import qualified Parse.Primitives as P
31+import qualified Reporting.Exit as E
29−import qualified Reporting.Exit as Exit
32+import qualified Reporting.Suggest as Suggest
30import qualified Stuff
33import qualified Stuff
31
34
32
35
@@ -54,14 +57,18 @@ data KnownVersions =
54
57
55read :: Stuff.PackageCache -> IO (Maybe Registry)
58read :: Stuff.PackageCache -> IO (Maybe Registry)
56read cache =
59read cache =
57− File.readBinary (Stuff.registry cache)
60+ do let path = Stuff.registry cache
61+ exists <- File.exists path
62+ if exists
63+ then File.readBinary path
64+ else return Nothing
58
65
59
66
60
67
61-- FETCH
68-- FETCH
62
69
63
70
64−fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
71+fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
65fetch manager cache =
72fetch manager cache =
66 post manager "/all-packages" allPkgsDecoder $
73 post manager "/all-packages" allPkgsDecoder $
67 \versions ->
74 \versions ->
@@ -79,26 +86,33 @@ addEntry (KnownVersions _ vs) count =
79
86
80allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
87allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
81allPkgsDecoder =
88allPkgsDecoder =
82− let
89+ do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))
83− keyDecoder =
90+ checkKeys pairs Map.empty
84− Pkg.keyDecoder bail
91+ where
92+ checkKeys pairs pkgs =
93+ case pairs of
94+ [] ->
95+ return pkgs
85
96
86− versionsDecoder =
97+ (key, versions) : rest ->
87− D.list (D.mapError (\_ -> ()) V.decoder)
98+ case Pkg.fromString key of
99+ Right pkg ->
100+ case List.sortBy (flip compare) versions of
101+ [] ->
102+ D.failure ()
88
103
89− toKnownVersions versions =
104+ v:vs ->
90− case List.sortBy (flip compare) versions of
91− v:vs -> return (KnownVersions v vs)
105+ checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)
106+
107+ Left _ ->
92− [] -> D.failure ()
108+ D.failure ()
93− in
94− D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
95
109
96
110
97
111
98-- UPDATE
112-- UPDATE
99
113
100
114
101−update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
115+update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either E.RegistryProblem Registry)
102update manager cache oldRegistry@(Registry size packages) =
116update manager cache oldRegistry@(Registry size packages) =
103 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
117 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
104 \news ->
118 \news ->
@@ -130,33 +144,29 @@ addNew (name, version) versions =
130 Map.alter (Just . add) name versions
144 Map.alter (Just . add) name versions
131
145
132
146
133−
134−-- NEW PACKAGE DECODER
135−
136−
137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
147newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
138newPkgDecoder =
148newPkgDecoder =
139− D.customString newPkgParser bail
149+ do str <- D.string
140−
150+ case Utf8.split 0x40 {-@-} str of
151+ [key, value] ->
152+ case Pkg.fromString key of
153+ Right pkg ->
154+ case V.fromString value of
155+ Just vsn -> return (pkg, vsn)
156+ Nothing -> D.failure ()
141
157
142−newPkgParser :: P.Parser () (Pkg.Name, V.Version)
158+ Left _ ->
143−newPkgParser =
159+ D.failure ()
144− do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
145− P.word1 0x40 {-@-} bail
146− vsn <- P.specialize (\_ _ _ -> ()) V.parser
147− return (pkg, vsn)
148
160
149−
161+ _ ->
150−bail :: row -> col -> ()
162+ D.failure ()
151−bail _ _ =
152− ()
153
163
154
164
155
165
156-- LATEST
166-- LATEST
157
167
158
168
159−latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
169+latest :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)
160latest manager cache =
170latest manager cache =
161 do maybeOldRegistry <- read cache
171 do maybeOldRegistry <- read cache
162 case maybeOldRegistry of
172 case maybeOldRegistry of
@@ -180,23 +190,46 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
180getVersions' name (Registry _ versions) =
190getVersions' name (Registry _ versions) =
181 case Map.lookup name versions of
191 case Map.lookup name versions of
182 Just kvs -> Right kvs
192 Just kvs -> Right kvs
183− Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
193+ Nothing -> Left $ nearbyNames name (Map.keys versions)
194+
195+
196+nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]
197+nearbyNames (Pkg.Name author1 project1) possibleNames =
198+ let
199+ authorDist = authorDistance (Name.toChars author1)
200+ projectDist = projectDistance (Name.toChars project1)
201+
202+ addDistance name@(Pkg.Name author2 project2) =
203+ ( authorDist author2 + projectDist project2, name )
204+ in
205+ map snd $ take 4 $
206+ List.sortBy (compare `on` fst) $
207+ map addDistance possibleNames
208+
209+
210+authorDistance :: String -> Name.Name -> Int
211+authorDistance bad possibility =
212+ abs (Suggest.distance bad (Name.toChars possibility))
213+
214+
215+projectDistance :: String -> Name.Name -> Int
216+projectDistance bad possibility =
217+ if possibility == "elm" || possibility == "elm-explorations"
218+ then 0
219+ else abs (Suggest.distance bad (Name.toChars possibility))
184
220
185
221
186
222
187-- POST
223-- POST
188
224
189
225
190−post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
226+post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either E.RegistryProblem b)
191post manager path decoder callback =
227post manager path decoder callback =
192− let
193− url = Website.route path []
194− in
195− Http.post manager url [] Exit.RP_Http $
228+ Http.post manager (Website.route path []) [] E.RP_Http $
196 \body ->
229 \body ->
197 case D.fromByteString decoder body of
230 case D.fromByteString decoder body of
198 Right a -> Right <$> callback a
231 Right a -> Right <$> callback a
199− Left _ -> return $ Left $ Exit.RP_Data url body
232+ Left _ -> return $ Left E.RP_Data
200
233
201
234
202
235
builder/src/Deps/Solver.hs+121−243
@@ -1,27 +1,16 @@
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
1{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Deps.Solver
2module Deps.Solver
3 ( Solver
3 ( Solver
4− , Result(..)
5− , Connection(..)
6− --
7 , Details(..)
4 , Details(..)
8− , verify
5+ , Connection(..)
9− --
6+ , solve
10− , AppSolution(..)
11− , addToApp
12− --
13− , Env(..)
14− , initEnv
15 )
7 )
16 where
8 where
17
9
18
10
19import Control.Monad (foldM)
11import Control.Monad (foldM)
20−import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
21import qualified Data.Map as Map
12import qualified Data.Map as Map
22−import Data.Map ((!))
23import qualified System.Directory as Dir
13import qualified System.Directory as Dir
24−import System.FilePath ((</>))
25
14
26import qualified Deps.Registry as Registry
15import qualified Deps.Registry as Registry
27import qualified Deps.Website as Website
16import qualified Deps.Website as Website
@@ -32,7 +21,6 @@ import qualified Elm.Version as V
32import qualified File
21import qualified File
33import qualified Http
22import qualified Http
34import qualified Json.Decode as D
23import qualified Json.Decode as D
35−import qualified Reporting.Exit as Exit
36import qualified Stuff
24import qualified Stuff
37
25
38
26
@@ -47,7 +35,6 @@ newtype Solver a =
47 State
35 State
48 -> (State -> a -> (State -> IO b) -> IO b)
36 -> (State -> a -> (State -> IO b) -> IO b)
49 -> (State -> IO b)
37 -> (State -> IO b)
50− -> (Exit.Solver -> IO b)
51 -> IO b
38 -> IO b
52 )
39 )
53
40
@@ -55,9 +42,10 @@ newtype Solver a =
55data State =
42data State =
56 State
43 State
57 { _cache :: Stuff.PackageCache
44 { _cache :: Stuff.PackageCache
58− , _connection :: Connection
45+ , _internet :: Connection
59 , _registry :: Registry.Registry
46 , _registry :: Registry.Registry
60 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
47 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
48+ , _problems :: [Problem]
61 }
49 }
62
50
63
51
@@ -73,126 +61,46 @@ data Connection
73 | Offline
61 | Offline
74
62
75
63
64+data Problem
65+ = BadCacheData Pkg.Name V.Version
66+ | BadHttpData Pkg.Name V.Version
67+ | BadHttp Http.Error
68+ | UnknownPackage [Pkg.Name]
69+ | ImpossibleConstraint Pkg.Name C.Constraint
70+ | UnavailableOffline Pkg.Name V.Version
76
71
77−-- RESULT
78−
79−
80−data Result a
81− = Ok a
82− | NoSolution
83− | NoOfflineSolution
84− | Err Exit.Solver
85
72
86
73
87−
74+-- SOLVE
88−-- VERIFY -- used by Elm.Details
89
75
90
76
91data Details =
77data Details =
92− Details V.Version (Map.Map Pkg.Name C.Constraint)
78+ Details V.Version [Pkg.Name]
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
79
120
80
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)
81+solve :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))
133−addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
82+solve cache connection registry constraints =
134− Stuff.withRegistryLock cache $
135 let
83 let
136− allIndirects = Map.union indirect testIndirect
84+ (Solver solver) = exploreGoals (Goals constraints Map.empty)
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
85 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)
86+ solver (State cache connection registry Map.empty [])
154− (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
87+ (\(State _ _ _ cs _) vs _ -> return $ Right $ getDetails vs cs)
155− (\_ -> return $ noSolution connection)
88+ (\(State _ _ _ _ ps) -> return $ Left ps)
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
89
188
90
91+getDetails :: Map.Map Pkg.Name V.Version -> Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name Details
92+getDetails solution constraints =
93+ Map.mapWithKey (getDetailsHelp constraints) solution
189
94
190−-- TRY
191
95
96+getDetailsHelp :: Map.Map (Pkg.Name, V.Version) Constraints -> Pkg.Name -> V.Version -> Details
97+getDetailsHelp constraints name vsn =
98+ case Map.lookup (name, vsn) constraints of
99+ Just (Constraints _ deps) ->
100+ Details vsn (Map.keys deps)
192
101
193−try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
102+ Nothing ->
194−try constraints =
103+ error "compiler bug in Deps.Solver manifesting in getDetailsHelp"
195− exploreGoals (Goals constraints Map.empty)
196
104
197
105
198
106
@@ -228,7 +136,7 @@ addVersion (Goals pending solved) name version =
228 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
136 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
229 return (Goals newPending (Map.insert name version solved))
137 return (Goals newPending (Map.insert name version solved))
230 else
138 else
231− backtrack
139+ deadend
232
140
233
141
234addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
142addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
@@ -237,7 +145,7 @@ addConstraint solved unsolved (name, newConstraint) =
237 Just version ->
145 Just version ->
238 if C.satisfies newConstraint version
146 if C.satisfies newConstraint version
239 then return unsolved
147 then return unsolved
240− else backtrack
148+ else deadend
241
149
242 Nothing ->
150 Nothing ->
243 case Map.lookup name unsolved of
151 case Map.lookup name unsolved of
@@ -247,7 +155,7 @@ addConstraint solved unsolved (name, newConstraint) =
247 Just oldConstraint ->
155 Just oldConstraint ->
248 case C.intersect oldConstraint newConstraint of
156 case C.intersect oldConstraint newConstraint of
249 Nothing ->
157 Nothing ->
250− backtrack
158+ deadend
251
159
252 Just mergedConstraint ->
160 Just mergedConstraint ->
253 if oldConstraint == mergedConstraint
161 if oldConstraint == mergedConstraint
@@ -261,15 +169,18 @@ addConstraint solved unsolved (name, newConstraint) =
261
169
262getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
170getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
263getRelevantVersions name constraint =
171getRelevantVersions name constraint =
264− Solver $ \state@(State _ _ registry _) ok back _ ->
172+ Solver $ \state@(State _ _ registry _ _) ok err ->
265− case Registry.getVersions name registry of
173+ case Registry.getVersions' name registry of
266− Just (Registry.KnownVersions newest previous) ->
174+ Right (Registry.KnownVersions newest previous) ->
267 case filter (C.satisfies constraint) (newest:previous) of
175 case filter (C.satisfies constraint) (newest:previous) of
268− [] -> back state
176+ [] ->
177+ err (addProblem (ImpossibleConstraint name constraint) state)
178+
179+ v:vs ->
269− v:vs -> ok state (v,vs) back
180+ ok state (v,vs) err
270
181
271− Nothing ->
182+ Left suggestions ->
272− back state
183+ err (addProblem (UnknownPackage suggestions) state)
273
184
274
185
275
186
@@ -277,57 +188,59 @@ getRelevantVersions name constraint =
277
188
278
189
279getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
190getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
280−getConstraints pkg vsn =
191+getConstraints name version =
281− Solver $ \state@(State cache connection registry cDict) ok back err ->
192+ Solver $ \state@(State cache connection registry cDict ps) ok err ->
282− do let key = (pkg, vsn)
193+ do let key = (name, version)
283 case Map.lookup key cDict of
194 case Map.lookup key cDict of
284 Just cs ->
195 Just cs ->
285− ok state cs back
196+ ok state cs err
286
197
287 Nothing ->
198 Nothing ->
199+ do result <- getConstraintsHelp cache connection name version
200+ case result of
201+ Right cs ->
288− do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
202+ ok (State cache connection registry (Map.insert key cs cDict) ps) cs err
289− let home = Stuff.package cache pkg vsn
203+
204+ Left p ->
205+ err (State cache connection registry cDict (p:ps))
206+
207+
208+getConstraintsHelp :: Stuff.PackageCache -> Connection -> Pkg.Name -> V.Version -> IO (Either Problem Constraints)
209+getConstraintsHelp cache connection name version =
290− let path = home </> "elm.json"
210+ do let path = Stuff.metadata cache name version "elm.json"
291− outlineExists <- File.exists path
211+ outlineExists <- File.exists path
292− if outlineExists
212+ if outlineExists
293− then
213+ then
294− do bytes <- File.readUtf8 path
214+ do result <- D.fromFile constraintsDecoder path
295− case D.fromByteString constraintsDecoder bytes of
215+ case result of
296− Right cs ->
216+ Right cs ->
297− case connection of
217+ case connection of
298− Online _ ->
218+ Online _ ->
299− ok (toNewState cs) cs back
219+ return $ Right cs
300−
220+
301− Offline ->
221+ Offline ->
302− do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
222+ do srcExists <- Dir.doesDirectoryExist (Stuff.metadata cache name version "src")
303− if srcExists
223+ if srcExists
304− then ok (toNewState cs) cs back
224+ then return $ Right cs
305− else back state
225+ else return $ Left (UnavailableOffline name version)
306−
226+
307− Left _ ->
227+ Left _ ->
308− do File.remove path
228+ do File.remove path
309− err (Exit.SolverBadCacheData pkg vsn)
229+ return $ Left (BadCacheData name version)
310− else
230+ else
311− case connection of
231+ case connection of
312− Offline ->
232+ Offline ->
313− back state
233+ return (Left (UnavailableOffline name version))
314−
234+
315− Online manager ->
235+ Online manager ->
316− do let url = Website.metadata pkg vsn "elm.json"
236+ Http.post manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->
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 ->
323− case D.fromByteString constraintsDecoder body of
237+ case D.fromByteString constraintsDecoder body of
324− Right cs ->
238+ Right cs ->
325− do Dir.createDirectoryIfMissing True home
326− File.writeUtf8 path body
239+ do File.writeUtf8 path body
327− ok (toNewState cs) cs back
240+ return $ Right cs
328−
241+
329− Left _ ->
242+ Left _ ->
330− err (Exit.SolverBadHttpData pkg vsn url)
243+ return $ Left (BadHttpData name version)
331
244
332
245
333constraintsDecoder :: D.Decoder () Constraints
246constraintsDecoder :: D.Decoder () Constraints
@@ -342,83 +255,46 @@ constraintsDecoder =
342
255
343
256
344
257
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−
382-- INSTANCES
258-- INSTANCES
383
259
384
260
385instance Functor Solver where
261instance Functor Solver where
386 fmap func (Solver solver) =
262 fmap func (Solver solver) =
387− Solver $ \state ok back err ->
263+ Solver $ \state ok err ->
388 let
264 let
389− okA stateA arg backA = ok stateA (func arg) backA
265+ okA stateA arg errA = ok stateA (func arg) errA
390 in
266 in
391− solver state okA back err
267+ solver state okA err
392
268
393
269
394instance Applicative Solver where
270instance Applicative Solver where
395 pure a =
271 pure a =
396− Solver $ \state ok back _ -> ok state a back
272+ Solver $ \state ok err -> ok state a err
397
273
398 (<*>) (Solver solverFunc) (Solver solverArg) =
274 (<*>) (Solver solverFunc) (Solver solverArg) =
399− Solver $ \state ok back err ->
275+ Solver $ \state ok err ->
400 let
276 let
401− okF stateF func backF =
277+ okF stateF func errF =
402 let
278 let
403− okA stateA arg backA = ok stateA (func arg) backA
279+ okA stateA arg errA = ok stateA (func arg) errA
404 in
280 in
405− solverArg stateF okA backF err
281+ solverArg stateF okA errF
406 in
282 in
407− solverFunc state okF back err
283+ solverFunc state okF err
408
284
409
285
410instance Monad Solver where
286instance Monad Solver where
411 return a =
287 return a =
412− Solver $ \state ok back _ -> ok state a back
288+ Solver $ \state ok err -> ok state a err
413
289
414 (>>=) (Solver solverA) callback =
290 (>>=) (Solver solverA) callback =
415− Solver $ \state ok back err ->
291+ Solver $ \state ok err ->
416 let
292 let
417− okA stateA a backA =
293+ okA stateA a errA =
418 case callback a of
294 case callback a of
419− Solver solverB -> solverB stateA ok backA err
295+ Solver solverB -> solverB stateA ok errA
420 in
296 in
421− solverA state okA back err
297+ solverA state okA err
422
298
423
299
424oneOf :: Solver a -> [Solver a] -> Solver a
300oneOf :: Solver a -> [Solver a] -> Solver a
@@ -428,17 +304,19 @@ oneOf solver@(Solver solverHead) solvers =
428 solver
304 solver
429
305
430 s:ss ->
306 s:ss ->
431− Solver $ \state0 ok back err ->
307+ Solver $ \state0 ok err ->
432− let
308+ solverHead state0 ok $ \state1 ->
433− tryTail state1 =
434− let
309+ let
435− (Solver solverTail) = oneOf s ss
310+ (Solver solverTail) = oneOf s ss
436− in
311+ in
437− solverTail state1 ok back err
312+ solverTail state1 ok err
438− in
313+
439− solverHead state0 ok tryTail err
314+
440−
441−
442−backtrack :: Solver a
315+deadend :: Solver a
443−backtrack =
316+deadend =
444− Solver $ \state _ back _ -> back state
317+ Solver $ \state _ err -> err state
318+
319+
320+addProblem :: Problem -> State -> State
321+addProblem problem (State cache registry cDict maybeManager problems) =
322+ State cache registry cDict maybeManager (problem:problems)
builder/src/Deps/Verify.hsnew file+388
@@ -0,0 +1,388 @@
1+module Deps.Verify
2+ ( verify
3+ )
4+ where
5+
6+
7+import Control.Concurrent (forkIO)
8+import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar, putMVar, readMVar, takeMVar)
9+import Control.Monad (filterM, void)
10+import Control.Monad.Trans (liftIO)
11+import qualified Data.Map as Map
12+import qualified Data.Map.Merge.Strict as Map
13+import qualified Data.Set as Set
14+import System.Directory (doesDirectoryExist)
15+import System.FilePath ((</>))
16+
17+import qualified Deps.Cache as Cache
18+import qualified Deps.Explorer as Explorer
19+import qualified Deps.Solver as Solver
20+import qualified Deps.Website as Website
21+import qualified Elm.Compiler as Compiler
22+import qualified Elm.Compiler.Objects as Obj
23+import qualified Elm.Constraint as Con
24+import qualified Elm.Interface as I
25+import qualified Elm.ModuleName as ModuleName
26+import qualified Elm.Package as Pkg
27+import qualified Elm.PerUserCache as PerUserCache
28+import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))
29+import qualified Elm.Project.Json as Project
30+import qualified Elm.Project.Summary as Summary
31+import qualified Elm.Version as V
32+import qualified File.Args as Args
33+import qualified File.Compile as Compile
34+import qualified File.Crawl as Crawl
35+import qualified File.IO as IO
36+import qualified File.Plan as Plan
37+import qualified Generate.Artifacts as Artifacts
38+import qualified Reporting.Exit as Exit
39+import qualified Reporting.Exit.Deps as E
40+import qualified Reporting.Progress as Progress
41+import qualified Reporting.Task as Task
42+import qualified Stuff.Paths as Paths
43+
44+
45+
46+-- VERIFY
47+
48+
49+verify :: FilePath -> Project -> Task.Task Summary.Summary
50+verify root project =
51+ do solution <-
52+ case project of
53+ Project.App info -> verifyApp info
54+ Project.Pkg info -> verifyPkg info
55+
56+ (RawInfo infos ifaces) <- verifyArtifacts solution
57+ return (Summary.init root project infos ifaces)
58+
59+
60+throw :: E.Exit -> Task.Task a
61+throw exit =
62+ Task.throw (Exit.Deps exit)
63+
64+
65+
66+-- VERIFY APP
67+
68+
69+verifyApp :: AppInfo -> Task.Task (Map.Map Pkg.Name V.Version)
70+verifyApp info =
71+ if _app_elm_version info /= V.compiler then
72+ throw (E.AppBadElm (_app_elm_version info))
73+
74+ else
75+ do oldSolution <- appToSolution info
76+ let solver = Solver.solve (Map.map Con.exactly oldSolution)
77+ registry <- Cache.optionalUpdate
78+ maybeSolution <- Explorer.run registry (Solver.run solver)
79+ case maybeSolution of
80+ Nothing ->
81+ throw E.BadDeps
82+
83+ Just newSolution ->
84+ if Map.size oldSolution == Map.size newSolution then
85+ return newSolution
86+ else
87+ throw (E.AppMissingTrans (Map.toList (Map.difference newSolution oldSolution)))
88+
89+
90+
91+-- VERIFY PKG
92+
93+
94+verifyPkg :: PkgInfo -> Task.Task (Map.Map Pkg.Name V.Version)
95+verifyPkg info =
96+ if not (Con.goodElm (_pkg_elm_version info)) then
97+ throw (E.PkgBadElm (_pkg_elm_version info))
98+
99+ else
100+ do deps <- union noDups (_pkg_deps info) (_pkg_test_deps info)
101+ let solver = Solver.solve deps
102+ registry <- Cache.optionalUpdate
103+ maybeSolution <- Explorer.run registry (Solver.run solver)
104+ case maybeSolution of
105+ Nothing ->
106+ throw E.BadDeps
107+
108+ Just solution ->
109+ return solution
110+
111+
112+
113+-- APP TO SOLUTION
114+
115+
116+appToSolution :: Project.AppInfo -> Task.Task (Map.Map Pkg.Name V.Version)
117+appToSolution (Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =
118+ do a <- union allowEqualDups depsTrans testDirect
119+ b <- union noDups depsDirect testTrans
120+ union noDups a b
121+
122+
123+noDups :: Pkg.Name -> a -> a -> Task.Task a
124+noDups _ _ _ =
125+ throw E.BadDeps
126+
127+
128+allowEqualDups :: Pkg.Name -> V.Version -> V.Version -> Task.Task V.Version
129+allowEqualDups _ v1 v2 =
130+ if v1 == v2 then
131+ return v1
132+ else
133+ throw E.BadDeps
134+
135+
136+union :: (Pkg.Name -> a -> a -> Task.Task a) -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Task.Task (Map.Map Pkg.Name a)
137+union tieBreaker deps1 deps2 =
138+ Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
139+
140+
141+
142+-- VERIFY ARTIFACTS
143+
144+
145+verifyArtifacts :: Map.Map Pkg.Name V.Version -> Task.Task RawInfo
146+verifyArtifacts solution =
147+ do Website.download =<< filterM noSrc (Map.toList solution)
148+ verifyBuildArtifacts solution
149+
150+
151+noSrc :: (Pkg.Name, V.Version) -> Task.Task Bool
152+noSrc (name, version) =
153+ do root <- Task.getPackageCacheDirFor name version
154+ liftIO $ not <$> doesDirectoryExist (root </> "src")
155+
156+
157+
158+-- VERIFY BUILD ARTIFACTS
159+
160+
161+verifyBuildArtifacts :: Map.Map Pkg.Name V.Version -> Task.Task RawInfo
162+verifyBuildArtifacts solution =
163+ do Task.report (Progress.BuildDepsStart (Map.size solution))
164+ startMVar <- liftIO newEmptyMVar
165+ ifacesMVar <- liftIO $ newMVar Map.empty
166+ pkgInfoMVars <- Map.traverseWithKey (verifyBuild startMVar ifacesMVar) solution
167+ liftIO $ putMVar startMVar pkgInfoMVars
168+ answers <- liftIO $ traverse readMVar pkgInfoMVars
169+ Task.report Progress.BuildDepsEnd
170+ RawInfo
171+ <$> Map.traverseMaybeWithKey toInfo answers
172+ <*> liftIO (readMVar ifacesMVar)
173+
174+
175+data RawInfo =
176+ RawInfo (Map.Map Pkg.Name PkgInfo) I.Interfaces
177+
178+
179+verifyBuild
180+ :: MVar (Map.Map Pkg.Name (MVar Answer))
181+ -> MVar I.Interfaces
182+ -> Pkg.Name
183+ -> V.Version
184+ -> Task.Task (MVar Answer)
185+verifyBuild pkgInfoMVar ifacesMVar name version =
186+ do mvar <- liftIO newEmptyMVar
187+ info <- Cache.getElmJson name version
188+ report <- Task.getReporter
189+ runner <- Task.getSilentRunner
190+
191+ liftIO $ void $ forkIO $
192+ do allMVars <- readMVar pkgInfoMVar
193+ let deps = Project._pkg_deps info
194+ let depsMVars = Map.intersection allMVars deps
195+ depAnswers <- traverse readMVar depsMVars
196+
197+ answer <- ifNotBlocked depAnswers $ \infos ->
198+ do ifacesBefore <- readMVar ifacesMVar
199+ result <- runner (getIface name version info infos ifacesBefore)
200+ case result of
201+ Right ifaces ->
202+ do ifacesNow <- takeMVar ifacesMVar
203+ putMVar ifacesMVar (Map.union ifacesNow ifaces)
204+ return (Ok info)
205+
206+ Left _ ->
207+ return (Err name version)
208+
209+ report Progress.BuildDepsProgress
210+ putMVar mvar answer
211+
212+ return mvar
213+
214+
215+
216+-- ANSWERS
217+
218+
219+data Answer
220+ = Ok PkgInfo
221+ | Blocked
222+ | Err Pkg.Name V.Version
223+
224+
225+toInfo :: Pkg.Name -> Answer -> Task.Task (Maybe PkgInfo)
226+toInfo _ answer =
227+ case answer of
228+ Ok info ->
229+ return (Just info)
230+
231+ Blocked ->
232+ return Nothing
233+
234+ Err name version ->
235+ do elmHome <- liftIO PerUserCache.getElmHome
236+ throw (E.BuildFailure elmHome name version)
237+
238+
239+ifNotBlocked :: Map.Map Pkg.Name Answer -> (Map.Map Pkg.Name PkgInfo -> IO Answer) -> IO Answer
240+ifNotBlocked answers callback =
241+ case traverse isOk answers of
242+ Nothing ->
243+ return Blocked
244+
245+ Just infos ->
246+ callback infos
247+
248+
249+isOk :: Answer -> Maybe PkgInfo
250+isOk answer =
251+ case answer of
252+ Ok info -> Just info
253+ Blocked -> Nothing
254+ Err _ _ -> Nothing
255+
256+
257+
258+-- GET INTERFACE
259+
260+
261+getIface
262+ :: Pkg.Name
263+ -> V.Version
264+ -> PkgInfo
265+ -> Map.Map Pkg.Name PkgInfo
266+ -> I.Interfaces
267+ -> Task.Task I.Interfaces
268+getIface name version info infos depIfaces =
269+ do root <- Task.getPackageCacheDirFor name version
270+ let solution = Map.map _pkg_version infos
271+
272+ cached <- liftIO $ isCached root solution
273+
274+ if cached
275+ then
276+ do maybeIfaces <- liftIO $ IO.readBinary (root </> "ifaces.dat")
277+ maybe (Task.throw (error "TODO corrupt binary 1")) return maybeIfaces
278+ else
279+ do Paths.removeStuff root
280+ let summary = Summary.cheapInit root info infos depIfaces
281+ args <- Args.fromSummary summary
282+ graph <- Crawl.crawl summary args
283+ (dirty, cachedIfaces) <- Plan.plan summary graph
284+ answers <- Compile.compile (Pkg info) cachedIfaces dirty
285+ results <- Artifacts.ignore answers
286+ Paths.removeStuff root
287+
288+ updateCache root name info solution graph results
289+
290+
291+
292+-- IS CACHED?
293+
294+
295+isCached :: FilePath -> Map.Map Pkg.Name V.Version -> IO Bool
296+isCached root solution =
297+ IO.andM
298+ [ IO.exists (root </> "cached.dat")
299+ , IO.exists (root </> "ifaces.dat")
300+ , IO.exists (root </> "objs.dat")
301+ , isCachedHelp solution <$> IO.readBinary (root </> "cached.dat")
302+ ]
303+
304+
305+isCachedHelp :: Map.Map Pkg.Name V.Version -> Maybe (Map.Map Pkg.Name (Set.Set V.Version)) -> Bool
306+isCachedHelp solution maybeCachedDeps =
307+ case maybeCachedDeps of
308+ Nothing ->
309+ False
310+
311+ Just cachedDeps ->
312+ let
313+ matches =
314+ Map.intersectionWith Set.member solution cachedDeps
315+ in
316+ Map.size solution == Map.size matches
317+ && Map.foldr (&&) True matches
318+
319+
320+
321+-- UPDATE CACHE
322+
323+
324+updateCache
325+ :: FilePath
326+ -> Pkg.Name
327+ -> PkgInfo
328+ -> Map.Map Pkg.Name V.Version
329+ -> Crawl.Result
330+ -> Map.Map ModuleName.Raw Compiler.Artifacts
331+ -> Task.Task I.Interfaces
332+updateCache root name info solution graph results =
333+ do let path = root </> "cached.dat"
334+ let deps = Map.map Set.singleton solution
335+ let elmi = crush name info results
336+
337+ exists <- liftIO $ IO.exists path
338+
339+ if exists
340+ then
341+ do maybeOldDeps <- liftIO $ IO.readBinary path
342+ oldDeps <- maybe (error "TODO corrupt binary 2") return maybeOldDeps
343+ liftIO $ IO.writeBinary path (Map.unionWith Set.union deps oldDeps)
344+ else
345+ liftIO $
346+ do IO.writeBinary (root </> "ifaces.dat") elmi
347+ IO.writeBinary path deps
348+ IO.writeBinary (root </> "objs.dat") $
349+ Map.foldr addGraph (objGraphFromKernels graph) results
350+
351+ return elmi
352+
353+
354+
355+-- CRUSH INTERFACES
356+
357+
358+crush :: Pkg.Name -> PkgInfo -> Map.Map ModuleName.Raw Compiler.Artifacts -> I.Interfaces
359+crush pkg info results =
360+ let
361+ exposed =
362+ Set.fromList (Project.getExposed info)
363+ in
364+ Map.mapKeys (ModuleName.Canonical pkg) $
365+ Map.mapMaybeWithKey (crushHelp exposed) results
366+
367+
368+crushHelp :: Set.Set ModuleName.Raw -> ModuleName.Raw -> Compiler.Artifacts -> Maybe I.Interface
369+crushHelp exposed name (Compiler.Artifacts elmi _) =
370+ if Set.member name exposed then
371+ Just elmi
372+
373+ else
374+ Nothing
375+
376+
377+
378+-- OBJECT GRAPH
379+
380+
381+addGraph :: Compiler.Artifacts -> Obj.Graph -> Obj.Graph
382+addGraph (Compiler.Artifacts _ elmo) graph =
383+ Obj.union elmo graph
384+
385+
386+objGraphFromKernels :: Crawl.Result -> Obj.Graph
387+objGraphFromKernels (Crawl.Graph _ _ kernels _ _) =
388+ Obj.fromKernels kernels
builder/src/Elm/Bump.hsnew file+137
@@ -0,0 +1,137 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Bump
3+ ( bump
4+ , toPossibleBumps
5+ )
6+ where
7+
8+
9+import Control.Monad.Trans (liftIO)
10+import qualified Data.List as List
11+
12+import qualified Deps.Cache as Cache
13+import qualified Deps.Diff as Diff
14+import qualified Elm.Project.Json as Project
15+import qualified Elm.Project.Summary as Summary
16+import qualified Elm.Version as V
17+import Reporting.Doc ((<>), (<+>))
18+import qualified Reporting.Doc as D
19+import qualified Reporting.Exit as Exit
20+import qualified Reporting.Exit.Bump as E
21+import qualified Reporting.Exit.Help as Help
22+import qualified Reporting.Progress.Terminal as Terminal
23+import qualified Reporting.Task as Task
24+
25+
26+
27+-- BUMP
28+
29+
30+bump :: Summary.Summary -> Task.Task ()
31+bump summary@(Summary.Summary root project _ _ _) =
32+ case project of
33+ Project.App _ ->
34+ Task.throw (Exit.Bump E.Application)
35+
36+ Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
37+ do registry <- Cache.mandatoryUpdate
38+ case Cache.getVersions name registry of
39+ Left _suggestions ->
40+ checkNewPackage root info
41+
42+ Right publishedVersions ->
43+ let
44+ bumpableVersions =
45+ map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
46+ in
47+ if elem version bumpableVersions then
48+ suggestVersion summary info
49+ else
50+ Task.throw $ Exit.Bump $ E.Unbumpable version $
51+ map head (List.group (List.sort bumpableVersions))
52+
53+
54+
55+-- VALID BUMPS
56+
57+
58+toPossibleBumps :: [V.Version] -> [(V.Version, V.Version, Diff.Magnitude)]
59+toPossibleBumps publishedVersions =
60+ case publishedVersions of
61+ [] ->
62+ []
63+
64+ _ ->
65+ let
66+ patchPoints =
67+ V.filterLatest V.majorAndMinor publishedVersions
68+
69+ minorPoints =
70+ V.filterLatest V._major publishedVersions
71+
72+ majorPoint =
73+ maximum publishedVersions
74+ in
75+ (majorPoint, V.bumpMajor majorPoint, Diff.MAJOR)
76+ : map (\v -> (v, V.bumpMinor v, Diff.MINOR)) minorPoints
77+ ++ map (\v -> (v, V.bumpPatch v, Diff.PATCH)) patchPoints
78+
79+
80+
81+-- CHECK NEW PACKAGE
82+
83+
84+checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
85+checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
86+ do liftIO $ putStrLn Terminal.newPackageOverview
87+ if version == V.one
88+ then
89+ liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
90+ else
91+ changeVersion root info V.one $
92+ "It looks like the version in elm.json has been changed though!\n\
93+ \Would you like me to change it back to "
94+ <> D.fromUtf8 (V.toString V.one) <> "? [Y/n] "
95+
96+
97+
98+-- SUGGEST VERSION
99+
100+
101+suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
102+suggestVersion (Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
103+ do oldDocs <- Cache.getDocs name version
104+ newDocs <- Task.silently (error "TODO Project.generateDocs summary")
105+ let changes = Diff.diff oldDocs newDocs
106+ let newVersion = Diff.bump changes version
107+ changeVersion root info newVersion $
108+ let
109+ old = D.fromUtf8 $ V.toString version
110+ new = D.fromUtf8 $ V.toString newVersion
111+ mag = D.fromChars $ Diff.magnitudeToString (Diff.toMagnitude changes)
112+ in
113+ "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
114+ <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
115+ <> "\n"
116+ <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
117+
118+
119+
120+-- CHANGE VERSION
121+
122+
123+changeVersion :: FilePath -> Project.PkgInfo -> V.Version -> D.Doc -> Task.Task ()
124+changeVersion root info targetVersion explanation =
125+ do approved <- Task.getApproval explanation
126+ if not approved
127+ then
128+ liftIO $ putStrLn "Okay, I did not change anything!"
129+
130+ else
131+ do liftIO $ Project.write root $ Project.Pkg $
132+ info { Project._pkg_version = targetVersion }
133+
134+ liftIO $ Help.toStdout $
135+ "Version changed to "
136+ <> D.green (D.fromUtf8 (V.toString targetVersion))
137+ <> "!\n"
builder/src/Elm/Details.hs+17−746
@@ -1,49 +1,28 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Elm.Details
2module Elm.Details
4 ( Details(..)
3 ( Details(..)
5− , BuildID
6 , ValidOutline(..)
4 , ValidOutline(..)
7 , Local(..)
5 , Local(..)
8 , Foreign(..)
6 , Foreign(..)
9− , load
10− , loadObjects
11− , loadInterfaces
12− , verifyInstall
13 )
7 )
14 where
8 where
15
9
16
10
17import Control.Concurrent (forkIO)
11import Control.Concurrent (forkIO)
18−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
12+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
19−import Control.Monad (liftM, liftM2, liftM3)
13+import Control.Monad (liftM, liftM2, liftM3, liftM4)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
14import Data.Binary (Binary, get, put, getWord8, putWord8)
21−import qualified Data.Either as Either
22import qualified Data.Map as Map
15import qualified Data.Map as Map
23−import qualified Data.Map.Utils as Map
24import qualified Data.Map.Merge.Strict as Map
16import 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
28−import qualified Data.OneOrMore as OneOrMore
29import qualified Data.Set as Set
17import qualified Data.Set as Set
30import qualified Data.Utf8 as Utf8
18import qualified Data.Utf8 as Utf8
31−import Data.Word (Word64)
32−import qualified System.Directory as Dir
19+import System.Directory (doesDirectoryExist)
33−import System.FilePath ((</>), (<.>))
20+import System.FilePath ((</>))
34
21
35−import qualified AST.Canonical as Can
36−import qualified AST.Source as Src
37−import qualified AST.Optimized as Opt
38−import qualified BackgroundWriter as BW
39−import qualified Compile
40import qualified Deps.Registry as Registry
22import qualified Deps.Registry as Registry
41import qualified Deps.Solver as Solver
23import qualified Deps.Solver as Solver
42−import qualified Deps.Website as Website
43import qualified Elm.Constraint as Con
24import qualified Elm.Constraint as Con
44−import qualified Elm.Docs as Docs
45import qualified Elm.Interface as I
25import qualified Elm.Interface as I
46−import qualified Elm.Kernel as Kernel
47import qualified Elm.ModuleName as ModuleName
26import qualified Elm.ModuleName as ModuleName
48import qualified Elm.Outline as Outline
27import qualified Elm.Outline as Outline
49import qualified Elm.Package as Pkg
28import qualified Elm.Package as Pkg
@@ -51,11 +30,8 @@ import qualified Elm.Version as V
51import qualified File
30import qualified File
52import qualified Http
31import qualified Http
53import qualified Json.Decode as D
32import qualified Json.Decode as D
54−import qualified Json.Encode as E
55−import qualified Parse.Module as Parse
56−import qualified Reporting
57−import qualified Reporting.Annotation as A
58import qualified Reporting.Exit as Exit
33import qualified Reporting.Exit as Exit
34+import qualified Reporting.Progress as Progress
59import qualified Reporting.Task as Task
35import qualified Reporting.Task as Task
60import qualified Stuff
36import qualified Stuff
61
37
@@ -68,42 +44,21 @@ data Details =
68 Details
44 Details
69 { _outlineTime :: File.Time
45 { _outlineTime :: File.Time
70 , _outline :: ValidOutline
46 , _outline :: ValidOutline
71− , _buildID :: BuildID
72 , _locals :: Map.Map ModuleName.Raw Local
47 , _locals :: Map.Map ModuleName.Raw Local
73 , _foreigns :: Map.Map ModuleName.Raw Foreign
48 , _foreigns :: Map.Map ModuleName.Raw Foreign
74− , _extras :: Extras
75 }
49 }
76
50
77
51
78−type BuildID = Word64
79−
80−
81data ValidOutline
52data ValidOutline
82− = ValidApp (NE.List Outline.SrcDir)
53+ = ValidApp Outline.AppOutline
83− | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
54+ | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)
84
55
85
56
86−-- NOTE: we need two ways to detect if a file must be recompiled:
87−--
88−-- (1) _time is the modification time from the last time we compiled the file.
89−-- By checking EQUALITY with the current modification time, we can detect file
90−-- saves and `git checkout` of previous versions. Both need a recompile.
91−--
92−-- (2) _lastChange is the BuildID from the last time a new interface file was
93−-- generated, and _lastCompile is the BuildID from the last time the file was
94−-- compiled. These may be different if a file is recompiled but the interface
95−-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
96−-- imports, we need to recompile. This can happen when a project has multiple
97−-- entrypoints and some modules are compiled less often than their imports.
98−--
99data Local =
57data Local =
100 Local
58 Local
101 { _path :: FilePath
59 { _path :: FilePath
102 , _time :: File.Time
60 , _time :: File.Time
103 , _deps :: [ModuleName.Raw]
61 , _deps :: [ModuleName.Raw]
104− , _main :: Bool
105− , _lastChange :: BuildID
106− , _lastCompile :: BuildID
107 }
62 }
108
63
109
64
@@ -111,711 +66,32 @@ data Foreign =
111 Foreign Pkg.Name [Pkg.Name]
66 Foreign Pkg.Name [Pkg.Name]
112
67
113
68
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−
141−
142−-- VERIFY INSTALL -- used by Install
143−
144−
145−verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())
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 =
161− do newTime <- File.getTime (root </> "elm.json")
162− maybeDetails <- File.readBinary (Stuff.details root)
163− case maybeDetails of
164− Nothing ->
165− generate style scope root newTime
166−
167− Just details@(Details oldTime _ buildID _ _ _) ->
168− if oldTime == newTime
169− then return (Right details { _buildID = buildID + 1 })
170− else generate style scope root newTime
171−
172−
173−
174−-- GENERATE
175−
176−
177−generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)
178−generate style scope root time =
179− Reporting.trackDetails style $ \key ->
180− do result <- initEnv key scope root
181− case result of
182− Left exit ->
183− return (Left exit)
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)
189−
190−
191−
192−-- ENV
193−
194−
195−data Env =
196− Env
197− { _key :: Reporting.DKey
198− , _scope :: BW.Scope
199− , _root :: FilePath
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
210− eitherOutline <- Outline.read root
211− case eitherOutline of
212− Left problem ->
213− return $ Left $ Exit.DetailsBadOutline problem
214−
215− Right outline ->
216− do maybeEnv <- readMVar mvar
217− case maybeEnv of
218− Left problem ->
219− return $ Left $ Exit.DetailsCannotGetRegistry problem
220−
221− Right (Solver.Env cache manager connection registry) ->
222− return $ Right (Env key scope root cache manager connection registry, outline)
223−
224−
225−
226−-- VERIFY PROJECT
227−
228−
229−type Task a = Task.Task Exit.Details a
230−
231−
232−verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
233−verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =
234− if Con.goodElm elm
235− then
236− do solution <- verifyConstraints env =<< union noDups direct testDirect
237− let exposedList = Outline.flattenExposed exposed
238− let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
239− verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
240− else
241− Task.throw $ Exit.DetailsBadElmInPkg elm
242−
243−
244−verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
245−verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =
246− if elmVersion == V.compiler
247− then
248− do stated <- checkAppDeps outline
249− actual <- verifyConstraints env (Map.map Con.exactly stated)
250− if Map.size stated == Map.size actual
251− then verifyDependencies env time (ValidApp srcDirs) actual direct
252− else Task.throw $ Exit.DetailsHandEditedDependencies
253− else
254− Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
255−
256−
257−checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
258−checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
259− do x <- union allowEqualDups indirect testDirect
260− y <- union noDups direct testIndirect
261− union noDups x y
262−
263−
264−
265−-- VERIFY CONSTRAINTS
266−
267−
268−verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
269−verifyConstraints (Env _ _ _ cache _ connection registry) constraints =
270− do result <- Task.io $ Solver.verify cache connection registry constraints
271− case result of
272− Solver.Ok details -> return details
273− Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
274− Solver.NoOfflineSolution -> Task.throw $ Exit.DetailsNoOfflineSolution
275− Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit
276−
277−
278−
279−-- UNION
280−
281−
282−union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v)
283−union tieBreaker deps1 deps2 =
284− Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
285−
286−
287−noDups :: k -> v -> v -> Task v
288−noDups _ _ _ =
289− Task.throw Exit.DetailsHandEditedDependencies
290−
291−
292−allowEqualDups :: (Eq v) => k -> v -> v -> Task v
293−allowEqualDups _ v1 v2 =
294− if v1 == v2
295− then return v1
296− else Task.throw Exit.DetailsHandEditedDependencies
297−
298−
299−
300−-- FORK
301−
302−
303−fork :: IO a -> IO (MVar a)
304−fork work =
305− do mvar <- newEmptyMVar
306− _ <- forkIO $ putMVar mvar =<< work
307− return mvar
308−
309−
310−
311−-- VERIFY DEPENDENCIES
312−
313−
314−verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
315−verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =
316− Task.eio id $
317− do Reporting.report key (Reporting.DStart (Map.size solution))
318− mvar <- newEmptyMVar
319− mvars <- Stuff.withRegistryLock cache $
320− Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
321− putMVar mvar mvars
322− deps <- traverse readMVar mvars
323− case sequence deps of
324− Left _ ->
325− do home <- Stuff.getElmHome
326− return $ Left $ Exit.DetailsBadDeps home $
327− Maybe.catMaybes $ Either.lefts $ Map.elems deps
328−
329− Right artifacts ->
330− let
331− objs = Map.foldr addObjects Opt.empty artifacts
332− ifaces = Map.foldrWithKey (addInterfaces directDeps) 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)
335− in
336− do BW.writeBinary scope (Stuff.objects root) objs
337− BW.writeBinary scope (Stuff.interfaces root) ifaces
338− BW.writeBinary scope (Stuff.details root) details
339− return (Right details)
340−
341−
342−addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph
343−addObjects (Artifacts _ objs) graph =
344− Opt.addGlobalGraph objs graph
345−
346−
347−addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces
348−addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
349− Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $
350− if Map.member pkg directDeps
351− then ifaces
352− else Map.map I.privatize ifaces
353−
354−
355−gatherForeigns :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name)
356−gatherForeigns pkg (Artifacts ifaces _) foreigns =
357− let
358− isPublic di =
359− case di of
360− I.Public _ -> Just (OneOrMore.one pkg)
361− I.Private _ _ _ -> Nothing
362− in
363− Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
364−
365−
366−
367−-- VERIFY DEPENDENCY
368−
369−
370−data Artifacts =
371− Artifacts
372− { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
373− , _objects :: Opt.GlobalGraph
374− }
375−
376−
377−type Dep =
378− Either (Maybe Exit.DetailsBadDep) Artifacts
379−
380−
381−verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
382−verifyDep (Env key _ _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
383− do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
384− exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
385− if exists
386− then
387− do Reporting.report key Reporting.DCached
388− maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
389− case maybeCache of
390− Nothing ->
391− build key cache depsMVar pkg details fingerprint Set.empty
392−
393− Just (ArtifactCache fingerprints artifacts) ->
394− if Set.member fingerprint fingerprints
395− then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
396− else build key cache depsMVar pkg details fingerprint fingerprints
397− else
398− do Reporting.report key Reporting.DRequested
399− result <- downloadPackage cache manager pkg vsn
400− case result of
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)
407− build key cache depsMVar pkg details fingerprint Set.empty
408−
409−
410−
411−-- ARTIFACT CACHE
412−
413−
414−data ArtifactCache =
415− ArtifactCache
416− { _fingerprints :: Set.Set Fingerprint
417− , _artifacts :: Artifacts
418− }
419−
420−
421−type Fingerprint =
422− Map.Map Pkg.Name V.Version
423−
424−
425−
426−-- BUILD
427−
428−
429−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep
430−build key cache depsMVar pkg (Solver.Details vsn _) f fs =
431− do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
432− case eitherOutline of
433− Left _ ->
434− do Reporting.report key Reporting.DBroken
435− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
436−
437− Right (Outline.App _) ->
438− do Reporting.report key Reporting.DBroken
439− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
440−
441− Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
442− do allDeps <- readMVar depsMVar
443− directDeps <- traverse readMVar (Map.intersection allDeps deps)
444− case sequence directDeps of
445− Left _ ->
446− do Reporting.report key Reporting.DBroken
447− return $ Left $ Nothing
448−
449− Right directArtifacts ->
450− do let src = Stuff.package cache pkg vsn </> "src"
451− let foreignDeps = gatherForeignInterfaces directArtifacts
452− let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
453− docsStatus <- getDocsStatus cache pkg vsn
454− mvar <- newEmptyMVar
455− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict
456− putMVar mvar mvars
457− mapM_ readMVar mvars
458− maybeStatuses <- traverse readMVar =<< readMVar mvar
459− case sequence maybeStatuses of
460− Nothing ->
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−
487−
488−
489−-- GATHER
490−
491−
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 =
499− case status of
500− RLocal _ objs _ -> Opt.addLocalGraph objs graph
501− RForeign _ -> graph
502− RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
503− RKernelForeign -> graph
504−
505−
506−gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface
507−gatherInterfaces exposed artifacts =
508− let
509− onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces")
510− onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface)
511− onBoth = Map.zipWithMaybeMatched (\_ () iface -> toLocalInterface I.public iface)
512− in
513− Map.merge onLeft onRight onBoth exposed artifacts
514−
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
523−
524−
525−
526−-- GATHER FOREIGN INTERFACES
527−
528−
529−data ForeignInterface
530− = ForeignAmbiguous
531− | ForeignSpecific I.Interface
532−
533−
534−gatherForeignInterfaces :: Map.Map Pkg.Name Artifacts -> Map.Map ModuleName.Raw ForeignInterface
535−gatherForeignInterfaces directArtifacts =
536− Map.map (OneOrMore.destruct finalize) $
537− Map.foldrWithKey gather Map.empty directArtifacts
538− where
539− finalize :: I.Interface -> [I.Interface] -> ForeignInterface
540− finalize i is =
541− case is of
542− [] -> ForeignSpecific i
543− _:_ -> ForeignAmbiguous
544−
545− gather :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface)
546− gather _ (Artifacts ifaces _) buckets =
547− Map.unionWith OneOrMore.more buckets (Map.mapMaybe isPublic ifaces)
548−
549− isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
550− isPublic di =
551− case di of
552− I.Public iface -> Just (OneOrMore.one iface)
553− I.Private _ _ _ -> Nothing
554−
555−
556−
557−-- CRAWL
558−
559−
560−type StatusDict =
561− Map.Map ModuleName.Raw (MVar (Maybe Status))
562−
563−
564−data Status
565− = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module
566− | SForeign I.Interface
567− | SKernelLocal [Kernel.Chunk]
568− | SKernelForeign
569−
570−
571−crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)
572−crawlModule foreignDeps mvar pkg src docsStatus name =
573− do let path = src </> ModuleName.toFilePath name <.> "elm"
574− exists <- File.exists path
575− case Map.lookup name foreignDeps of
576− Just ForeignAmbiguous ->
577− return Nothing
578−
579− Just (ForeignSpecific iface) ->
580− if exists
581− then return Nothing
582− else return (Just (SForeign iface))
583−
584− Nothing ->
585− if exists then
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−
591− else
592− return Nothing
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
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 =
609− do statusDict <- takeMVar mvar
610− let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
611− let news = Map.difference deps statusDict
612− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news
613− putMVar mvar (Map.union mvars statusDict)
614− mapM_ readMVar mvars
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
626− Nothing ->
627− return Nothing
628−
629− Just (Kernel.Content imports chunks) ->
630− do _ <- crawlImports foreignDeps mvar pkg src imports
631− return (Just (SKernelLocal chunks))
632− else
633− return (Just SKernelForeign)
634−
635−
636−getDepHome :: ForeignInterface -> Maybe Pkg.Name
637−getDepHome fi =
638− case fi of
639− ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg
640− ForeignAmbiguous -> Nothing
641−
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 =
656− case status of
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−
676− SForeign iface ->
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
742−
743−
744−
745−-- DOWNLOAD PACKAGE
746−
747−
748−downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
749−downloadPackage cache manager pkg vsn =
750− let
751− url = Website.metadata pkg vsn "endpoint.json"
752− in
753− do eitherByteString <-
754− Http.get manager url [] id (return . Right)
755−
756− case eitherByteString of
757− Left err ->
758− return $ Left $ Exit.PP_BadEndpointRequest err
759−
760− Right byteString ->
761− case D.fromByteString endpointDecoder byteString of
762− Left _ ->
763− return $ Left $ Exit.PP_BadEndpointContent url
764−
765− Right (endpoint, expectedHash) ->
766− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $
767− \(sha, archive) ->
768− if expectedHash == Http.shaToChars sha
769− then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive
770− else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)
771−
772−
773−endpointDecoder :: D.Decoder e (String, String)
774−endpointDecoder =
775− do url <- D.field "url" D.string
776− hash <- D.field "hash" D.string
777− return (Utf8.toChars url, Utf8.toChars hash)
778−
779−
780
69
781-- BINARY
70-- BINARY
782
71
783
72
784instance Binary Details where
73instance Binary Details where
74+ get = liftM4 Details get get get get
785− put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
75+ put (Details a b c d) = put a >> put b >> put c >> put d
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)
793
76
794
77
795instance Binary ValidOutline where
78instance Binary ValidOutline where
796 put outline =
79 put outline =
797 case outline of
80 case outline of
798− ValidApp a -> putWord8 0 >> put a
81+ ValidApp a -> putWord8 0 >> put a
799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
82+ ValidPkg a b -> putWord8 1 >> put a >> put b
800
83
801 get =
84 get =
802 do n <- getWord8
85 do n <- getWord8
803 case n of
86 case n of
804 0 -> liftM ValidApp get
87 0 -> liftM ValidApp get
805− 1 -> liftM3 ValidPkg get get get
88+ 1 -> liftM2 ValidPkg get get
806− _ -> fail "binary encoding of ValidOutline was corrupted"
89+ _ -> error "binary encoding of ValidOutline was corrupted"
807
90
808
91
809instance Binary Local where
92instance Binary Local where
93+ get = liftM3 Local get get get
810− put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
94+ put (Local a b c) = put a >> put b >> put c
811− get =
812− do a <- get
813− b <- get
814− c <- get
815− d <- get
816− e <- get
817− f <- get
818− return (Local a b c d e f)
819
95
820
96
821instance Binary Foreign where
97instance Binary Foreign where
@@ -824,10 +100,5 @@ instance Binary Foreign where
824
100
825
101
826instance Binary Artifacts where
102instance Binary Artifacts where
827− get = liftM2 Artifacts get get
103+ get = liftM3 Artifacts get get get
828− put (Artifacts a b) = put a >> put b
104+ put (Artifacts a b c) = put a >> put b >> put c
829−
830−
831−instance Binary ArtifactCache where
832− get = liftM2 ArtifactCache get get
833− put (ArtifactCache a b) = put a >> put b
builder/src/Elm/Diff.hsnew file+284
@@ -0,0 +1,284 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Diff
4+ ( Args(..)
5+ , diff
6+ )
7+ where
8+
9+
10+import Control.Monad.Except (liftIO)
11+import qualified Data.List as List
12+import qualified Data.Map as Map
13+import qualified Data.Maybe as Maybe
14+import qualified Data.Name as Name
15+
16+import qualified Deps.Cache as Cache
17+import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18+import qualified Deps.Diff as Diff
19+import qualified Elm.Compiler.Type as Type
20+import qualified Elm.Docs as Docs
21+import qualified Elm.ModuleName as ModuleName
22+import qualified Elm.Package as Pkg
23+import qualified Elm.Project as Project
24+import qualified Elm.Project.Json as Project
25+import qualified Elm.Project.Summary as Summary
26+import qualified Elm.Version as V
27+import Reporting.Doc ((<>), (<+>))
28+import qualified Reporting.Doc as D
29+import qualified Reporting.Exit as Exit
30+import qualified Reporting.Exit.Diff as E
31+import qualified Reporting.Exit.Help as Help
32+import qualified Reporting.Render.Type.Localizer as L
33+import qualified Reporting.Task as Task
34+
35+
36+
37+-- DIFF
38+
39+
40+data Args
41+ = CodeVsLatest
42+ | CodeVsExactly V.Version
43+ | LocalInquiry V.Version V.Version
44+ | GlobalInquiry Pkg.Name V.Version V.Version
45+
46+
47+diff :: Args -> Task.Task ()
48+diff args =
49+ case args of
50+ GlobalInquiry name v1 v2 ->
51+ do registry <- Cache.mandatoryUpdate
52+ case Cache.getVersions name registry of
53+ Left suggestions ->
54+ throw $ E.UnknownPackage name suggestions
55+
56+ Right vsns ->
57+ do oldDocs <- getDocs name vsns (min v1 v2)
58+ newDocs <- getDocs name vsns (max v1 v2)
59+ writeDiff oldDocs newDocs
60+
61+ LocalInquiry v1 v2 ->
62+ do (_, name, vsns) <- getPackageInfo
63+ oldDocs <- getDocs name vsns (min v1 v2)
64+ newDocs <- getDocs name vsns (max v1 v2)
65+ writeDiff oldDocs newDocs
66+
67+ CodeVsLatest ->
68+ do (summary, name, vsns) <- getPackageInfo
69+ oldDocs <- getDocs name vsns (maximum vsns)
70+ newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
71+ writeDiff oldDocs newDocs
72+
73+ CodeVsExactly version ->
74+ do (summary, name, vsns) <- getPackageInfo
75+ oldDocs <- getDocs name vsns version
76+ newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)
77+ writeDiff oldDocs newDocs
78+
79+
80+throw :: E.Exit -> Task.Task a
81+throw exit =
82+ Task.throw $ Exit.Diff exit
83+
84+
85+
86+-- DIFF HELPERS
87+
88+
89+getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation
90+getDocs name allVersions version =
91+ if elem version allVersions then
92+ Cache.getDocs name version
93+ else
94+ throw $ E.UnknownVersion name version allVersions
95+
96+
97+getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])
98+getPackageInfo =
99+ do summary <- Project.getRoot
100+ case Summary._project summary of
101+ Project.App _ ->
102+ throw $ E.Application
103+
104+ Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
105+ do registry <- Cache.mandatoryUpdate
106+ case Cache.getVersions name registry of
107+ Right vsns ->
108+ return ( summary, name, vsns )
109+
110+ Left _ ->
111+ throw E.Unpublished
112+
113+
114+
115+-- WRITE DOC
116+
117+
118+writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()
119+writeDiff oldDocs newDocs =
120+ let
121+ changes = Diff.diff oldDocs newDocs
122+ localizer = L.fromNames (Map.union oldDocs newDocs)
123+ in
124+ liftIO $ Help.toStdout (toDoc localizer changes <> "\n")
125+
126+
127+
128+-- TO DOC
129+
130+
131+toDoc :: L.Localizer -> PackageChanges -> D.Doc
132+toDoc localizer changes@(PackageChanges added changed removed) =
133+ if null added && Map.null changed && null removed then
134+ "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."
135+ else
136+ let
137+ magDoc =
138+ D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))
139+
140+ header =
141+ "This is a" <+> D.green magDoc <+> "change."
142+
143+ addedChunk =
144+ if null added then [] else
145+ [ Chunk "ADDED MODULES" MINOR $
146+ D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added
147+ ]
148+
149+ removedChunk =
150+ if null removed then [] else
151+ [ Chunk "REMOVED MODULES" MAJOR $
152+ D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed
153+ ]
154+
155+ chunks =
156+ addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)
157+ in
158+ D.vcat (header : "" : map chunkToDoc chunks)
159+
160+
161+data Chunk =
162+ Chunk
163+ { _title :: String
164+ , _magnitude :: Magnitude
165+ , _details :: D.Doc
166+ }
167+
168+
169+chunkToDoc :: Chunk -> D.Doc
170+chunkToDoc (Chunk title magnitude details) =
171+ let
172+ magDoc =
173+ Diff.magnitudeToString magnitude
174+
175+ header =
176+ "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"
177+ in
178+ D.vcat
179+ [ D.dullcyan header
180+ , ""
181+ , D.indent 4 details
182+ , ""
183+ , ""
184+ ]
185+
186+
187+changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk
188+changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =
189+ let
190+ magnitude =
191+ Diff.moduleChangeMagnitude changes
192+
193+ (unionAdd, unionChange, unionRemove) =
194+ changesToDocTriple (unionToDoc localizer) unions
195+
196+ (aliasAdd, aliasChange, aliasRemove) =
197+ changesToDocTriple (aliasToDoc localizer) aliases
198+
199+ (valueAdd, valueChange, valueRemove) =
200+ changesToDocTriple (valueToDoc localizer) values
201+
202+ (binopAdd, binopChange, binopRemove) =
203+ changesToDocTriple (binopToDoc localizer) binops
204+ in
205+ Chunk (Name.toChars name) magnitude $
206+ D.vcat $ List.intersperse "" $ Maybe.catMaybes $
207+ [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
208+ , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
209+ , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
210+ ]
211+
212+
213+changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])
214+changesToDocTriple entryToDoc (Changes added changed removed) =
215+ let
216+ indented (name, value) =
217+ D.indent 4 (entryToDoc name value)
218+
219+ diffed (name, (oldValue, newValue)) =
220+ D.vcat
221+ [ " - " <> entryToDoc name oldValue
222+ , " + " <> entryToDoc name newValue
223+ , ""
224+ ]
225+ in
226+ ( map indented (Map.toList added)
227+ , map diffed (Map.toList changed)
228+ , map indented (Map.toList removed)
229+ )
230+
231+
232+changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc
233+changesToDoc categoryName unions aliases values binops =
234+ if null unions && null aliases && null values && null binops then
235+ Nothing
236+
237+ else
238+ Just $ D.vcat $
239+ D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values
240+
241+
242+unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc
243+unionToDoc localizer name (Docs.Union _ tvars ctors) =
244+ let
245+ setup =
246+ "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)
247+
248+ ctorDoc (ctor, tipes) =
249+ typeDoc localizer (Type.Type ctor tipes)
250+ in
251+ D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
252+
253+
254+aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc
255+aliasToDoc localizer name (Docs.Alias _ tvars tipe) =
256+ let
257+ declaration =
258+ "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="
259+ in
260+ D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])
261+
262+
263+valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc
264+valueToDoc localizer name (Docs.Value _ tipe) =
265+ D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]
266+
267+
268+binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc
269+binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
270+ "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details
271+ where
272+ details =
273+ " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"
274+
275+ assoc =
276+ case associativity of
277+ Docs.Left -> "left"
278+ Docs.Non -> "non"
279+ Docs.Right -> "right"
280+
281+
282+typeDoc :: L.Localizer -> Type.Type -> D.Doc
283+typeDoc localizer tipe =
284+ Type.toDoc localizer Type.None tipe
builder/src/Elm/Install.hsnew file+448
@@ -0,0 +1,448 @@
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+150−160
@@ -1,17 +1,18 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
3module Elm.Outline
3module Elm.Outline
4 ( Outline(..)
4 ( Outline(..)
5 , AppOutline(..)
5 , AppOutline(..)
6 , PkgOutline(..)
6 , PkgOutline(..)
7 , Exposed(..)
7 , Exposed(..)
8− , SrcDir(..)
9 , read
8 , read
10 , write
9 , write
11 , encode
10 , encode
12 , decoder
11 , decoder
13 , defaultSummary
12 , defaultSummary
14− , flattenExposed
13+ , isPlatformPackage
14+ , getName
15+ , getExposed
15 )
16 )
16 where
17 where
17
18
@@ -19,12 +20,10 @@ module Elm.Outline
19import Prelude hiding (read)
20import Prelude hiding (read)
20import Control.Monad (filterM, liftM)
21import Control.Monad (filterM, liftM)
21import Data.Binary (Binary, get, put, getWord8, putWord8)
22import Data.Binary (Binary, get, put, getWord8, putWord8)
23+import Data.Foldable (traverse_)
22import qualified Data.Map as Map
24import qualified Data.Map as Map
23−import qualified Data.NonEmptyList as NE
25+import qualified Data.Utf8 as Utf8
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
28import System.FilePath ((</>))
27import System.FilePath ((</>))
29
28
30import qualified Elm.Constraint as Con
29import qualified Elm.Constraint as Con
@@ -32,13 +31,10 @@ import qualified Elm.Licenses as Licenses
32import qualified Elm.ModuleName as ModuleName
31import qualified Elm.ModuleName as ModuleName
33import qualified Elm.Package as Pkg
32import qualified Elm.Package as Pkg
34import qualified Elm.Version as V
33import qualified Elm.Version as V
35−import qualified File
36import qualified Json.Decode as D
34import qualified Json.Decode as D
37import qualified Json.Encode as E
35import qualified Json.Encode as E
38−import Json.Encode ((==>))
39−import qualified Json.String as Json
40−import qualified Parse.Primitives as P
41import qualified Reporting.Exit as Exit
36import qualified Reporting.Exit as Exit
37+import qualified Reporting.Exit.Assets as E
42
38
43
39
44
40
@@ -53,7 +49,7 @@ data Outline
53data AppOutline =
49data AppOutline =
54 AppOutline
50 AppOutline
55 { _app_elm_version :: V.Version
51 { _app_elm_version :: V.Version
56− , _app_source_dirs :: NE.List SrcDir
52+ , _app_source_dirs :: [FilePath]
57 , _app_deps_direct :: Map.Map Pkg.Name V.Version
53 , _app_deps_direct :: Map.Map Pkg.Name V.Version
58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
54 , _app_deps_indirect :: Map.Map Pkg.Name V.Version
59 , _app_test_direct :: Map.Map Pkg.Name V.Version
55 , _app_test_direct :: Map.Map Pkg.Name V.Version
@@ -64,7 +60,7 @@ data AppOutline =
64data PkgOutline =
60data PkgOutline =
65 PkgOutline
61 PkgOutline
66 { _pkg_name :: Pkg.Name
62 { _pkg_name :: Pkg.Name
67− , _pkg_summary :: Json.String
63+ , _pkg_summary :: Utf8.String
68 , _pkg_license :: Licenses.License
64 , _pkg_license :: Licenses.License
69 , _pkg_version :: V.Version
65 , _pkg_version :: V.Version
70 , _pkg_exposed :: Exposed
66 , _pkg_exposed :: Exposed
@@ -76,29 +72,45 @@ data PkgOutline =
76
72
77data Exposed
73data Exposed
78 = ExposedList [ModuleName.Raw]
74 = ExposedList [ModuleName.Raw]
79− | ExposedDict [(Json.String, [ModuleName.Raw])]
75+ | ExposedDict [(Utf8.String, [ModuleName.Raw])]
80−
81−
82−data SrcDir
83− = AbsoluteSrcDir FilePath
84− | RelativeSrcDir FilePath
85
76
86
77
87
78
88-- DEFAULTS
79-- DEFAULTS
89
80
90
81
91−defaultSummary :: Json.String
82+defaultSummary :: Utf8.String
92defaultSummary =
83defaultSummary =
93− Json.fromChars "helpful summary of your project, less than 80 characters"
84+ "helpful summary of your project, less than 80 characters"
85+
86+
87+
88+-- QUERIES
89+
90+
91+isPlatformPackage :: Outline -> Bool
92+isPlatformPackage outline =
93+ case outline of
94+ App _ ->
95+ False
96+
97+ Pkg pkgOutline ->
98+ let author = Pkg._author (_pkg_name pkgOutline) in
99+ author == "elm" || author == "elm-explorations"
94
100
95
101
102+getName :: Outline -> Pkg.Name
103+getName outline =
104+ case outline of
105+ App _ ->
106+ Pkg.dummyName
96
107
97−-- HELPERS
108+ Pkg (PkgOutline name _ _ _ _ _ _ _) ->
109+ name
98
110
99
111
100−flattenExposed :: Exposed -> [ModuleName.Raw]
112+getExposed :: PkgOutline -> [ModuleName.Raw]
101−flattenExposed exposed =
113+getExposed (PkgOutline _ _ _ _ exposed _ _ _) =
102 case exposed of
114 case exposed of
103 ExposedList names ->
115 ExposedList names ->
104 names
116 names
@@ -125,8 +137,8 @@ encode outline =
125 case outline of
137 case outline of
126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
138 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
127 E.object
139 E.object
128− [ "type" ==> E.chars "application"
140+ [ "type" ==> E.string "application"
129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
141+ , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs
130 , "elm-version" ==> V.encode elm
142 , "elm-version" ==> V.encode elm
131 , "dependencies" ==>
143 , "dependencies" ==>
132 E.object
144 E.object
@@ -142,7 +154,7 @@ encode outline =
142
154
143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
155 Pkg (PkgOutline name summary license version exposed deps tests elm) ->
144 E.object
156 E.object
145− [ "type" ==> E.string (Json.fromChars "package")
157+ [ "type" ==> E.string "package"
146 , "name" ==> Pkg.encode name
158 , "name" ==> Pkg.encode name
147 , "summary" ==> E.string summary
159 , "summary" ==> E.string summary
148 , "license" ==> Licenses.encode license
160 , "license" ==> Licenses.encode license
@@ -154,6 +166,11 @@ encode outline =
154 ]
166 ]
155
167
156
168
169+(==>) :: a -> b -> (a, b)
170+(==>) a b =
171+ (a, b)
172+
173+
157encodeExposed :: Exposed -> E.Value
174encodeExposed :: Exposed -> E.Value
158encodeExposed exposed =
175encodeExposed exposed =
159 case exposed of
176 case exposed of
@@ -171,95 +188,35 @@ encodeModule name =
171
188
172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
189encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
173encodeDeps encodeValue deps =
190encodeDeps encodeValue deps =
174− E.dict Pkg.toJsonString encodeValue deps
191+ E.dict Pkg.toString encodeValue deps
175−
176−
177−encodeSrcDir :: SrcDir -> E.Value
178−encodeSrcDir srcDir =
179− case srcDir of
180− AbsoluteSrcDir dir -> E.chars dir
181− RelativeSrcDir dir -> E.chars dir
182
192
183
193
184
194
185-- PARSE AND VERIFY
195-- PARSE AND VERIFY
186
196
187
197
188−read :: FilePath -> IO (Either Exit.Outline Outline)
198+read :: FilePath -> IO (Either Exit.OutlineProblem Outline)
189read root =
199read root =
190− do bytes <- File.readUtf8 (root </> "elm.json")
200+ do result <- D.fromFile decoder (root </> "elm.json")
191− case D.fromByteString decoder bytes of
201+ case result of
192 Left err ->
202 Left err ->
193− return $ Left (Exit.OutlineHasBadStructure err)
203+ return $ Left (Exit.BadOutlineStructure err)
194
204
195 Right outline ->
205 Right outline ->
196 case outline of
206 case outline of
197− Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
207+ Pkg _ ->
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 ->
220− return $ Right outline
208+ return $ Right outline
221−
222− Just (canonicalDir, (dir1,dir2)) ->
223− return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
224−
225−
226−isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227−isSrcDirMissing root srcDir =
228− not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
229−
230−
231−toGiven :: SrcDir -> FilePath
232−toGiven srcDir =
233− case srcDir of
234− AbsoluteSrcDir dir -> dir
235− RelativeSrcDir dir -> dir
236−
237
209
238−toAbsolute :: FilePath -> SrcDir -> FilePath
210+ App (AppOutline _ srcDirs _ _ _ _) ->
239−toAbsolute root srcDir =
211+ do badDirs <- filterM (isBadSrcDir root) srcDirs
240− case srcDir of
212+ case badDirs of
241− AbsoluteSrcDir dir -> dir
213+ [] -> return $ Right outline
242− RelativeSrcDir dir -> root </> dir
214+ d:ds -> return $ Left (Exit.BadOutlineSrcDirs d ds)
243
215
244
216
245−detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
217+isBadSrcDir :: FilePath -> FilePath -> IO Bool
246−detectDuplicates root srcDirs =
218+isBadSrcDir root dir =
247− do pairs <- traverse (toPair root) srcDirs
219+ not <$> Dir.doesDirectoryExist (root </> dir)
248− return $ Map.lookupMin $ Map.mapMaybe isDup $
249− Map.fromListWith OneOrMore.more pairs
250−
251−
252−toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)
253−toPair root srcDir =
254− do key <- Dir.canonicalizePath (toAbsolute root srcDir)
255− return (key, OneOrMore.one (toGiven srcDir))
256−
257−
258−isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)
259−isDup paths =
260− case paths of
261− OneOrMore.One _ -> Nothing
262− OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)
263
220
264
221
265
222
@@ -267,26 +224,28 @@ isDup paths =
267
224
268
225
269type Decoder a =
226type Decoder a =
270− D.Decoder Exit.OutlineProblem a
227+ D.Decoder E.BadElmJsonContent a
271
228
272
229
273decoder :: Decoder Outline
230decoder :: Decoder Outline
274decoder =
231decoder =
275− let
276− application = Json.fromChars "application"
277− package = Json.fromChars "package"
278− in
279 do tipe <- D.field "type" D.string
232 do tipe <- D.field "type" D.string
233+ case tipe of
234+ "application" ->
280− if | tipe == application -> App <$> appDecoder
235+ App <$> appDecoder
236+
237+ "package" ->
281− | tipe == package -> Pkg <$> pkgDecoder
238+ Pkg <$> pkgDecoder
282− | otherwise -> D.failure Exit.OP_BadType
239+
240+ other ->
241+ D.failure (E.BadType other)
283
242
284
243
285appDecoder :: Decoder AppOutline
244appDecoder :: Decoder AppOutline
286appDecoder =
245appDecoder =
287 AppOutline
246 AppOutline
288 <$> D.field "elm-version" versionDecoder
247 <$> D.field "elm-version" versionDecoder
289− <*> D.field "source-directories" dirsDecoder
248+ <*> D.field "source-directories" (D.list dirDecoder)
290 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
249 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
291 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
250 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
292 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
251 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
@@ -296,9 +255,9 @@ appDecoder =
296pkgDecoder :: Decoder PkgOutline
255pkgDecoder :: Decoder PkgOutline
297pkgDecoder =
256pkgDecoder =
298 PkgOutline
257 PkgOutline
299− <$> D.field "name" nameDecoder
258+ <$> D.field "name" (D.mapError E.BadPkgName Pkg.decoder)
300 <*> D.field "summary" summaryDecoder
259 <*> D.field "summary" summaryDecoder
301− <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
260+ <*> D.field "license" (Licenses.decoder E.BadLicense)
302 <*> D.field "version" versionDecoder
261 <*> D.field "version" versionDecoder
303 <*> D.field "exposed-modules" exposedDecoder
262 <*> D.field "exposed-modules" exposedDecoder
304 <*> D.field "dependencies" (depsDecoder constraintDecoder)
263 <*> D.field "dependencies" (depsDecoder constraintDecoder)
@@ -310,43 +269,44 @@ pkgDecoder =
310-- JSON DECODE HELPERS
269-- JSON DECODE HELPERS
311
270
312
271
313−nameDecoder :: Decoder Pkg.Name
314−nameDecoder =
315− D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316−
317−
318−summaryDecoder :: Decoder Json.String
272+summaryDecoder :: Decoder Utf8.String
319summaryDecoder =
273summaryDecoder =
320− D.customString
274+ do summary <- D.string
321− (boundParser 80 Exit.OP_BadSummaryTooLong)
275+ if Utf8.size summary < 80
322− (\_ _ -> Exit.OP_BadSummaryTooLong)
276+ then return summary
277+ else D.failure E.BadSummaryTooLong
323
278
324
279
325versionDecoder :: Decoder V.Version
280versionDecoder :: Decoder V.Version
326versionDecoder =
281versionDecoder =
327− D.mapError (uncurry Exit.OP_BadVersion) V.decoder
282+ D.mapError E.BadVersion V.decoder
328
283
329
284
330constraintDecoder :: Decoder Con.Constraint
285constraintDecoder :: Decoder Con.Constraint
331constraintDecoder =
286constraintDecoder =
332− D.mapError Exit.OP_BadConstraint Con.decoder
287+ D.mapError E.BadConstraint Con.decoder
333
288
334
289
335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
290depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
336depsDecoder valueDecoder =
291depsDecoder valueDecoder =
337− D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
292+ Map.fromList <$> (
293+ traverse validateKey =<< D.pairs valueDecoder
294+ )
338
295
339
296
340−dirsDecoder :: Decoder (NE.List SrcDir)
297+validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)
341−dirsDecoder =
298+validateKey (key, value) =
342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
299+ case Pkg.fromString key of
300+ Right name ->
301+ return (name, value)
343
302
303+ Left _ ->
304+ D.failure (E.BadDependencyName key)
344
305
345−toSrcDir :: FilePath -> SrcDir
306+
346−toSrcDir path =
307+dirDecoder :: Decoder FilePath
347− if FP.isRelative path
308+dirDecoder =
348− then RelativeSrcDir path
309+ Utf8.toChars <$> D.string
349− else AbsoluteSrcDir path
350
310
351
311
352
312
@@ -357,51 +317,81 @@ exposedDecoder :: Decoder Exposed
357exposedDecoder =
317exposedDecoder =
358 D.oneOf
318 D.oneOf
359 [ ExposedList <$> D.list moduleDecoder
319 [ ExposedList <$> D.list moduleDecoder
360− , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
320+ , do pairs <- D.pairs (D.list moduleDecoder)
321+ traverse_ (checkHeader . fst) pairs
322+ return (ExposedDict pairs)
361 ]
323 ]
362
324
363
325
364moduleDecoder :: Decoder ModuleName.Raw
326moduleDecoder :: Decoder ModuleName.Raw
365moduleDecoder =
327moduleDecoder =
366− D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
328+ D.mapError E.BadModuleName ModuleName.decoder
367
329
368
330
369−headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
331+checkHeader :: Utf8.String -> Decoder ()
370−headerKeyDecoder =
332+checkHeader header =
371− D.KeyDecoder
333+ if Utf8.size header < 20
372− (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
334+ then return ()
373− (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
335+ else D.failure (E.BadModuleHeaderTooLong header)
374
336
375
337
376
338
377−-- BOUND PARSER
339+-- BINARY
378
340
379
341
380−boundParser :: Int -> x -> P.Parser x Json.String
342+instance Binary Outline where
381−boundParser bound tooLong =
343+ put outline =
382− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
344+ case outline of
383− let
345+ App a -> putWord8 0 >> put a
384− len = minusPtr end pos
346+ Pkg a -> putWord8 1 >> put a
385− newCol = col + fromIntegral len
386− in
387− if len < bound
388− then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)
389− else cerr row newCol (\_ _ -> tooLong)
390
347
348+ get =
349+ do n <- getWord8
350+ case n of
351+ 0 -> liftM App get
352+ 1 -> liftM Pkg get
353+ _ -> error "binary encoding of Outline was corrupted"
391
354
392
355
393−-- BINARY
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
394
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)
395
368
369+
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+
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+
396−instance Binary SrcDir where
386+instance Binary Exposed where
397− put outline =
387+ put exposed =
398− case outline of
388+ case exposed of
399− AbsoluteSrcDir a -> putWord8 0 >> put a
389+ ExposedList a -> putWord8 0 >> put a
400− RelativeSrcDir a -> putWord8 1 >> put a
390+ ExposedDict a -> putWord8 1 >> put a
401
391
402 get =
392 get =
403 do n <- getWord8
393 do n <- getWord8
404 case n of
394 case n of
405− 0 -> liftM AbsoluteSrcDir get
395+ 0 -> liftM ExposedList get
406− 1 -> liftM RelativeSrcDir get
396+ 1 -> liftM ExposedDict get
407− _ -> fail "binary encoding of SrcDir was corrupted"
397+ _ -> error "binary encoding of ProjectDeps was corrupted"
builder/src/Elm/PerUserCache.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Elm.PerUserCache
3+ ( getPackageRoot
4+ , getReplRoot
5+ , getElmHome
6+ )
7+ where
8+
9+import qualified System.Directory as Dir
10+import qualified System.Environment as Env
11+import System.FilePath ((</>))
12+
13+import qualified Elm.Version as V
14+
15+
16+
17+-- ROOTS
18+
19+
20+getPackageRoot :: IO FilePath
21+getPackageRoot =
22+ getRoot "package"
23+
24+
25+getReplRoot :: IO FilePath
26+getReplRoot =
27+ getRoot "repl"
28+
29+
30+getRoot :: FilePath -> IO FilePath
31+getRoot projectName =
32+ do home <- getElmHome
33+ let root = home </> version </> projectName
34+ Dir.createDirectoryIfMissing True root
35+ return root
36+
37+
38+version :: FilePath
39+version =
40+ V.toChars V.compiler
41+
42+
43+getElmHome :: IO FilePath
44+getElmHome =
45+ do maybeHome <- Env.lookupEnv "ELM_HOME"
46+ maybe (Dir.getAppUserDataDirectory "elm") return maybeHome
builder/src/Elm/Publish.hsnew file+255
@@ -0,0 +1,255 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Elm.Publish (publish) where
3+
4+
5+import Control.Monad (when)
6+import Control.Monad.Except (catchError, runExceptT)
7+import Control.Monad.Trans (liftIO, lift)
8+import qualified Data.List as List
9+import qualified Data.Utf8 as Utf8
10+import qualified System.Directory as Dir
11+import qualified System.Exit as Exit
12+import System.FilePath ((</>))
13+import qualified System.IO as IO
14+import qualified System.Process as Process
15+
16+import qualified Deps.Cache as Cache
17+import qualified Deps.Diff as Diff
18+import qualified Deps.Website as Website
19+import qualified Elm.Bump as Bump
20+import qualified Elm.Docs as Docs
21+import qualified Elm.Package as Pkg
22+import qualified Elm.Project.Json as Project
23+import qualified Elm.Project.Summary as Summary
24+import qualified Elm.Version as V
25+import qualified Reporting.Exit as Exit
26+import qualified Reporting.Exit.Publish as E
27+import qualified Reporting.Progress as Progress
28+import qualified Reporting.Task as Task
29+import qualified Stuff.Paths as Path
30+
31+
32+
33+-- PUBLISH
34+
35+
36+publish :: Summary.Summary -> Task.Task ()
37+publish summary@(Summary.Summary root project _ _ _) =
38+ case project of
39+ Project.App _ ->
40+ throw E.Application
41+
42+ Project.Pkg (Project.PkgInfo name smry _ version exposed _ _ _) ->
43+ do
44+ registry <- Cache.mandatoryUpdate
45+ let maybePublishedVersions = either (const Nothing) Just (Cache.getVersions name registry)
46+
47+ Task.report (Progress.PublishStart name version maybePublishedVersions)
48+
49+ when (noExposed exposed) $ throw E.NoExposed
50+ when (badSummary smry) $ throw E.NoSummary
51+
52+ verifyReadme root
53+ verifyLicense root
54+ docs <- Task.silently (error "TODO Project.generateDocs summary" summary)
55+ verifyVersion name version docs maybePublishedVersions
56+ commitHash <- verifyTag name version
57+ verifyNoChanges commitHash version
58+ zipHash <- verifyZip name version
59+
60+ Website.register name version commitHash zipHash
61+
62+ Task.report Progress.PublishEnd
63+
64+
65+throw :: E.Exit -> Task.Task a
66+throw exit =
67+ Task.throw (Exit.Publish exit)
68+
69+
70+
71+-- VERIFY SUMMARY
72+
73+
74+badSummary :: Utf8.String -> Bool
75+badSummary summary =
76+ Utf8.isEmpty summary || Project.defaultSummary == summary
77+
78+
79+noExposed :: Project.Exposed -> Bool
80+noExposed exposed =
81+ case exposed of
82+ Project.ExposedList modules ->
83+ null modules
84+
85+ Project.ExposedDict chunks ->
86+ all (null . snd) chunks
87+
88+
89+
90+-- VERIFY README
91+
92+
93+verifyReadme :: FilePath -> Task.Task ()
94+verifyReadme root =
95+ phase Progress.CheckReadme $
96+ do let readmePath = root </> "README.md"
97+ exists <- liftIO $ Dir.doesFileExist readmePath
98+ case exists of
99+ False ->
100+ throw E.NoReadme
101+
102+ True ->
103+ do size <- liftIO $ IO.withFile readmePath IO.ReadMode IO.hFileSize
104+ if size < 300
105+ then throw E.ShortReadme
106+ else return ()
107+
108+
109+
110+-- VERIFY LICENSE
111+
112+
113+verifyLicense :: FilePath -> Task.Task ()
114+verifyLicense root =
115+ phase Progress.CheckLicense $
116+ do let licensePath = root </> "LICENSE"
117+ exists <- liftIO $ Dir.doesFileExist licensePath
118+ if exists
119+ then return ()
120+ else throw E.NoLicense
121+
122+
123+
124+-- VERIFY GITHUB TAG
125+
126+
127+verifyTag :: Pkg.Name -> V.Version -> Task.Task String
128+verifyTag name version =
129+ phase (Progress.CheckTag version) $
130+ Website.githubCommit name version `catchError` \_ ->
131+ throw (E.MissingTag version)
132+
133+
134+
135+-- VERIFY NO LOCAL CHANGES SINCE TAG
136+
137+
138+verifyNoChanges :: String -> V.Version -> Task.Task ()
139+verifyNoChanges commitHash version =
140+ phase Progress.CheckChanges $
141+ do maybeGit <- liftIO $ Dir.findExecutable "git"
142+ case maybeGit of
143+ Nothing ->
144+ throw E.NoGit
145+
146+ Just git ->
147+ do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes
148+ exitCode <- liftIO $
149+ Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]
150+
151+ case exitCode of
152+ Exit.ExitSuccess ->
153+ return ()
154+
155+ Exit.ExitFailure _ ->
156+ throw (E.LocalChanges version)
157+
158+
159+
160+-- VERIFY THAT ZIP BUILDS / COMPUTE HASH
161+
162+
163+verifyZip :: Pkg.Name -> V.Version -> Task.Task Website.Sha
164+verifyZip name version =
165+ withTempDir $ \dir ->
166+ do hash <- phase Progress.CheckDownload $
167+ Website.githubDownload name version dir
168+
169+ phase Progress.CheckBuild $
170+ do runner <- Task.getSilentRunner
171+ result <- liftIO $ Dir.withCurrentDirectory dir $ runner $
172+ Task.silently $ error "TODO Project.generateDocs =<< Project.getRoot"
173+ either Task.throw (\_ -> return ()) result
174+
175+ return hash
176+
177+
178+withTempDir :: (FilePath -> Task.Task a) -> Task.Task a
179+withTempDir callback =
180+ do liftIO $ Dir.createDirectoryIfMissing True Path.prepublishDir
181+ result <- lift $ runExceptT $ callback Path.prepublishDir
182+ liftIO $ Dir.removeDirectoryRecursive Path.prepublishDir
183+ either Task.throw return result
184+
185+
186+
187+-- PHASE REPORTING
188+
189+
190+phase :: Progress.PublishPhase -> Task.Task a -> Task.Task a
191+phase publishPhase task =
192+ do Task.report $ Progress.PublishProgress publishPhase Nothing
193+
194+ result <- task `catchError` \exit ->
195+ do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)
196+ Task.throw exit
197+
198+ Task.report $ Progress.PublishProgress publishPhase (Just Progress.Good)
199+
200+ return result
201+
202+
203+
204+-- VERIFY VERSION
205+
206+
207+verifyVersion :: Pkg.Name -> V.Version -> Docs.Documentation -> Maybe [V.Version] -> Task.Task ()
208+verifyVersion name version docs maybePublishedVersions =
209+ let
210+ reportBumpPhase bumpPhase =
211+ Task.report $ Progress.PublishCheckBump version bumpPhase
212+ in
213+ do reportBumpPhase Progress.StatedVersion
214+ case maybePublishedVersions of
215+ Nothing ->
216+ if version == V.one then
217+ reportBumpPhase Progress.GoodStart
218+ else
219+ throw (E.NotInitialVersion version)
220+
221+ Just publishedVersions ->
222+ if elem version publishedVersions then
223+ throw $ E.AlreadyPublished version
224+ else
225+ do (old, magnitude) <- verifyBump name version docs publishedVersions
226+ reportBumpPhase (Progress.GoodBump old magnitude)
227+
228+ `catchError` \exit ->
229+ do reportBumpPhase Progress.BadBump
230+ Task.throw exit
231+
232+
233+verifyBump :: Pkg.Name -> V.Version -> Docs.Documentation -> [V.Version] -> Task.Task (V.Version, Diff.Magnitude)
234+verifyBump name statedVersion newDocs publishedVersions =
235+ let
236+ possibleBumps =
237+ Bump.toPossibleBumps publishedVersions
238+
239+ isTheBump (_ ,new, _) =
240+ statedVersion == new
241+ in
242+ case List.find isTheBump possibleBumps of
243+ Nothing ->
244+ throw $ E.InvalidBump statedVersion (last publishedVersions)
245+
246+ Just (old, new, magnitude) ->
247+ do oldDocs <- Cache.getDocs name old
248+ let changes = Diff.diff oldDocs newDocs
249+ let realNew = Diff.bump changes old
250+ if new == realNew
251+ then
252+ return (old, magnitude)
253+ else
254+ throw $ E.BadBump old new magnitude realNew $
255+ Diff.toMagnitude changes
builder/src/File.hs+17−67
@@ -1,13 +1,12 @@
1module File
1module File
2 ( Time
2 ( Time
3 , getTime
3 , getTime
4− , zeroTime
4+ , withLock
5 , writeBinary
5 , writeBinary
6 , readBinary
6 , readBinary
7 , writeUtf8
7 , writeUtf8
8 , readUtf8
8 , readUtf8
9 , writeBuilder
9 , writeBuilder
10− , writePackage
11 , exists
10 , exists
12 , remove
11 , remove
13 , removeDir
12 , removeDir
@@ -15,22 +14,18 @@ module File
15 where
14 where
16
15
17
16
18−import qualified Codec.Archive.Zip as Zip
19import Control.Exception (catch)
17import Control.Exception (catch)
20import qualified Data.Binary as Binary
18import qualified Data.Binary as Binary
21import qualified Data.ByteString as BS
19import qualified Data.ByteString as BS
22import qualified Data.ByteString.Internal as BS
20import qualified Data.ByteString.Internal as BS
23import qualified Data.ByteString.Builder as B
21import qualified Data.ByteString.Builder as B
24−import qualified Data.ByteString.Lazy as LBS
25import qualified Data.Fixed as Fixed
22import qualified Data.Fixed as Fixed
26−import qualified Data.List as List
27−import qualified Data.Time.Clock as Time
28import qualified Data.Time.Clock.POSIX as Time
23import qualified Data.Time.Clock.POSIX as Time
29import qualified Foreign.ForeignPtr as FPtr
24import qualified Foreign.ForeignPtr as FPtr
30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
25import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
31import qualified System.Directory as Dir
26import qualified System.Directory as Dir
27+import qualified System.FileLock as Lock
32import qualified System.FilePath as FP
28import qualified System.FilePath as FP
33−import System.FilePath ((</>))
34import qualified System.IO as IO
29import qualified System.IO as IO
35import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
30import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
36
31
@@ -46,21 +41,26 @@ newtype Time = Time Fixed.Pico
46getTime :: FilePath -> IO Time
41getTime :: FilePath -> IO Time
47getTime path =
42getTime path =
48 fmap
43 fmap
44+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)
49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
45+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
50 (Dir.getModificationTime path)
46 (Dir.getModificationTime path)
51
47
52
48
53−zeroTime :: Time
54−zeroTime =
55− Time 0
56−
57−
58instance Binary.Binary Time where
49instance Binary.Binary Time where
59 put (Time time) = Binary.put time
50 put (Time time) = Binary.put time
60 get = Time <$> Binary.get
51 get = Time <$> Binary.get
61
52
62
53
63
54
55+-- LOCK
56+
57+
58+withLock :: FilePath -> IO a -> IO a
59+withLock path work =
60+ Lock.withFileLock path Lock.Exclusive (\_ -> work)
61+
62+
63+
64-- BINARY
64-- BINARY
65
65
66
66
@@ -73,28 +73,10 @@ writeBinary path value =
73
73
74readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
74readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
75readBinary path =
75readBinary path =
76− do pathExists <- Dir.doesFileExist path
77− if pathExists
78− then
79− do result <- Binary.decodeFileOrFail path
76+ do result <- Binary.decodeFileOrFail path
80− case result of
77+ case result of
81− Right a ->
82− return (Just a)
78+ Right a -> return (Just a)
83−
84− Left (offset, message) ->
85− do IO.hPutStrLn IO.stderr $ unlines $
86− [ "+-------------------------------------------------------------------------------"
87− , "| Corrupt File: " ++ path
88− , "| Byte Offset: " ++ show offset
89− , "| Message: " ++ message
90− , "|"
91− , "| Please report this to https://github.com/elm/compiler/issues"
92− , "| Trying to continue anyway."
93− , "+-------------------------------------------------------------------------------"
94− ]
95− return Nothing
96− else
97− return Nothing
79+ Left _ -> return Nothing
98
80
99
81
100
82
@@ -171,38 +153,6 @@ writeBuilder path builder =
171
153
172
154
173
155
174−-- WRITE PACKAGE
175−
176−
177−writePackage :: FilePath -> Zip.Archive -> IO ()
178−writePackage destination archive =
179− case Zip.zEntries archive of
180− [] ->
181− return ()
182−
183− entry:entries ->
184− do let root = length (Zip.eRelativePath entry)
185− mapM_ (writeEntry destination root) entries
186−
187−
188−writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()
189−writeEntry destination root entry =
190− let
191− path = drop root (Zip.eRelativePath entry)
192− in
193− if List.isPrefixOf "src/" path
194− || path == "LICENSE"
195− || path == "README.md"
196− || path == "elm.json"
197− then
198− if not (null path) && last path == '/'
199− then Dir.createDirectoryIfMissing True (destination </> path)
200− else LBS.writeFile (destination </> path) (Zip.fromEntry entry)
201− else
202− return ()
203−
204−
205−
206-- EXISTS
156-- EXISTS
207
157
208
158
builder/src/Generate.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−module Generate
3− ( debug
4− , dev
5− , prod
6− , repl
7− )
8− where
9−
10−
11−import Prelude hiding (cycle, print)
12−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13−import Control.Monad (liftM2)
14−import qualified Data.ByteString.Builder as B
15−import Data.Map ((!))
16−import qualified Data.Map as Map
17−import qualified Data.Maybe as Maybe
18−import qualified Data.Name as N
19−import qualified Data.NonEmptyList as NE
20−
21−import qualified AST.Optimized as Opt
22−import qualified Build
23−import qualified Elm.Compiler.Type.Extract as Extract
24−import qualified Elm.Details as Details
25−import qualified Elm.Interface as I
26−import qualified Elm.ModuleName as ModuleName
27−import qualified Elm.Package as Pkg
28−import qualified File
29−import qualified Generate.JavaScript as JS
30−import qualified Generate.Mode as Mode
31−import qualified Nitpick.Debug as Nitpick
32−import qualified Reporting.Exit as Exit
33−import qualified Reporting.Task as Task
34−import qualified Stuff
35−
36−
37−-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38−-- desireable to have Repl and Reactor to keep foreign objects in memory
39−-- to make things a bit faster?
40−
41−
42−
43−-- GENERATORS
44−
45−
46−type Task a =
47− Task.Task Exit.Generate a
48−
49−
50−debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51−debug root details (Build.Artifacts pkg ifaces roots modules) =
52− do loading <- loadObjects root details modules
53− types <- loadTypes root ifaces modules
54− objects <- finalizeObjects loading
55− let mode = Mode.Dev (Just types)
56− let graph = objectsToGlobalGraph objects
57− let mains = gatherMains pkg objects roots
58− return $ JS.generate mode graph mains
59−
60−
61−dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62−dev root details (Build.Artifacts pkg _ roots modules) =
63− do objects <- finalizeObjects =<< loadObjects root details modules
64− let mode = Mode.Dev Nothing
65− let graph = objectsToGlobalGraph objects
66− let mains = gatherMains pkg objects roots
67− return $ JS.generate mode graph mains
68−
69−
70−prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71−prod root details (Build.Artifacts pkg _ roots modules) =
72− do objects <- finalizeObjects =<< loadObjects root details modules
73− checkForDebugUses objects
74− let graph = objectsToGlobalGraph objects
75− let mode = Mode.Prod (Mode.shortenFieldNames graph)
76− let mains = gatherMains pkg objects roots
77− return $ JS.generate mode graph mains
78−
79−
80−repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81−repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82− do objects <- finalizeObjects =<< loadObjects root details modules
83− let graph = objectsToGlobalGraph objects
84− return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85−
86−
87−
88−-- CHECK FOR DEBUG
89−
90−
91−checkForDebugUses :: Objects -> Task ()
92−checkForDebugUses (Objects _ locals) =
93− case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94− [] -> return ()
95− m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96−
97−
98−
99−-- GATHER MAINS
100−
101−
102−gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103−gatherMains pkg (Objects _ locals) roots =
104− Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105−
106−
107−lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108−lookupMain pkg locals root =
109− let
110− toPair name (Opt.LocalGraph maybeMain _ _) =
111− (,) (ModuleName.Canonical pkg name) <$> maybeMain
112− in
113− case root of
114− Build.Inside name -> toPair name =<< Map.lookup name locals
115− Build.Outside name _ g -> toPair name g
116−
117−
118−
119−-- LOADING OBJECTS
120−
121−
122−data LoadingObjects =
123− LoadingObjects
124− { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125− , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126− }
127−
128−
129−loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130−loadObjects root details modules =
131− Task.io $
132− do mvar <- Details.loadObjects root details
133− mvars <- traverse (loadObject root) modules
134− return $ LoadingObjects mvar (Map.fromList mvars)
135−
136−
137−loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138−loadObject root modul =
139− case modul of
140− Build.Fresh name _ graph ->
141− do mvar <- newMVar (Just graph)
142− return (name, mvar)
143−
144− Build.Cached name _ _ ->
145− do mvar <- newEmptyMVar
146− _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147− return (name, mvar)
148−
149−
150−
151−-- FINALIZE OBJECTS
152−
153−
154−data Objects =
155− Objects
156− { _foreign :: Opt.GlobalGraph
157− , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158− }
159−
160−
161−finalizeObjects :: LoadingObjects -> Task Objects
162−finalizeObjects (LoadingObjects mvar mvars) =
163− Task.eio id $
164− do result <- readMVar mvar
165− results <- traverse readMVar mvars
166− case liftM2 Objects result (sequence results) of
167− Just loaded -> return (Right loaded)
168− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169−
170−
171−objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172−objectsToGlobalGraph (Objects globals locals) =
173− foldr Opt.addLocalGraph globals locals
174−
175−
176−
177−-- LOAD TYPES
178−
179−
180−loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181−loadTypes root ifaces modules =
182− Task.eio id $
183− do mvars <- traverse (loadTypesHelp root) modules
184− let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185− results <- traverse readMVar mvars
186− case sequence results of
187− Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189−
190−
191−loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192−loadTypesHelp root modul =
193− case modul of
194− Build.Fresh name iface _ ->
195− newMVar (Just (Extract.fromInterface name iface))
196−
197− Build.Cached name _ ciMVar ->
198− do cachedInterface <- readMVar ciMVar
199− case cachedInterface of
200− Build.Unneeded ->
201− do mvar <- newEmptyMVar
202− _ <- forkIO $
203− do maybeIface <- File.readBinary (Stuff.elmi root name)
204− putMVar mvar (Extract.fromInterface name <$> maybeIface)
205− return mvar
206−
207− Build.Loaded iface ->
208− newMVar (Just (Extract.fromInterface name iface))
209−
210− Build.Corrupted ->
211− newMVar Nothing
builder/src/Http.hs+115−86
@@ -3,21 +3,22 @@ module Http
3 ( Manager
3 ( Manager
4 , getManager
4 , getManager
5 , toUrl
5 , toUrl
6− -- fetch
7− , get
8 , post
6 , post
7+ , post'
9 , Header
8 , Header
10 , accept
9 , accept
11− , Error(..)
10+ , Timeout(..)
12− -- archives
11+ , Body(..)
13− , Sha
12+ , Multi.Part
14− , shaToChars
15− , getArchive
16− -- upload
17− , upload
18 , filePart
13 , filePart
19− , jsonPart
20 , stringPart
14 , stringPart
15+ , BodyReader
16+ , readByteString
17+ , Sha
18+ , shaToChars
19+ , readArchive
20+ , writeArchive
21+ , Error(..)
21 )
22 )
22 where
23 where
23
24
@@ -27,7 +28,6 @@ import qualified Codec.Archive.Zip as Zip
27import Control.Exception (SomeException, handle)
28import Control.Exception (SomeException, handle)
28import qualified Data.Binary as Binary
29import qualified Data.Binary as Binary
29import qualified Data.Binary.Get as Binary
30import qualified Data.Binary.Get as Binary
30−import qualified Data.ByteString.Builder as B
31import qualified Data.ByteString.Char8 as BS
31import qualified Data.ByteString.Char8 as BS
32import qualified Data.Digest.Pure.SHA as SHA
32import qualified Data.Digest.Pure.SHA as SHA
33import qualified Data.String as String
33import qualified Data.String as String
@@ -35,11 +35,10 @@ import Network.HTTP (urlEncodeVars)
35import Network.HTTP.Client
35import Network.HTTP.Client
36import Network.HTTP.Client.TLS (tlsManagerSettings)
36import Network.HTTP.Client.TLS (tlsManagerSettings)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38−import Network.HTTP.Types.Method (Method, methodGet, methodPost)
38+import Network.HTTP.Types.Method (methodPost)
39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
40import qualified Network.HTTP.Client.MultipartFormData as Multi
39import qualified Network.HTTP.Client.MultipartFormData as Multi
40+import qualified System.Directory as Dir
41
41
42−import qualified Json.Encode as Encode
43import qualified Elm.Version as V
42import qualified Elm.Version as V
44
43
45
44
@@ -64,27 +63,23 @@ toUrl url params =
64
63
65
64
66
65
67−-- FETCH
66+-- POST
68
67
69
68
70−get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
69+post
71−get =
70+ :: Manager
72− fetch methodGet
71+ -> String
73−
72+ -> [Header]
74−
73+ -> (Error -> e)
75−post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
74+ -> (BS.ByteString -> IO (Either e a))
76−post =
75+ -> IO (Either e a)
77− fetch methodPost
78−
79−
80−fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
81−fetch methodVerb manager url headers onError onSuccess =
76+post manager url headers onError onSuccess =
82 handle (handleSomeException url onError) $
77 handle (handleSomeException url onError) $
83 handle (handleHttpException url onError) $
78 handle (handleHttpException url onError) $
84 do req0 <- parseUrlThrow url
79 do req0 <- parseUrlThrow url
85 let req1 =
80 let req1 =
86 req0
81 req0
87− { method = methodVerb
82+ { method = methodPost
88 , requestHeaders = addDefaultHeaders headers
83 , requestHeaders = addDefaultHeaders headers
89 }
84 }
90 withResponse req1 manager $ \response ->
85 withResponse req1 manager $ \response ->
@@ -92,6 +87,33 @@ fetch methodVerb manager url headers onError onSuccess =
92 onSuccess (BS.concat chunks)
87 onSuccess (BS.concat chunks)
93
88
94
89
90+post'
91+ :: Manager
92+ -> String
93+ -> [Header]
94+ -> Timeout
95+ -> Body
96+ -> (Error -> e)
97+ -> (BodyReader -> IO (Either e a))
98+ -> IO (Either e a)
99+post' manager url headers timeout body onError onSuccess =
100+ handle (handleSomeException url onError) $
101+ handle (handleHttpException url onError) $
102+ do req0 <- parseUrlThrow url
103+ req1 <-
104+ addBody body $
105+ addTimeout timeout $
106+ req0
107+ { method = methodPost
108+ , requestHeaders = addDefaultHeaders headers
109+ }
110+ withResponse req1 manager (onSuccess . responseBody)
111+
112+
113+
114+-- HEADERS
115+
116+
95addDefaultHeaders :: [Header] -> [Header]
117addDefaultHeaders :: [Header] -> [Header]
96addDefaultHeaders headers =
118addDefaultHeaders headers =
97 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
119 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
@@ -109,6 +131,54 @@ accept mime =
109
131
110
132
111
133
134+-- TIMEOUT
135+
136+
137+data Timeout
138+ = DefaultTimeout
139+ | NeverTimeout
140+
141+
142+addTimeout :: Timeout -> Request -> Request
143+addTimeout timeout req =
144+ case timeout of
145+ DefaultTimeout ->
146+ req
147+
148+ NeverTimeout ->
149+ req { responseTimeout = responseTimeoutNone }
150+
151+
152+
153+-- BODY
154+
155+
156+data Body
157+ = NoBody
158+ | FormDataBody [Multi.Part]
159+
160+
161+addBody :: Body -> Request -> IO Request
162+addBody body req =
163+ case body of
164+ NoBody ->
165+ return req
166+
167+ FormDataBody parts ->
168+ Multi.formDataBody parts req
169+
170+
171+filePart :: String -> FilePath -> Multi.Part
172+filePart name filePath =
173+ Multi.partFileSource (String.fromString name) filePath
174+
175+
176+stringPart :: String -> String -> Multi.Part
177+stringPart name string =
178+ Multi.partBS (String.fromString name) (BS.pack string)
179+
180+
181+
112-- EXCEPTIONS
182-- EXCEPTIONS
113
183
114
184
@@ -134,7 +204,12 @@ handleSomeException url onError exception =
134
204
135
205
136
206
137−-- SHA
207+-- BODY READERS
208+
209+
210+readByteString :: BodyReader -> IO BS.ByteString
211+readByteString bodyReader =
212+ BS.concat <$> brConsume bodyReader
138
213
139
214
140type Sha = SHA.Digest SHA.SHA1State
215type Sha = SHA.Digest SHA.SHA1State
@@ -145,33 +220,6 @@ shaToChars =
145 SHA.showDigest
220 SHA.showDigest
146
221
147
222
148−
149−-- FETCH ARCHIVE
150−
151−
152−getArchive
153− :: Manager
154− -> String
155− -> (Error -> e)
156− -> e
157− -> ((Sha, Zip.Archive) -> IO (Either e a))
158− -> IO (Either e a)
159−getArchive manager url onError err onSuccess =
160− handle (handleSomeException url onError) $
161− handle (handleHttpException url onError) $
162− do req0 <- parseUrlThrow url
163− let req1 =
164− req0
165− { method = methodGet
166− , requestHeaders = addDefaultHeaders []
167− }
168− withResponse req1 manager $ \response ->
169− do result <- readArchive (responseBody response)
170− case result of
171− Nothing -> return (Left err)
172− Just shaAndArchive -> onSuccess shaAndArchive
173−
174−
175readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
223readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
176readArchive body =
224readArchive body =
177 readArchiveHelp body $
225 readArchiveHelp body $
@@ -206,39 +254,20 @@ readArchiveHelp body (AS len sha zip) =
206
254
207
255
208
256
209−-- UPLOAD
257+-- WRITE ARCHIVE
210
258
211
259
212−upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
260+writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
213−upload manager url parts =
261+writeArchive archive destination newRoot =
214− handle (handleSomeException url id) $
262+ do Dir.createDirectoryIfMissing True destination
215− handle (handleHttpException url id) $
263+ let opts = [Zip.OptDestination destination]
216− do req0 <- parseUrlThrow url
264+ mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)
217− req1 <-
218− Multi.formDataBody parts $
219− req0
220− { method = methodPost
221− , requestHeaders = addDefaultHeaders []
222− , responseTimeout = responseTimeoutNone
223− }
224− withResponse req1 manager $ \_ ->
225− return (Right ())
226−
227−
228−filePart :: String -> FilePath -> Multi.Part
229−filePart name filePath =
230− Multi.partFileSource (String.fromString name) filePath
231
265
232
266
233−jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
267+replaceRoot :: String -> Zip.Entry -> Zip.Entry
234−jsonPart name filePath value =
268+replaceRoot root entry =
235 let
269 let
236− body =
270+ rootless =
237− Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
271+ dropWhile (/='/') (Zip.eRelativePath entry)
238 in
272 in
239− Multi.partFileRequestBody (String.fromString name) filePath body
273+ entry { Zip.eRelativePath = root ++ rootless }
240−
241−
242−stringPart :: String -> String -> Multi.Part
243−stringPart name string =
244− Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hsdeleted−474
@@ -1,474 +0,0 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2−module Reporting
3− ( Style
4− , silent
5− , json
6− , terminal
7− --
8− , attempt
9− , attemptWithStyle
10− --
11− , Key
12− , report
13− , ignorer
14− , ask
15− --
16− , DKey
17− , DMsg(..)
18− , trackDetails
19− --
20− , BKey
21− , BMsg(..)
22− , trackBuild
23− --
24− , reportGenerate
25− )
26− where
27−
28−
29−import Control.Concurrent
30−import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
31−import Control.Monad (when)
32−import qualified Data.ByteString.Builder as B
33−import qualified Data.NonEmptyList as NE
34−import qualified System.Exit as Exit
35−import qualified System.Info as Info
36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
37−
38−import qualified Elm.ModuleName as ModuleName
39−import qualified Elm.Package as Pkg
40−import qualified Elm.Version as V
41−import qualified Json.Encode as Encode
42−import Reporting.Doc ((<+>), (<>))
43−import qualified Reporting.Doc as D
44−import qualified Reporting.Exit as Exit
45−import qualified Reporting.Exit.Help as Help
46−
47−
48−
49−-- STYLE
50−
51−
52−data Style
53− = Silent
54− | Json
55− | Terminal (MVar ())
56−
57−
58−silent :: Style
59−silent =
60− Silent
61−
62−
63−json :: Style
64−json =
65− Json
66−
67−
68−terminal :: IO Style
69−terminal =
70− Terminal <$> newMVar ()
71−
72−
73−
74−-- ATTEMPT
75−
76−
77−attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
78−attempt toReport work =
79− do result <- work `catch` reportExceptionsNicely
80− case result of
81− Right a ->
82− return a
83−
84− Left x ->
85− do Exit.toStderr (toReport x)
86− Exit.exitFailure
87−
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−
105− Terminal mvar ->
106− do readMVar mvar
107− Exit.toStderr (toReport x)
108− Exit.exitFailure
109−
110−
111−
112−-- MARKS
113−
114−
115−goodMark :: D.Doc
116−goodMark =
117− D.green $ if isWindows then "+" else "●"
118−
119−
120−badMark :: D.Doc
121−badMark =
122− D.red $ if isWindows then "X" else "✗"
123−
124−
125−isWindows :: Bool
126−isWindows =
127− Info.os == "mingw32"
128−
129−
130−
131−-- KEY
132−
133−
134−newtype Key msg = Key (msg -> IO ())
135−
136−
137−report :: Key msg -> msg -> IO ()
138−report (Key send) msg =
139− send msg
140−
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−
170−
171−-- DETAILS
172−
173−
174−type DKey = Key DMsg
175−
176−
177−trackDetails :: Style -> (DKey -> IO a) -> IO a
178−trackDetails style callback =
179− case style of
180− Silent ->
181− callback (Key (\_ -> return ()))
182−
183− Json ->
184− callback (Key (\_ -> return ()))
185−
186− Terminal mvar ->
187− do chan <- newChan
188−
189− _ <- forkIO $
190− do takeMVar mvar
191− detailsLoop chan (DState 0 0 0 0 0 0 0)
192− putMVar mvar ()
193−
194− answer <- callback (Key (writeChan chan . Just))
195− writeChan chan Nothing
196− return answer
197−
198−
199−detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
200−detailsLoop chan state@(DState total _ _ _ _ built _) =
201− do msg <- readChan chan
202− case msg of
203− Just dmsg ->
204− detailsLoop chan =<< detailsStep dmsg state
205−
206− Nothing ->
207− putStrLn $ clear (toBuildProgress total total) $
208− if built == total
209− then "Dependencies ready!"
210− else "Dependency problem!"
211−
212−
213−data DState =
214− DState
215− { _total :: !Int
216− , _cached :: !Int
217− , _requested :: !Int
218− , _received :: !Int
219− , _failed :: !Int
220− , _built :: !Int
221− , _broken :: !Int
222− }
223−
224−
225−data DMsg
226− = DStart Int
227− | DCached
228− | DRequested
229− | DReceived Pkg.Name V.Version
230− | DFailed Pkg.Name V.Version
231− | DBuilt
232− | DBroken
233−
234−
235−detailsStep :: DMsg -> DState -> IO DState
236−detailsStep msg (DState total cached rqst rcvd failed built broken) =
237− case msg of
238− DStart numDependencies ->
239− return (DState numDependencies 0 0 0 0 0 0)
240−
241− DCached ->
242− putTransition (DState total (cached + 1) rqst rcvd failed built broken)
243−
244− DRequested ->
245− do when (rqst == 0) (putStrLn "Starting downloads...\n")
246− return (DState total cached (rqst + 1) rcvd failed built broken)
247−
248− DReceived pkg vsn ->
249− do putDownload goodMark pkg vsn
250− putTransition (DState total cached rqst (rcvd + 1) failed built broken)
251−
252− DFailed pkg vsn ->
253− do putDownload badMark pkg vsn
254− putTransition (DState total cached rqst rcvd (failed + 1) built broken)
255−
256− DBuilt ->
257− putBuilt (DState total cached rqst rcvd failed (built + 1) broken)
258−
259− DBroken ->
260− putBuilt (DState total cached rqst rcvd failed built (broken + 1))
261−
262−
263−putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
264−putDownload mark pkg vsn =
265− Help.toStdout $ D.indent 2 $
266− mark
267− <+> D.fromPackage pkg
268− <+> D.fromVersion vsn
269− <> "\n"
270−
271−
272−putTransition :: DState -> IO DState
273−putTransition state@(DState total cached _ rcvd failed built broken) =
274− if cached + rcvd + failed < total then
275− return state
276−
277− else
278− do let char = if rcvd + failed == 0 then '\r' else '\n'
279− putStrFlush (char : toBuildProgress (built + broken + failed) total)
280− return state
281−
282−
283−putBuilt :: DState -> IO DState
284−putBuilt state@(DState total cached _ rcvd failed built broken) =
285− do when (total == cached + rcvd + failed) $
286− putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
287− return state
288−
289−
290−toBuildProgress :: Int -> Int -> [Char]
291−toBuildProgress built total =
292− "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"
293−
294−
295−clear :: [Char] -> [Char] -> [Char]
296−clear before after =
297− '\r' : replicate (length before) ' ' ++ '\r' : after
298−
299−
300−
301−-- BUILD
302−
303−
304−type BKey = Key BMsg
305−
306−type BResult a = Either Exit.BuildProblem a
307−
308−
309−trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
310−trackBuild style callback =
311− case style of
312− Silent ->
313− callback (Key (\_ -> return ()))
314−
315− Json ->
316− callback (Key (\_ -> return ()))
317−
318− Terminal mvar ->
319− do chan <- newChan
320−
321− _ <- forkIO $
322− do takeMVar mvar
323− putStrFlush "Compiling ..."
324− buildLoop chan 0
325− putMVar mvar ()
326−
327− result <- callback (Key (writeChan chan . Left))
328− writeChan chan (Right result)
329− return result
330−
331−
332−data BMsg
333− = BDone
334−
335−
336−buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
337−buildLoop chan done =
338− do msg <- readChan chan
339− case msg of
340− Left BDone ->
341− do let !done1 = done + 1
342− putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
343− buildLoop chan done1
344−
345− Right result ->
346− let
347− !message = toFinalMessage done result
348− !width = 12 + length (show done)
349− in
350− putStrLn $
351− if length message < width
352− then '\r' : replicate width ' ' ++ '\r' : message
353− else '\r' : message
354−
355−
356−toFinalMessage :: Int -> BResult a -> [Char]
357−toFinalMessage done result =
358− case result of
359− Right _ ->
360− case done of
361− 0 -> "Success!"
362− 1 -> "Success! Compiled 1 module."
363− n -> "Success! Compiled " ++ show n ++ " modules."
364−
365− Left problem ->
366− case problem of
367− Exit.BuildBadModules _ _ [] ->
368− "Detected problems in 1 module."
369−
370− Exit.BuildBadModules _ _ (_:ps) ->
371− "Detected problems in " ++ show (2 + length ps) ++ " modules."
372−
373− Exit.BuildProjectProblem _ ->
374− "Detected a problem."
375−
376−
377−
378−-- GENERATE
379−
380−
381−reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
382−reportGenerate style names output =
383− case style of
384− Silent ->
385− return ()
386−
387− Json ->
388− return ()
389−
390− Terminal mvar ->
391− do readMVar mvar
392− let cnames = fmap ModuleName.toChars names
393− putStrLn ('\n' : toGenDiagram cnames output)
394−
395−
396−toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
397−toGenDiagram (NE.List name names) output =
398− let
399− width = 3 + foldr (max . length) (length name) names
400− in
401− case names of
402− [] ->
403− toGenLine width name ('>' : ' ' : output ++ "\n")
404−
405− _:_ ->
406− unlines $
407− toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
408− : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
409−
410−
411−toGenLine :: Int -> [Char] -> [Char] -> [Char]
412−toGenLine width name end =
413− " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end
414−
415−
416−hbar :: Char
417−hbar = if isWindows then '-' else '─'
418−
419−vtop :: Char
420−vtop = if isWindows then '+' else '┬'
421−
422−vmiddle :: Char
423−vmiddle = if isWindows then '+' else '┤'
424−
425−vbottom :: Char
426−vbottom = if isWindows then '+' else '┘'
427−
428−
429−--
430−
431−
432−putStrFlush :: String -> IO ()
433−putStrFlush str =
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+64−2015
@@ -1,27 +1,6 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Exit
2module Reporting.Exit
3− ( Init(..), initToReport
3+ ( Exit(..)
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− --
25 , toString
4 , toString
26 , toStderr
5 , toStderr
27 , toJson
6 , toJson
@@ -29,1579 +8,66 @@ module Reporting.Exit
29 where
8 where
30
9
31
10
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
46import qualified Elm.ModuleName as ModuleName
11import 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
52import qualified Json.Encode as Encode
12import 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 ((<>))
57import qualified Reporting.Doc as D
13import qualified Reporting.Doc as D
58−import qualified Reporting.Error.Import as Import
14+import qualified Reporting.Exit.Assets as Asset
15+import qualified Reporting.Exit.Bump as Bump
16+import qualified Reporting.Exit.Compile as Compile
17+import qualified Reporting.Exit.Crawl as Crawl
18+import qualified Reporting.Exit.Deps as Deps
59−import qualified Reporting.Error.Json as Json
19+import qualified Reporting.Exit.Diff as Diff
60import qualified Reporting.Exit.Help as Help
20import qualified Reporting.Exit.Help as Help
61−import qualified Reporting.Error as Error
21+import qualified Reporting.Exit.Http as Http
62−import qualified Reporting.Render.Code as Code
22+import qualified Reporting.Exit.Make as Make
63−
23+import qualified Reporting.Exit.Init as Init
64−
24+import qualified Reporting.Exit.Install as Install
65−
25+import qualified Reporting.Exit.Publish as Publish
66−-- RENDERERS
67−
68−
69−toString :: Help.Report -> String
70−toString report =
71− Help.toString (Help.reportToDoc report)
72−
73−
74−toStderr :: Help.Report -> IO ()
75−toStderr report =
76− Help.toStderr (Help.reportToDoc report)
77−
78−
79−toJson :: Help.Report -> Encode.Value
80−toJson report =
81− Help.reportToJson report
82−
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
26
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
27
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
28
648− PublishZipNoExposed ->
29+-- ALL POSSIBLE ERRORS
649− badZipReport
650
30
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
31
32+data Exit
33+ = NoElmJson
34+ | Assets Asset.Exit
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
677
46
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
47
689
48
49+-- RENDERERS
690
50
691−-- DOCS
692−
693−
694−data DocsProblem
695− = DP_Http Http.Error
696− | DP_Data String BS.ByteString
697− | DP_Cache
698−
699−
700−toDocsProblemReport :: DocsProblem -> String -> Help.Report
701−toDocsProblemReport problem context =
702− case problem of
703− DP_Http httpError ->
704− toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705−
706− DP_Data url body ->
707− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708− [ D.indent 4 $ D.dullyellow $ D.fromChars url
709− , D.reflow $
710− "I got the data back, but it was not what I was expecting. The response\
711− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713− , D.indent 4 $ D.dullyellow $ D.fromChars $
714− if BS.length body <= 76
715− then BS_UTF8.toString body
716− else take 73 (BS_UTF8.toString body) ++ "..."
717− , D.reflow $
718− "Does this error keep showing up? Maybe there is something weird with your\
719− \ internet connection. We have gotten reports that schools, businesses,\
720− \ airports, etc. sometimes intercept requests and add things to the body\
721− \ or change its contents entirely. Could that be the problem?"
722− ]
723−
724− DP_Cache ->
725− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726− [ D.reflow $
727− "I deleted the cached version, so the next run should download a fresh copy of\
728− \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729− \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730− \ for some reason."
731− ]
732
51
52+toString :: Exit -> String
53+toString exit =
54+ Help.toString (Help.reportToDoc (toReport exit))
733
55
734
56
735−-- INSTALL
57+toStderr :: Exit -> IO ()
58+toStderr exit =
59+ Help.toStderr (Help.reportToDoc (toReport exit))
736
60
737
61
738−data Install
62+toJson :: Exit -> Encode.Value
739− = InstallNoOutline
63+toJson exit =
740− | InstallBadOutline Outline
64+ Help.reportToJson (toReport exit)
741− | InstallBadRegistry RegistryProblem
742− | InstallNoArgs FilePath
743− | InstallNoOnlineAppSolution Pkg.Name
744− | InstallNoOfflineAppSolution Pkg.Name
745− | InstallNoOnlinePkgSolution Pkg.Name
746− | InstallNoOfflinePkgSolution Pkg.Name
747− | InstallHadSolverTrouble Solver
748− | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749− | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750− | InstallBadDetails Details
751
65
752
66
753−installToReport :: Install -> Help.Report
67+toReport :: Exit -> Help.Report
754−installToReport exit =
68+toReport exit =
755 case exit of
69 case exit of
756− InstallNoOutline ->
70+ NoElmJson ->
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 ->
1605 Help.report "NO elm.json FILE" Nothing
71 Help.report "NO elm.json FILE" Nothing
1606 "It looks like you are starting a new Elm project. Very exciting! Try running:"
72 "It looks like you are starting a new Elm project. Very exciting! Try running:"
1607 [ D.indent 4 $ D.green $ "elm init"
73 [ D.indent 4 $ D.green $ "elm init"
@@ -1609,461 +75,44 @@ makeToReport make =
1609 "It will help you get set up. It is really simple!"
75 "It will help you get set up. It is really simple!"
1610 ]
76 ]
1611
77
1612− MakeCannotOptimizeAndDebug ->
78+ Assets assetExit ->
1613− Help.docReport "CLASHING FLAGS" Nothing
79+ Asset.toReport assetExit
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− ]
1819
80
1820− BP_MainPathDuplicate path1 path2 ->
81+ Bump bumpExit ->
1821− Help.report "CONFUSING FILES" Nothing
82+ Bump.toReport bumpExit
1822− "You are telling me to compile these two files:"
1823− [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]
1824− , D.reflow $
1825− if path1 == path2 then
1826− "Why are you telling me twice? Is something weird going on with a script?\
1827− \ I figured I would let you know about it just in case something is wrong.\
1828− \ Only list it once and you should be all set!"
1829− else
1830− "But seem to be the same file though... It makes me think something tricky is\
1831− \ going on with symlinks in your project, so I figured I would let you know\
1832− \ about it just in case. Remove one of these files from your command to get\
1833− \ unstuck!"
1834− ]
1835−
1836− BP_RootNameDuplicate name outsidePath otherPath ->
1837− Help.report "MODULE NAME CLASH" Nothing
1838− "These two files are causing a module name clash:"
1839− [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]
1840− , D.reflow $
1841− "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\
1842− \ at the top, but they cannot have the same name!"
1843− , D.reflow $
1844− "Try changing to a different module name in one of them!"
1845− ]
1846
83
1847− BP_RootNameInvalid givenPath srcDir _ ->
84+ Compile e es ->
1848− Help.report "UNEXPECTED FILE NAME" Nothing
85+ Help.compilerReport e es
1849− "I am having trouble with this file name:"
1850− [ D.indent 4 $ D.red $ D.fromChars givenPath
1851− , D.reflow $
1852− "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\
1853− \ which is good, but I expect all of the files in there to use the following\
1854− \ module naming convention:"
1855− , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]
1856− , D.reflow $
1857− "Notice that the names always start with capital letters! Can you make your file\
1858− \ use this naming convention?"
1859− , D.toSimpleNote $
1860− "Having a strict naming convention like this makes it a lot easier to find\
1861− \ things in large projects. If you see a module imported, you know where to look\
1862− \ for the corresponding file every time!"
1863− ]
1864
86
1865− BP_CannotLoadDependencies ->
87+ Crawl crawlExit ->
1866− corruptCacheReport
88+ Crawl.toReport crawlExit
1867
89
1868− BP_Cycle name names ->
90+ Cycle names ->
1869 Help.report "IMPORT CYCLE" Nothing
91 Help.report "IMPORT CYCLE" Nothing
1870 "Your module imports form a cycle:"
92 "Your module imports form a cycle:"
1871− [ D.cycle 4 name names
93+ [ D.cycle 4 names
1872 , D.reflow $
94 , D.reflow $
1873 "Learn more about why this is disallowed and how to break cycles here:"
95 "Learn more about why this is disallowed and how to break cycles here:"
1874 ++ D.makeLink "import-cycles"
96 ++ D.makeLink "import-cycles"
1875 ]
97 ]
1876
98
1877− BP_MissingExposed (NE.List (name, problem) _) ->
99+ Deps depsExit ->
1878− case problem of
100+ Deps.toReport depsExit
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
2052
101
2053− ReplBadInput source err ->
102+ Diff commandsExit ->
2054− Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
103+ Diff.toReport commandsExit
2055
104
2056− ReplBadLocalDeps root e es ->
105+ Make makeExit ->
2057− Help.compilerReport root e es
106+ Make.toReport makeExit
2058
107
2059− ReplProjectProblem projectProblem ->
108+ Init initExit ->
2060− toProjectProblemReport projectProblem
109+ Init.toReport initExit
2061
110
2062− ReplBadGenerate generate ->
111+ Install installExit ->
2063− toGenerateReport generate
112+ Install.toReport installExit
2064
113
2065− ReplBadCache ->
114+ Publish publishExit ->
2066− corruptCacheReport
115+ Publish.toReport publishExit
2067
116
2068− ReplBlocked ->
117+ BadHttp url httpExit ->
2069− corruptCacheReport
118+ Http.toReport url httpExit
builder/src/Reporting/Exit/Assets.hsnew file+227
@@ -0,0 +1,227 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Assets
3+ ( Exit(..)
4+ , ElmJsonProblem(..)
5+ , toReport
6+ , BadElmJsonContent(..)
7+ , badContentToDocs
8+ )
9+ where
10+
11+
12+import qualified Data.Text as Text
13+
14+import qualified Elm.Package as Pkg
15+import Reporting.Doc ((<>))
16+import qualified Reporting.Doc as D
17+import qualified Reporting.Exit.Help as Help
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit
25+ = BadElmJson ElmJsonProblem
26+ | CorruptElmJson Pkg.Name Pkg.Version
27+ | CorruptDocumentation Pkg.Name Pkg.Version
28+ | CorruptBinary FilePath FilePath
29+
30+
31+
32+-- ELM JSON PROBLEM
33+
34+
35+data ElmJsonProblem
36+ = BadJson D.Doc
37+ | BadSrcDir FilePath
38+ | NoPkgCore
39+ | NoAppCore
40+ | NoAppJson
41+
42+
43+
44+-- TO REPORT
45+
46+
47+toReport :: Exit -> Help.Report
48+toReport exit =
49+ case exit of
50+ CorruptElmJson pkg vsn ->
51+ corruptJsonToReport "elm.json" pkg vsn
52+
53+ CorruptDocumentation pkg vsn ->
54+ corruptJsonToReport "docs.json" pkg vsn
55+
56+ CorruptBinary elmHome path ->
57+ Help.report "CORRUPT BINARY" (Just path)
58+ ("The binary data at " ++ path ++ " is corrupt.")
59+ [ D.reflow "Elm caches build artifacts in the following directories:"
60+ , D.dullyellow $ D.indent 4 $ D.vcat $
61+ [ D.fromString elmHome
62+ , "elm-stuff/"
63+ ]
64+ , D.reflow
65+ "Maybe you recently installed a command line tool or editor plugin that messes\
66+ \ with them? They definitely should not be doing that, but you never know! So\
67+ \ maybe try deleting them? Everything will be rebuilt from scratch. This may\
68+ \ help reveal the corrupting influence."
69+ ]
70+
71+ BadElmJson problem ->
72+ elmJsonProblemToReport problem
73+
74+
75+
76+-- CORRUPT JSON
77+
78+
79+corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
80+corruptJsonToReport path pkg vsn =
81+ Help.report "CORRUPT JSON" Nothing
82+ ( "The " ++ path ++ " for " ++ Pkg.toString pkg
83+ ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
84+ )
85+ [ D.reflow $
86+ "I removed it from my file cache, so if it was some transient\
87+ \ error it should be fixed if you try the same thing again.\
88+ \ Please report this if it seems like an Elm problem though!"
89+ ]
90+
91+
92+
93+-- BAD ELM JSON
94+
95+
96+elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
97+elmJsonProblemToReport problem =
98+ case problem of
99+ BadJson doc ->
100+ Help.jsonReport "BAD JSON" (Just "elm.json") doc
101+
102+ BadSrcDir dir ->
103+ Help.report "BAD JSON" (Just "elm.json")
104+ "The \"source-directories\" in your elm.json lists the following directory:"
105+ [ D.indent 4 (D.dullyellow (D.fromString dir))
106+ , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
107+ ]
108+
109+ NoPkgCore ->
110+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
111+ "A package must have \"elm/core\" as a dependency. Try running:"
112+ [ D.indent 4 $ D.green $ "elm install elm/core"
113+ , D.reflow "I need it for the default imports that make `List` and `Maybe` available."
114+ ]
115+
116+ NoAppCore ->
117+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
118+ "An application must have \"elm/core\" as a dependency. Try running:"
119+ [ D.indent 4 $ D.green $ "elm install elm/core"
120+ , D.reflow "It has some supporting code that is needed by every Elm application!"
121+ ]
122+
123+ NoAppJson ->
124+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
125+ "An application must have \"elm/json\" as a dependency. Try running:"
126+ [ D.indent 4 $ D.green $ "elm install elm/json"
127+ , D.reflow "It helps me handle flags and ports."
128+ ]
129+
130+
131+
132+-- PROBLEM TO DOCS
133+
134+
135+data BadElmJsonContent
136+ = BadType Text.Text
137+ | BadPkgName String
138+ | BadVersion Text.Text
139+ | BadConstraint String
140+ | BadModuleName Text.Text
141+ | BadModuleHeaderTooLong Text.Text
142+ | BadDependencyName Text.Text
143+ | BadLicense Text.Text [Text.Text]
144+ | BadDirectoryNotString
145+ | BadSummaryTooLong
146+
147+
148+badContentToDocs :: BadElmJsonContent -> [D.Doc]
149+badContentToDocs badContent =
150+ case badContent of
151+ BadType _ ->
152+ ["The","only","valid","types","of","elm.json","are"
153+ ,D.green "\"application\"","and",D.green "\"package\"" <> "."
154+ ]
155+
156+ BadPkgName problem ->
157+ map D.fromString (words problem)
158+
159+ BadVersion txt ->
160+ ["You","provided",D.red (D.fromString (show txt))
161+ ,"which","is","not","a","valid","version.","I","need","something","like"
162+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
163+ ]
164+
165+ BadConstraint problem ->
166+ map D.fromString (words ("It is not a valid constraint. " ++ problem))
167+
168+ BadModuleName name ->
169+ ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."
170+ ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."
171+ ]
172+
173+ BadModuleHeaderTooLong header ->
174+ ["The",D.fromString (show header),"header","is","too","long."
175+ ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"
176+ ,"to","ensure","that","formatting","is","nice","on","the","package","website."
177+ ]
178+
179+ BadDependencyName name ->
180+ ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."
181+ ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
182+ ,"the","package","website,","and","installing","it","with","the"
183+ ,D.green "`elm install`","command","instead."
184+ ]
185+
186+ BadLicense _given suggestions ->
187+ case suggestions of
188+ [] ->
189+ ["I","need","an","OSI","approved","SPDX","license,","like"
190+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"
191+ ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
192+ ]
193+
194+ code:codes ->
195+ ["I","need","an","OSI","approved","SPDX","license."]
196+ ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
197+ ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
198+
199+ BadDirectoryNotString ->
200+ ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."
201+ ]
202+
203+ BadSummaryTooLong ->
204+ ["Your","summary","is","too","long.","I","need","it","to"
205+ ,"be",D.green "under",D.green "80",D.green "characters."
206+ ]
207+
208+
209+oneOf :: Text.Text -> [Text.Text] -> [D.Doc]
210+oneOf code codes =
211+ let
212+ toDoc spdx =
213+ D.green (D.fromString (show spdx))
214+ in
215+ case codes of
216+ [] ->
217+ [toDoc code]
218+
219+ [code2] ->
220+ [toDoc code,"or",toDoc code2]
221+
222+ _:_ ->
223+ let
224+ these = code : init codes
225+ final = last codes
226+ in
227+ map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Exit/Bump.hsnew file+51
@@ -0,0 +1,51 @@
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.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reporting.Exit.Compile
4+ ( Exit(..)
5+ , toJson
6+ , toDoc
7+ )
8+ where
9+
10+
11+import qualified Data.List as List
12+import qualified Data.Time.Clock as Time
13+
14+import qualified Elm.Compiler as Compiler
15+import qualified Elm.ModuleName as ModuleName
16+import qualified Json.Encode as Encode
17+import qualified Reporting.Doc as D
18+
19+
20+
21+-- EXITS
22+
23+
24+data Exit =
25+ Exit
26+ { _name :: ModuleName.Raw
27+ , _path :: FilePath
28+ , _time :: Time.UTCTime
29+ , _source :: String
30+ , _errors :: [Compiler.Error]
31+ }
32+
33+
34+
35+-- TO JSON
36+
37+
38+toJson :: Exit -> Encode.Value
39+toJson (Exit name path _ source errors) =
40+ Compiler.errorsToJson name path source errors
41+
42+
43+
44+-- TO DOC
45+
46+
47+toDoc :: Exit -> [Exit] -> D.Doc
48+toDoc e es =
49+ let
50+ (exit, exits) = sortByTime e es
51+ in
52+ D.vcat (toDocHelp exit exits)
53+
54+
55+toDocHelp :: Exit -> [Exit] -> [D.Doc]
56+toDocHelp e1 exits =
57+ case exits of
58+ [] ->
59+ [exitToDoc e1]
60+
61+ e2 : otherErrors ->
62+ exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors
63+
64+
65+exitToDoc :: Exit -> D.Doc
66+exitToDoc (Exit _name path _time source errors) =
67+ Compiler.errorsToDoc path source errors
68+
69+
70+separator :: ModuleName.Raw -> ModuleName.Raw -> D.Doc
71+separator beforeName afterName =
72+ let
73+ before = ModuleName.nameToChars beforeName ++ " ↑ "
74+ after = " ↓ " ++ ModuleName.nameToChars afterName
75+ in
76+ D.dullred $ D.vcat $
77+ [ D.indent (80 - length before) (D.fromChars before)
78+ , "====o======================================================================o===="
79+ , D.fromChars after
80+ , D.empty
81+ , D.empty
82+ ]
83+
84+
85+
86+-- SORT BY TIME
87+
88+
89+sortByTime :: Exit -> [Exit] -> (Exit, [Exit])
90+sortByTime exit exits =
91+ case List.sortBy timeCompare exits of
92+ [] ->
93+ (exit, [])
94+
95+ e:es ->
96+ if _time exit < _time e then
97+ (exit, e:es)
98+ else
99+ (e, List.insertBy timeCompare exit es)
100+
101+
102+timeCompare :: Exit -> Exit -> Ordering
103+timeCompare e1 e2 =
104+ compare (_time e1) (_time e2)
builder/src/Reporting/Exit/Crawl.hsnew file+345
@@ -0,0 +1,345 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Crawl
3+ ( Exit(..)
4+ , Problem(..)
5+ , Origin(..)
6+ , SrcDirs(..)
7+ , toReport
8+ )
9+ where
10+
11+
12+import qualified Data.Char as Char
13+import qualified Data.Map as Map
14+import qualified Data.Time.Clock as Time
15+
16+import qualified Elm.Compiler as Compiler
17+import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Package as Pkg
19+import qualified Elm.Version as V
20+import Reporting.Doc ((<+>), (<>))
21+import qualified Reporting.Doc as D
22+import qualified Reporting.Exit.Compile as Compile
23+import qualified Reporting.Exit.Help as Help
24+
25+
26+
27+-- EXIT
28+
29+
30+data Exit
31+ = RootFileNotFound FilePath
32+ | RootModuleNameDuplicate ModuleName.Raw [FilePath]
33+ | RootNameless FilePath
34+ | DependencyProblems Problem [Problem]
35+ | BadKernelHeader FilePath
36+
37+
38+data Problem
39+ = ModuleNotFound Origin ModuleName.Raw SrcDirs
40+ | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]
41+ | BadHeader FilePath Time.UTCTime String Compiler.Error
42+ | ModuleNameReservedForKernel Origin ModuleName.Raw
43+ | ModuleNameMissing FilePath ModuleName.Raw
44+ | ModuleNameMismatch
45+ FilePath
46+ ModuleName.Raw -- expected
47+ ModuleName.Raw -- actual
48+ | PortsInPackage FilePath ModuleName.Raw
49+ | EffectsUnexpected FilePath ModuleName.Raw
50+
51+
52+data Origin
53+ = ElmJson
54+ | File FilePath
55+ | Module FilePath ModuleName.Raw
56+
57+
58+data SrcDirs
59+ = App [FilePath]
60+ | Pkg
61+
62+
63+
64+-- TO REPORT
65+
66+
67+toReport :: Exit -> Help.Report
68+toReport exit =
69+ case exit of
70+ RootFileNotFound path ->
71+ Help.report "FILE NOT FOUND" Nothing
72+ "You want me to compile this file:"
73+ [ D.indent 4 $ D.dullyellow $ D.fromChars path
74+ , "I cannot find it though! Is there a typo?"
75+ ]
76+
77+ RootModuleNameDuplicate name paths ->
78+ Help.report "DUPLICATE NAMES" Nothing
79+ "I am trying to compile multiple modules with the same name:"
80+ [ D.indent 4 $ D.dullyellow $ D.vcat $
81+ map D.fromChars paths
82+ , D.fillSep $
83+ [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
84+ , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."
85+ , "Change", "them", "to", "have", "unique", "names", "and", "you"
86+ , "should", "be", "all", "set!"
87+ ]
88+ ]
89+
90+ RootNameless path ->
91+ namelessToDoc path "Main"
92+
93+ DependencyProblems problem otherProblems ->
94+ case otherProblems of
95+ [] ->
96+ problemToReport problem
97+
98+ _ ->
99+ problemToReport problem
100+ -- error "TODO handle multiple dependency errors"
101+
102+ BadKernelHeader filePath ->
103+ Help.report "BAD KERNEL HEADER" Nothing
104+ "I ran into a bad header in this file:"
105+ [ D.indent 4 $ D.dullyellow $ D.fromChars filePath
106+ , D.reflow $
107+ "NOTE: Kernel code is only available to core Elm libraries to ensure\
108+ \ the portability and security of the Elm ecosystem. This restriction\
109+ \ also makes it possible to improve code gen (i.e. performance) without\
110+ \ disrupting the ecosystem."
111+ ]
112+
113+
114+
115+-- PROBLEM TO REPORT
116+
117+
118+problemToReport :: Problem -> Help.Report
119+problemToReport problem =
120+ case problem of
121+ ModuleNotFound origin name srcDirs ->
122+ notFoundToDoc origin name srcDirs
123+
124+ ModuleAmbiguous origin child paths pkgs ->
125+ ambiguousToDoc origin child paths pkgs
126+
127+ BadHeader path time source compilerError ->
128+ let
129+ compilerExit =
130+ Compile.Exit "???" path time source [compilerError]
131+ in
132+ Help.compilerReport compilerExit []
133+
134+ ModuleNameMissing path name ->
135+ namelessToDoc path name
136+
137+ ModuleNameMismatch path expected actual ->
138+ Help.report "MODULE NAME MISMATCH" (Just path)
139+ ( "The file at " ++ path ++ " has a typo in the module name. It says:"
140+ )
141+ [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"
142+ , "Looks like a typo or copy/paste error. Instead it needs to say:"
143+ , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"
144+ , "Make the change and you should be all set!"
145+ ]
146+
147+ ModuleNameReservedForKernel origin name ->
148+ kernelNameToDoc origin name
149+
150+ PortsInPackage path name ->
151+ badTagToDoc path name "port" "port-modules" $
152+ "Packages cannot have any `port` modules."
153+
154+ EffectsUnexpected path name ->
155+ badTagToDoc path name "effect" "effect-modules" $
156+ "Creating `effect` modules is relatively experimental. There are a\
157+ \ couple in @elm repos right now, but we have decided to be very\
158+ \ cautious in expanding its usage."
159+
160+
161+badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report
162+badTagToDoc path name tag hintName summary =
163+ Help.report
164+ ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
165+ (Just path)
166+ summary
167+ [ D.fillSep $
168+ [ "Get", "rid", "of", "all", "the"
169+ , D.red (D.fromChars tag)
170+ , "stuff", "in"
171+ , D.dullyellow (D.fromChars (ModuleName.nameToChars name))
172+ , "to", "proceed."
173+ ]
174+ , D.toSimpleNote $
175+ "You can learn the reasoning behind this design choice at "
176+ ++ D.makeLink hintName
177+ ]
178+
179+
180+
181+-- NAMELESS
182+
183+
184+namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report
185+namelessToDoc path name =
186+ Help.report "UNNAMED MODULE" (Just path)
187+ ( "The `" ++ ModuleName.nameToChars name
188+ ++ "` module must start with a line like this:"
189+ )
190+ [ D.indent 4 $ D.dullyellow $ D.fromChars $
191+ "module " ++ ModuleName.nameToChars name ++ " exposing (..)"
192+ , D.reflow $
193+ "Try adding that as the first line of your file!"
194+ , D.toSimpleNote $
195+ "It is best to replace (..) with an explicit list of types and\
196+ \ functions you want to expose. If you know a value is only used\
197+ \ WITHIN this module, it is extra easy to refactor. This kind of\
198+ \ information is great, especially as your project grows!"
199+ ]
200+
201+
202+
203+-- NOT FOUND
204+
205+
206+notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report
207+notFoundToDoc origin child srcDirs =
208+ case origin of
209+ ElmJson ->
210+ Help.report "MODULE NOT FOUND" (Just "elm.json")
211+ "Your elm.json says your project has the following module:"
212+ [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child
213+ , D.reflow $
214+ "When creating packages, all modules must live in the src/ directory."
215+ ]
216+
217+ File path ->
218+ Help.report "UNKNOWN IMPORT" (Just path)
219+ ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")
220+ (notFoundDetails child srcDirs)
221+
222+ Module path parent ->
223+ Help.report "UNKNOWN IMPORT" (Just path)
224+ ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")
225+ (notFoundDetails child srcDirs)
226+
227+
228+notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]
229+notFoundDetails child srcDirs =
230+ let
231+ simulatedCode =
232+ D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child
233+ in
234+ case Map.lookup child Pkg.suggestions of
235+ Just pkg ->
236+ [ simulatedCode
237+ , D.reflow $
238+ "Do you want the one from the " ++ Pkg.toChars pkg
239+ ++ " package? If so, run this command to add that dependency to your elm.json file:"
240+ , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg
241+ , case srcDirs of
242+ Pkg ->
243+ D.reflow $
244+ "If you want a local file, make sure the `"
245+ ++ ModuleName.nameToChars child
246+ ++ "` module is in your src/ directory."
247+
248+ App _ ->
249+ D.reflow $
250+ "If you want a local file, make sure the `"
251+ ++ ModuleName.nameToChars child
252+ ++ "` module is in one of the \"source-directories\" listed in your elm.json file."
253+ ]
254+
255+ Nothing ->
256+ [ simulatedCode
257+ , "I cannot find that module! Is there a typo in the module name?"
258+ , D.reflow $
259+ case srcDirs of
260+ Pkg ->
261+ "When creating a package, all modules must live in the src/ directory."
262+
263+ App [] ->
264+ "The \"source-directories\" field of your elm.json is empty, so I only\
265+ \ searched in packages. Maybe you need to add a \"src\" directory there?"
266+
267+ App [dir] ->
268+ "The \"source-directories\" field of your elm.json tells me to only look in the "
269+ ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"
270+
271+ App (dir:_:_) ->
272+ "The \"source-directories\" field of your elm.json tells me to look in directories like "
273+ ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"
274+ ]
275+
276+
277+ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report
278+ambiguousToDoc origin child paths pkgs =
279+ let
280+ pkgToString (Pkg.Canonical pkg vsn) =
281+ "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
282+
283+ makeReport maybePath summary yellowString =
284+ Help.report "AMBIGUOUS IMPORT" maybePath summary
285+ [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString
286+ , D.reflow $
287+ "I found multiple module with that name though:"
288+ , D.indent 4 $ D.dullyellow $ D.vcat $
289+ map D.fromChars $ paths ++ map pkgToString pkgs
290+ , D.reflow $
291+ if null paths then
292+ "It looks like the name clash is in your dependencies, which is\
293+ \ out of your control. Elm does not support this scenario right\
294+ \ now, but it may be worthwhile. Please open an issue describing\
295+ \ your scenario so we can gather more usage information!"
296+ else
297+ "Which is the right one? Try renaming your modules to have unique names."
298+ ]
299+ in
300+ case origin of
301+ ElmJson ->
302+ makeReport
303+ Nothing
304+ "Your elm.json wants the following module:"
305+ (ModuleName.nameToChars child)
306+
307+ File path ->
308+ makeReport
309+ (Just path)
310+ ("The file at " ++ path ++ " has an ambiguous import:")
311+ ("import " ++ ModuleName.nameToChars child)
312+
313+ Module path parent ->
314+ makeReport
315+ (Just path)
316+ ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")
317+ ("import " ++ ModuleName.nameToChars child)
318+
319+
320+kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report
321+kernelNameToDoc origin kernelName =
322+ let
323+ (maybePath, statement) =
324+ case origin of
325+ ElmJson ->
326+ ( Nothing
327+ , "Your elm.json says your project has the following module:"
328+ )
329+
330+ File path ->
331+ ( Just path
332+ , "This file is trying to import the following module:"
333+ )
334+
335+ Module path parent ->
336+ ( Just path
337+ , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"
338+ )
339+ in
340+ Help.report "BAD MODULE NAME" maybePath statement
341+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName
342+ , D.reflow $
343+ "But names like that are reserved for internal use.\
344+ \ Switch to a name outside of the Elm/Kernel/ namespace."
345+ ]
builder/src/Reporting/Exit/Deps.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Deps
3+ ( Exit(..)
4+ , toReport
5+ )
6+ where
7+
8+
9+import qualified Elm.Constraint as Con
10+import qualified Elm.Package as Pkg
11+import qualified Elm.Version as V
12+import Reporting.Doc ((<>))
13+import qualified Reporting.Doc as D
14+import qualified Reporting.Exit.Help as Help
15+
16+
17+
18+-- EXITS
19+
20+
21+data Exit
22+ = CorruptVersionCache FilePath Pkg.Name
23+ | PackageNotFound Pkg.Name [Pkg.Name]
24+ -- verify
25+ | PkgBadElm Con.Constraint
26+ | AppBadElm V.Version
27+ | AppMissingTrans [(Pkg.Name, V.Version)]
28+ | BadDeps
29+ | BuildFailure FilePath Pkg.Name V.Version
30+
31+
32+
33+-- TO DOC
34+
35+
36+toReport :: Exit -> Help.Report
37+toReport exit =
38+ case exit of
39+ CorruptVersionCache elmHome pkg ->
40+ Help.report "CORRUPT CACHE" Nothing
41+ ( "I ran into an unknown package while exploring dependencies:"
42+ )
43+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg
44+ , D.reflow $
45+ "This suggests that your " ++ elmHome ++ " directory has been corrupted.\
46+ \ Maybe some program is messing with it? It is just cached files,\
47+ \ so you can delete it and see if that fixes the issue."
48+ ]
49+
50+ PackageNotFound package suggestions ->
51+ Help.docReport "PACKAGE NOT FOUND" Nothing
52+ ( D.fillSep
53+ ["I","cannot","find","a"
54+ ,D.red (D.fromUtf8 (Pkg.toString package))
55+ ,"package","on","the","package","website."
56+ ]
57+ )
58+ [ "Maybe you want one of these instead?"
59+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions
60+ , "But check <https://package.elm-lang.org> to see all possibilities!"
61+ ]
62+
63+ PkgBadElm constraint ->
64+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
65+ "Your elm.json says this package needs a version of Elm in this range:"
66+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint
67+ , D.fillSep
68+ [ "But", "you", "are", "using", "Elm"
69+ , D.red (D.fromUtf8 (V.toString V.compiler))
70+ , "right", "now."
71+ ]
72+ ]
73+
74+ AppBadElm version ->
75+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")
76+ "Your elm.json says this application needs a different version of Elm."
77+ [ D.fillSep
78+ [ "It", "requires"
79+ , D.green (D.fromUtf8 (V.toString version)) <> ","
80+ , "but", "you", "are", "using"
81+ , D.red (D.fromUtf8 (V.toString V.compiler))
82+ , "right", "now."
83+ ]
84+ ]
85+
86+ AppMissingTrans missingDeps ->
87+ let
88+ toEntry (pkg, vsn) =
89+ "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""
90+ in
91+ Help.report "MISSING DEPENDENCIES" (Just "elm.json")
92+ "Your elm.json is missing some \"indirect\" dependencies:"
93+ [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps
94+ , D.fillSep
95+ ["This","usually","means","you","are","editing","elm.json","by","hand."
96+ ,"It","is","much","more","reliable","to","use","the"
97+ ,D.green "elm install","command","instead."
98+ ]
99+ ]
100+
101+ BadDeps ->
102+ Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")
103+ "The dependencies in your elm.json are not compatible."
104+ [ D.fillSep
105+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"
106+ ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"
107+ ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."
108+ ]
109+ , D.reflow $
110+ "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
111+ \ you try those paths and still cannot figure it out!"
112+ ]
113+
114+ BuildFailure elmHome pkg vsn ->
115+ Help.report "CORRUPT DEPENDENCY" Nothing
116+ "I ran into a problem while building the following package:"
117+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn
118+ , D.fillSep
119+ ["This","probably","means","the","downloaded","files","got","corrupted","somehow."
120+ ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"
121+ ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."
122+ ]
123+ ]
builder/src/Reporting/Exit/Diff.hsnew file+73
@@ -0,0 +1,73 @@
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+12−11
@@ -14,6 +14,7 @@ module Reporting.Exit.Help
14 where
14 where
15
15
16
16
17+import qualified Data.Utf8 as Utf8
17import GHC.IO.Handle (hIsTerminalDevice)
18import GHC.IO.Handle (hIsTerminalDevice)
18import System.IO (Handle, hPutStr, stderr, stdout)
19import System.IO (Handle, hPutStr, stderr, stdout)
19
20
@@ -21,7 +22,7 @@ import qualified Json.Encode as E
21import Json.Encode ((==>))
22import Json.Encode ((==>))
22import Reporting.Doc ((<+>))
23import Reporting.Doc ((<+>))
23import qualified Reporting.Doc as D
24import qualified Reporting.Doc as D
24−import qualified Reporting.Error as Error
25+import qualified Reporting.Exit.Compile as Compile
25
26
26
27
27
28
@@ -29,7 +30,7 @@ import qualified Reporting.Error as Error
29
30
30
31
31data Report
32data Report
32− = CompilerReport FilePath Error.Module [Error.Module]
33+ = CompilerReport Compile.Exit [Compile.Exit]
33 | Report
34 | Report
34 { _title :: String
35 { _title :: String
35 , _path :: Maybe FilePath
36 , _path :: Maybe FilePath
@@ -52,7 +53,7 @@ jsonReport =
52 Report
53 Report
53
54
54
55
55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
56+compilerReport :: Compile.Exit -> [Compile.Exit] -> Report
56compilerReport =
57compilerReport =
57 CompilerReport
58 CompilerReport
58
59
@@ -64,8 +65,8 @@ compilerReport =
64reportToDoc :: Report -> D.Doc
65reportToDoc :: Report -> D.Doc
65reportToDoc report_ =
66reportToDoc report_ =
66 case report_ of
67 case report_ of
67− CompilerReport root e es ->
68+ CompilerReport e es ->
68− Error.toDoc root e es
69+ Compile.toDoc e es
69
70
70 Report title maybePath message ->
71 Report title maybePath message ->
71 let
72 let
@@ -94,17 +95,17 @@ reportToDoc report_ =
94reportToJson :: Report -> E.Value
95reportToJson :: Report -> E.Value
95reportToJson report_ =
96reportToJson report_ =
96 case report_ of
97 case report_ of
97− CompilerReport _ e es ->
98+ CompilerReport e es ->
98 E.object
99 E.object
99− [ "type" ==> E.chars "compile-errors"
100+ [ "type" ==> E.string "compile-errors"
100− , "errors" ==> E.list Error.toJson (e:es)
101+ , "errors" ==> E.list Compile.toJson (e:es)
101 ]
102 ]
102
103
103 Report title maybePath message ->
104 Report title maybePath message ->
104 E.object
105 E.object
105− [ "type" ==> E.chars "error"
106+ [ "type" ==> E.string "error"
106− , "path" ==> maybe E.null E.chars maybePath
107+ , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath
107− , "title" ==> E.chars title
108+ , "title" ==> E.string (Utf8.fromChars title)
108 , "message" ==> D.encode message
109 , "message" ==> D.encode message
109 ]
110 ]
110
111
builder/src/Reporting/Exit/Http.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Http
3+ ( Exit(..)
4+ , toReport
5+ , BadJson(..)
6+ , badJsonToDocs
7+ )
8+ where
9+
10+
11+import qualified Data.Text as Text
12+
13+import Reporting.Doc ((<>))
14+import qualified Reporting.Doc as D
15+import qualified Reporting.Exit.Help as Help
16+
17+
18+
19+-- EXITS
20+
21+
22+data Exit
23+ = Unknown String
24+ | BadJson String D.Doc
25+ | BadZipData
26+ | BadZipSha String String
27+
28+
29+
30+-- TO REPORT
31+
32+
33+toReport :: String -> Exit -> Help.Report
34+toReport url exit =
35+ let
36+ urlDoc =
37+ D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"
38+ in
39+ case exit of
40+ Unknown message ->
41+ Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
42+ [ urlDoc
43+ , D.stack
44+ [ "Here is the error message I was able to extract:"
45+ , D.indent 4 $ D.reflow message
46+ ]
47+ ]
48+
49+ BadJson path doc ->
50+ Help.jsonReport "UNEXPECTED JSON" (Just path) doc
51+
52+ BadZipData ->
53+ Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
54+ [ urlDoc
55+ , D.reflow $
56+ "If it is a transient issue, it should be fixed if you try this\
57+ \ again. If it seems like an Elm problem, please report it though!"
58+ ]
59+
60+ BadZipSha expectedHash actualHash ->
61+ Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
62+ [ urlDoc
63+ , D.reflow "I check the hash the zip, and it seems off:"
64+ , D.vcat $ map D.fromString $
65+ [ " Expected: " ++ expectedHash
66+ , " Actual: " ++ actualHash
67+ ]
68+ , D.reflow $
69+ "This usually means that the package author moved the version\
70+ \ tag, so report it to them and see if that is the issue. Folks\
71+ \ on Elm slack can probably help as well."
72+ ]
73+
74+
75+
76+-- BAD JSON
77+
78+
79+data BadJson
80+ = BadNewPkg Text.Text
81+ | BadAllPkg Text.Text String
82+ | BadAllVsn Text.Text
83+
84+
85+badJsonToDocs :: BadJson -> [D.Doc]
86+badJsonToDocs badJson =
87+ case badJson of
88+ BadNewPkg txt ->
89+ ["I","ran","into",D.red (D.fromString (show txt)) <> ","
90+ ,"but","I","need","entries","like"
91+ ,D.green "\"elm/core@6.0.0\"" <> "."
92+ ]
93+
94+ BadAllPkg txt suggestion ->
95+ ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."
96+ ]
97+ ++ map D.fromString (words suggestion)
98+
99+ BadAllVsn txt ->
100+ ["You","provided",D.red (D.fromString (show txt))
101+ ,"which","is","not","a","valid","version.","I","need","something","like"
102+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."
103+ ]
104+
builder/src/Reporting/Exit/Init.hsnew file+48
@@ -0,0 +1,48 @@
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.hsnew file+82
@@ -0,0 +1,82 @@
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.hsnew file+75
@@ -0,0 +1,75 @@
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.hsnew file+241
@@ -0,0 +1,241 @@
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/Progress.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Reporting.Progress
3+ ( Reporter(..)
4+ , makeReporter
5+ , silentReporter
6+ , Msg(..)
7+ , Progress(..)
8+ , Outcome(..)
9+ , PublishPhase(..)
10+ , BumpPhase(..)
11+ )
12+ where
13+
14+
15+import Control.Concurrent.Chan (Chan, writeChan)
16+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar)
17+import qualified Elm.ModuleName as ModuleName
18+import Deps.Diff (Magnitude)
19+import qualified Elm.Package as Pkg
20+import qualified Elm.Version as V
21+import qualified Reporting.Doc as D
22+import Reporting.Exit (Exit)
23+
24+
25+
26+-- REPORTER
27+
28+
29+data Reporter =
30+ Reporter
31+ { _tell :: Progress -> IO ()
32+ , _ask :: D.Doc -> IO Bool
33+ , _end :: Maybe Exit -> IO ()
34+ }
35+
36+
37+makeReporter :: Chan Msg -> MVar () -> Reporter
38+makeReporter chan mvar =
39+ let
40+ tell progress =
41+ writeChan chan (Progress progress)
42+
43+ ask doc =
44+ do var <- newEmptyMVar
45+ writeChan chan (Ask doc var)
46+ readMVar var
47+
48+ end maybeError =
49+ do writeChan chan (End maybeError)
50+ readMVar mvar
51+ in
52+ Reporter tell ask end
53+
54+
55+silentReporter :: Reporter
56+silentReporter =
57+ Reporter
58+ (\_ -> return ())
59+ (\_ -> return True)
60+ (\_ -> return ())
61+
62+
63+
64+-- MESSAGES
65+
66+
67+data Msg
68+ = Progress Progress
69+ | Ask D.Doc (MVar Bool)
70+ | End (Maybe Exit)
71+
72+
73+data Progress
74+ -- download packages
75+ = DownloadSkip
76+ | DownloadStart [(Pkg.Name, V.Version)]
77+ | DownloadPkgStart Pkg.Name V.Version
78+ | DownloadPkgEnd Pkg.Name V.Version Outcome
79+ | DownloadEnd Outcome
80+
81+ -- build dependencies
82+ | BuildDepsStart Int
83+ | BuildDepsProgress
84+ | BuildDepsEnd
85+
86+ -- compile files
87+ | CompileStart Int
88+ | CompileFileStart ModuleName.Raw
89+ | CompileFileEnd ModuleName.Raw Outcome
90+ | CompileEnd
91+
92+ -- publish
93+ | PublishStart Pkg.Name V.Version (Maybe [V.Version])
94+ | PublishCheckBump V.Version BumpPhase
95+ | PublishProgress PublishPhase (Maybe Outcome)
96+ | PublishEnd
97+
98+ -- solver
99+ | UnableToLoadLatestPackages
100+
101+
102+data Outcome = Good | Bad
103+
104+
105+data PublishPhase
106+ = CheckReadme
107+ | CheckLicense
108+ | CheckTag V.Version
109+ | CheckDownload
110+ | CheckBuild
111+ | CheckChanges
112+
113+
114+data BumpPhase
115+ = StatedVersion
116+ | GoodStart
117+ | GoodBump V.Version Magnitude
118+ | BadBump
builder/src/Reporting/Progress/Json.hsnew file+34
@@ -0,0 +1,34 @@
1+module Reporting.Progress.Json
2+ ( reporter
3+ )
4+ where
5+
6+
7+import qualified Data.ByteString.Builder as B
8+import System.IO (stderr)
9+
10+import qualified Reporting.Exit as Exit
11+import qualified Reporting.Progress as Progress
12+import qualified Json.Encode as Encode
13+
14+
15+
16+-- REPORTER
17+
18+
19+reporter :: Progress.Reporter
20+reporter =
21+ Progress.Reporter
22+ (\_ -> return ())
23+ (\_ -> return True)
24+ end
25+
26+
27+end :: Maybe Exit.Exit -> IO ()
28+end maybeExit =
29+ case maybeExit of
30+ Just exit ->
31+ B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson exit))
32+
33+ Nothing ->
34+ return ()
builder/src/Reporting/Progress/Repl.hsnew file+30
@@ -0,0 +1,30 @@
1+module Reporting.Progress.Repl
2+ ( reporter
3+ )
4+ where
5+
6+
7+import qualified Reporting.Exit as Exit
8+import qualified Reporting.Progress as Progress
9+
10+
11+
12+-- REPORTER
13+
14+
15+reporter :: Progress.Reporter
16+reporter =
17+ Progress.Reporter
18+ (\_ -> return ())
19+ (\_ -> return True)
20+ end
21+
22+
23+end :: Maybe Exit.Exit -> IO ()
24+end maybeExit =
25+ case maybeExit of
26+ Just exit ->
27+ Exit.toStderr exit
28+
29+ Nothing ->
30+ return ()
builder/src/Reporting/Progress/Terminal.hsnew file+379
@@ -0,0 +1,379 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Progress.Terminal
3+ ( create
4+ , newPackageOverview
5+ )
6+ where
7+
8+
9+import Control.Concurrent (forkIO)
10+import Control.Concurrent.Chan (Chan, newChan, readChan)
11+import Control.Concurrent.MVar (newEmptyMVar, putMVar)
12+import qualified System.Info as Info
13+import System.IO (hFlush, hPutStr, stdout)
14+import qualified Elm.Package as Pkg
15+import qualified Elm.Version as V
16+
17+import qualified Deps.Diff as Diff
18+import Reporting.Doc ((<>), (<+>))
19+import qualified Reporting.Doc as D
20+import qualified Reporting.Exit as Exit
21+import qualified Reporting.Exit.Help as Help
22+import Reporting.Progress (Msg(..), Progress(..), Outcome(..), PublishPhase(..), BumpPhase(..))
23+import qualified Reporting.Progress as Progress
24+import qualified Reporting.Progress.Bar as Bar
25+
26+
27+
28+-- CREATE
29+
30+
31+create :: IO Progress.Reporter
32+create =
33+ do chan <- newChan
34+ mvar <- newEmptyMVar
35+ _ <- forkIO (loop chan (State 0 0 0) >>= putMVar mvar)
36+ return (Progress.makeReporter chan mvar)
37+
38+
39+
40+-- STATE
41+
42+
43+data State =
44+ State
45+ { _total :: !Int
46+ , _good :: !Int
47+ , _bad :: !Int
48+ }
49+
50+
51+
52+-- LOOP
53+
54+
55+loop :: Chan Msg -> State -> IO ()
56+loop chan state =
57+ do msg <- readChan chan
58+ case msg of
59+ End (Just exit) ->
60+ Exit.toStderr exit
61+
62+ End Nothing ->
63+ return ()
64+
65+ Ask doc mvar ->
66+ do Help.toStdout doc
67+ putMVar mvar =<< getApproval
68+ loop chan state
69+
70+ Progress progress ->
71+ loopHelp chan progress state
72+
73+
74+getApproval :: IO Bool
75+getApproval =
76+ do hFlush stdout
77+ input <- getLine
78+ case input of
79+ "" -> return True
80+ "Y" -> return True
81+ "y" -> return True
82+ "n" -> return False
83+ _ ->
84+ do putStr "Must type 'y' for yes or 'n' for no: "
85+ getApproval
86+
87+
88+loopHelp :: Chan Msg -> Progress -> State -> IO ()
89+loopHelp chan progress state@(State total good bad) =
90+ case progress of
91+
92+
93+ -- DOWNLOADS
94+
95+ DownloadSkip ->
96+ do putStrLn "Dependencies loaded from local cache."
97+ loop chan state
98+
99+ DownloadStart [] ->
100+ loop chan state
101+
102+ DownloadStart _ ->
103+ do putStrLn "Starting downloads...\n"
104+ loop chan state
105+
106+ DownloadPkgStart _name _version ->
107+ loop chan state
108+
109+ DownloadPkgEnd name version outcome ->
110+ do Help.toStdout (makeBullet name version outcome)
111+ loop chan state
112+
113+ DownloadEnd Bad ->
114+ do putStrLn ""
115+ loop chan state
116+
117+ DownloadEnd Good ->
118+ do putStrLn ""
119+ loop chan state
120+
121+
122+ -- BUILD DEPS
123+
124+ BuildDepsStart size ->
125+ do hPutStr stdout "Verifying dependencies..."
126+ hFlush stdout
127+ loop chan (State size 0 0)
128+
129+ BuildDepsProgress ->
130+ do let n = good + 1
131+ let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"
132+ hPutStr stdout msg
133+ hFlush stdout
134+ loop chan (State total n 0)
135+
136+ BuildDepsEnd ->
137+ do putStrLn "\rDependencies ready! "
138+ loop chan (State 0 0 0)
139+
140+
141+ -- COMPILE
142+
143+ CompileStart size ->
144+ loop chan (State size 0 0)
145+
146+ CompileFileStart _ ->
147+ loop chan state
148+
149+ CompileFileEnd _ Good ->
150+ do hPutStr stdout $ Bar.render (good + 1) bad total
151+ hFlush stdout
152+ loop chan (State total (good + 1) bad)
153+
154+ CompileFileEnd _ Bad ->
155+ do hPutStr stdout $ Bar.render good (bad + 1) total
156+ hFlush stdout
157+ loop chan (State total good (bad + 1))
158+
159+ CompileEnd ->
160+ let
161+ message =
162+ case (bad, total) of
163+ (0, 0) -> "Success!"
164+ (0, 1) -> "Success! Compiled 1 module."
165+ (0, n) -> "Success! Compiled " ++ show n ++ " modules."
166+ (1, _) -> "Detected errors in 1 module."
167+ (n, _) -> "Detected errors in " ++ show n ++ " modules."
168+ in
169+ do hPutStr stdout $ Bar.clear
170+ putStrLn message
171+ loop chan (State 0 0 0)
172+
173+
174+ -- PUBLISH
175+
176+ PublishStart name version maybePublishedVersions ->
177+ case maybePublishedVersions of
178+ Nothing ->
179+ do putStrLn newPackageOverview
180+ putStrLn "I will now verify that everything is in order..."
181+ putStrLn ""
182+ loop chan state
183+
184+ Just _ ->
185+ do putStrLn $ unwords [ "Verifying", Pkg.toChars name, V.toChars version, "..." ]
186+ putStrLn ""
187+ loop chan state
188+
189+ PublishCheckBump version bumpPhase ->
190+ do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase
191+ hFlush stdout
192+ loop chan state
193+
194+ PublishProgress phase status ->
195+ do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)
196+ hFlush stdout
197+ loop chan state
198+
199+ PublishEnd ->
200+ do putStrLn "Success!"
201+ loop chan state
202+
203+
204+ -- SOLVER
205+
206+ UnableToLoadLatestPackages ->
207+ do putStrLn ""
208+ Help.toStdout $ D.dullyellow "WARNING:" <+> "I normally check <https://package.elm-lang.org> for new packages\n"
209+ putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"
210+ loop chan state
211+
212+
213+
214+-- BULLETS
215+
216+
217+makeBullet :: Pkg.Name -> V.Version -> Outcome -> D.Doc
218+makeBullet name version outcome =
219+ let
220+ nm = D.fromUtf8 (Pkg.toString name)
221+ vsn = D.fromUtf8 (V.toString version)
222+
223+ bullet =
224+ case outcome of
225+ Good -> goodMark
226+ Bad -> badMark
227+ in
228+ D.indent 2 $ bullet <+> nm <+> vsn <> "\n"
229+
230+
231+goodMark :: D.Doc
232+goodMark =
233+ D.green $
234+ if Info.os == "mingw32" then "+" else "●"
235+
236+
237+badMark :: D.Doc
238+badMark =
239+ D.red $
240+ if Info.os == "mingw32" then "X" else "✗"
241+
242+
243+waitingMark :: D.Doc
244+waitingMark =
245+ D.dullyellow $
246+ if Info.os == "mingw32" then "-" else "→"
247+
248+
249+
250+-- OVERVIEW OF VERSIONING
251+
252+
253+newPackageOverview :: String
254+newPackageOverview =
255+ unlines
256+ [ "This package has never been published before. Here's how things work:"
257+ , ""
258+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
259+ , ""
260+ , " - All packages start with initial version " ++ V.toChars V.one
261+ , ""
262+ , " - Versions are incremented based on how the API changes:"
263+ , ""
264+ , " PATCH = the API is the same, no risk of breaking code"
265+ , " MINOR = values have been added, existing values are unchanged"
266+ , " MAJOR = existing values have been changed or removed"
267+ , ""
268+ , " - I will bump versions for you, automatically enforcing these rules"
269+ , ""
270+ ]
271+
272+
273+
274+-- CHECKLIST
275+
276+
277+toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc
278+toChecklistDoc status (ChecklistMessages waiting success failure) =
279+ let
280+ padded message =
281+ message ++ replicate (length waiting - length message) ' '
282+ in
283+ case status of
284+ Nothing ->
285+ " " <> waitingMark <+> D.fromChars waiting
286+
287+ Just Good ->
288+ "\r " <> goodMark <+> D.fromChars (padded success ++ "\n")
289+
290+ Just Bad ->
291+ "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n")
292+
293+
294+data ChecklistMessages =
295+ ChecklistMessages
296+ { _waiting :: String
297+ , _success :: String
298+ , _failure :: String
299+ }
300+
301+
302+toChecklistMessages :: PublishPhase -> ChecklistMessages
303+toChecklistMessages phase =
304+ case phase of
305+ CheckReadme ->
306+ ChecklistMessages
307+ "Looking for README.md"
308+ "Found README.md"
309+ "Problem with your README.md"
310+
311+ CheckLicense ->
312+ ChecklistMessages
313+ "Looking for LICENSE"
314+ "Found LICENSE"
315+ "Problem with your LICENSE"
316+
317+ CheckTag version ->
318+ ChecklistMessages
319+ ("Is version " ++ V.toChars version ++ " tagged on GitHub?")
320+ ("Version " ++ V.toChars version ++ " is tagged on GitHub")
321+ ("Version " ++ V.toChars version ++ " is not tagged on GitHub!")
322+
323+ CheckDownload ->
324+ ChecklistMessages
325+ "Downloading code from GitHub..."
326+ "Code downloaded successfully from GitHub"
327+ "Could not download code from GitHub!"
328+
329+ CheckBuild ->
330+ ChecklistMessages
331+ "Building downloaded code and generated docs..."
332+ "Downloaded code compiles successfully / docs generated\n"
333+ "Cannot compile downloaded code!"
334+
335+ CheckChanges ->
336+ ChecklistMessages
337+ "Checking for uncommitted changes..."
338+ "No uncommitted changes in local code"
339+ "Your local code is different than the code tagged on GitHub"
340+
341+
342+
343+-- BUMP PHASE
344+
345+
346+bumpPhaseToChecklistDoc :: V.Version -> BumpPhase -> D.Doc
347+bumpPhaseToChecklistDoc version bumpPhase =
348+ let
349+ mkMsgs success =
350+ ChecklistMessages
351+ ("Checking semantic versioning rules. Is " ++ V.toChars version ++ " correct?")
352+ success
353+ ("Version " ++ V.toChars version ++ " is not correct!")
354+ in
355+
356+ case bumpPhase of
357+ StatedVersion ->
358+ toChecklistDoc Nothing $ mkMsgs ""
359+
360+ GoodStart ->
361+ toChecklistDoc (Just Good) $ mkMsgs $
362+ "All packages start at version " ++ V.toChars V.one
363+
364+ GoodBump old magnitude ->
365+ toChecklistDoc (Just Good) $ mkMsgs $
366+ toCheckVersionSuccessMessage old version magnitude
367+
368+ BadBump ->
369+ toChecklistDoc (Just Bad) $ mkMsgs ""
370+
371+
372+toCheckVersionSuccessMessage :: V.Version -> V.Version -> Diff.Magnitude -> String
373+toCheckVersionSuccessMessage oldVersion newVersion magnitude =
374+ let
375+ old = V.toChars oldVersion
376+ new = V.toChars newVersion
377+ mag = Diff.magnitudeToString magnitude
378+ in
379+ "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"
builder/src/Reporting/Task.hs+76−40
@@ -1,42 +1,78 @@
1−{-# LANGUAGE Rank2Types #-}
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2module Reporting.Task
2module Reporting.Task
3 ( Task
3 ( Task
4 , run
4 , run
5 , throw
5 , throw
6− , mapError
6+ -- progress
7+ , notify
8+ , ask
7− --
9+ -- io
8 , io
10 , io
9− , mio
10 , eio
11 , eio
12+ , withKey
11 )
13 )
12 where
14 where
13
15
14
16
17+import qualified System.Exit as Exit
18+
19+import qualified Reporting.Doc as D
20+import qualified Reporting.Exit as Exit
21+import qualified Reporting.Progress as Progress
22+
23+
15
24
16-- TASKS
25-- TASKS
17
26
18
27
19−newtype Task x a =
28+newtype Task a =
20 Task
29 Task
21 (
30 (
22− forall result. (a -> IO result) -> (x -> IO result) -> IO result
31+ forall result.
32+ Env
33+ -> (a -> IO result)
34+ -> (Exit.Exit -> IO result)
35+ -> IO result
23 )
36 )
24
37
25
38
26−run :: Task x a -> IO (Either x a)
39+data Env =
27−run (Task task) =
40+ Env
28− task (return . Right) (return . Left)
41+ { _tell :: Progress.Progress -> IO ()
42+ , _ask :: D.Doc -> IO Bool
43+ }
44+
45+
46+run :: Progress.Reporter -> Task a -> IO ()
47+run (Progress.Reporter pTell pAsk pEnd) (Task task) =
48+ task (Env pTell pAsk)
49+ (\_ ->
50+ do pEnd Nothing
51+ return ()
52+ )
53+ (\exit ->
54+ do pEnd (Just exit)
55+ Exit.exitFailure
56+ )
57+
58+
59+throw :: Exit.Exit -> Task a
60+throw exit =
61+ Task $ \_ _ err -> err exit
29
62
30
63
31−throw :: x -> Task x a
32−throw x =
33− Task $ \_ err -> err x
34
64
65+-- PROGRESS
35
66
36−mapError :: (x -> y) -> Task x a -> Task y a
67+
37−mapError func (Task task) =
68+notify :: Progress.Progress -> Task ()
38− Task $ \ok err ->
69+notify progress =
39− task ok (err . func)
70+ Task $ \(Env pTell _) ok _ -> pTell progress >>= ok
71+
72+
73+ask :: D.Doc -> Task Bool
74+ask question =
75+ Task $ \(Env _ pAsk) ok _ -> pAsk question >>= ok
40
76
41
77
42
78
@@ -44,71 +80,71 @@ mapError func (Task task) =
44
80
45
81
46{-# INLINE io #-}
82{-# INLINE io #-}
47−io :: IO a -> Task x a
83+io :: IO a -> Task a
48io work =
84io work =
49− Task $ \ok _ -> work >>= ok
85+ Task $ \_ ok _ -> work >>= ok
50
86
51
87
52−mio :: x -> IO (Maybe a) -> Task x a
88+eio :: (x -> Exit.Exit) -> IO (Either x a) -> Task a
53−mio x work =
89+eio func work =
54− Task $ \ok err ->
90+ Task $ \_ ok err ->
55 do result <- work
91 do result <- work
56 case result of
92 case result of
57− Just a -> ok a
93+ Right a -> ok a
58− Nothing -> err x
94+ Left e -> err (func e)
59
95
60
96
61−eio :: (x -> y) -> IO (Either x a) -> Task y a
97+withKey :: (Progress.Key -> IO (Either Exit.Exit a)) -> Task a
62−eio func work =
98+withKey callback =
63− Task $ \ok err ->
99+ Task $ \(Env pTell _) ok err ->
64− do result <- work
100+ do result <- callback (Progress.Key pTell)
65 case result of
101 case result of
66 Right a -> ok a
102 Right a -> ok a
67− Left x -> err (func x)
103+ Left e -> err e
68
104
69
105
70
106
71-- INSTANCES
107-- INSTANCES
72
108
73
109
74−instance Functor (Task x) where
110+instance Functor Task where
75 {-# INLINE fmap #-}
111 {-# INLINE fmap #-}
76 fmap func (Task taskA) =
112 fmap func (Task taskA) =
77− Task $ \ok err ->
113+ Task $ \env ok err ->
78 let
114 let
79 okA arg = ok (func arg)
115 okA arg = ok (func arg)
80 in
116 in
81− taskA okA err
117+ taskA env okA err
82
118
83
119
84−instance Applicative (Task x) where
120+instance Applicative Task where
85 {-# INLINE pure #-}
121 {-# INLINE pure #-}
86 pure a =
122 pure a =
87− Task $ \ok _ -> ok a
123+ Task $ \_ ok _ -> ok a
88
124
89 {-# INLINE (<*>) #-}
125 {-# INLINE (<*>) #-}
90 (<*>) (Task taskFunc) (Task taskArg) =
126 (<*>) (Task taskFunc) (Task taskArg) =
91− Task $ \ok err ->
127+ Task $ \env ok err ->
92 let
128 let
93 okFunc func =
129 okFunc func =
94 let
130 let
95 okArg arg = ok (func arg)
131 okArg arg = ok (func arg)
96 in
132 in
97− taskArg okArg err
133+ taskArg env okArg err
98 in
134 in
99− taskFunc okFunc err
135+ taskFunc env okFunc err
100
136
101
137
102−instance Monad (Task x) where
138+instance Monad Task where
103 {-# INLINE return #-}
139 {-# INLINE return #-}
104 return = pure
140 return = pure
105
141
106 {-# INLINE (>>=) #-}
142 {-# INLINE (>>=) #-}
107 (>>=) (Task taskA) callback =
143 (>>=) (Task taskA) callback =
108− Task $ \ok err ->
144+ Task $ \env ok err ->
109 let
145 let
110 okA a =
146 okA a =
111 case callback a of
147 case callback a of
112− Task taskB -> taskB ok err
148+ Task taskB -> taskB env ok err
113 in
149 in
114− taskA okA err
150+ taskA env okA err
builder/src/Stuff.hs+29−49
@@ -7,22 +7,18 @@ module Stuff
7 , elmi
7 , elmi
8 , elmo
8 , elmo
9 , temp
9 , temp
10− , findRoot
10+ , getRoot
11− , withRootLock
12− , withRegistryLock
13 , PackageCache
11 , PackageCache
14 , getPackageCache
12 , getPackageCache
15 , registry
13 , registry
16 , package
14 , package
17 , getReplCache
15 , getReplCache
18− , getElmHome
19 )
16 )
20 where
17 where
21
18
22
19
23import qualified System.Directory as Dir
20import qualified System.Directory as Dir
24import qualified System.Environment as Env
21import qualified System.Environment as Env
25−import qualified System.FileLock as Lock
26import qualified System.FilePath as FP
22import qualified System.FilePath as FP
27import System.FilePath ((</>), (<.>))
23import System.FilePath ((</>), (<.>))
28
24
@@ -35,29 +31,29 @@ import qualified Elm.Version as V
35-- PATHS
31-- PATHS
36
32
37
33
38−stuff :: FilePath -> FilePath
34+stuff :: FilePath
39−stuff root =
35+stuff =
40− root </> "elm-stuff" </> compilerVersion
36+ "elm-stuff" </> compilerVersion
41
37
42
38
43−details :: FilePath -> FilePath
39+details :: FilePath
44−details root =
40+details =
45− stuff root </> "d.dat"
41+ stuff </> "d.dat"
46
42
47
43
48−interfaces :: FilePath -> FilePath
44+interfaces :: FilePath
49−interfaces root =
45+interfaces =
50− stuff root </> "i.dat"
46+ stuff </> "i.dat"
51
47
52
48
53−objects :: FilePath -> FilePath
49+objects :: FilePath
54−objects root =
50+objects =
55− stuff root </> "o.dat"
51+ stuff </> "o.dat"
56
52
57
53
58−prepublishDir :: FilePath -> FilePath
54+prepublishDir :: FilePath
59−prepublishDir root =
55+prepublishDir =
60− stuff root </> "prepublish"
56+ stuff </> "prepublish"
61
57
62
58
63compilerVersion :: FilePath
59compilerVersion :: FilePath
@@ -81,55 +77,39 @@ elmo root name =
81
77
82toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath
78toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath
83toArtifactPath root name ext =
79toArtifactPath root name ext =
84− stuff root </> ModuleName.toHyphenPath name <.> ext
80+ root </> stuff </> ModuleName.toHyphenPath name <.> ext
85
81
86
82
87
83
88-- TEMP
84-- TEMP
89
85
90
86
91−temp :: FilePath -> String -> FilePath
87+temp :: String -> FilePath
92−temp root ext =
88+temp ext =
93− stuff root </> "temp" <.> ext
89+ stuff </> "temp" <.> ext
94
90
95
91
96
92
97−-- ROOT
93+-- GET ROOT
98
94
99
95
100−findRoot :: IO (Maybe FilePath)
96+getRoot :: IO (Maybe FilePath)
101−findRoot =
97+getRoot =
102 do dir <- Dir.getCurrentDirectory
98 do dir <- Dir.getCurrentDirectory
103− findRootHelp (FP.splitDirectories dir)
99+ getRootHelp (FP.splitDirectories dir)
104
100
105
101
106−findRootHelp :: [String] -> IO (Maybe FilePath)
102+getRootHelp :: [String] -> IO (Maybe FilePath)
107−findRootHelp dirs =
103+getRootHelp dirs =
108 case dirs of
104 case dirs of
109 [] ->
105 [] ->
110 return Nothing
106 return Nothing
111
107
112 _:_ ->
108 _:_ ->
113− do exists <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")
109+ do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")
114− if exists
110+ if exists_
115 then return (Just (FP.joinPath dirs))
111 then return (Just (FP.joinPath dirs))
116− else findRootHelp (init dirs)
112+ else getRootHelp (init dirs)
117−
118−
119−
120−-- LOCKS
121−
122−
123−withRootLock :: FilePath -> IO a -> IO a
124−withRootLock root work =
125− do let dir = stuff root
126− Dir.createDirectoryIfMissing True dir
127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
128−
129−
130−withRegistryLock :: PackageCache -> IO a -> IO a
131−withRegistryLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
133
113
134
114
135
115
cabal.configdeleted−2
@@ -1,2 +0,0 @@
1−profiling: False
2−library-profiling: True
compiler/src/AST/Canonical.hs+9−12
@@ -56,14 +56,12 @@ import Data.Binary
56import qualified Data.List as List
56import qualified Data.List as List
57import qualified Data.Map as Map
57import qualified Data.Map as Map
58import Data.Name (Name)
58import Data.Name (Name)
59+import qualified Data.Utf8 as Utf8
59
60
60−import qualified AST.Source as Src
61import qualified AST.Utils.Binop as Binop
61import qualified AST.Utils.Binop as Binop
62import qualified AST.Utils.Shader as Shader
62import qualified AST.Utils.Shader as Shader
63import qualified Data.Index as Index
63import qualified Data.Index as Index
64−import qualified Elm.Float as EF
65import qualified Elm.ModuleName as ModuleName
64import qualified Elm.ModuleName as ModuleName
66−import qualified Elm.String as ES
67import qualified Reporting.Annotation as A
65import qualified Reporting.Annotation as A
68
66
69
67
@@ -84,10 +82,10 @@ data Expr_
84 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
82 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
85 | VarDebug ModuleName.Canonical Name Annotation
83 | VarDebug ModuleName.Canonical Name Annotation
86 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
84 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
87− | Chr ES.String
85+ | Chr Utf8.String
88− | Str ES.String
86+ | Str Utf8.String
89 | Int Int
87 | Int Int
90− | Float EF.Float
88+ | Float (Utf8.Under256 Float)
91 | List [Expr]
89 | List [Expr]
92 | Negate Expr
90 | Negate Expr
93 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
91 | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
@@ -130,7 +128,7 @@ data Def
130
128
131data Decls
129data Decls
132 = Declare Def Decls
130 = Declare Def Decls
133− | DeclareRec Def [Def] Decls
131+ | DeclareRec [Def] Decls
134 | SaveTheEnvironment
132 | SaveTheEnvironment
135
133
136
134
@@ -152,8 +150,8 @@ data Pattern_
152 | PList [Pattern]
150 | PList [Pattern]
153 | PCons Pattern Pattern
151 | PCons Pattern Pattern
154 | PBool Union Bool
152 | PBool Union Bool
155− | PChr ES.String
153+ | PChr Utf8.String
156− | PStr ES.String
154+ | PStr Utf8.String
157 | PInt Int
155 | PInt Int
158 | PCtor
156 | PCtor
159 { _p_home :: ModuleName.Canonical
157 { _p_home :: ModuleName.Canonical
@@ -233,7 +231,6 @@ data Module =
233 Module
231 Module
234 { _name :: ModuleName.Canonical
232 { _name :: ModuleName.Canonical
235 , _exports :: Exports
233 , _exports :: Exports
236− , _docs :: Src.Docs
237 , _decls :: Decls
234 , _decls :: Decls
238 , _unions :: Map.Map Name Union
235 , _unions :: Map.Map Name Union
239 , _aliases :: Map.Map Name Alias
236 , _aliases :: Map.Map Name Alias
@@ -342,7 +339,7 @@ instance Binary CtorOpts where
342 0 -> return Normal
339 0 -> return Normal
343 1 -> return Enum
340 1 -> return Enum
344 2 -> return Unbox
341 2 -> return Unbox
345− _ -> fail "binary encoding of CtorOpts was corrupted"
342+ _ -> error "binary encoding of CtorOpts was corrupted"
346
343
347
344
348instance Binary Annotation where
345instance Binary Annotation where
@@ -393,7 +390,7 @@ instance Binary AliasType where
393 case n of
390 case n of
394 0 -> liftM Holey get
391 0 -> liftM Holey get
395 1 -> liftM Filled get
392 1 -> liftM Filled get
396− _ -> fail "binary encoding of AliasType was corrupted"
393+ _ -> error "binary encoding of AliasType was corrupted"
397
394
398
395
399instance Binary FieldType where
396instance Binary FieldType where
compiler/src/AST/Optimized.hs+40−101
@@ -7,35 +7,30 @@ module AST.Optimized
7 , Destructor(..)
7 , Destructor(..)
8 , Decider(..)
8 , Decider(..)
9 , Choice(..)
9 , Choice(..)
10− , GlobalGraph(..)
10+ , Graph(..)
11− , LocalGraph(..)
12 , Main(..)
11 , Main(..)
13 , Node(..)
12 , Node(..)
14 , EffectsType(..)
13 , EffectsType(..)
15 , empty
14 , empty
16− , addGlobalGraph
15+ , union
17− , addLocalGraph
16+ , unions
18− , addKernel
19− , toKernelGlobal
20 )
17 )
21 where
18 where
22
19
23
20
24import Control.Monad (liftM, liftM2, liftM3, liftM4)
21import Control.Monad (liftM, liftM2, liftM3, liftM4)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
22import Data.Binary (Binary, get, put, getWord8, putWord8)
23+import qualified Data.List as List
26import qualified Data.Map as Map
24import qualified Data.Map as Map
27−import qualified Data.Name as Name
28import Data.Name (Name)
25import Data.Name (Name)
29import qualified Data.Set as Set
26import qualified Data.Set as Set
27+import qualified Data.Utf8 as Utf8
30
28
31import qualified AST.Canonical as Can
29import qualified AST.Canonical as Can
32import qualified AST.Utils.Shader as Shader
30import qualified AST.Utils.Shader as Shader
33import qualified Data.Index as Index
31import qualified Data.Index as Index
34−import qualified Elm.Float as EF
35import qualified Elm.Kernel as K
32import qualified Elm.Kernel as K
36import qualified Elm.ModuleName as ModuleName
33import qualified Elm.ModuleName as ModuleName
37−import qualified Elm.Package as Pkg
38−import qualified Elm.String as ES
39import qualified Optimize.DecisionTree as DT
34import qualified Optimize.DecisionTree as DT
40import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
41
36
@@ -46,10 +41,10 @@ import qualified Reporting.Annotation as A
46
41
47data Expr
42data Expr
48 = Bool Bool
43 = Bool Bool
49− | Chr ES.String
44+ | Chr Utf8.String
50− | Str ES.String
45+ | Str Utf8.String
51 | Int Int
46 | Int Int
52− | Float EF.Float
47+ | Float (Utf8.Under256 Float)
53 | VarLocal Name
48 | VarLocal Name
54 | VarGlobal Global
49 | VarGlobal Global
55 | VarEnum Global Index.ZeroBased
50 | VarEnum Global Index.ZeroBased
@@ -75,6 +70,7 @@ data Expr
75
70
76
71
77data Global = Global ModuleName.Canonical Name
72data Global = Global ModuleName.Canonical Name
73+ deriving (Eq, Ord)
78
74
79
75
80
76
@@ -125,18 +121,11 @@ data Choice
125-- OBJECT GRAPH
121-- OBJECT GRAPH
126
122
127
123
128−data GlobalGraph =
124+data Graph =
129− GlobalGraph
125+ Graph
130− { _g_nodes :: Map.Map Global Node
126+ { _mains :: Map.Map ModuleName.Canonical Main
131− , _g_fields :: Map.Map Name Int
132− }
133−
134−
135−data LocalGraph =
136− LocalGraph
137− { _l_main :: Maybe Main
138− , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
127+ , _nodes :: Map.Map Global Node
139− , _l_fields :: Map.Map Name Int
128+ , _fields :: Map.Map Name Int
140 }
129 }
141
130
142
131
@@ -170,72 +159,27 @@ data EffectsType = Cmd | Sub | Fx
170
159
171
160
172{-# NOINLINE empty #-}
161{-# NOINLINE empty #-}
173−empty :: GlobalGraph
162+empty :: Graph
174empty =
163empty =
175− GlobalGraph Map.empty Map.empty
164+ Graph Map.empty 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−
193
165
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
222
166
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)
223
173
224
174
225−-- INSTANCES
175+unions :: [Graph] -> Graph
176+unions graphs =
177+ case graphs of
178+ [] ->
179+ empty
226
180
227−
181+ g:gs ->
228−instance Eq Global where
182+ List.foldl' union g gs
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
239
183
240
184
241
185
@@ -308,7 +252,7 @@ instance Binary Expr where
308 24 -> pure Unit
252 24 -> pure Unit
309 25 -> liftM3 Tuple get get get
253 25 -> liftM3 Tuple get get get
310 26 -> liftM3 Shader get get get
254 26 -> liftM3 Shader get get get
311− _ -> fail "problem getting Opt.Expr binary"
255+ _ -> error "problem getting Opt.Expr binary"
312
256
313
257
314instance Binary Def where
258instance Binary Def where
@@ -322,7 +266,7 @@ instance Binary Def where
322 case word of
266 case word of
323 0 -> liftM2 Def get get
267 0 -> liftM2 Def get get
324 1 -> liftM3 TailDef get get get
268 1 -> liftM3 TailDef get get get
325− _ -> fail "problem getting Opt.Def binary"
269+ _ -> error "problem getting Opt.Def binary"
326
270
327
271
328instance Binary Destructor where
272instance Binary Destructor where
@@ -345,7 +289,7 @@ instance Binary Path where
345 1 -> liftM2 Field get get
289 1 -> liftM2 Field get get
346 2 -> liftM Unbox get
290 2 -> liftM Unbox get
347 3 -> liftM Root get
291 3 -> liftM Root get
348− _ -> fail "problem getting Opt.Path binary"
292+ _ -> error "problem getting Opt.Path binary"
349
293
350
294
351instance (Binary a) => Binary (Decider a) where
295instance (Binary a) => Binary (Decider a) where
@@ -361,7 +305,7 @@ instance (Binary a) => Binary (Decider a) where
361 0 -> liftM Leaf get
305 0 -> liftM Leaf get
362 1 -> liftM3 Chain get get get
306 1 -> liftM3 Chain get get get
363 2 -> liftM3 FanOut get get get
307 2 -> liftM3 FanOut get get get
364− _ -> fail "problem getting Opt.Decider binary"
308+ _ -> error "problem getting Opt.Decider binary"
365
309
366
310
367instance Binary Choice where
311instance Binary Choice where
@@ -375,18 +319,13 @@ instance Binary Choice where
375 case word of
319 case word of
376 0 -> liftM Inline get
320 0 -> liftM Inline get
377 1 -> liftM Jump get
321 1 -> liftM Jump get
378− _ -> fail "problem getting Opt.Choice binary"
322+ _ -> error "problem getting Opt.Choice binary"
379−
380−
381
323
382−instance Binary GlobalGraph where
383− get = liftM2 GlobalGraph get get
384− put (GlobalGraph a b) = put a >> put b
385
324
386
325
387−instance Binary LocalGraph where
326+instance Binary Graph where
388− get = liftM3 LocalGraph get get get
327+ get = liftM3 Graph get get get
389− put (LocalGraph a b c) = put a >> put b >> put c
328+ put (Graph a b c) = put a >> put b >> put c
390
329
391
330
392instance Binary Main where
331instance Binary Main where
@@ -400,7 +339,7 @@ instance Binary Main where
400 case word of
339 case word of
401 0 -> return Static
340 0 -> return Static
402 1 -> liftM2 Dynamic get get
341 1 -> liftM2 Dynamic get get
403− _ -> fail "problem getting Opt.Main binary"
342+ _ -> error "problem getting Opt.Main binary"
404
343
405
344
406instance Binary Node where
345instance Binary Node where
@@ -432,7 +371,7 @@ instance Binary Node where
432 8 -> liftM2 Kernel get get
371 8 -> liftM2 Kernel get get
433 9 -> liftM2 PortIncoming get get
372 9 -> liftM2 PortIncoming get get
434 10 -> liftM2 PortOutgoing get get
373 10 -> liftM2 PortOutgoing get get
435− _ -> fail "problem getting Opt.Node binary"
374+ _ -> error "problem getting Opt.Node binary"
436
375
437
376
438instance Binary EffectsType where
377instance Binary EffectsType where
@@ -448,4 +387,4 @@ instance Binary EffectsType where
448 0 -> return Cmd
387 0 -> return Cmd
449 1 -> return Sub
388 1 -> return Sub
450 2 -> return Fx
389 2 -> return Fx
451− _ -> fail "problem getting Opt.EffectsType binary"
390+ _ -> error "problem getting Opt.EffectsType binary"
compiler/src/AST/Source.hs+22−39
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module AST.Source
3module AST.Source
3 ( Expr, Expr_(..), VarType(..)
4 ( Expr, Expr_(..), VarType(..)
4 , Def(..)
5 , Def(..)
@@ -6,17 +7,15 @@ module AST.Source
6 , Type, Type_(..)
7 , Type, Type_(..)
7 , Module(..)
8 , Module(..)
8 , getName
9 , getName
9− , getImportName
10+ , getImport
10 , Import(..)
11 , Import(..)
11 , Value(..)
12 , Value(..)
12 , Union(..)
13 , Union(..)
13 , Alias(..)
14 , Alias(..)
14− , Infix(..)
15+ , Binop(..)
15 , Port(..)
16 , Port(..)
16 , Effects(..)
17 , Effects(..)
17 , Manager(..)
18 , Manager(..)
18− , Docs(..)
19− , Comment(..)
20 , Exposing(..)
19 , Exposing(..)
21 , Exposed(..)
20 , Exposed(..)
22 , Privacy(..)
21 , Privacy(..)
@@ -25,13 +24,10 @@ module AST.Source
25
24
26
25
27import Data.Name (Name)
26import Data.Name (Name)
28−import qualified Data.Name as Name
27+import qualified Data.Utf8 as Utf8
29
28
30import qualified AST.Utils.Binop as Binop
29import qualified AST.Utils.Binop as Binop
31import qualified AST.Utils.Shader as Shader
30import qualified AST.Utils.Shader as Shader
32−import qualified Elm.Float as EF
33−import qualified Elm.String as ES
34−import qualified Parse.Primitives as P
35import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
36
32
37
33
@@ -43,10 +39,10 @@ type Expr = A.Located Expr_
43
39
44
40
45data Expr_
41data Expr_
46− = Chr ES.String
42+ = Chr Utf8.String
47− | Str ES.String
43+ | Str Utf8.String
48 | Int Int
44 | Int Int
49− | Float EF.Float
45+ | Float (Utf8.Under256 Float)
50 | Var VarType Name
46 | Var VarType Name
51 | VarQual VarType Name Name
47 | VarQual VarType Name Name
52 | List [Expr]
48 | List [Expr]
@@ -97,8 +93,8 @@ data Pattern_
97 | PCtorQual A.Region Name Name [Pattern]
93 | PCtorQual A.Region Name Name [Pattern]
98 | PList [Pattern]
94 | PList [Pattern]
99 | PCons Pattern Pattern
95 | PCons Pattern Pattern
100− | PChr ES.String
96+ | PChr Utf8.String
101− | PStr ES.String
97+ | PStr Utf8.String
102 | PInt Int
98 | PInt Int
103
99
104
100
@@ -126,30 +122,26 @@ data Type_
126
122
127data Module =
123data Module =
128 Module
124 Module
129− { _name :: Maybe (A.Located Name)
125+ { _name :: Maybe Name
130 , _exports :: A.Located Exposing
126 , _exports :: A.Located Exposing
131− , _docs :: Docs
132 , _imports :: [Import]
127 , _imports :: [Import]
133 , _values :: [A.Located Value]
128 , _values :: [A.Located Value]
134 , _unions :: [A.Located Union]
129 , _unions :: [A.Located Union]
135 , _aliases :: [A.Located Alias]
130 , _aliases :: [A.Located Alias]
136− , _binops :: [A.Located Infix]
131+ , _binops :: [A.Located Binop]
137 , _effects :: Effects
132 , _effects :: Effects
138 }
133 }
139
134
140
135
141getName :: Module -> Name
136getName :: Module -> Name
142−getName (Module maybeName _ _ _ _ _ _ _ _) =
137+getName (Module maybeName _ _ _ _ _ _ _) =
143 case maybeName of
138 case maybeName of
144− Just (A.At _ name) ->
139+ Just name -> name
145− name
140+ Nothing -> "Main"
146
141
147− Nothing ->
148− Name._Main
149
142
150−
151−getImportName :: Import -> Name
143+getImport :: Import -> Name
152−getImportName (Import (A.At _ name) _ _) =
144+getImport (Import (A.At _ name) _ _) =
153 name
145 name
154
146
155
147
@@ -164,7 +156,7 @@ data Import =
164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
156data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
157data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
166data Alias = Alias (A.Located Name) [A.Located Name] Type
158data Alias = Alias (A.Located Name) [A.Located Name] Type
167−data Infix = Infix Name Binop.Associativity Binop.Precedence Name
159+data Binop = Binop Name Binop.Associativity Binop.Precedence Name
168data Port = Port (A.Located Name) Type
160data Port = Port (A.Located Name) Type
169
161
170
162
@@ -180,30 +172,21 @@ data Manager
180 | Fx (A.Located Name) (A.Located Name)
172 | Fx (A.Located Name) (A.Located Name)
181
173
182
174
183−data Docs
184− = NoDocs A.Region
185− | YesDocs Comment [(Name, Comment)]
186−
187−
188−newtype Comment =
189− Comment P.Snippet
190−
191−
192
175
193-- EXPOSING
176-- EXPOSING
194
177
195
178
196data Exposing
179data Exposing
197 = Open
180 = Open
198− | Explicit [Exposed]
181+ | Explicit [A.Located Exposed]
199
182
200
183
201data Exposed
184data Exposed
202− = Lower (A.Located Name)
185+ = Lower Name
203− | Upper (A.Located Name) Privacy
186+ | Upper Name Privacy
204− | Operator A.Region Name
187+ | Operator Name
205
188
206
189
207data Privacy
190data Privacy
208− = Public A.Region
191+ = Public
209 | Private
192 | Private
compiler/src/AST/Utils/Binop.hs+6−5
@@ -41,11 +41,12 @@ instance Binary Precedence where
41instance Binary Associativity where
41instance Binary Associativity where
42 get =
42 get =
43 do n <- getWord8
43 do n <- getWord8
44+ return $
44− case n of
45+ case n of
45− 0 -> return Left
46+ 0 -> Left
46− 1 -> return Non
47+ 1 -> Non
47− 2 -> return Right
48+ 2 -> Right
48− _ -> fail "Error reading valid associativity from serialized string"
49+ _ -> error "Error reading valid associativity from serialized string"
49
50
50 put assoc =
51 put assoc =
51 putWord8 $
52 putWord8 $
compiler/src/AST/Utils/Shader.hs+4−51
@@ -4,27 +4,22 @@ module AST.Utils.Shader
4 ( Source
4 ( Source
5 , Types(..)
5 , Types(..)
6 , Type(..)
6 , Type(..)
7− , fromChars
8− , toJsStringBuilder
9 )
7 )
10 where
8 where
11
9
12
10
13−import Control.Monad (liftM)
14−import Data.Binary (Binary, get, put)
15−import qualified Data.ByteString as BS
16−import qualified Data.ByteString.Builder as B
17−import qualified Data.ByteString.UTF8 as BS_UTF8
18import qualified Data.Map as Map
11import qualified Data.Map as Map
19import qualified Data.Name as Name
12import qualified Data.Name as Name
13+import qualified Data.Utf8 as Utf8
20
14
21
15
22
16
23-- SOURCE
17-- SOURCE
24
18
25
19
26−newtype Source =
20+type Source = Utf8.VeryLong SOURCE
27− Source BS.ByteString
21+
22+data SOURCE
28
23
29
24
30
25
@@ -47,45 +42,3 @@ data Type
47 | V4
42 | V4
48 | M4
43 | M4
49 | Texture
44 | Texture
50−
51−
52−
53−-- TO BUILDER
54−
55−
56−toJsStringBuilder :: Source -> B.Builder
57−toJsStringBuilder (Source src) =
58− B.byteString src
59−
60−
61−
62−-- FROM CHARS
63−
64−
65−fromChars :: [Char] -> Source
66−fromChars chars =
67− Source (BS_UTF8.fromString (escape chars))
68−
69−
70−escape :: [Char] -> [Char]
71−escape chars =
72− case chars of
73− [] ->
74− []
75−
76− c:cs
77− | c == '\r' -> escape cs
78− | c == '\n' -> '\\' : 'n' : escape cs
79− | c == '\"' -> '\\' : '"' : escape cs
80− | c == '\'' -> '\\' : '\'' : escape cs
81− | c == '\\' -> '\\' : '\\' : escape cs
82− | otherwise -> c : escape cs
83−
84−
85−
86−-- BINARY
87−
88−
89−instance Binary Source where
90− get = liftM Source get
91− put (Source a) = put a
compiler/src/AST/Utils/Type.hs+1
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module AST.Utils.Type
3module AST.Utils.Type
3 ( delambda
4 ( delambda
4 , dealias
5 , dealias
compiler/src/Canonicalize/Environment.hs+20−50
@@ -4,8 +4,6 @@ module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5 , Exposed
5 , Exposed
6 , Qualified
6 , Qualified
7− , Info(..)
8− , mergeInfo
9 , Var(..)
7 , Var(..)
10 , Type(..)
8 , Type(..)
11 , Ctor(..)
9 , Ctor(..)
@@ -22,8 +20,8 @@ module Canonicalize.Environment
22
20
23import qualified Data.Map.Merge.Strict as Map
21import qualified Data.Map.Merge.Strict as Map
24import qualified Data.Map.Strict as Map
22import qualified Data.Map.Strict as Map
23+import qualified Data.Map.Strict.Internal as I
25import qualified Data.Name as Name
24import qualified Data.Name as Name
26−import qualified Data.OneOrMore as OneOrMore
27
25
28import qualified AST.Utils.Binop as Binop
26import qualified AST.Utils.Binop as Binop
29import qualified AST.Canonical as Can
27import qualified AST.Canonical as Can
@@ -60,34 +58,11 @@ data Env =
60
58
61
59
62type Exposed a =
60type Exposed a =
63− Map.Map Name.Name (Info a)
61+ Map.Map Name.Name (Map.Map ModuleName.Canonical a)
64
62
65
63
66type Qualified a =
64type Qualified a =
67− Map.Map Name.Name (Map.Map Name.Name (Info a))
65+ Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))
68−
69−
70−
71−-- INFO
72−
73−
74−data Info a
75− = Specific ModuleName.Canonical a
76− | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77−
78−
79−mergeInfo :: Info a -> Info a -> Info a
80−mergeInfo info1 info2 =
81− case info1 of
82− Specific h1 _ ->
83− case info2 of
84− Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86−
87− Ambiguous h1 hs1 ->
88− case info2 of
89− Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90− Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
91
66
92
67
93
68
@@ -97,8 +72,7 @@ mergeInfo info1 info2 =
97data Var
72data Var
98 = Local A.Region
73 = Local A.Region
99 | TopLevel A.Region
74 | TopLevel A.Region
100− | Foreign ModuleName.Canonical Can.Annotation
75+ | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
101− | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
102
76
103
77
104
78
@@ -165,10 +139,7 @@ addLocalLeft _ region =
165addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
139addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
166addLocalBoth name region var =
140addLocalBoth name region var =
167 case var of
141 case var of
168− Foreign _ _ ->
142+ Foreign _ ->
169− Result.ok (Local region)
170−
171− Foreigns _ _ ->
172 Result.ok (Local region)
143 Result.ok (Local region)
173
144
174 Local parentRegion ->
145 Local parentRegion ->
@@ -179,18 +150,17 @@ addLocalBoth name region var =
179
150
180
151
181
152
182−
183-- FIND TYPE
153-- FIND TYPE
184
154
185
155
186findType :: A.Region -> Env -> Name.Name -> Result i w Type
156findType :: A.Region -> Env -> Name.Name -> Result i w Type
187findType region (Env _ _ ts _ _ _ qts _) name =
157findType region (Env _ _ ts _ _ _ qts _) name =
188 case Map.lookup name ts of
158 case Map.lookup name ts of
189− Just (Specific _ tipe) ->
159+ Just (I.Bin 1 _ tipe _ _) ->
190 Result.ok tipe
160 Result.ok tipe
191
161
192− Just (Ambiguous h hs) ->
162+ Just homes ->
193− Result.throw (Error.AmbiguousType region Nothing name h hs)
163+ Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
194
164
195 Nothing ->
165 Nothing ->
196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
@@ -201,11 +171,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
201 case Map.lookup prefix qts of
171 case Map.lookup prefix qts of
202 Just qualified ->
172 Just qualified ->
203 case Map.lookup name qualified of
173 case Map.lookup name qualified of
204− Just (Specific _ tipe) ->
174+ Just (I.Bin 1 _ tipe _ _) ->
205 Result.ok tipe
175 Result.ok tipe
206
176
207− Just (Ambiguous h hs) ->
177+ Just homes ->
208− Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
178+ Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
209
179
210 Nothing ->
180 Nothing ->
211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -221,11 +191,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
221findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
191findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
223 case Map.lookup name cs of
193 case Map.lookup name cs of
224− Just (Specific _ ctor) ->
194+ Just (I.Bin 1 _ ctor _ _) ->
225 Result.ok ctor
195 Result.ok ctor
226
196
227− Just (Ambiguous h hs) ->
197+ Just homes ->
228− Result.throw (Error.AmbiguousVariant region Nothing name h hs)
198+ Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))
229
199
230 Nothing ->
200 Nothing ->
231 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
201 Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
@@ -236,11 +206,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
236 case Map.lookup prefix qcs of
206 case Map.lookup prefix qcs of
237 Just qualified ->
207 Just qualified ->
238 case Map.lookup name qualified of
208 case Map.lookup name qualified of
239− Just (Specific _ pattern) ->
209+ Just (I.Bin 1 _ pattern _ _) ->
240 Result.ok pattern
210 Result.ok pattern
241
211
242− Just (Ambiguous h hs) ->
212+ Just homes ->
243− Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
213+ Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))
244
214
245 Nothing ->
215 Nothing ->
246 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
216 Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
@@ -256,11 +226,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
256findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
226findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
257findBinop region (Env _ _ _ _ binops _ _ _) name =
227findBinop region (Env _ _ _ _ binops _ _ _) name =
258 case Map.lookup name binops of
228 case Map.lookup name binops of
259− Just (Specific _ binop) ->
229+ Just (I.Bin 1 _ binop _ _) ->
260 Result.ok binop
230 Result.ok binop
261
231
262− Just (Ambiguous h hs) ->
232+ Just homes ->
263− Result.throw (Error.AmbiguousBinop region name h hs)
233+ Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
264
234
265 Nothing ->
235 Nothing ->
266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
236 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
compiler/src/Canonicalize/Environment/Dups.hs+3−6
@@ -57,11 +57,8 @@ detectHelp toError name values =
57 OneOrMore.One (Info _ value) ->
57 OneOrMore.One (Info _ value) ->
58 return value
58 return value
59
59
60− OneOrMore.More left right ->
60+ OneOrMore.More _ _ ->
61− let
62− (Info r1 _, Info r2 _) =
61+ let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in
63− OneOrMore.getFirstTwo left right
64− in
65 Result.throw (toError name r1 r2)
62 Result.throw (toError name r1 r2)
66
63
67
64
@@ -105,7 +102,7 @@ one name region value =
105
102
106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
103insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107insert name region value dict =
104insert name region value dict =
108− Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
105+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
109
106
110
107
111union :: Dict a -> Dict a -> Dict a
108union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hs+38−73
@@ -18,7 +18,6 @@ import qualified AST.Source as Src
18import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment as Env
19import qualified Elm.Interface as I
19import qualified Elm.Interface as I
20import qualified Elm.ModuleName as ModuleName
20import qualified Elm.ModuleName as ModuleName
21−import qualified Elm.Package as Pkg
22import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
24import qualified Reporting.Result as Result
23import qualified Reporting.Result as Result
@@ -34,15 +33,8 @@ type Result i w a =
34
33
35createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
34createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
36createInitialEnv home ifaces imports =
35createInitialEnv home ifaces imports =
37− do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
36+ do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState imports
38− Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
37+ Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
39−
40−
41−infoToVar :: Env.Info Can.Annotation -> Env.Var
42−infoToVar info =
43− case info of
44− Env.Specific home tipe -> Env.Foreign home tipe
45− Env.Ambiguous h hs -> Env.Foreigns h hs
46
38
47
39
48
40
@@ -68,29 +60,7 @@ emptyState =
68
60
69emptyTypes :: Env.Exposed Env.Type
61emptyTypes :: Env.Exposed Env.Type
70emptyTypes =
62emptyTypes =
71− Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))
63+ Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))
72−
73−
74−
75−-- TO SAFE IMPORTS
76−
77−
78−toSafeImports :: ModuleName.Canonical -> [Src.Import] -> [Src.Import]
79−toSafeImports (ModuleName.Canonical pkg _) imports =
80− if Pkg.isKernel pkg
81− then filter isNormal imports
82− else imports
83−
84−
85−isNormal :: Src.Import -> Bool
86−isNormal (Src.Import (A.At _ name) maybeAlias _) =
87− if Name.isKernel name
88− then
89− case maybeAlias of
90− Nothing -> False
91− Just _ -> error "kernel imports cannot use `as`"
92− else
93− True
94
64
95
65
96
66
@@ -109,8 +79,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
109 (Map.mapMaybeWithKey (unionToType home) unions)
79 (Map.mapMaybeWithKey (unionToType home) unions)
110 (Map.mapMaybeWithKey (aliasToType home) aliases)
80 (Map.mapMaybeWithKey (aliasToType home) aliases)
111
81
112− !vars = Map.map (Env.Specific home) defs
82+ !vars = Map.map (Map.singleton home) defs
113− !types = Map.map (Env.Specific home . fst) rawTypeInfo
83+ !types = Map.map (Map.singleton home . fst) rawTypeInfo
114 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
84 !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
115
85
116 !qvs2 = addQualified prefix vars qvs
86 !qvs2 = addQualified prefix vars qvs
@@ -136,7 +106,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe
136
106
137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
107addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138addExposed =
108addExposed =
139− Map.unionWith Env.mergeInfo
109+ Map.unionWith Map.union
140
110
141
111
142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
112addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
@@ -157,7 +127,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,
157unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
127unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158 let
128 let
159 addCtor dict (Can.Ctor ctor index _ args) =
129 addCtor dict (Can.Ctor ctor index _ args) =
160− Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
130+ Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict
161 in
131 in
162 ( Env.Union (length vars) home
132 ( Env.Union (length vars) home
163 , List.foldl' addCtor Map.empty ctors
133 , List.foldl' addCtor Map.empty ctors
@@ -188,7 +158,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
188 (Can.TAlias home name avars (Can.Filled tipe))
158 (Can.TAlias home name avars (Can.Filled tipe))
189 (Can.fieldsToList fields)
159 (Can.fieldsToList fields)
190 in
160 in
191− Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
161+ Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))
192
162
193 _ ->
163 _ ->
194 Map.empty
164 Map.empty
@@ -199,9 +169,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =
199-- BINOP
169-- BINOP
200
170
201
171
202−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
172+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop
203binopToBinop home op (I.Binop name annotation associativity precedence) =
173binopToBinop home op (I.Binop name annotation associativity precedence) =
204− Env.Specific home (Env.Binop op home name annotation associativity precedence)
174+ Map.singleton home (Env.Binop op home name annotation associativity precedence)
205
175
206
176
207
177
@@ -214,19 +184,19 @@ addExposedValue
214 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
184 -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215 -> Map.Map Name.Name I.Binop
185 -> Map.Map Name.Name I.Binop
216 -> State
186 -> State
217− -> Src.Exposed
187+ -> A.Located Src.Exposed
218 -> Result i w State
188 -> Result i w State
219−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
189+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
220 case exposed of
190 case exposed of
221− Src.Lower (A.At region name) ->
191+ Src.Lower name ->
222 case Map.lookup name vars of
192 case Map.lookup name vars of
223 Just info ->
193 Just info ->
224− Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
194+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
225
195
226 Nothing ->
196 Nothing ->
227 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
197 Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228
198
229− Src.Upper (A.At region name) privacy ->
199+ Src.Upper name privacy ->
230 case privacy of
200 case privacy of
231 Src.Private ->
201 Src.Private ->
232 case Map.lookup name types of
202 case Map.lookup name types of
@@ -234,43 +204,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
234 case tipe of
204 case tipe of
235 Env.Union _ _ ->
205 Env.Union _ _ ->
236 let
206 let
237− !ts2 = Map.insert name (Env.Specific home tipe) ts
207+ !ts2 = Map.insert name (Map.singleton home tipe) ts
238 in
208 in
239 Result.ok (State vs ts2 cs bs qvs qts qcs)
209 Result.ok (State vs ts2 cs bs qvs qts qcs)
240
210
241 Env.Alias _ _ _ _ ->
211 Env.Alias _ _ _ _ ->
242 let
212 let
243− !ts2 = Map.insert name (Env.Specific home tipe) ts
213+ !ts2 = Map.insert name (Map.singleton home tipe) ts
244 !cs2 = addExposed cs ctors
214 !cs2 = addExposed cs ctors
245 in
215 in
246 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
216 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247
217
248 Nothing ->
218 Nothing ->
249− case checkForCtorMistake name types of
219+ case Map.lookup name (toCtors types) of
250− tipe:_ ->
220+ Just tipe ->
251 Result.throw $ Error.ImportCtorByName region name tipe
221 Result.throw $ Error.ImportCtorByName region name tipe
252
222
253− [] ->
223+ Nothing ->
254 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
224 Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255
225
256− Src.Public dotDotRegion ->
226+ Src.Public ->
257 case Map.lookup name types of
227 case Map.lookup name types of
258 Just (tipe, ctors) ->
228 Just (tipe, ctors) ->
259 case tipe of
229 case tipe of
260 Env.Union _ _ ->
230 Env.Union _ _ ->
261 let
231 let
262− !ts2 = Map.insert name (Env.Specific home tipe) ts
232+ !ts2 = Map.insert name (Map.singleton home tipe) ts
263 !cs2 = addExposed cs ctors
233 !cs2 = addExposed cs ctors
264 in
234 in
265 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
235 Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266
236
267 Env.Alias _ _ _ _ ->
237 Env.Alias _ _ _ _ ->
268− Result.throw (Error.ImportOpenAlias dotDotRegion name)
238+ Result.throw (Error.ImportOpenAlias region name)
269
239
270 Nothing ->
240 Nothing ->
271 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
241 Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272
242
273− Src.Operator region op ->
243+ Src.Operator op ->
274 case Map.lookup op binops of
244 case Map.lookup op binops of
275 Just binop ->
245 Just binop ->
276 let
246 let
@@ -282,23 +252,18 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
282 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
252 Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283
253
284
254
255+
285−checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
256+toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name
286−checkForCtorMistake givenName types =
257+toCtors types =
287− Map.foldr addMatches [] types
258+ Map.foldr addCtors Map.empty types
288 where
259 where
289− addMatches (_, exposedCtors) matches =
260+ addCtors (_, exposedCtors) dict =
290− Map.foldrWithKey addMatch matches exposedCtors
261+ Map.foldrWithKey addCtor dict exposedCtors
291−
262+
292− addMatch ctorName info matches =
263+ addCtor ctorName homes dict =
293− if ctorName /= givenName
294− then matches
295− else
296− case info of
264+ case Map.elems homes of
297− Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
265+ [Env.Ctor _ tipeName _ _ _] ->
298− tipeName : matches
266+ Map.insert ctorName tipeName dict
299−
267+
300− Env.Specific _ (Env.RecordCtor _ _ _) ->
268+ _ ->
301− matches
269+ dict
302−
303− Env.Ambiguous _ _ ->
304− matches
compiler/src/Canonicalize/Environment/Local.hs+8−8
@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
54
54
55
55
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57−collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
57+collectVars (Src.Module _ _ _ values _ _ _ effects) =
58 let
58 let
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
60 Dups.insert name region (Env.TopLevel region) dict
60 Dups.insert name region (Env.TopLevel region) dict
@@ -95,7 +95,7 @@ toEffectDups effects =
95
95
96
96
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98−addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
98+addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
99 let
99 let
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112 do arity <- checkUnionFreeVars union
112 do arity <- checkUnionFreeVars union
113− let one = Env.Specific home (Env.Union arity home)
113+ let one = Map.singleton home (Env.Union arity home)
114 Result.ok $ Map.insert name one types
114 Result.ok $ Map.insert name one types
115
115
116
116
@@ -133,7 +133,7 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134 do args <- checkAliasFreeVars alias
134 do args <- checkAliasFreeVars alias
135 ctype <- Type.canonicalize env tipe
135 ctype <- Type.canonicalize env tipe
136− let one = Env.Specific home (Env.Alias (length args) home args ctype)
136+ let one = Map.singleton home (Env.Alias (length args) home args ctype)
137 let ts1 = Map.insert name one ts
137 let ts1 = Map.insert name one ts
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139
139
@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =
262
262
263
263
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265−addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
265+addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266 do unionInfo <- traverse (canonicalizeUnion env) unions
266 do unionInfo <- traverse (canonicalizeUnion env) unions
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
268
268
@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs
281 )
281 )
282
282
283
283
284−type CtorDups = Dups.Dict (Env.Info Env.Ctor)
284+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
285
285
286
286
287
287
@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi
297 ,
297 ,
298 case ctipe of
298 case ctipe of
299 Can.TRecord fields Nothing ->
299 Can.TRecord fields Nothing ->
300− Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
300+ Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
301
301
302 _ ->
302 _ ->
303 Dups.none
303 Dups.none
@@ -351,5 +351,5 @@ toOpts ctors =
351
351
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
352toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354− Dups.one name region $ Env.Specific home $
354+ Dups.one name region $ Map.singleton home $
355 Env.Ctor home typeName union index args
355 Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hs+7−6
@@ -14,6 +14,7 @@ import Control.Monad (foldM)
14import qualified Data.Graph as Graph
14import qualified Data.Graph as Graph
15import qualified Data.List as List
15import qualified Data.List as List
16import qualified Data.Map.Strict as Map
16import qualified Data.Map.Strict as Map
17+import qualified Data.Map.Strict.Internal as I
17import qualified Data.Name as Name
18import qualified Data.Name as Name
18
19
19import qualified AST.Canonical as Can
20import qualified AST.Canonical as Can
@@ -695,15 +696,15 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
695 Env.TopLevel _ ->
696 Env.TopLevel _ ->
696 logVar name (Can.VarTopLevel localHome name)
697 logVar name (Can.VarTopLevel localHome name)
697
698
698− Env.Foreign home annotation ->
699+ Env.Foreign (I.Bin 1 home annotation _ _) ->
699 Result.ok $
700 Result.ok $
700 if home == ModuleName.debug then
701 if home == ModuleName.debug then
701 Can.VarDebug localHome name annotation
702 Can.VarDebug localHome name annotation
702 else
703 else
703 Can.VarForeign home name annotation
704 Can.VarForeign home name annotation
704
705
705− Env.Foreigns h hs ->
706+ Env.Foreign homes ->
706− Result.throw (Error.AmbiguousVar region Nothing name h hs)
707+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
707
708
708 Nothing ->
709 Nothing ->
709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
710 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
@@ -714,15 +715,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714 case Map.lookup prefix qvs of
715 case Map.lookup prefix qvs of
715 Just qualified ->
716 Just qualified ->
716 case Map.lookup name qualified of
717 case Map.lookup name qualified of
717− Just (Env.Specific home annotation) ->
718+ Just (I.Bin 1 home annotation _ _) ->
718 Result.ok $
719 Result.ok $
719 if home == ModuleName.debug then
720 if home == ModuleName.debug then
720 Can.VarDebug localHome name annotation
721 Can.VarDebug localHome name annotation
721 else
722 else
722 Can.VarForeign home name annotation
723 Can.VarForeign home name annotation
723
724
724− Just (Env.Ambiguous h hs) ->
725+ Just homes ->
725− Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
726+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
726
727
727 Nothing ->
728 Nothing ->
728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
729 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
compiler/src/Canonicalize/Module.hs+19−31
@@ -42,7 +42,7 @@ type Result i w a =
42
42
43
43
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
44canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45−canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops effects) =
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
46 do let home = ModuleName.Canonical pkg (Src.getName modul)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
48
48
@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ bino
54 ceffects <- Effects.canonicalize env values cunions effects
54 ceffects <- Effects.canonicalize env values cunions effects
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
56
56
57− return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects
58
58
59
59
60
60
61-- CANONICALIZE BINOP
61-- CANONICALIZE BINOP
62
62
63
63
64−canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
64+canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )
65−canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
65+canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =
66 ( op, Can.Binop_ associativity precedence func )
66 ( op, Can.Binop_ associativity precedence func )
67
67
68
68
@@ -93,11 +93,13 @@ 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+
96 Graph.CyclicSCC subNodes ->
99 Graph.CyclicSCC subNodes ->
100+ Can.DeclareRec
97− do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)
101+ <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
98− case defs of
99− [] -> detectCycles otherSccs
100− d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs
102+ <*> detectCycles otherSccs
101
103
102
104
103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
105detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
@@ -106,22 +108,8 @@ detectBadCycles scc =
106 Graph.AcyclicSCC def ->
108 Graph.AcyclicSCC def ->
107 Result.ok def
109 Result.ok def
108
110
109− Graph.CyclicSCC [] ->
111+ Graph.CyclicSCC cyclicValueDefs ->
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
117− Result.throw (Error.RecursiveDecl region name names)
112+ Result.throw (Error.RecursiveDecl cyclicValueDefs)
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
125
113
126
114
127
115
@@ -236,11 +224,11 @@ checkExposed
236 -> Map.Map Name.Name alias
224 -> Map.Map Name.Name alias
237 -> Map.Map Name.Name binop
225 -> Map.Map Name.Name binop
238 -> Can.Effects
226 -> Can.Effects
239− -> Src.Exposed
227+ -> A.Located Src.Exposed
240 -> Result i w (Dups.Dict (A.Located Can.Export))
228 -> Result i w (Dups.Dict (A.Located Can.Export))
241−checkExposed values unions aliases binops effects exposed =
229+checkExposed values unions aliases binops effects (A.At region exposed) =
242 case exposed of
230 case exposed of
243− Src.Lower (A.At region name) ->
231+ Src.Lower name ->
244 if Map.member name values then
232 if Map.member name values then
245 ok name region Can.ExportValue
233 ok name region Can.ExportValue
246 else
234 else
@@ -252,23 +240,23 @@ checkExposed values unions aliases binops effects exposed =
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
240 Result.throw $ Error.ExportNotFound region Error.BadVar name $
253 ports ++ Map.keys values
241 ports ++ Map.keys values
254
242
255− Src.Operator region name ->
243+ Src.Operator name ->
256 if Map.member name binops then
244 if Map.member name binops then
257 ok name region Can.ExportBinop
245 ok name region Can.ExportBinop
258 else
246 else
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
247 Result.throw $ Error.ExportNotFound region Error.BadOp name $
260 Map.keys binops
248 Map.keys binops
261
249
262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
250+ Src.Upper name Src.Public ->
263 if Map.member name unions then
251 if Map.member name unions then
264 ok name region Can.ExportUnionOpen
252 ok name region Can.ExportUnionOpen
265 else if Map.member name aliases then
253 else if Map.member name aliases then
266− Result.throw $ Error.ExportOpenAlias dotDotRegion name
254+ Result.throw $ Error.ExportOpenAlias region name
267 else
255 else
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
256 Result.throw $ Error.ExportNotFound region Error.BadType name $
269 Map.keys unions ++ Map.keys aliases
257 Map.keys unions ++ Map.keys aliases
270
258
271− Src.Upper (A.At region name) Src.Private ->
259+ Src.Upper name Src.Private ->
272 if Map.member name unions then
260 if Map.member name unions then
273 ok name region Can.ExportUnionClosed
261 ok name region Can.ExportUnionClosed
274 else if Map.member name aliases then
262 else if Map.member name aliases then
compiler/src/Canonicalize/Pattern.hs+2−3
@@ -8,7 +8,6 @@ module Canonicalize.Pattern
8 where
8 where
9
9
10
10
11−import qualified Data.List as List
12import qualified Data.Map.Strict as Map
11import qualified Data.Map.Strict as Map
13import qualified Data.Name as Name
12import qualified Data.Name as Name
14
13
@@ -174,8 +173,8 @@ logVar name region value =
174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175logFields fields value =
174logFields fields value =
176 let
175 let
177− addField dict (A.At region name) =
176+ addField (A.At region name) dict =
178 Dups.insert name region region dict
177 Dups.insert name region region dict
179 in
178 in
180 Result.Result $ \bindings warnings _ ok ->
179 Result.Result $ \bindings warnings _ ok ->
181− ok (List.foldl' addField bindings fields) warnings value
180+ ok (foldr addField bindings fields) warnings value
compiler/src/Compile.hs+19−27
@@ -8,6 +8,7 @@ module Compile
8
8
9import qualified Data.Map as Map
9import qualified Data.Map as Map
10import qualified Data.Name as Name
10import qualified Data.Name as Name
11+import qualified Data.OneOrMore as OneOrMore
11
12
12import qualified AST.Source as Src
13import qualified AST.Source as Src
13import qualified AST.Canonical as Can
14import qualified AST.Canonical as Can
@@ -20,7 +21,7 @@ import qualified Nitpick.PatternMatches as PatternMatches
20import qualified Optimize.Module as Optimize
21import qualified Optimize.Module as Optimize
21import qualified Reporting.Error as E
22import qualified Reporting.Error as E
22import qualified Reporting.Result as R
23import qualified Reporting.Result as R
23−import qualified Reporting.Render.Type.Localizer as Localizer
24+import qualified Reporting.Warning as W
24import qualified Type.Constrain.Module as Type
25import qualified Type.Constrain.Module as Type
25import qualified Type.Solve as Type
26import qualified Type.Solve as Type
26
27
@@ -35,16 +36,17 @@ data Artifacts =
35 Artifacts
36 Artifacts
36 { _modul :: Can.Module
37 { _modul :: Can.Module
37 , _types :: Map.Map Name.Name Can.Annotation
38 , _types :: Map.Map Name.Name Can.Annotation
38− , _graph :: Opt.LocalGraph
39+ , _graph :: Opt.Graph
39 }
40 }
40
41
41
42
42−compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
43+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> ([W.Warning], Either (OneOrMore.OneOrMore E.Error) Artifacts)
43compile pkg ifaces modul =
44compile pkg ifaces modul =
45+ R.run $
44 do canonical <- canonicalize pkg ifaces modul
46 do canonical <- canonicalize pkg ifaces modul
45− annotations <- typeCheck modul canonical
47+ annotations <- typeCheck canonical
46 () <- nitpick canonical
48 () <- nitpick canonical
47− objects <- optimize modul annotations canonical
49+ objects <- optimize annotations canonical
48 return (Artifacts canonical annotations objects)
50 return (Artifacts canonical annotations objects)
49
51
50
52
@@ -52,41 +54,31 @@ compile pkg ifaces modul =
52-- PHASES
54-- PHASES
53
55
54
56
55−canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
57+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> R.Result i [W.Warning] E.Error Can.Module
56canonicalize pkg ifaces modul =
58canonicalize pkg ifaces modul =
57− case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
59+ R.mapError E.Canonicalize $ Canonicalize.canonicalize pkg ifaces modul
58− Right canonical ->
59− Right canonical
60−
61− Left errors ->
62− Left $ E.BadNames errors
63
60
64
61
65−typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
62+typeCheck :: Can.Module -> R.Result i w E.Error (Map.Map Name.Name Can.Annotation)
66−typeCheck modul canonical =
63+typeCheck canonical =
67 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
64 case unsafePerformIO (Type.run =<< Type.constrain canonical) of
68 Right annotations ->
65 Right annotations ->
69− Right annotations
66+ R.ok annotations
70
67
71 Left errors ->
68 Left errors ->
72− Left (E.BadTypes (Localizer.fromModule modul) errors)
69+ R.throw (E.Type errors)
73
70
74
71
75−nitpick :: Can.Module -> Either E.Error ()
72+nitpick :: Can.Module -> R.Result i w E.Error ()
76nitpick canonical =
73nitpick canonical =
77 case PatternMatches.check canonical of
74 case PatternMatches.check canonical of
78 Right () ->
75 Right () ->
79− Right ()
76+ R.ok ()
80
77
81 Left errors ->
78 Left errors ->
82− Left (E.BadPatterns errors)
79+ R.throw (E.Pattern errors)
83
80
84
81
85−optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
82+optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> R.Result i [W.Warning] E.Error Opt.Graph
86−optimize modul annotations canonical =
83+optimize annotations canonical =
87− case snd $ R.run $ Optimize.optimize annotations canonical of
84+ R.mapError E.Main $ Optimize.optimize annotations canonical
88− Right localGraph ->
89− Right localGraph
90−
91− Left errors ->
92− Left (E.BadMains (Localizer.fromModule modul) errors)
compiler/src/Data/Map/Utils.hsdeleted−43
@@ -1,43 +0,0 @@
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+177−166
@@ -1,119 +1,130 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}
3module Data.Name
3module Data.Name
4 ( Name
4 ( Name
5− --
5+ , toUtf8
6− , toChars
6+ , fromUtf8
7− , toElmString
7+ , toEscapedBuilder
8− , toBuilder
8+ , Utf8.toBuilder
9− --
10− , fromPtr
9+ , Utf8.fromPtr
11− , fromChars
10+ , Utf8.fromChars
11+ , Utf8.toChars
12− --
12+ -- misc
13 , getKernel
13 , getKernel
14 , hasDot
14 , hasDot
15− , splitDots
16 , isKernel
15 , isKernel
17 , isNumberType
16 , isNumberType
18 , isComparableType
17 , isComparableType
19 , isAppendableType
18 , isAppendableType
20 , isCompappendType
19 , isCompappendType
21 , fromVarIndex
20 , fromVarIndex
21+ , fromReplCount
22 , fromWords
22 , fromWords
23 , fromManyNames
23 , fromManyNames
24 , fromTypeVariable
24 , fromTypeVariable
25 , fromTypeVariableScheme
25 , fromTypeVariableScheme
26 , sepBy
26 , sepBy
27− --
27+ -- interned
28 , int, float, bool, char, string
28 , int, float, bool, char, string
29 , maybe, result, list, array, dict, tuple, jsArray
29 , maybe, result, list, array, dict, tuple, jsArray
30 , task, router, cmd, sub, platform, virtualDom
30 , task, router, cmd, sub, platform, virtualDom
31 , shader, debug, debugger, bitwise, basics
31 , shader, debug, debugger, bitwise, basics
32 , utils, negate, true, false, value
32 , utils, negate, true, false, value
33− , node, program, _main, _Main, dollar, identity
33+ , node, program, main, dollar, identity
34− , replModule, replValueToPrint
34+ , replModule
35 )
35 )
36 where
36 where
37
37
38
38
39import Prelude hiding (length, maybe, negate)
39import Prelude hiding (length, maybe, negate)
40import Control.Exception (assert)
40import Control.Exception (assert)
41−import qualified Data.Binary as Binary
42import qualified Data.ByteString.Builder.Internal as B
41import qualified Data.ByteString.Builder.Internal as B
43−import qualified Data.Coerce as Coerce
42+import Data.Coerce (coerce)
44import qualified Data.List as List
43import qualified Data.List as List
45−import qualified Data.String as Chars
46import qualified Data.Utf8 as Utf8
44import qualified Data.Utf8 as Utf8
45+import Foreign.Ptr (plusPtr, minusPtr)
47import GHC.Exts
46import GHC.Exts
48− ( Int(I#), Ptr
47+ ( Int(I#), Ptr(Ptr)
48+ , RealWorld
49 , MutableByteArray#
49 , MutableByteArray#
50 , isTrue#
50 , isTrue#
51 , newByteArray#
51 , newByteArray#
52 , sizeofByteArray#
52 , sizeofByteArray#
53+ , writeWord8OffAddr#
54+ , copyByteArrayToAddr#
53 , unsafeFreezeByteArray#
55 , unsafeFreezeByteArray#
54 )
56 )
57+import GHC.IO
55import GHC.ST (ST(ST), runST)
58import GHC.ST (ST(ST), runST)
56import GHC.Prim
59import GHC.Prim
57import GHC.Word (Word8(W8#))
60import GHC.Word (Word8(W8#))
58
61
59−import qualified Elm.String as ES
60−
61
62
62
63
63-- NAME
64-- NAME
64
65
65
66
66−type Name =
67+type Name = Utf8.Under256 NAME
67− Utf8.Utf8 ELM_NAME
68−
69−
70−data ELM_NAME
71−
72−
73−
74−-- INSTANCES
75−
76
68
77−instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78− fromString = Utf8.fromChars
79
69
80−instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
70+data NAME
81− get = Utf8.getUnder256
82− put = Utf8.putUnder256
83
71
84
72
73+toUtf8 :: Name -> Utf8.String
74+toUtf8 =
75+ coerce
85
76
86−-- TO
87
77
78+fromUtf8 :: Utf8.String -> Name
79+fromUtf8 =
80+ coerce
88
81
89−toChars :: Name -> [Char]
90−toChars =
91− Utf8.toChars
92
82
93
83
94−toElmString :: Name -> ES.String
84+-- TO ESCAPED BUILDER
95−toElmString =
96− Coerce.coerce
97
85
98
86
99−{-# INLINE toBuilder #-}
87+{-# INLINE toEscapedBuilder #-}
100−toBuilder :: Name -> B.Builder
88+toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder
101−toBuilder =
89+toEscapedBuilder before after =
102− Utf8.toBuilder
90+ \name -> B.builder (toEscapedBuilderHelp before after name)
103
91
104
92
93+{-# INLINE toEscapedBuilderHelp #-}
94+toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a
95+toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =
96+ go 0 (I# (sizeofByteArray# ba#))
97+ where
98+ go !offset !len !(B.BufferRange bOffset bEnd) =
99+ let
100+ !bLen = minusPtr bEnd bOffset
101+ in
102+ if len <= bLen then
103+ do -- TODO test if writing word-by-word is faster
104+ stToIO (copyToPtr name offset bOffset len)
105+ stToIO (escape before after bOffset name offset len 0)
106+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
107+ k newBufferRange
108+ else
109+ do stToIO (copyToPtr name offset bOffset bLen)
110+ stToIO (escape before after bOffset name offset bLen 0)
111+ let !newOffset = offset + bLen
112+ let !newLength = len - bLen
113+ return $ B.bufferFull 1 bEnd (go newOffset newLength)
114+
115+
116+escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()
117+escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
118+ if isTrue# (i# <# len#) then
119+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
120+ then
121+ do writeWordToPtr ptr i after
122+ escape before after ptr name offset len (i + 1)
123+ else
124+ do escape before after ptr name offset len (i + 1)
105
125
106−-- FROM
126+ else
107−
127+ return ()
108−
109−fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110−fromPtr =
111− Utf8.fromPtr
112−
113−
114−fromChars :: [Char] -> Name
115−fromChars =
116− Utf8.fromChars
117
128
118
129
119
130
@@ -122,12 +133,7 @@ fromChars =
122
133
123hasDot :: Name -> Bool
134hasDot :: Name -> Bool
124hasDot name =
135hasDot name =
125− Utf8.contains 0x2E {- . -} name
136+ Utf8.contains 0x2E {- . -} (coerce name)
126−
127−
128−splitDots :: Name -> [Name]
129−splitDots name =
130− Utf8.split 0x2E {- . -} name
131
137
132
138
133
139
@@ -175,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend
175
181
176{-# NOINLINE prefix_kernel #-}
182{-# NOINLINE prefix_kernel #-}
177prefix_kernel :: Name
183prefix_kernel :: Name
178−prefix_kernel = fromChars "Elm.Kernel."
184+prefix_kernel = "Elm.Kernel."
179
185
180{-# NOINLINE prefix_number #-}
186{-# NOINLINE prefix_number #-}
181prefix_number :: Name
187prefix_number :: Name
182−prefix_number = fromChars "number"
188+prefix_number = "number"
183
189
184{-# NOINLINE prefix_comparable #-}
190{-# NOINLINE prefix_comparable #-}
185prefix_comparable :: Name
191prefix_comparable :: Name
186−prefix_comparable = fromChars "comparable"
192+prefix_comparable = "comparable"
187
193
188{-# NOINLINE prefix_appendable #-}
194{-# NOINLINE prefix_appendable #-}
189prefix_appendable :: Name
195prefix_appendable :: Name
190−prefix_appendable = fromChars "appendable"
196+prefix_appendable = "appendable"
191
197
192{-# NOINLINE prefix_compappend #-}
198{-# NOINLINE prefix_compappend #-}
193prefix_compappend :: Name
199prefix_compappend :: Name
194−prefix_compappend = fromChars "compappend"
200+prefix_compappend = "compappend"
195
201
196
202
197
203
@@ -202,11 +208,11 @@ fromVarIndex :: Int -> Name
202fromVarIndex n =
208fromVarIndex n =
203 runST
209 runST
204 (
210 (
205− do let !size = 2 + getIndexSize n
211+ do let !size = getIndexSize n
206 mba <- newByteArray size
212 mba <- newByteArray size
207 writeWord8 mba 0 0x5F {- _ -}
213 writeWord8 mba 0 0x5F {- _ -}
208 writeWord8 mba 1 0x76 {- v -}
214 writeWord8 mba 1 0x76 {- v -}
209− writeDigitsAtEnd mba size n
215+ writeDigits mba (size - 1) n
210 freeze mba
216 freeze mba
211 )
217 )
212
218
@@ -214,20 +220,19 @@ fromVarIndex n =
214{-# INLINE getIndexSize #-}
220{-# INLINE getIndexSize #-}
215getIndexSize :: Int -> Int
221getIndexSize :: Int -> Int
216getIndexSize n
222getIndexSize n
217− | n < 10 = 1
223+ | n < 10 = 3
218− | n < 100 = 2
224+ | n < 100 = 4
219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
225+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220
226
221
227
222
228
223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
229+writeDigits :: MBA s -> Int -> Int -> ST s ()
224−writeDigitsAtEnd !mba !oldOffset !n =
230+writeDigits !mba !offset !n =
225 do let (q,r) = quotRem n 10
231 do let (q,r) = quotRem n 10
226− let !newOffset = oldOffset - 1
227− writeWord8 mba newOffset (0x30 + fromIntegral r)
232+ writeWord8 mba offset (0x30 + fromIntegral r)
228 if q <= 0
233 if q <= 0
229 then return ()
234 then return ()
230− else writeDigitsAtEnd mba newOffset q
235+ else writeDigits mba (offset-1) q
231
236
232
237
233
238
@@ -250,7 +255,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
250 mba <- newByteArray size
255 mba <- newByteArray size
251 copyToMBA name mba
256 copyToMBA name mba
252 writeWord8 mba (I# len#) 0x5F {- _ -}
257 writeWord8 mba (I# len#) 0x5F {- _ -}
253− writeDigitsAtEnd mba size index
258+ writeDigits mba (size - 1) index
254 freeze mba
259 freeze mba
255 )
260 )
256 else
261 else
@@ -259,7 +264,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =
259 do let !size = I# len# + getIndexSize index
264 do let !size = I# len# + getIndexSize index
260 mba <- newByteArray size
265 mba <- newByteArray size
261 copyToMBA name mba
266 copyToMBA name mba
262− writeDigitsAtEnd mba size index
267+ writeDigits mba (size - 1) index
263 freeze mba
268 freeze mba
264 )
269 )
265
270
@@ -278,61 +283,61 @@ fromTypeVariableScheme scheme =
278 freeze mba
283 freeze mba
279 else
284 else
280 do let (extra, letter) = quotRem scheme 26
285 do let (extra, letter) = quotRem scheme 26
281− let !size = 1 + getIndexSize extra
286+ let !size = getIndexSize extra
282 mba <- newByteArray size
287 mba <- newByteArray size
283 writeWord8 mba 0 (0x61 + fromIntegral letter)
288 writeWord8 mba 0 (0x61 + fromIntegral letter)
284− writeDigitsAtEnd mba size extra
289+ writeDigits mba (size - 1) extra
285 freeze mba
290 freeze mba
286 )
291 )
287
292
288
293
289
294
295+-- FROM REPL COUNT
296+
297+
298+fromReplCount :: Int -> Name
299+fromReplCount n =
300+ Utf8.fromChars ("repl_value_" ++ show n)
301+
302+
303+
290-- FROM MANY NAMES
304-- FROM MANY NAMES
291−--
292−-- Creating a unique name by combining all the subnames can create names
293−-- longer than 256 bytes relatively easily. So instead, the first given name
294−-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295−--
296−-- This should be a unique name since 0.19 disallows shadowing. It would not
297−-- be possible for multiple top-level cycles to include values with the same
298−-- name, so the important thing is to make the cycle name distinct from the
299−-- normal name. Same logic for destructuring patterns like (x,y)
300
305
301
306
302fromManyNames :: [Name] -> Name
307fromManyNames :: [Name] -> Name
303fromManyNames names =
308fromManyNames names =
304− case names of
309+ let
305− [] ->
306− blank
307− -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)
308− -- but maybe unused patterns should be stripped out instead
309−
310− Utf8.Utf8 ba# : _ ->
311− let
312− len# = sizeofByteArray# ba#
310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
313− in
311+ in
314− runST
312+ runST
315− (
313+ (
316− ST $ \s ->
314+ ST $ \s ->
317− case newByteArray# (len# +# 3#) s of
315+ case newByteArray# size# s of
316+ (# s, mba# #) ->
317+ case writeNames mba# 0# names s of
318− (# s, mba# #) ->
318+ s ->
319− case writeWord8Array# mba# 0# 0x5F## {-_-} s of
320− s ->
321− case writeWord8Array# mba# 1# 0x4D## {-M-} s of
322− s ->
323− case writeWord8Array# mba# 2# 0x24## {-$-} s of
324− s ->
325− case copyByteArray# ba# 0# mba# 3# len# s of
326− s ->
327− case unsafeFreezeByteArray# mba# s of
319+ case unsafeFreezeByteArray# mba# s of
328− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329− )
321+ )
330
322
331
323
332−{-# NOINLINE blank #-}
324+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
333−blank :: Name
325+writeNames mba# !offset# names s =
334−blank =
326+ case names of
335− fromWords [0x5F,0x4D,0x24] {-_M$-}
327+ [] ->
328+ s
329+
330+ (Utf8.Utf8 ba#) : names ->
331+ case writeWord8Array# mba# offset# 0x24## {- $ -} s of
332+ s ->
333+ let
334+ !offset1# = offset# +# 1#
335+ !len# = sizeofByteArray# ba#
336+ !newOffset# = offset1# +# len#
337+ in
338+ case copyByteArray# ba# 0# mba# offset1# len# s of
339+ s ->
340+ writeNames mba# newOffset# names s
336
341
337
342
338
343
@@ -418,6 +423,22 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
418 s -> (# s, () #)
423 s -> (# s, () #)
419
424
420
425
426+{-# INLINE writeWordToPtr #-}
427+writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()
428+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
429+ ST $ \s ->
430+ case writeWord8OffAddr# addr# offset# word# s of
431+ s -> (# s, () #)
432+
433+
434+{-# INLINE copyToPtr #-}
435+copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()
436+copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =
437+ ST $ \s ->
438+ case copyByteArrayToAddr# ba# offset# addr# len# s of
439+ s -> (# s, () #)
440+
441+
421{-# INLINE copyToMBA #-}
442{-# INLINE copyToMBA #-}
422copyToMBA :: Name -> MBA s -> ST s ()
443copyToMBA :: Name -> MBA s -> ST s ()
423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
@@ -432,179 +453,169 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
432
453
433{-# NOINLINE int #-}
454{-# NOINLINE int #-}
434int :: Name
455int :: Name
435−int = fromChars "Int"
456+int = "Int"
436
457
437
458
438{-# NOINLINE float #-}
459{-# NOINLINE float #-}
439float :: Name
460float :: Name
440−float = fromChars "Float"
461+float = "Float"
441
462
442
463
443{-# NOINLINE bool #-}
464{-# NOINLINE bool #-}
444bool :: Name
465bool :: Name
445−bool = fromChars "Bool"
466+bool = "Bool"
446
467
447
468
448{-# NOINLINE char #-}
469{-# NOINLINE char #-}
449char :: Name
470char :: Name
450−char = fromChars "Char"
471+char = "Char"
451
472
452
473
453{-# NOINLINE string #-}
474{-# NOINLINE string #-}
454string :: Name
475string :: Name
455−string = fromChars "String"
476+string = "String"
456
477
457
478
458{-# NOINLINE maybe #-}
479{-# NOINLINE maybe #-}
459maybe :: Name
480maybe :: Name
460−maybe = fromChars "Maybe"
481+maybe = "Maybe"
461
482
462
483
463{-# NOINLINE result #-}
484{-# NOINLINE result #-}
464result :: Name
485result :: Name
465−result = fromChars "Result"
486+result = "Result"
466
487
467
488
468{-# NOINLINE list #-}
489{-# NOINLINE list #-}
469list :: Name
490list :: Name
470−list = fromChars "List"
491+list = "List"
471
492
472
493
473{-# NOINLINE array #-}
494{-# NOINLINE array #-}
474array :: Name
495array :: Name
475−array = fromChars "Array"
496+array = "Array"
476
497
477
498
478{-# NOINLINE dict #-}
499{-# NOINLINE dict #-}
479dict :: Name
500dict :: Name
480−dict = fromChars "Dict"
501+dict = "Dict"
481
502
482
503
483{-# NOINLINE tuple #-}
504{-# NOINLINE tuple #-}
484tuple :: Name
505tuple :: Name
485−tuple = fromChars "Tuple"
506+tuple = "Tuple"
486
507
487
508
488{-# NOINLINE jsArray #-}
509{-# NOINLINE jsArray #-}
489jsArray :: Name
510jsArray :: Name
490−jsArray = fromChars "JsArray"
511+jsArray = "JsArray"
491
512
492
513
493{-# NOINLINE task #-}
514{-# NOINLINE task #-}
494task :: Name
515task :: Name
495−task = fromChars "Task"
516+task = "Task"
496
517
497
518
498{-# NOINLINE router #-}
519{-# NOINLINE router #-}
499router :: Name
520router :: Name
500−router = fromChars "Router"
521+router = "Router"
501
522
502
523
503{-# NOINLINE cmd #-}
524{-# NOINLINE cmd #-}
504cmd :: Name
525cmd :: Name
505−cmd = fromChars "Cmd"
526+cmd = "Cmd"
506
527
507
528
508{-# NOINLINE sub #-}
529{-# NOINLINE sub #-}
509sub :: Name
530sub :: Name
510−sub = fromChars "Sub"
531+sub = "Sub"
511
532
512
533
513{-# NOINLINE platform #-}
534{-# NOINLINE platform #-}
514platform :: Name
535platform :: Name
515−platform = fromChars "Platform"
536+platform = "Platform"
516
537
517
538
518{-# NOINLINE virtualDom #-}
539{-# NOINLINE virtualDom #-}
519virtualDom :: Name
540virtualDom :: Name
520−virtualDom = fromChars "VirtualDom"
541+virtualDom = "VirtualDom"
521
542
522
543
523{-# NOINLINE shader #-}
544{-# NOINLINE shader #-}
524shader :: Name
545shader :: Name
525−shader = fromChars "Shader"
546+shader = "Shader"
526
547
527
548
528{-# NOINLINE debug #-}
549{-# NOINLINE debug #-}
529debug :: Name
550debug :: Name
530−debug = fromChars "Debug"
551+debug = "Debug"
531
552
532
553
533{-# NOINLINE debugger #-}
554{-# NOINLINE debugger #-}
534debugger :: Name
555debugger :: Name
535−debugger = fromChars "Debugger"
556+debugger = "Debugger"
536
557
537
558
538{-# NOINLINE bitwise #-}
559{-# NOINLINE bitwise #-}
539bitwise :: Name
560bitwise :: Name
540−bitwise = fromChars "Bitwise"
561+bitwise = "Bitwise"
541
562
542
563
543{-# NOINLINE basics #-}
564{-# NOINLINE basics #-}
544basics :: Name
565basics :: Name
545−basics = fromChars "Basics"
566+basics = "Basics"
546
567
547
568
548{-# NOINLINE utils #-}
569{-# NOINLINE utils #-}
549utils :: Name
570utils :: Name
550−utils = fromChars "Utils"
571+utils = "Utils"
551
572
552
573
553{-# NOINLINE negate #-}
574{-# NOINLINE negate #-}
554negate :: Name
575negate :: Name
555−negate = fromChars "negate"
576+negate = "negate"
556
577
557
578
558{-# NOINLINE true #-}
579{-# NOINLINE true #-}
559true :: Name
580true :: Name
560−true = fromChars "True"
581+true = "True"
561
582
562
583
563{-# NOINLINE false #-}
584{-# NOINLINE false #-}
564false :: Name
585false :: Name
565−false = fromChars "False"
586+false = "False"
566
587
567
588
568{-# NOINLINE value #-}
589{-# NOINLINE value #-}
569value :: Name
590value :: Name
570−value = fromChars "Value"
591+value = "Value"
571
592
572
593
573{-# NOINLINE node #-}
594{-# NOINLINE node #-}
574node :: Name
595node :: Name
575−node = fromChars "Node"
596+node = "Node"
576
597
577
598
578{-# NOINLINE program #-}
599{-# NOINLINE program #-}
579program :: Name
600program :: Name
580−program = fromChars "Program"
601+program = "Program"
581−
582
602
583−{-# NOINLINE _main #-}
584−_main :: Name
585−_main = fromChars "main"
586
603
587−
588−{-# NOINLINE _Main #-}
604+{-# NOINLINE main #-}
589−_Main :: Name
605+main :: Name
590−_Main = fromChars "Main"
606+main = "main"
591
607
592
608
593{-# NOINLINE dollar #-}
609{-# NOINLINE dollar #-}
594dollar :: Name
610dollar :: Name
595−dollar = fromChars "$"
611+dollar = "$"
596
612
597
613
598{-# NOINLINE identity #-}
614{-# NOINLINE identity #-}
599identity :: Name
615identity :: Name
600−identity = fromChars "identity"
616+identity = "identity"
601
617
602
618
603{-# NOINLINE replModule #-}
619{-# NOINLINE replModule #-}
604replModule :: Name
620replModule :: Name
605−replModule = fromChars "Elm_Repl"
621+replModule = "Elm_Repl"
606−
607−
608−{-# NOINLINE replValueToPrint #-}
609−replValueToPrint :: Name
610−replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hsdeleted−78
@@ -1,78 +0,0 @@
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+24−39
@@ -3,9 +3,9 @@ module Data.OneOrMore
3 ( OneOrMore(..)
3 ( OneOrMore(..)
4 , one
4 , one
5 , more
5 , more
6+ , toList
6 , map
7 , map
7 , destruct
8 , destruct
8− , getFirstTwo
9 )
9 )
10 where
10 where
11
11
@@ -33,6 +33,25 @@ more =
33
33
34
34
35
35
36+-- TO LIST
37+
38+
39+toList :: OneOrMore a -> [a]
40+toList oneOrMore =
41+ toListHelp oneOrMore []
42+
43+
44+toListHelp :: OneOrMore a -> [a] -> [a]
45+toListHelp oneOrMore list =
46+ case oneOrMore of
47+ One x ->
48+ x : list
49+
50+ More a b ->
51+ toListHelp a (toListHelp b list)
52+
53+
54+
36-- MAP
55-- MAP
37
56
38
57
@@ -52,48 +71,14 @@ map func oneOrMore =
52
71
53destruct :: (a -> [a] -> b) -> OneOrMore a -> b
72destruct :: (a -> [a] -> b) -> OneOrMore a -> b
54destruct func oneOrMore =
73destruct func oneOrMore =
55− destructLeft func oneOrMore []
74+ destructHelp func oneOrMore []
56
75
57
76
58−destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
77+destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
59−destructLeft func oneOrMore xs =
78+destructHelp func oneOrMore xs =
60 case oneOrMore of
79 case oneOrMore of
61 One x ->
80 One x ->
62 func x xs
81 func x xs
63
82
64 More a b ->
83 More a b ->
65− destructLeft func a (destructRight b xs)
84+ destructHelp func a (toListHelp b xs)
66−
67−
68−destructRight :: OneOrMore a -> [a] -> [a]
69−destructRight oneOrMore xs =
70− case oneOrMore of
71− One x ->
72− x : xs
73−
74− More a b ->
75− destructRight a (destructRight b xs)
76−
77−
78−
79−-- GET FIRST TWO
80−
81−
82−getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)
83−getFirstTwo left right =
84− case left of
85− One x ->
86− (x, getFirstOne right)
87−
88− More lleft lright ->
89− getFirstTwo lleft lright
90−
91−
92−getFirstOne :: OneOrMore a -> a
93−getFirstOne oneOrMore =
94− case oneOrMore of
95− One x ->
96− x
97−
98− More left _ ->
99− getFirstOne left
compiler/src/Data/Utf8.hs+300−158
@@ -1,42 +1,36 @@
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3module Data.Utf8
3module Data.Utf8
4+ ( String
4− ( Utf8(..)
5+ , Utf8(..)
6+ , VeryLong
7+ , Under256
5 , isEmpty
8 , isEmpty
6− , empty
7 , size
9 , size
8 , contains
10 , contains
11+ , containsDouble
9 , startsWith
12 , startsWith
10 , startsWithChar
13 , startsWithChar
11− , endsWithWord8
14+ , endsWithWord
12 , split
15 , split
13 , join
16 , join
14− --
17+ , all
15− , getUnder256
18+ , any
16− , putUnder256
19+ , toWord16
17− --
20+ , fromWord16
18− , getVeryLong
21+ -- conversions
19− , putVeryLong
22+ , fromChars
20− --
21 , toChars
23 , toChars
22 , toBuilder
24 , toBuilder
23− , toEscapedBuilder
24− --
25 , fromPtr
25 , fromPtr
26− , fromSnippet
26+ , fromChunks
27− , fromChars
27+ , Chunk(..)
28− --
29− , MBA
30− , newByteArray
31− , copyFromPtr
32− , writeWord8
33− , freeze
34 )
28 )
35 where
29 where
36
30
37
31
38import Prelude hiding (String, all, any, concat)
32import Prelude hiding (String, all, any, concat)
39−import Data.Binary (Get, get, getWord8, Put, put, putWord8)
33+import Data.Binary (Binary(..), Get, getWord8, putWord8)
40import Data.Binary.Put (putBuilder)
34import Data.Binary.Put (putBuilder)
41import Data.Binary.Get.Internal (readN)
35import Data.Binary.Get.Internal (readN)
42import Data.Bits ((.&.), shiftR)
36import Data.Bits ((.&.), shiftR)
@@ -44,6 +38,7 @@ import qualified Data.ByteString.Internal as B
44import qualified Data.ByteString.Builder.Internal as B
38import qualified Data.ByteString.Builder.Internal as B
45import qualified Data.Char as Char
39import qualified Data.Char as Char
46import qualified Data.List as List
40import qualified Data.List as List
41+import Data.String (IsString(..))
47import Foreign.ForeignPtr (touchForeignPtr)
42import Foreign.ForeignPtr (touchForeignPtr)
48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
43import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
49import Foreign.Ptr (minusPtr, plusPtr)
44import Foreign.Ptr (minusPtr, plusPtr)
@@ -58,35 +53,36 @@ import GHC.Exts
58 , copyByteArray#
53 , copyByteArray#
59 , copyAddrToByteArray#
54 , copyAddrToByteArray#
60 , copyByteArrayToAddr#
55 , copyByteArrayToAddr#
61− , writeWord8Array#
56+ , writeWord8Array#,
62 )
57 )
63import GHC.IO
58import GHC.IO
64import GHC.ST (ST(ST), runST)
59import GHC.ST (ST(ST), runST)
65import GHC.Prim
60import GHC.Prim
66−import GHC.Word (Word8(W8#))
61+import GHC.Word (Word8(W8#), Word16(W16#))
67−
68−import qualified Parse.Primitives as P
69
62
70
63
71
64
72-- UTF-8
65-- UTF-8
73
66
74
67
75−data Utf8 tipe =
68+data Utf8 size tipe =
76 Utf8 ByteArray#
69 Utf8 ByteArray#
77
70
78
71
72+type String = Utf8 VERY_LONG STRING
73+type VeryLong t = Utf8 VERY_LONG t
74+type Under256 t = Utf8 UNDER_256 t
79
75
80−-- EMPTY
76+data STRING
77+data VERY_LONG
78+data UNDER_256
81
79
82
80
83−{-# NOINLINE empty #-}
84−empty :: Utf8 t
85−empty =
86− runST (freeze =<< newByteArray 0)
87
81
82+-- IS EMPTY
88
83
84+
89−isEmpty :: Utf8 t -> Bool
85+isEmpty :: Utf8 l t -> Bool
90isEmpty (Utf8 ba#) =
86isEmpty (Utf8 ba#) =
91 isTrue# (sizeofByteArray# ba# ==# 0#)
87 isTrue# (sizeofByteArray# ba# ==# 0#)
92
88
@@ -95,7 +91,7 @@ isEmpty (Utf8 ba#) =
95-- SIZE
91-- SIZE
96
92
97
93
98−size :: Utf8 t -> Int
94+size :: Utf8 l t -> Int
99size (Utf8 ba#) =
95size (Utf8 ba#) =
100 I# (sizeofByteArray# ba#)
96 I# (sizeofByteArray# ba#)
101
97
@@ -104,7 +100,7 @@ size (Utf8 ba#) =
104-- CONTAINS
100-- CONTAINS
105
101
106
102
107−contains :: Word8 -> Utf8 t -> Bool
103+contains :: Word8 -> Utf8 l t -> Bool
108contains (W8# word#) (Utf8 ba#) =
104contains (W8# word#) (Utf8 ba#) =
109 containsHelp word# ba# 0# (sizeofByteArray# ba#)
105 containsHelp word# ba# 0# (sizeofByteArray# ba#)
110
106
@@ -120,11 +116,32 @@ containsHelp word# ba# !offset# len# =
120
116
121
117
122
118
119+-- CONTAINS DOUBLE
120+
121+
122+containsDouble :: Word8 -> Utf8 l t -> Bool
123+containsDouble (W8# word#) (Utf8 ba#) =
124+ containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)
125+
126+
127+containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
128+containsDoubleHelp word# ba# !offset# len# =
129+ let !offset1# = offset# +# 1# in
130+ if isTrue# (offset1# <# len#) then
131+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))
132+ && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))
133+ then True
134+ else containsDoubleHelp word# ba# (offset# +# 1#) len#
135+ else
136+ False
137+
138+
139+
123-- STARTS WITH
140-- STARTS WITH
124
141
125
142
126{-# INLINE startsWith #-}
143{-# INLINE startsWith #-}
127−startsWith :: Utf8 t -> Utf8 t -> Bool
144+startsWith :: Utf8 l t -> Utf8 l t -> Bool
128startsWith (Utf8 ba1#) (Utf8 ba2#) =
145startsWith (Utf8 ba1#) (Utf8 ba2#) =
129 let
146 let
130 !len1# = sizeofByteArray# ba1#
147 !len1# = sizeofByteArray# ba1#
@@ -139,9 +156,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =
139-- STARTS WITH CHAR
156-- STARTS WITH CHAR
140
157
141
158
142−startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
159+startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool
143−startsWithChar isGood bytes@(Utf8 ba#) =
160+startsWithChar isGood str@(Utf8 ba#) =
144− if isEmpty bytes then
161+ if isEmpty str then
145 False
162 False
146 else
163 else
147 let
164 let
@@ -159,8 +176,8 @@ startsWithChar isGood bytes@(Utf8 ba#) =
159-- ENDS WITH WORD
176-- ENDS WITH WORD
160
177
161
178
162−endsWithWord8 :: Word8 -> Utf8 t -> Bool
179+endsWithWord :: Word8 -> Utf8 l t -> Bool
163−endsWithWord8 (W8# w#) (Utf8 ba#) =
180+endsWithWord (W8# w#) (Utf8 ba#) =
164 let len# = sizeofByteArray# ba# in
181 let len# = sizeofByteArray# ba# in
165 isTrue# (len# ># 0#)
182 isTrue# (len# ># 0#)
166 &&
183 &&
@@ -171,12 +188,12 @@ endsWithWord8 (W8# w#) (Utf8 ba#) =
171-- SPLIT
188-- SPLIT
172
189
173
190
174−split :: Word8 -> Utf8 t -> [Utf8 t]
191+split :: Word8 -> String -> [String]
175split (W8# divider#) str@(Utf8 ba#) =
192split (W8# divider#) str@(Utf8 ba#) =
176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
193 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
177
194
178
195
179−splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
196+splitHelp :: String -> Int -> [Int] -> [String]
180splitHelp str start offsets =
197splitHelp str start offsets =
181 case offsets of
198 case offsets of
182 [] ->
199 [] ->
@@ -197,7 +214,7 @@ findDividers divider# ba# !offset# len# revOffsets =
197 reverse revOffsets
214 reverse revOffsets
198
215
199
216
200−unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
217+unsafeSlice :: String -> Int -> Int -> String
201unsafeSlice str start end =
218unsafeSlice str start end =
202 let !len = end - start in
219 let !len = end - start in
203 if len == 0 then
220 if len == 0 then
@@ -213,7 +230,7 @@ unsafeSlice str start end =
213-- JOIN
230-- JOIN
214
231
215
232
216−join :: Word8 -> [Utf8 t] -> Utf8 t
233+join :: Word8 -> [String] -> String
217join sep strings =
234join sep strings =
218 case strings of
235 case strings of
219 [] ->
236 [] ->
@@ -227,7 +244,7 @@ join sep strings =
227 freeze mba
244 freeze mba
228
245
229
246
230−joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
247+joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()
231joinHelp sep mba offset str strings =
248joinHelp sep mba offset str strings =
232 let
249 let
233 !len = size str
250 !len = size str
@@ -245,10 +262,46 @@ joinHelp sep mba offset str strings =
245
262
246
263
247
264
265+-- ALL
266+
267+
268+all :: (Char -> Bool) -> Utf8 l t -> Bool
269+all isGood utf8 =
270+ not (any (not . isGood) utf8)
271+
272+
273+
274+-- ANY
275+
276+
277+any :: (Char -> Bool) -> Utf8 l t -> Bool
278+any isGood (Utf8 ba#) =
279+ anyHelp isGood ba# 0# (sizeofByteArray# ba#)
280+
281+
282+anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool
283+anyHelp isGood ba# offset# len# =
284+ if isTrue# (offset# >=# len#) then
285+ False
286+ else
287+ let
288+ !w# = indexWord8Array# ba# offset#
289+ !(# char, width# #)
290+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
291+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
292+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
293+ | True = (# chr4 ba# offset# w#, 4# #)
294+ in
295+ if isGood char
296+ then True
297+ else anyHelp isGood ba# (offset# +# width#) len#
298+
299+
300+
248-- EQUAL
301-- EQUAL
249
302
250
303
251−instance Eq (Utf8 t) where
304+instance Eq (Utf8 l t) where
252 (==) (Utf8 ba1#) (Utf8 ba2#) =
305 (==) (Utf8 ba1#) (Utf8 ba2#) =
253 let
306 let
254 !len1# = sizeofByteArray# ba1#
307 !len1# = sizeofByteArray# ba1#
@@ -261,11 +314,9 @@ instance Eq (Utf8 t) where
261
314
262
315
263-- COMPARE
316-- COMPARE
264−--
265−-- TODO: is it fine to sort by length and only compare bytes on length ties?
266−--
267
317
318+
268−instance Ord (Utf8 t) where
319+instance Ord (Utf8 l t) where
269 compare (Utf8 ba1#) (Utf8 ba2#) =
320 compare (Utf8 ba1#) (Utf8 ba2#) =
270 let
321 let
271 !len1# = sizeofByteArray# ba1#
322 !len1# = sizeofByteArray# ba1#
@@ -282,20 +333,84 @@ instance Ord (Utf8 t) where
282
333
283
334
284
335
336+-- TO WORD16
337+
338+
339+toWord16 :: String -> Maybe Word16
340+toWord16 (Utf8 ba#) =
341+ let !len# = sizeofByteArray# ba# in
342+ if isTrue# (len# ==# 0#) then
343+ Nothing
344+ else
345+ let !w# = indexWord8Array# ba# 0# in
346+ if isTrue# (eqWord# w# 0x30##) then
347+ if isTrue# (len# ==# 1#) then Just 0 else Nothing
348+ else
349+ toWordHelp ba# 0# len# 0##
350+
351+
352+toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16
353+toWordHelp ba# offset# len# number# =
354+ if isTrue# (offset# <# len#) then
355+ let !w# = indexWord8Array# ba# offset# in
356+ if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then
357+ let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in
358+ toWordHelp ba# (offset# +# 1#) len# newNumber#
359+ else
360+ Nothing
361+ else
362+ Just (W16# number#)
363+
364+
365+
366+-- FROM WORD16
367+
368+
369+fromWord16 :: Word16 -> String
370+fromWord16 n =
371+ runST $
372+ do let !size = getWordSize n
373+ mba <- newByteArray size
374+ writeDigits mba (size - 1) n
375+ freeze mba
376+
377+
378+getWordSize :: Word16 -> Int
379+getWordSize n
380+ | n < 10 = 1
381+ | n < 100 = 2
382+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
383+
384+
385+writeDigits :: MBA s -> Int -> Word16 -> ST s ()
386+writeDigits !mba !offset !n =
387+ do let (q,r) = quotRem n 10
388+ writeWord8 mba offset (0x30 + fromIntegral r)
389+ if q <= 0
390+ then return ()
391+ else writeDigits mba (offset-1) q
392+
393+
394+
285-- FROM STRING
395-- FROM STRING
286
396
287
397
288−fromChars :: [Char] -> Utf8 t
398+fromChars :: [Char] -> Utf8 l t
289−fromChars chars =
399+fromChars =
290− runST
400+ fromString
291− (
401+
292− do mba <- newByteArray (sum (map getWidth chars))
293− writeChars mba 0 chars
294− )
295
402
403+instance IsString (Utf8 l t) where
404+ fromString str =
405+ runST
406+ (
407+ do mba <- newByteArray (sum (map getWidth str))
408+ writeString mba 0 str
409+ )
296
410
411+
297−writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
412+writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)
298−writeChars !mba !offset chars =
413+writeString !mba !offset chars =
299 case chars of
414 case chars of
300 [] ->
415 [] ->
301 freeze mba
416 freeze mba
@@ -303,25 +418,25 @@ writeChars !mba !offset chars =
303 char : chars
418 char : chars
304 | n < 0x80 ->
419 | n < 0x80 ->
305 do writeWord8 mba (offset ) (fromIntegral n)
420 do writeWord8 mba (offset ) (fromIntegral n)
306− writeChars mba (offset + 1) chars
421+ writeString mba (offset + 1) chars
307
422
308 | n < 0x800 ->
423 | n < 0x800 ->
309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
424 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
425 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
311− writeChars mba (offset + 2) chars
426+ writeString mba (offset + 2) chars
312
427
313 | n < 0x10000 ->
428 | n < 0x10000 ->
314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
429 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
430 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
431 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
317− writeChars mba (offset + 3) chars
432+ writeString mba (offset + 3) chars
318
433
319 | otherwise ->
434 | otherwise ->
320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
435 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
436 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
437 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
438 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
324− writeChars mba (offset + 4) chars
439+ writeString mba (offset + 4) chars
325
440
326 where
441 where
327 n = Char.ord char
442 n = Char.ord char
@@ -339,10 +454,10 @@ getWidth char
339
454
340
455
341
456
342−-- TO CHARS
457+-- TO STRING
343
458
344
459
345−toChars :: Utf8 t -> [Char]
460+toChars :: Utf8 l t -> [Char]
346toChars (Utf8 ba#) =
461toChars (Utf8 ba#) =
347 toCharsHelp ba# 0# (sizeofByteArray# ba#)
462 toCharsHelp ba# 0# (sizeofByteArray# ba#)
348
463
@@ -412,13 +527,13 @@ chr4 ba# offset# firstWord# =
412
527
413
528
414{-# INLINE toBuilder #-}
529{-# INLINE toBuilder #-}
415−toBuilder :: Utf8 t -> B.Builder
530+toBuilder :: Utf8 l t -> B.Builder
416toBuilder =
531toBuilder =
417 \bytes -> B.builder (toBuilderHelp bytes)
532 \bytes -> B.builder (toBuilderHelp bytes)
418
533
419
534
420{-# INLINE toBuilderHelp #-}
535{-# INLINE toBuilderHelp #-}
421−toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
536+toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a
422toBuilderHelp !bytes@(Utf8 ba#) k =
537toBuilderHelp !bytes@(Utf8 ba#) k =
423 go 0 (I# (sizeofByteArray# ba#))
538 go 0 (I# (sizeofByteArray# ba#))
424 where
539 where
@@ -438,57 +553,10 @@ toBuilderHelp !bytes@(Utf8 ba#) k =
438
553
439
554
440
555
441−-- TO ESCAPED BUILDER
442−
443−
444−{-# INLINE toEscapedBuilder #-}
445−toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder
446−toEscapedBuilder before after =
447− \name -> B.builder (toEscapedBuilderHelp before after name)
448−
449−
450−{-# INLINE toEscapedBuilderHelp #-}
451−toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a
452−toEscapedBuilderHelp before after !name@(Utf8 ba#) k =
453− go 0 (I# (sizeofByteArray# ba#))
454− where
455− go !offset !len !(B.BufferRange bOffset bEnd) =
456− let
457− !bLen = minusPtr bEnd bOffset
458− in
459− if len <= bLen then
460− do -- PERF test if writing word-by-word is faster
461− copyToPtr name offset bOffset len
462− escape before after bOffset name offset len 0
463− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd
464− k newBufferRange
465− else
466− do copyToPtr name offset bOffset bLen
467− escape before after bOffset name offset bLen 0
468− let !newOffset = offset + bLen
469− let !newLength = len - bLen
470− return $ B.bufferFull 1 bEnd (go newOffset newLength)
471−
472−
473−escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()
474−escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =
475− if isTrue# (i# <# len#) then
476− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))
477− then
478− do writeWordToPtr ptr i after
479− escape before after ptr name offset len (i + 1)
480− else
481− do escape before after ptr name offset len (i + 1)
482−
483− else
484− return ()
485−
486−
487−
488-- FROM PTR
556-- FROM PTR
489
557
490
558
491−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
559+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t
492fromPtr pos end =
560fromPtr pos end =
493 unsafeDupablePerformIO (stToIO (
561 unsafeDupablePerformIO (stToIO (
494 do let !len = minusPtr end pos
562 do let !len = minusPtr end pos
@@ -499,48 +567,130 @@ fromPtr pos end =
499
567
500
568
501
569
502−-- FROM SNIPPET
570+-- FROM CHUNKS
503
571
504
572
505−fromSnippet :: P.Snippet -> Utf8 t
573+data Chunk
506−fromSnippet (P.Snippet fptr off len _ _) =
574+ = Slice (Ptr Word8) Int
575+ | Escape Word8
576+ | CodePoint Int
577+
578+
579+fromChunks :: [Chunk] -> Utf8 l t
580+fromChunks chunks =
507 unsafeDupablePerformIO (stToIO (
581 unsafeDupablePerformIO (stToIO (
508− do mba <- newByteArray len
582+ do let !len = sum (map chunkToWidth chunks)
509− let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
583+ mba <- newByteArray len
510− copyFromPtr pos mba 0 len
584+ writeChunks mba 0 chunks
511 freeze mba
585 freeze mba
512 ))
586 ))
513
587
514
588
589+chunkToWidth :: Chunk -> Int
590+chunkToWidth chunk =
591+ case chunk of
592+ Slice _ len ->
593+ len
594+
595+ Escape _ ->
596+ 2
597+
598+ CodePoint code ->
599+ if code < 0xFFFF then 6 else 12
600+
601+
602+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
603+writeChunks mba offset chunks =
604+ case chunks of
605+ [] ->
606+ return ()
607+
608+ chunk : chunks ->
609+ case chunk of
610+ Slice ptr len ->
611+ do copyFromPtr ptr mba offset len
612+ let !newOffset = offset + len
613+ writeChunks mba newOffset chunks
614+
615+ Escape word ->
616+ do writeWord8 mba offset 0x5C {- \ -}
617+ writeWord8 mba (offset + 1) word
618+ let !newOffset = offset + 2
619+ writeChunks mba newOffset chunks
620+
621+ CodePoint code ->
622+ if code < 0xFFFF then
623+ do writeCode mba offset code
624+ let !newOffset = offset + 6
625+ writeChunks mba newOffset chunks
626+ else
627+ do let (hi,lo) = divMod (code - 0x10000) 0x400
628+ writeCode mba (offset ) (hi + 0xD800)
629+ writeCode mba (offset + 6) (lo + 0xDC00)
630+ let !newOffset = offset + 12
631+ writeChunks mba newOffset chunks
632+
633+
634+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii
635+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
636+writeCode mba offset code =
637+ do writeWord8 mba offset 0x5C {- \ -}
638+ writeWord8 mba offset 0x75 {- u -}
639+ writeHex mba (offset + 2) (shiftR code 12)
640+ writeHex mba (offset + 3) (shiftR code 8)
641+ writeHex mba (offset + 4) (shiftR code 4)
642+ writeHex mba (offset + 5) code
643+
644+
645+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
646+writeHex mba !offset !bits =
647+ do let !n = fromIntegral bits .&. 0x0F
648+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
515
649
516−-- BINARY
517
650
518
651
519−putUnder256 :: Utf8 t -> Put
652+-- UNDER 256 BINARY
520−putUnder256 bytes =
521− do putWord8 (fromIntegral (size bytes))
522− putBuilder (toBuilder bytes)
523
653
524
654
525−getUnder256 :: Get (Utf8 t)
655+instance Binary (Utf8 UNDER_256 t) where
526−getUnder256 =
656+ put bytes@(Utf8 ba#) =
657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))
658+ putBuilder (toBuilder bytes)
659+ get =
527− do word <- getWord8
660+ getUnder256 =<< getWord8
528− let !n = fromIntegral word
529− readN n (copyFromByteString n)
530
661
531
662
532−putVeryLong :: Utf8 t -> Put
663+{-# INLINE getUnder256 #-}
533−putVeryLong bytes =
664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)
534− do put (size bytes)
665+getUnder256 w =
535− putBuilder (toBuilder bytes)
666+ let !n = fromIntegral w in
667+ readN n (copyFromByteString n)
536
668
537
669
670+
671+-- VERY LONG BINARY
672+
673+
674+instance Binary (Utf8 VERY_LONG t) where
675+ put str =
676+ do put (size str)
677+ putBuilder (toBuilder str)
678+ get =
538−getVeryLong :: Get (Utf8 t)
679+ getVeryLong =<< get
680+
681+
682+{-# INLINE getVeryLong #-}
683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)
539−getVeryLong =
684+getVeryLong n =
540− do n <- get
541− if n > 0
685+ if n > 0
542− then readN n (copyFromByteString n)
686+ then readN n (copyFromByteString n)
543− else return empty
687+ else return empty
688+
689+
690+{-# NOINLINE empty #-}
691+empty :: Utf8 l t
692+empty =
693+ runST (freeze =<< newByteArray 0)
544
694
545
695
546
696
@@ -548,7 +698,7 @@ getVeryLong =
548
698
549
699
550{-# INLINE copyFromByteString #-}
700{-# INLINE copyFromByteString #-}
551−copyFromByteString :: Int -> B.ByteString -> Utf8 t
701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t
552copyFromByteString len (B.PS fptr offset _) =
702copyFromByteString len (B.PS fptr offset _) =
553 unsafeDupablePerformIO
703 unsafeDupablePerformIO
554 (
704 (
@@ -567,21 +717,21 @@ data MBA s =
567 MBA# (MutableByteArray# s)
717 MBA# (MutableByteArray# s)
568
718
569
719
570−newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
720+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive
571newByteArray (I# len#) =
721newByteArray (I# len#) =
572 ST $ \s ->
722 ST $ \s ->
573 case newByteArray# len# s of
723 case newByteArray# len# s of
574 (# s, mba# #) -> (# s, MBA# mba# #)
724 (# s, mba# #) -> (# s, MBA# mba# #)
575
725
576
726
577−freeze :: MBA s -> ST s (Utf8 t)
727+freeze :: MBA s -> ST s (Utf8 l t)
578freeze (MBA# mba#) =
728freeze (MBA# mba#) =
579 ST $ \s ->
729 ST $ \s ->
580 case unsafeFreezeByteArray# mba# s of
730 case unsafeFreezeByteArray# mba# s of
581 (# s, ba# #) -> (# s, Utf8 ba# #)
731 (# s, ba# #) -> (# s, Utf8 ba# #)
582
732
583
733
584−copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
734+copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()
585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
735copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
586 ST $ \s ->
736 ST $ \s ->
587 case copyByteArray# ba# offset# mba# i# len# s of
737 case copyByteArray# ba# offset# mba# i# len# s of
@@ -595,11 +745,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
595 s -> (# s, () #)
745 s -> (# s, () #)
596
746
597
747
598−copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()
599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
600− IO $ \s ->
750+ IO $ \s ->
601− case copyByteArrayToAddr# ba# offset# mba# len# s of
751+ case copyByteArrayToAddr# ba# offset# mba# len# s of
602− s -> (# s, () #)
752+ s -> (# s, () #)
603
753
604
754
605{-# INLINE writeWord8 #-}
755{-# INLINE writeWord8 #-}
@@ -608,11 +758,3 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
608 ST $ \s ->
758 ST $ \s ->
609 case writeWord8Array# mba# offset# w# s of
759 case writeWord8Array# mba# offset# w# s of
610 s -> (# s, () #)
760 s -> (# s, () #)
611−
612−
613−{-# INLINE writeWordToPtr #-}
614−writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
615−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
616− IO $ \s ->
617− case writeWord8OffAddr# addr# offset# word# s of
618− s -> (# s, () #)
compiler/src/Elm/Compiler.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Elm.Compiler
3+ ( Compile.Artifacts(..)
4+ , compile
5+ , Error.Error
6+ , errorsToDoc
7+ , errorsToJson
8+ , Warning.Warning
9+ )
10+ where
11+
12+
13+import qualified Data.ByteString as BS
14+import qualified Data.Map as Map
15+import qualified Data.Name as Name
16+import qualified Data.Utf8 as Utf8
17+
18+import qualified Compile
19+import qualified Elm.Interface as I
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Elm.Package as Pkg
22+import qualified Json.Encode as E
23+import Json.Encode ((==>))
24+import qualified Reporting.Annotation as A
25+import qualified Reporting.Doc as D
26+import qualified Reporting.Error as Error
27+import qualified Reporting.Render.Code as Code
28+import qualified Reporting.Report as Report
29+import qualified Reporting.Result as Result
30+import qualified Reporting.Warning as Warning
31+
32+
33+
34+-- COMPILE
35+
36+
37+compile
38+ :: Pkg.Name
39+ -> Map.Map ModuleName.Raw ModuleName.Canonical
40+ -> I.Interfaces
41+ -> BS.ByteString
42+ -> ( [Warning.Warning], Either [Error.Error] Compile.Artifacts )
43+compile pkg importDict interfaces source =
44+ Result.run $ Compile.compile pkg importDict interfaces source
45+
46+
47+
48+-- ERRORS TO DOC
49+
50+
51+errorsToDoc :: FilePath -> String -> [Error.Error] -> D.Doc
52+errorsToDoc filePath source errors =
53+ let
54+ reports =
55+ concatMap (Error.toReports (Code.toSource source)) errors
56+ in
57+ D.vcat $ map (Report.toDoc filePath) reports
58+
59+
60+
61+-- ERRORS TO JSON
62+
63+
64+errorsToJson :: ModuleName.Raw -> FilePath -> String -> [Error.Error] -> E.Value
65+errorsToJson moduleName filePath source errors =
66+ let
67+ reports =
68+ concatMap (Error.toReports (Code.toSource source)) errors
69+ in
70+ E.object
71+ [ "path" ==> E.string (Utf8.fromChars filePath)
72+ , "name" ==> E.string (Name.toUtf8 moduleName)
73+ , "problems" ==> E.array (map reportToJson reports)
74+ ]
75+
76+
77+reportToJson :: Report.Report -> E.Value
78+reportToJson (Report.Report title region _sgstns message) =
79+ E.object
80+ [ "title" ==> E.string (Utf8.fromChars title)
81+ , "region" ==> encodeRegion region
82+ , "message" ==> D.encode message
83+ ]
84+
85+
86+encodeRegion :: A.Region -> E.Value
87+encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =
88+ E.object
89+ [ "start" ==>
90+ E.object
91+ [ ("line", E.int (fromIntegral sr))
92+ , ("column", E.int (fromIntegral sc))
93+ ]
94+ , "end" ==>
95+ E.object
96+ [ ("line", E.int (fromIntegral er))
97+ , ("column", E.int (fromIntegral ec))
98+ ]
99+ ]
compiler/src/Elm/Compiler/Imports.hs+13−4
@@ -1,7 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Imports
3module Elm.Compiler.Imports
4− ( defaults
4+ ( addDefaults
5 )
5 )
6 where
6 where
7
7
@@ -14,6 +14,15 @@ import qualified Reporting.Annotation as A
14
14
15
15
16
16
17+-- ADD DEFAULTS
18+
19+
20+addDefaults :: [Src.Import] -> [Src.Import]
21+addDefaults imports =
22+ defaults ++ imports
23+
24+
25+
17-- DEFAULTS
26-- DEFAULTS
18
27
19
28
@@ -49,14 +58,14 @@ closed =
49
58
50typeOpen :: Name.Name -> Src.Exposing
59typeOpen :: Name.Name -> Src.Exposing
51typeOpen name =
60typeOpen name =
52− Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
61+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]
53
62
54
63
55typeClosed :: Name.Name -> Src.Exposing
64typeClosed :: Name.Name -> Src.Exposing
56typeClosed name =
65typeClosed name =
57− Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
66+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]
58
67
59
68
60operator :: Name.Name -> Src.Exposing
69operator :: Name.Name -> Src.Exposing
61operator op =
70operator op =
62− Src.Explicit [ Src.Operator A.zero op ]
71+ Src.Explicit [ A.At A.zero (Src.Operator op) ]
compiler/src/Elm/Compiler/Type.hs+35−33
@@ -15,19 +15,21 @@ 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
18
20
19import qualified AST.Source as Src
21import 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
24−import qualified Parse.Primitives as P
22+import qualified Parse.Primitives as Parse
25import qualified Parse.Type as Type
23import qualified Parse.Type as Type
26import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
27import qualified Reporting.Doc as D
25import qualified Reporting.Doc as D
28import qualified Reporting.Render.Type as RT
26import qualified Reporting.Render.Type as RT
29import qualified Reporting.Render.Type.Localizer as L
27import qualified Reporting.Render.Type.Localizer as L
30
28
29+import qualified Json.Decode as Decode
30+import qualified Json.Encode as Encode
31+import Json.Encode ((==>))
32+
31
33
32
34
33-- TYPES
35-- TYPES
@@ -111,18 +113,20 @@ collectLambdas tipe =
111-- JSON for TYPE
113-- JSON for TYPE
112
114
113
115
114−encode :: Type -> E.Value
116+encode :: Type -> Encode.Value
115encode tipe =
117encode tipe =
116− E.chars $ D.toLine (toDoc L.empty RT.None tipe)
118+ Encode.text $ Text.pack $ D.toLine (toDoc L.empty RT.None tipe)
117
119
118
120
119−decoder :: D.Decoder () Type
121+decoder :: Decode.Decoder () Type
120decoder =
122decoder =
121− let
123+ do txt <- Decode.text
122− parser =
124+ case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of
123− P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)
125+ Left _ ->
124− in
126+ Decode.fail ()
125− D.customString parser (\_ _ -> ())
127+
128+ Right (tipe, _, _) ->
129+ Decode.succeed (fromRawType tipe)
126
130
127
131
128fromRawType :: Src.Type -> Type
132fromRawType :: Src.Type -> Type
@@ -160,35 +164,33 @@ fromRawType (A.At _ astType) =
160-- JSON for PROGRAM
164-- JSON for PROGRAM
161
165
162
166
163−encodeMetadata :: DebugMetadata -> E.Value
167+encodeMetadata :: DebugMetadata -> Encode.Value
164encodeMetadata (DebugMetadata msg aliases unions) =
168encodeMetadata (DebugMetadata msg aliases unions) =
165− E.object
169+ Encode.object
166 [ "message" ==> encode msg
170 [ "message" ==> encode msg
167− , "aliases" ==> E.object (map toTypeAliasField aliases)
171+ , "aliases" ==> Encode.object (map toAliasField aliases)
168− , "unions" ==> E.object (map toCustomTypeField unions)
172+ , "unions" ==> Encode.object (map toUnionField unions)
169 ]
173 ]
170
174
171
175
172−toTypeAliasField :: Alias -> ( Json.String, E.Value )
176+toAliasField :: Alias -> ( Text.Text, Encode.Value )
173−toTypeAliasField (Alias name args tipe) =
177+toAliasField (Alias name args tipe) =
174− ( Json.fromName name
178+ Name.toText name ==>
175− , E.object
179+ Encode.object
176− [ "args" ==> E.list E.name args
180+ [ "args" ==> Encode.list Encode.name args
177 , "type" ==> encode tipe
181 , "type" ==> encode tipe
178 ]
182 ]
179− )
180
183
181
184
182−toCustomTypeField :: Union -> ( Json.String, E.Value )
185+toUnionField :: Union -> ( Text.Text, Encode.Value )
183−toCustomTypeField (Union name args constructors) =
186+toUnionField (Union name args constructors) =
184− ( Json.fromName name
187+ Name.toText name ==>
185− , E.object
188+ Encode.object
186− [ "args" ==> E.list E.name args
189+ [ "args" ==> Encode.list Encode.name args
187− , "tags" ==> E.object (map toVariantObject constructors)
190+ , "tags" ==> Encode.object (map toCtorObject constructors)
188 ]
191 ]
189− )
190
192
191
193
192−toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )
194+toCtorObject :: (Name.Name, [Type]) -> ( Text.Text, Encode.Value )
193−toVariantObject (name, args) =
195+toCtorObject (name, args) =
194− ( Json.fromName name, E.list encode args )
196+ Name.toText name ==> Encode.list encode args
compiler/src/Elm/Compiler/Type/Extract.hs+20−69
@@ -1,20 +1,15 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE Rank2Types #-}
3module Elm.Compiler.Type.Extract
4module Elm.Compiler.Type.Extract
4 ( fromAnnotation
5 ( fromAnnotation
5 , fromType
6 , fromType
6− , Types(..)
7− , mergeMany
8− , merge
9− , fromInterface
10− , fromDependencyInterface
11 , fromMsg
7 , fromMsg
12 )
8 )
13 where
9 where
14
10
15
11
16import Data.Map ((!))
12import Data.Map ((!))
17−import qualified Data.Map as Map
18import qualified Data.Maybe as Maybe
13import qualified Data.Maybe as Maybe
19import qualified Data.Name as Name
14import qualified Data.Name as Name
20import qualified Data.Set as Set
15import qualified Data.Set as Set
@@ -82,70 +77,23 @@ toPublicName (ModuleName.Canonical _ home) name =
82
77
83
78
84
79
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−
132-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
80-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
133
81
134
82
135−fromMsg :: Types -> Can.Type -> T.DebugMetadata
83+fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
136−fromMsg types message =
84+fromMsg interfaces message =
137 let
85 let
138 (msgDeps, msgType) =
86 (msgDeps, msgType) =
139 run (extract message)
87 run (extract message)
140
88
141 (aliases, unions) =
89 (aliases, unions) =
142− extractTransitive types noDeps msgDeps
90+ extractTransitive interfaces noDeps msgDeps
143 in
91 in
144 T.DebugMetadata msgType aliases unions
92 T.DebugMetadata msgType aliases unions
145
93
146
94
147−extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )
95+extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
148−extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
96+extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
149 let
97 let
150 aliases = Set.difference nextAliases seenAliases
98 aliases = Set.difference nextAliases seenAliases
151 unions = Set.difference nextUnions seenUnions
99 unions = Set.difference nextUnions seenUnions
@@ -158,36 +106,39 @@ extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnio
158 (newDeps, result) =
106 (newDeps, result) =
159 run $
107 run $
160 (,)
108 (,)
161− <$> traverse (extractAlias types) (Set.toList aliases)
109+ <$> traverse (extractAlias interfaces) (Set.toList aliases)
162− <*> traverse (extractUnion types) (Set.toList unions)
110+ <*> traverse (extractUnion interfaces) (Set.toList unions)
163
111
164 oldDeps =
112 oldDeps =
165 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
113 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
166
114
167 remainingResult =
115 remainingResult =
168− extractTransitive types oldDeps newDeps
116+ extractTransitive interfaces oldDeps newDeps
169 in
117 in
170 mappend result remainingResult
118 mappend result remainingResult
171
119
172
120
173−extractAlias :: Types -> Opt.Global -> Extractor T.Alias
121+extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
174−extractAlias (Types dict) (Opt.Global home name) =
122+extractAlias interfaces (Opt.Global home name) =
175 let
123 let
124+ (I.Interface _ _ aliases _) = interfaces ! home
176− (Can.Alias args aliasType) = _alias_info (dict ! home) ! name
125+ (Can.Alias args aliasType) = I.toAliasInternals (aliases ! name)
177 in
126 in
178 T.Alias (toPublicName home name) args <$> extract aliasType
127 T.Alias (toPublicName home name) args <$> extract aliasType
179
128
180
129
181−extractUnion :: Types -> Opt.Global -> Extractor T.Union
130+extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
182−extractUnion (Types dict) (Opt.Global home name) =
131+extractUnion interfaces (Opt.Global home name) =
183 if name == Name.list && home == ModuleName.list
132 if name == Name.list && home == ModuleName.list
184 then return $ T.Union (toPublicName home name) ["a"] []
133 then return $ T.Union (toPublicName home name) ["a"] []
185 else
134 else
186 let
135 let
187 pname = toPublicName home name
136 pname = toPublicName home name
188− (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name
137+ unions = I._unions (interfaces ! home)
189 in
138 in
139+ case I.toUnionInternals (unions ! name) of
140+ Can.Union vars ctors _ _ ->
190− T.Union pname vars <$> traverse extractCtor ctors
141+ T.Union pname vars <$> traverse extractCtor ctors
191
142
192
143
193extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
144extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])
compiler/src/Elm/Constraint.hs+77−55
@@ -5,6 +5,9 @@ module Elm.Constraint
5 , exactly
5 , exactly
6 , anything
6 , anything
7 , toChars
7 , toChars
8+ , toString
9+ , Error(..)
10+ , fromString
8 , satisfies
11 , satisfies
9 , check
12 , check
10 , intersect
13 , intersect
@@ -13,8 +16,6 @@ module Elm.Constraint
13 , untilNextMajor
16 , untilNextMajor
14 , untilNextMinor
17 , untilNextMinor
15 , expand
18 , expand
16− --
17− , Error(..)
18 , decoder
19 , decoder
19 , encode
20 , encode
20 )
21 )
@@ -23,12 +24,11 @@ module Elm.Constraint
23
24
24import Control.Monad (liftM4)
25import Control.Monad (liftM4)
25import Data.Binary (Binary, get, put, getWord8, putWord8)
26import Data.Binary (Binary, get, put, getWord8, putWord8)
27+import qualified Data.Utf8 as Utf8
26
28
27import qualified Elm.Version as V
29import qualified Elm.Version as V
28import qualified Json.Decode as D
30import qualified Json.Decode as D
29import qualified Json.Encode as E
31import qualified Json.Encode as E
30−import qualified Parse.Primitives as P
31−import Parse.Primitives (Row, Col)
32
32
33
33
34
34
@@ -61,21 +61,78 @@ anything =
61
61
62
62
63
63
64−-- TO CHARS
64+-- TO STRING
65
65
66
66
67−toChars :: Constraint -> [Char]
67+toChars :: Constraint -> String
68toChars constraint =
68toChars constraint =
69+ Utf8.toChars (toString constraint)
70+
71+
72+toString :: Constraint -> Utf8.String
73+toString constraint =
69 case constraint of
74 case constraint of
70 Range lower lowerOp upperOp upper ->
75 Range lower lowerOp upperOp upper ->
71− V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper
76+ Utf8.join 0x20 {- -}
77+ [ V.toString lower
78+ , toStringHelp lowerOp
79+ , "v"
80+ , toStringHelp upperOp
81+ , V.toString upper
82+ ]
72
83
73
84
74−opToChars :: Op -> [Char]
85+toStringHelp :: Op -> Utf8.String
75−opToChars op =
86+toStringHelp op =
76 case op of
87 case op of
77− Less -> " < "
88+ Less -> "<"
78− LessOrEqual -> " <= "
89+ LessOrEqual -> "<="
90+
91+
92+
93+-- FROM STRING
94+
95+
96+data Error
97+ = BadLower Utf8.String
98+ | BadUpper Utf8.String
99+ | BadFormat
100+ | InvalidOp
101+ | InvalidRange V.Version V.Version
102+
103+
104+fromString :: Utf8.String -> Either Error Constraint
105+fromString string =
106+ case Utf8.split 0x20 {- -} string of
107+ [lower, lowerOp, "v", upperOp, upper] ->
108+ do lo <- versionFromString lower BadLower
109+ lop <- opFromString lowerOp
110+ hop <- opFromString upperOp
111+ hi <- versionFromString upper BadUpper
112+ if lo < hi
113+ then Right (Range lo lop hop hi)
114+ else Left (InvalidRange lo hi)
115+
116+ _ ->
117+ Left BadFormat
118+
119+
120+versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version
121+versionFromString string toError =
122+ case V.fromString string of
123+ Just vsn ->
124+ Right vsn
125+
126+ Nothing ->
127+ Left (toError string)
128+
129+
130+opFromString :: Utf8.String -> Either Error Op
131+opFromString text =
132+ case text of
133+ "<=" -> Right LessOrEqual
134+ "<" -> Right Less
135+ _ -> Left InvalidOp
79
136
80
137
81
138
@@ -188,12 +245,18 @@ expand constraint@(Range lower lowerOp upperOp upper) version
188
245
189encode :: Constraint -> E.Value
246encode :: Constraint -> E.Value
190encode constraint =
247encode constraint =
191− E.chars (toChars constraint)
248+ E.string (toString constraint)
192
249
193
250
194decoder :: D.Decoder Error Constraint
251decoder :: D.Decoder Error Constraint
195decoder =
252decoder =
196− D.customString parser BadFormat
253+ do str <- D.string
254+ case fromString str of
255+ Right constraint ->
256+ return constraint
257+
258+ Left err ->
259+ D.failure err
197
260
198
261
199
262
@@ -216,45 +279,4 @@ instance Binary Op where
216 case n of
279 case n of
217 0 -> return Less
280 0 -> return Less
218 1 -> return LessOrEqual
281 1 -> return LessOrEqual
219− _ -> fail "binary encoding of Op was corrupted"
282+ _ -> error "binary encoding of Op was corrupted"
220−
221−
222−
223−-- PARSER
224−
225−
226−data Error
227− = BadFormat Row Col
228− | InvalidRange V.Version V.Version
229−
230−
231−parser :: P.Parser Error Constraint
232−parser =
233− do lower <- parseVersion
234− P.word1 0x20 {- -} BadFormat
235− loOp <- parseOp
236− P.word1 0x20 {- -} BadFormat
237− P.word1 0x76 {-v-} BadFormat
238− P.word1 0x20 {- -} BadFormat
239− hiOp <- parseOp
240− P.word1 0x20 {- -} BadFormat
241− higher <- parseVersion
242− P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
243− if lower < higher
244− then eok (Range lower loOp hiOp higher) state
245− else eerr row col (\_ _ -> InvalidRange lower higher)
246−
247−
248−parseVersion :: P.Parser Error V.Version
249−parseVersion =
250− P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser
251−
252−
253−parseOp :: P.Parser Error Op
254−parseOp =
255− do P.word1 0x3C {-<-} BadFormat
256− P.oneOfWithFallback
257− [ do P.word1 0x3D {-=-} BadFormat
258− return LessOrEqual
259− ]
260− Less
compiler/src/Elm/Docs.hs+158−218
@@ -1,7 +1,8 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}
2+{-# LANGUAGE OverloadedStrings #-}
3module Elm.Docs
3module Elm.Docs
4 ( Documentation
4 ( Documentation
5+ , toDict
5 , Module(..)
6 , Module(..)
6 , fromModule
7 , fromModule
7 , Union(..)
8 , Union(..)
@@ -17,35 +18,33 @@ module Elm.Docs
17 where
18 where
18
19
19
20
20−import qualified Data.Coerce as Coerce
21+import qualified Data.ByteString as B
21import qualified Data.List as List
22import qualified Data.List as List
22import Data.Map ((!))
23import Data.Map ((!))
23import qualified Data.Map as Map
24import qualified Data.Map as Map
24−import qualified Data.Map.Merge.Strict as Map
25import qualified Data.Name as Name
25import qualified Data.Name as Name
26−import qualified Data.NonEmptyList as NE
26+import qualified Data.Text as Text
27−import qualified Data.OneOrMore as OneOrMore
27+import qualified Data.Text.Encoding as Text
28−import Data.Word (Word8)
29−import Foreign.Ptr (Ptr, plusPtr)
30
28
31import qualified AST.Canonical as Can
29import qualified AST.Canonical as Can
32−import qualified AST.Source as Src
33import qualified AST.Utils.Binop as Binop
30import qualified AST.Utils.Binop as Binop
31+import qualified Data.OneOrMore as OneOrMore
34import qualified Elm.Compiler.Type as Type
32import qualified Elm.Compiler.Type as Type
35import qualified Elm.Compiler.Type.Extract as Extract
33import qualified Elm.Compiler.Type.Extract as Extract
36import qualified Elm.ModuleName as ModuleName
34import qualified Elm.ModuleName as ModuleName
37import qualified Json.Decode as D
35import qualified Json.Decode as D
38import qualified Json.Encode as E
36import qualified Json.Encode as E
39import Json.Encode ((==>))
37import Json.Encode ((==>))
40−import qualified Json.String as Json
41−import Parse.Primitives (Row, Col, word1)
42−import qualified Parse.Primitives as P
43−import qualified Parse.Space as Space
44−import qualified Parse.Symbol as Symbol
45−import qualified Parse.Variable as Var
46import qualified Reporting.Annotation as A
38import qualified Reporting.Annotation as A
39+import qualified Reporting.Error as Error
47import qualified Reporting.Error.Docs as E
40import qualified Reporting.Error.Docs as E
41+import qualified Reporting.Region as R
48import qualified Reporting.Result as Result
42import qualified Reporting.Result as Result
43+import Parse.Primitives (Parser)
44+import qualified Parse.Primitives as P
45+import qualified Parse.Primitives.Symbol as Symbol
46+import qualified Parse.Primitives.Variable as Var
47+import qualified Parse.Primitives.Whitespace as W
49
48
50
49
51
50
@@ -56,6 +55,21 @@ type Documentation =
56 Map.Map Name.Name Module
55 Map.Map Name.Name Module
57
56
58
57
58+toDict :: [Module] -> Documentation
59+toDict modules =
60+ Map.fromList (map toPair modules)
61+
62+
63+
64+toPair :: Module -> (Name.Name, Module)
65+toPair modul@(Module name _ _ _ _ _) =
66+ (name, modul)
67+
68+
69+
70+-- MODULES
71+
72+
59data Module =
73data Module =
60 Module
74 Module
61 { _name :: Name.Name
75 { _name :: Name.Name
@@ -66,7 +80,9 @@ data Module =
66 , _binops :: Map.Map Name.Name Binop
80 , _binops :: Map.Map Name.Name Binop
67 }
81 }
68
82
83+
69−type Comment = Json.String
84+type Comment = Text.Text
85+
70
86
71data Alias = Alias Comment [Name.Name] Type.Type
87data Alias = Alias Comment [Name.Name] Type.Type
72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
88data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]
@@ -75,19 +91,14 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence
75
91
76
92
77
93
78−-- JSON
94+-- JSON ENCODE / DECODE
79−
80−
81−encode :: Documentation -> E.Value
82−encode docs =
83− E.list encodeModule (Map.elems docs)
84
95
85
96
86−encodeModule :: Module -> E.Value
97+encode :: Module -> E.Value
87−encodeModule (Module name comment unions aliases values binops) =
98+encode (Module name comment unions aliases values binops) =
88 E.object $
99 E.object $
89 [ "name" ==> ModuleName.encode name
100 [ "name" ==> ModuleName.encode name
90− , "comment" ==> E.string comment
101+ , "comment" ==> E.text comment
91 , "unions" ==> E.list encodeUnion (Map.toList unions)
102 , "unions" ==> E.list encodeUnion (Map.toList unions)
92 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)
93 , "values" ==> E.list encodeValue (Map.toList values)
104 , "values" ==> E.list encodeValue (Map.toList values)
@@ -96,31 +107,16 @@ encodeModule (Module name comment unions aliases values binops) =
96
107
97
108
98data Error
109data Error
99− = BadAssociativity
110+ = BadAssociativity Text.Text
100− | BadModuleName
111+ | BadName
101 | BadType
112 | BadType
102
113
103
114
104−decoder :: D.Decoder Error Documentation
115+decoder :: D.Decoder Error Module
105decoder =
116decoder =
106− toDict <$> D.list moduleDecoder
107−
108−
109−toDict :: [Module] -> Documentation
110−toDict modules =
111− Map.fromList (map toDictHelp modules)
112−
113−
114−toDictHelp :: Module -> (Name.Name, Module)
115−toDictHelp modul@(Module name _ _ _ _ _) =
116− (name, modul)
117−
118−
119−moduleDecoder :: D.Decoder Error Module
120−moduleDecoder =
121 Module
117 Module
122− <$> D.field "name" moduleNameDecoder
118+ <$> D.field "name" nameDecoder
123− <*> D.field "comment" D.string
119+ <*> D.field "comment" D.text
124 <*> D.field "unions" (dictDecoder union)
120 <*> D.field "unions" (dictDecoder union)
125 <*> D.field "aliases" (dictDecoder alias)
121 <*> D.field "aliases" (dictDecoder alias)
126 <*> D.field "values" (dictDecoder value)
122 <*> D.field "values" (dictDecoder value)
@@ -135,18 +131,13 @@ dictDecoder entryDecoder =
135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)
136named entryDecoder =
132named entryDecoder =
137 (,)
133 (,)
138− <$> D.field "name" nameDecoder
134+ <$> D.field "name" D.name
139 <*> entryDecoder
135 <*> entryDecoder
140
136
141
137
142−nameDecoder :: D.Decoder e Name.Name
138+nameDecoder :: D.Decoder Error Name.Name
143nameDecoder =
139nameDecoder =
144− fmap Coerce.coerce D.string
145−
146−
147−moduleNameDecoder :: D.Decoder Error ModuleName.Raw
148−moduleNameDecoder =
149− D.mapError (const BadModuleName) ModuleName.decoder
140+ D.mapError (const BadName) ModuleName.decoder
150
141
151
142
152typeDecoder :: D.Decoder Error Type.Type
143typeDecoder :: D.Decoder Error Type.Type
@@ -162,7 +153,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value
162encodeUnion (name, Union comment args cases) =
153encodeUnion (name, Union comment args cases) =
163 E.object
154 E.object
164 [ "name" ==> E.name name
155 [ "name" ==> E.name name
165− , "comment" ==> E.string comment
156+ , "comment" ==> E.text comment
166 , "args" ==> E.list E.name args
157 , "args" ==> E.list E.name args
167 , "cases" ==> E.list encodeCase cases
158 , "cases" ==> E.list encodeCase cases
168 ]
159 ]
@@ -171,8 +162,8 @@ encodeUnion (name, Union comment args cases) =
171union :: D.Decoder Error Union
162union :: D.Decoder Error Union
172union =
163union =
173 Union
164 Union
174− <$> D.field "comment" D.string
165+ <$> D.field "comment" D.text
175− <*> D.field "args" (D.list nameDecoder)
166+ <*> D.field "args" (D.list D.name)
176 <*> D.field "cases" (D.list caseDecoder)
167 <*> D.field "cases" (D.list caseDecoder)
177
168
178
169
@@ -183,7 +174,7 @@ encodeCase ( tag, args ) =
183
174
184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )
185caseDecoder =
176caseDecoder =
186− D.pair nameDecoder (D.list typeDecoder)
177+ D.pair D.name (D.list typeDecoder)
187
178
188
179
189
180
@@ -194,7 +185,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value
194encodeAlias ( name, Alias comment args tipe) =
185encodeAlias ( name, Alias comment args tipe) =
195 E.object
186 E.object
196 [ "name" ==> E.name name
187 [ "name" ==> E.name name
197− , "comment" ==> E.string comment
188+ , "comment" ==> E.text comment
198 , "args" ==> E.list E.name args
189 , "args" ==> E.list E.name args
199 , "type" ==> Type.encode tipe
190 , "type" ==> Type.encode tipe
200 ]
191 ]
@@ -203,8 +194,8 @@ encodeAlias ( name, Alias comment args tipe) =
203alias :: D.Decoder Error Alias
194alias :: D.Decoder Error Alias
204alias =
195alias =
205 Alias
196 Alias
206− <$> D.field "comment" D.string
197+ <$> D.field "comment" D.text
207− <*> D.field "args" (D.list nameDecoder)
198+ <*> D.field "args" (D.list D.name)
208 <*> D.field "type" typeDecoder
199 <*> D.field "type" typeDecoder
209
200
210
201
@@ -216,7 +207,7 @@ encodeValue :: (Name.Name, Value) -> E.Value
216encodeValue (name, Value comment tipe) =
207encodeValue (name, Value comment tipe) =
217 E.object
208 E.object
218 [ "name" ==> E.name name
209 [ "name" ==> E.name name
219− , "comment" ==> E.string comment
210+ , "comment" ==> E.text comment
220 , "type" ==> Type.encode tipe
211 , "type" ==> Type.encode tipe
221 ]
212 ]
222
213
@@ -224,7 +215,7 @@ encodeValue (name, Value comment tipe) =
224value :: D.Decoder Error Value
215value :: D.Decoder Error Value
225value =
216value =
226 Value
217 Value
227− <$> D.field "comment" D.string
218+ <$> D.field "comment" D.text
228 <*> D.field "type" typeDecoder
219 <*> D.field "type" typeDecoder
229
220
230
221
@@ -236,7 +227,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value
236encodeBinop (name, Binop comment tipe assoc prec) =
227encodeBinop (name, Binop comment tipe assoc prec) =
237 E.object
228 E.object
238 [ "name" ==> E.name name
229 [ "name" ==> E.name name
239− , "comment" ==> E.string comment
230+ , "comment" ==> E.text comment
240 , "type" ==> Type.encode tipe
231 , "type" ==> Type.encode tipe
241 , "associativity" ==> encodeAssoc assoc
232 , "associativity" ==> encodeAssoc assoc
242 , "precedence" ==> encodePrec prec
233 , "precedence" ==> encodePrec prec
@@ -246,7 +237,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =
246binop :: D.Decoder Error Binop
237binop :: D.Decoder Error Binop
247binop =
238binop =
248 Binop
239 Binop
249− <$> D.field "comment" D.string
240+ <$> D.field "comment" D.text
250 <*> D.field "type" typeDecoder
241 <*> D.field "type" typeDecoder
251 <*> D.field "associativity" assocDecoder
242 <*> D.field "associativity" assocDecoder
252 <*> D.field "precedence" precDecoder
243 <*> D.field "precedence" precDecoder
@@ -259,23 +250,19 @@ binop =
259encodeAssoc :: Binop.Associativity -> E.Value
250encodeAssoc :: Binop.Associativity -> E.Value
260encodeAssoc assoc =
251encodeAssoc assoc =
261 case assoc of
252 case assoc of
262− Binop.Left -> E.chars "left"
253+ Binop.Left -> E.text "left"
263− Binop.Non -> E.chars "non"
254+ Binop.Non -> E.text "non"
264− Binop.Right -> E.chars "right"
255+ Binop.Right -> E.text "right"
265
256
266
257
267assocDecoder :: D.Decoder Error Binop.Associativity
258assocDecoder :: D.Decoder Error Binop.Associativity
268assocDecoder =
259assocDecoder =
269− let
260+ do txt <- D.text
270− left = Json.fromChars "left"
261+ case txt of
271− non = Json.fromChars "non"
272− right = Json.fromChars "right"
273− in
274− do str <- D.string
275− if | str == left -> return Binop.Left
262+ "left" -> D.succeed Binop.Left
276− | str == non -> return Binop.Non
263+ "non" -> D.succeed Binop.Non
277− | str == right -> return Binop.Right
264+ "right" -> D.succeed Binop.Right
278− | otherwise -> D.failure BadAssociativity
265+ _ -> D.fail (BadAssociativity txt)
279
266
280
267
281
268
@@ -296,190 +283,142 @@ precDecoder =
296-- FROM MODULE
283-- FROM MODULE
297
284
298
285
299−fromModule :: Can.Module -> Either E.Error Module
286+fromModule :: Can.Module -> Result.Result i w Error.Error Module
300−fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =
287+fromModule (Can.Module name docs exports decls unions aliases binops effects) =
301 case exports of
288 case exports of
302 Can.ExportEverything region ->
289 Can.ExportEverything region ->
303− Left (E.ImplicitExposing region)
290+ Result.throw $ Error.Docs $ E.ImplicitExposing region
304
291
305 Can.Export exportDict ->
292 Can.Export exportDict ->
306 case docs of
293 case docs of
307− Src.NoDocs region ->
294+ Can.NoDocs region ->
308− Left (E.NoDocs region)
295+ Result.throw $ Error.Docs $ E.NoDocs region
309
296
310− Src.YesDocs overview comments ->
297+ Can.YesDocs region overview comments ->
311− do names <- parseOverview overview
298+ do names <- parseOverview region overview
299+ Result.mapError Error.Docs $
312− checkNames exportDict names
300+ do checkNames exportDict names
313− checkDefs exportDict overview (Map.fromList comments) modul
301+ let types = gatherTypes decls Map.empty
302+ let info = Info comments types unions aliases binops effects
303+ inserters <- Map.traverseWithKey (checkExport info) exportDict
304+ return $ foldr ($) (emptyModule name overview) inserters
305+
306+
307+emptyModule :: ModuleName.Canonical -> B.ByteString -> Module
308+emptyModule (ModuleName.Canonical _ name) overview =
309+ Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty
314
310
315
311
316
312
317-- PARSE OVERVIEW
313-- PARSE OVERVIEW
318
314
319
315
320−parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]
316+parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]
321−parseOverview (Src.Comment snippet) =
317+parseOverview (R.Region (R.Position row col) _) overview =
322− case P.fromSnippet (chompOverview []) E.BadEnd snippet of
318+ case P.runAt row (col + 3) (chompOverview []) overview of
323 Left err ->
319 Left err ->
324− Left (E.SyntaxProblem err)
320+ Result.throw (Error.Syntax err)
325
321
326 Right names ->
322 Right names ->
327− Right names
323+ Result.ok names
328−
329−
330−type Parser a =
331− P.Parser E.SyntaxProblem a
332
324
333
325
334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335chompOverview names =
327chompOverview names =
336− do isDocs <- chompUntilDocs
328+ do isDocs <- W.chompUntilDocs
337 if isDocs
329 if isDocs
338− then
330+ then chompOverviewHelp names
339− do Space.chomp E.Space
331+ else return names
332+
333+
334+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
335+chompOverviewHelp names =
336+ do pos <- P.getPosition
337+ (W.SPos spos) <- W.whitespace
338+ if pos == spos
339+ then chompOverview names
340− chompOverview =<< chompDocs names
340+ else chompOverview =<< chompDocs names
341− else
342− return names
343
341
344
342
345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]
346chompDocs names =
344chompDocs names =
347− do name <-
345+ do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])
348− P.addLocation $
346+ spos <- W.whitespace
349− P.oneOf E.Name
347+ P.oneOf
350− [ Var.lower E.Name
348+ [ do P.checkSpace spos
351− , Var.upper E.Name
349+ Symbol.comma
352− , chompOperator
350+ P.spaces
353− ]
354−
355− Space.chomp E.Space
356−
357− P.oneOfWithFallback
358− [ do pos <- P.getPosition
359− Space.checkIndent pos E.Comma
360− word1 0x2C {-,-} E.Comma
361− Space.chomp E.Space
362 chompDocs (name:names)
351 chompDocs (name:names)
352+ , return (name:names)
363 ]
353 ]
364− (name:names)
354+
365−
355+
366−
367−chompOperator :: Parser Name.Name
356+chompBinop :: Parser Name.Name
368−chompOperator =
357+chompBinop =
369− do word1 0x28 {-(-} E.Op
358+ do Symbol.leftParen
370− op <- Symbol.operator E.Op E.OpBad
359+ name <- Symbol.binop
371− word1 0x29 {-)-} E.Op
360+ Symbol.rightParen
372− return op
361+ return name
373−
374−
375−-- TODO add rule that @docs must be after newline in 0.20
376−--
377−chompUntilDocs :: Parser Bool
378−chompUntilDocs =
379− P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->
380− let
381− (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col
382− !newState = P.State src newPos end indent newRow newCol
383− in
384− cok isDocs newState
385−
386−
387−untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)
388−untilDocs pos end row col =
389− if pos >= end then
390− (# False, pos, row, col #)
391− else
392− let !word = P.unsafeIndex pos in
393− if word == 0x0A {-\n-} then
394− untilDocs (plusPtr pos 1) end (row + 1) 1
395− else
396− let !pos5 = plusPtr pos 5 in
397− if pos5 <= end
398− && P.unsafeIndex ( pos ) == 0x40 {-@-}
399− && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}
400− && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}
401− && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}
402− && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}
403− && Var.getInnerWidth pos5 end == 0
404− then
405− (# True, pos5, row, col + 5 #)
406− else
407− let !newPos = plusPtr pos (P.getCharWidth word) in
408− untilDocs newPos end row (col + 1)
409
362
410
363
411
364
412-- CHECK NAMES
365-- CHECK NAMES
413
366
414
367
415−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()
368+type Result i w a =
416−checkNames exports names =
369+ Result.Result i w E.Error a
417− let
370+
418− docs = List.foldl' addName Map.empty names
371+
419− loneDoc = Map.traverseMissing onlyInDocs
372+type Dups =
420− loneExport = Map.traverseMissing onlyInExports
373+ Map.Map Name.Name (OneOrMore.OneOrMore R.Region)
421− checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)
422− in
423− case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of
424− (_, Right _) -> Right ()
425− (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))
426
374
427
375
428−type DocNameRegions =
376+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()
429− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)
377+checkNames exports names =
378+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)
379+ let overlap = Map.size (Map.intersection docs exports)
380+ if Map.size exports == overlap && overlap == Map.size docs
381+ then Result.ok ()
382+ else
383+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)
384+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)
385+ Result.ok ()
430
386
431
387
432−addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions
388+addName :: Dups -> A.Located Name.Name -> Dups
433addName dict (A.At region name) =
389addName dict (A.At region name) =
434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict
435
391
436
392
437−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region
393+isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region
438isUnique name regions =
394isUnique name regions =
439 case regions of
395 case regions of
440 OneOrMore.One region ->
396 OneOrMore.One region ->
441 Result.ok region
397 Result.ok region
442
398
443− OneOrMore.More left right ->
399+ OneOrMore.More _ _ ->
444− let (r1, r2) = OneOrMore.getFirstTwo left right in
400+ let (r1:r2:_) = OneOrMore.toList regions in
445− Result.throw (E.NameDuplicate name r1 r2)
401+ Result.throw (E.Duplicate name r1 r2)
446
402
447
403
448−onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a
404+onlyInDocs :: Name.Name -> R.Region -> Result i w a
449−onlyInDocs name regions =
405+onlyInDocs name region =
450− do region <- isUnique name regions
451− Result.throw $ E.NameOnlyInDocs name region
406+ Result.throw $ E.OnlyInDocs name region
452
407
453
408
454−onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a
409+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a
455onlyInExports name (A.At region _) =
410onlyInExports name (A.At region _) =
456− Result.throw $ E.NameOnlyInExports name region
411+ Result.throw $ E.OnlyInExports name region
457−
458−
459−
460−-- CHECK DEFS
461−
462
412
463−checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module
464−checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =
465− let
466− types = gatherTypes decls Map.empty
467− info = Info comments types unions aliases infixes effects
468− in
469− case Result.run (Map.traverseWithKey (checkExport info) exportDict) of
470− (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)
471− (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters
472
413
473
414
474−emptyModule :: ModuleName.Canonical -> Src.Comment -> Module
415+-- CHECK EXPORTS
475−emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =
476− Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty
477
416
478
417
479data Info =
418data Info =
480 Info
419 Info
481− { _iComments :: Map.Map Name.Name Src.Comment
420+ { _iComments :: Map.Map Name.Name Comment
482− , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)
421+ , _iValues :: Types
483 , _iUnions :: Map.Map Name.Name Can.Union
422 , _iUnions :: Map.Map Name.Name Can.Union
484 , _iAliases :: Map.Map Name.Name Can.Alias
423 , _iAliases :: Map.Map Name.Name Can.Alias
485 , _iBinops :: Map.Map Name.Name Can.Binop
424 , _iBinops :: Map.Map Name.Name Can.Binop
@@ -487,7 +426,7 @@ data Info =
487 }
426 }
488
427
489
428
490−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)
429+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)
491checkExport info name (A.At region export) =
430checkExport info name (A.At region export) =
492 case export of
431 case export of
493 Can.ExportValue ->
432 Can.ExportValue ->
@@ -528,23 +467,23 @@ checkExport info name (A.At region export) =
528 m { _values = Map.insert name (Value comment tipe) (_values m) }
467 m { _values = Map.insert name (Value comment tipe) (_values m) }
529
468
530
469
531−getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment
470+getComment :: R.Region -> Name.Name -> Info -> Result i w Comment
532getComment region name info =
471getComment region name info =
533 case Map.lookup name (_iComments info) of
472 case Map.lookup name (_iComments info) of
534 Nothing ->
473 Nothing ->
535 Result.throw (E.NoComment name region)
474 Result.throw (E.NoComment name region)
536
475
537− Just (Src.Comment snippet) ->
476+ Just comment ->
538− Result.ok (Json.fromComment snippet)
477+ Result.ok comment
539
478
540
479
541−getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type
480+getType :: Name.Name -> Info -> Result i w Type.Type
542getType name info =
481getType name info =
543 case _iValues info ! name of
482 case _iValues info ! name of
544− Left region ->
483+ A.At defRegion Nothing ->
545− Result.throw (E.NoAnnotation name region)
484+ Result.throw (E.NoAnnotation name defRegion)
546
485
547− Right tipe ->
486+ A.At _ (Just tipe) ->
548 Result.ok (Extract.fromType tipe)
487 Result.ok (Extract.fromType tipe)
549
488
550
489
@@ -558,7 +497,7 @@ dector (Can.Ctor name _ _ args) =
558
497
559
498
560type Types =
499type Types =
561− Map.Map Name.Name (Either A.Region Can.Type)
500+ Map.Map Name.Name (A.Located (Maybe Can.Type))
562
501
563
502
564gatherTypes :: Can.Decls -> Types -> Types
503gatherTypes :: Can.Decls -> Types -> Types
@@ -567,8 +506,8 @@ gatherTypes decls types =
567 Can.Declare def subDecls ->
506 Can.Declare def subDecls ->
568 gatherTypes subDecls (addDef types def)
507 gatherTypes subDecls (addDef types def)
569
508
570− Can.DeclareRec def defs subDecls ->
509+ Can.DeclareRec defs subDecls ->
571− gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)
510+ gatherTypes subDecls (List.foldl' addDef types defs)
572
511
573 Can.SaveTheEnvironment ->
512 Can.SaveTheEnvironment ->
574 types
513 types
@@ -578,10 +517,11 @@ addDef :: Types -> Can.Def -> Types
578addDef types def =
517addDef types def =
579 case def of
518 case def of
580 Can.Def (A.At region name) _ _ ->
519 Can.Def (A.At region name) _ _ ->
581− Map.insert name (Left region) types
520+ Map.insert name (A.At region Nothing) types
582
521
583− Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->
522+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->
584 let
523 let
524+ tipe =
585− tipe = foldr Can.TLambda resultType (map snd typedArgs)
525+ foldr Can.TLambda resultType (map snd typedArgs)
586 in
526 in
587− Map.insert name (Right tipe) types
527+ Map.insert name (A.At region (Just tipe)) types
compiler/src/Elm/Float.hsdeleted−51
@@ -1,51 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}
3−module Elm.Float
4− ( Float
5− , fromPtr
6− , toBuilder
7− )
8− where
9−
10−
11−import Prelude hiding (Float)
12−import Data.Binary (Binary, get, put)
13−import qualified Data.ByteString.Builder as B
14−import qualified Data.Utf8 as Utf8
15−import Data.Word (Word8)
16−import Foreign.Ptr (Ptr)
17−
18−
19−
20−-- FLOATS
21−
22−
23−type Float =
24− Utf8.Utf8 ELM_FLOAT
25−
26−
27−data ELM_FLOAT
28−
29−
30−
31−-- HELPERS
32−
33−
34−fromPtr :: Ptr Word8 -> Ptr Word8 -> Float
35−fromPtr =
36− Utf8.fromPtr
37−
38−
39−{-# INLINE toBuilder #-}
40−toBuilder :: Float -> B.Builder
41−toBuilder =
42− Utf8.toBuilder
43−
44−
45−
46−-- BINARY
47−
48−
49−instance Binary (Utf8.Utf8 ELM_FLOAT) where
50− get = Utf8.getUnder256
51− put = Utf8.putUnder256
compiler/src/Elm/Interface.hs+14−17
@@ -11,13 +11,11 @@ module Elm.Interface
11 , public
11 , public
12 , private
12 , private
13 , privatize
13 , privatize
14− , extractUnion
15− , extractAlias
16 )
14 )
17 where
15 where
18
16
19
17
20−import Control.Monad (liftM, liftM3, liftM4, liftM5)
18+import Control.Monad (liftM, liftM2, liftM4, liftM5)
21import Data.Binary
19import Data.Binary
22import Data.Map.Strict ((!))
20import Data.Map.Strict ((!))
23import qualified Data.Map.Strict as Map
21import qualified Data.Map.Strict as Map
@@ -73,7 +71,7 @@ data Binop =
73
71
74
72
75fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
73fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
76−fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =
74+fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =
77 Interface
75 Interface
78 { _home = home
76 { _home = home
79 , _values = restrict exports annotations
77 , _values = restrict exports annotations
@@ -155,10 +153,7 @@ toPublicAlias iAlias =
155
153
156data DependencyInterface
154data DependencyInterface
157 = Public Interface
155 = Public Interface
158− | Private
159− Pkg.Name
160− (Map.Map Name.Name Can.Union)
156+ | Private (Map.Map Name.Name Can.Union) (Map.Map Name.Name Can.Alias)
161− (Map.Map Name.Name Can.Alias)
162
157
163
158
164public :: Interface -> DependencyInterface
159public :: Interface -> DependencyInterface
@@ -167,8 +162,10 @@ public =
167
162
168
163
169private :: Interface -> DependencyInterface
164private :: Interface -> DependencyInterface
170−private (Interface pkg _ unions aliases _) =
165+private (Interface _ _ unions aliases _) =
166+ Private
167+ (Map.map extractUnion unions)
171− Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases)
168+ (Map.map extractAlias aliases)
172
169
173
170
174extractUnion :: Union -> Can.Union
171extractUnion :: Union -> Can.Union
@@ -190,7 +187,7 @@ privatize :: DependencyInterface -> DependencyInterface
190privatize di =
187privatize di =
191 case di of
188 case di of
192 Public i -> private i
189 Public i -> private i
193− Private _ _ _ -> di
190+ Private _ _ -> di
194
191
195
192
196
193
@@ -215,7 +212,7 @@ instance Binary Union where
215 0 -> liftM OpenUnion get
212 0 -> liftM OpenUnion get
216 1 -> liftM ClosedUnion get
213 1 -> liftM ClosedUnion get
217 2 -> liftM PrivateUnion get
214 2 -> liftM PrivateUnion get
218− _ -> fail "binary encoding of Union was corrupted"
215+ _ -> error "binary encoding of Union was corrupted"
219
216
220
217
221instance Binary Alias where
218instance Binary Alias where
@@ -229,7 +226,7 @@ instance Binary Alias where
229 case n of
226 case n of
230 0 -> liftM PublicAlias get
227 0 -> liftM PublicAlias get
231 1 -> liftM PrivateAlias get
228 1 -> liftM PrivateAlias get
232− _ -> fail "binary encoding of Alias was corrupted"
229+ _ -> error "binary encoding of Alias was corrupted"
233
230
234
231
235instance Binary Binop where
232instance Binary Binop where
@@ -243,12 +240,12 @@ instance Binary Binop where
243instance Binary DependencyInterface where
240instance Binary DependencyInterface where
244 put union =
241 put union =
245 case union of
242 case union of
246− Public a -> putWord8 0 >> put a
243+ Public a -> putWord8 0 >> put a
247− Private a b c -> putWord8 1 >> put a >> put b >> put c
244+ Private a b -> putWord8 1 >> put a >> put b
248
245
249 get =
246 get =
250 do n <- getWord8
247 do n <- getWord8
251 case n of
248 case n of
252 0 -> liftM Public get
249 0 -> liftM Public get
253− 1 -> liftM3 Private get get get
250+ 1 -> liftM2 Private get get
254− _ -> fail "binary encoding of DependencyInterface was corrupted"
251+ _ -> error "binary encoding of DependencyInterface was corrupted"
compiler/src/Elm/Kernel.hs+127−132
@@ -3,40 +3,55 @@
3module Elm.Kernel
3module Elm.Kernel
4 ( Content(..)
4 ( Content(..)
5 , Chunk(..)
5 , Chunk(..)
6− , fromByteString
6+ , Dep(..)
7− , countFields
7+ , parser
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 qualified Data.ByteString.Internal as B
14+import Data.Coerce (coerce)
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
18−import Data.Word (Word8)
20+import Data.Word (Word8, Word16)
19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
21+import Foreign.Ptr (Ptr, plusPtr)
20−import Foreign.ForeignPtr (ForeignPtr)
21−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
22
22
23import qualified AST.Source as Src
23import qualified AST.Source as Src
24import qualified Elm.ModuleName as ModuleName
24import qualified Elm.ModuleName as ModuleName
25import qualified Elm.Package as Pkg
25import qualified Elm.Package as Pkg
26import qualified Parse.Module as Module
26import qualified Parse.Module as Module
27−import qualified Parse.Space as Space
28import qualified Parse.Variable as Var
27import qualified Parse.Variable as Var
28+import Parse.Utils
29−import Parse.Primitives hiding (fromByteString)
29+import Parse.Primitives hiding (Parser, State)
30import qualified Parse.Primitives as P
30import qualified Parse.Primitives as P
31import qualified Reporting.Annotation as A
31import qualified Reporting.Annotation as A
32+import qualified Reporting.Error.Syntax as E
32
33
33
34
34
35
35−-- CHUNK
36+-- CONTENT
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
36
51
37
52
38data Chunk
53data Chunk
39− = JS B.ByteString
54+ = JS (Utf8.VeryLong UNCHECKED)
40 | ElmVar ModuleName.Canonical Name.Name
55 | ElmVar ModuleName.Canonical Name.Name
41 | JsVar Name.Name Name.Name
56 | JsVar Name.Name Name.Name
42 | ElmField Name.Name
57 | ElmField Name.Name
@@ -46,93 +61,56 @@ data Chunk
46 | Prod
61 | Prod
47
62
48
63
64+data UNCHECKED
49
65
50−-- COUNT FIELDS
51−
52−
53−countFields :: [Chunk] -> Map.Map Name.Name Int
54−countFields chunks =
55− foldr addField Map.empty chunks
56
66
57
67
58−addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int
68+-- PARSE
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]
71
73
72−-- FROM FILE
73−
74−
75−data Content =
76− Content [Src.Import] [Chunk]
77
74
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−
93−parser :: Pkg.Name -> Foreigns -> Parser () Content
75+parser :: ImportDict -> Parser Content
94−parser pkg foreigns =
76+parser importDict =
95− do word2 0x2F 0x2A {-/*-} toError
77+ do word2 0x2F 0x2A {-/*-} E.XXX
96− Space.chomp ignoreError
78+ Module.freshLine
97− Space.checkFreshLine toError
98− imports <- specialize ignoreError (Module.chompImports [])
79+ imports <- Module.chompImports []
99− word2 0x2A 0x2F {-*/-} toError
80+ word2 0x2A 0x2F {-*/-} E.XXX
81+ let (vtable, deps) = processImports importDict imports
100− chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty
82+ chunks <- parseChunks vtable Map.empty Map.empty
101− return (Content imports chunks)
83+ return $ Content chunks deps
102−
103−
104−toError :: Row -> Col -> ()
105−toError _ _ =
106− ()
107−
108−
109−ignoreError :: a -> Row -> Col -> ()
110−ignoreError _ _ _ =
111− ()
112
84
113
85
114
86
115-- PARSE CHUNKS
87-- PARSE CHUNKS
116
88
117
89
118−parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]
90+parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]
119parseChunks vtable enums fields =
91parseChunks vtable enums fields =
120− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
92+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr _ ->
121 let
93 let
122 (# chunks, newPos, newRow, newCol #) =
94 (# chunks, newPos, newRow, newCol #) =
123− chompChunks vtable enums fields src pos end row col pos []
95+ chompChunks vtable enums fields pos end row col pos []
124 in
96 in
125 if newPos == end then
97 if newPos == end then
126− cok chunks (P.State src newPos end indent newRow newCol)
98+ cok chunks (P.State newPos end indent newRow newCol ctx)
127 else
99 else
128− cerr row col toError
100+ cerr row col ctx E.XXX
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
129
108
130
109
131−chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
110+chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
132−chompChunks vs es fs src pos end row col lastPos revChunks =
111+chompChunks vs es fs pos end row col lastPos revChunks =
133 if pos >= end then
112 if pos >= end then
134− let !js = toByteString src lastPos end in
135− (# reverse (JS js : revChunks), pos, row, col #)
113+ (# reverse (addJS lastPos end revChunks), pos, row, col #)
136
114
137 else
115 else
138 let !word = unsafeIndex pos in
116 let !word = unsafeIndex pos in
@@ -142,45 +120,31 @@ chompChunks vs es fs src pos end row col lastPos revChunks =
142 !pos3 = plusPtr pos 3
120 !pos3 = plusPtr pos 3
143 in
121 in
144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
122 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then
145− let !js = toByteString src lastPos pos in
146− chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)
123+ chompTag vs es fs pos3 end row (col + 3) (addJS lastPos pos revChunks)
147 else
124 else
148− chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks
125+ chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks
149
126
150 else if word == 0x0A {-\n-} then
127 else if word == 0x0A {-\n-} then
151− chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
128+ chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks
152
129
153 else
130 else
154 let
131 let
155− !newPos = plusPtr pos (getCharWidth word)
132+ !newPos = plusPtr pos (getCharWidth pos end word)
156 in
133 in
157− chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks
134+ chompChunks vs es fs newPos end row (col + 1) lastPos revChunks
158−
159−
160−toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString
161−toByteString src pos end =
162− let
163− !off = minusPtr pos (unsafeForeignPtrToPtr src)
164− !len = minusPtr end pos
165− in
166− B.PS src off len
167−
168
135
169
136
170-- relies on external checks in chompChunks
137-- relies on external checks in chompChunks
171−chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)
138+chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)
172−chompTag vs es fs src pos end row col revChunks =
139+chompTag vs es fs pos end row col revChunks =
173 let
140 let
174 (# newPos, newCol #) = Var.chompInnerChars pos end col
141 (# newPos, newCol #) = Var.chompInnerChars pos end col
175 !tagPos = plusPtr pos (-1)
142 !tagPos = plusPtr pos (-1)
176 !word = unsafeIndex tagPos
143 !word = unsafeIndex tagPos
177 in
144 in
178 if word == 0x24 {-$-} then
145 if word == 0x24 {-$-} then
179− let
180− !name = Name.fromPtr pos newPos
181− in
182− chompChunks vs es fs src newPos end row newCol newPos $
146+ chompChunks vs es fs newPos end row newCol newPos $
183− ElmField name : revChunks
147+ ElmField (Name.fromPtr pos newPos) : revChunks
184 else
148 else
185 let
149 let
186 !name = Name.fromPtr tagPos newPos
150 !name = Name.fromPtr tagPos newPos
@@ -190,7 +154,7 @@ chompTag vs es fs src pos end row col revChunks =
190 (enum, newEnums) =
154 (enum, newEnums) =
191 lookupEnum (word - 0x30) name es
155 lookupEnum (word - 0x30) name es
192 in
156 in
193− chompChunks vs newEnums fs src newPos end row newCol newPos $
157+ chompChunks vs newEnums fs newPos end row newCol newPos $
194 JsEnum enum : revChunks
158 JsEnum enum : revChunks
195
159
196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
160 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then
@@ -198,19 +162,19 @@ chompTag vs es fs src pos end row col revChunks =
198 (field, newFields) =
162 (field, newFields) =
199 lookupField name fs
163 lookupField name fs
200 in
164 in
201− chompChunks vs es newFields src newPos end row newCol newPos $
165+ chompChunks vs es newFields newPos end row newCol newPos $
202 JsField field : revChunks
166 JsField field : revChunks
203
167
204 else if name == "DEBUG" then
168 else if name == "DEBUG" then
205− chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)
169+ chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)
206
170
207 else if name == "PROD" then
171 else if name == "PROD" then
208− chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)
172+ chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)
209
173
210 else
174 else
211 case Map.lookup name vs of
175 case Map.lookup name vs of
212 Just chunk ->
176 Just chunk ->
213− chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)
177+ chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)
214
178
215 Nothing ->
179 Nothing ->
216 (# revChunks, pos, row, col #)
180 (# revChunks, pos, row, col #)
@@ -266,34 +230,60 @@ type VarTable =
266 Map.Map Name.Name Chunk
230 Map.Map Name.Name Chunk
267
231
268
232
269−toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable
233+type State =
270−toVarTable pkg foreigns imports =
234+ (VarTable, Set.Set Dep)
271− List.foldl' (addImport pkg foreigns) Map.empty imports
272
235
273
236
274−addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable
237+processImports :: ImportDict -> [Src.Import] -> State
238+processImports importDict imports =
239+ List.foldl' (addImport importDict) (Map.empty, Set.empty) imports
240+
241+
242+addImport :: ImportDict -> State -> Src.Import -> State
275−addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) =
243+addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
276− if Name.isKernel importName then
244+ if Name.isKernel home then
277 case maybeAlias of
245 case maybeAlias of
278 Just _ ->
246 Just _ ->
279− error ("cannot use `as` with kernel import of: " ++ Name.toChars importName)
247+ error ("Cannot use aliases on kernel import of: " ++ Name.toChars home)
280
248
281 Nothing ->
249 Nothing ->
250+ addKernelImport (Name.getKernel home) exposing state
251+
252+ else
253+ case Map.lookup home importDict of
254+ Just [pkg] ->
282 let
255 let
283− home = Name.getKernel importName
256+ canonicalHome = ModuleName.Canonical pkg home
284− add table name =
257+ prefix = toPrefix home maybeAlias
285− Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table
286 in
258 in
287− List.foldl' add vtable (toNames exposing)
259+ addNormalImport canonicalHome prefix exposing state
288
260
289− else
261+ _ ->
290− let
262+ error ("Cannot find kernel import of: " ++ Name.toChars home)
291− home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName
263+
292− prefix = toPrefix importName maybeAlias
264+
293− add table name =
265+-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
266+--
267+addKernelImport :: Name.Name -> Src.Exposing -> State -> State
268+addKernelImport home exposing (vtable, deps) =
269+ let
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 =
294− Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table
282+ ( Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) vtable
283+ , Set.insert (ElmDep home name) deps
284+ )
295− in
285+ in
296− List.foldl' add vtable (toNames exposing)
286+ List.foldl' addVar state (toNames exposing)
297
287
298
288
299toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name
289toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name
@@ -313,25 +303,25 @@ toNames :: Src.Exposing -> [Name.Name]
313toNames exposing =
303toNames exposing =
314 case exposing of
304 case exposing of
315 Src.Open ->
305 Src.Open ->
316− error "cannot have `exposing (..)` in kernel code."
306+ error "Cannot have `exposing (..)` in kernel code."
317
307
318 Src.Explicit exposedList ->
308 Src.Explicit exposedList ->
319 map toName exposedList
309 map toName exposedList
320
310
321
311
322−toName :: Src.Exposed -> Name.Name
312+toName :: A.Located Src.Exposed -> Name.Name
323−toName exposed =
313+toName (A.At _ exposed) =
324 case exposed of
314 case exposed of
325− Src.Lower (A.At _ name) ->
315+ Src.Lower name ->
326 name
316 name
327
317
328− Src.Upper (A.At _ name) Src.Private ->
318+ Src.Upper name Src.Private ->
329 name
319 name
330
320
331− Src.Upper _ (Src.Public _) ->
321+ Src.Upper _ Src.Public ->
332 error "cannot have Maybe(..) syntax in kernel code header"
322 error "cannot have Maybe(..) syntax in kernel code header"
333
323
334− Src.Operator _ _ ->
324+ Src.Operator _ ->
335 error "cannot use binops in kernel code"
325 error "cannot use binops in kernel code"
336
326
337
327
@@ -342,7 +332,7 @@ toName exposed =
342instance Binary Chunk where
332instance Binary Chunk where
343 put chunk =
333 put chunk =
344 case chunk of
334 case chunk of
345− JS a -> putWord8 0 >> put a
335+ JS a -> putWord8 0 >> put (coerce a :: Utf8.String)
346 ElmVar a b -> putWord8 1 >> put a >> put b
336 ElmVar a b -> putWord8 1 >> put a >> put b
347 JsVar a b -> putWord8 2 >> put a >> put b
337 JsVar a b -> putWord8 2 >> put a >> put b
348 ElmField a -> putWord8 3 >> put a
338 ElmField a -> putWord8 3 >> put a
@@ -354,7 +344,7 @@ instance Binary Chunk where
354 get =
344 get =
355 do word <- getWord8
345 do word <- getWord8
356 case word of
346 case word of
357− 0 -> liftM JS get
347+ 0 -> liftM toJS get
358 1 -> liftM2 ElmVar get get
348 1 -> liftM2 ElmVar get get
359 2 -> liftM2 JsVar get get
349 2 -> liftM2 JsVar get get
360 3 -> liftM ElmField get
350 3 -> liftM ElmField get
@@ -363,3 +353,8 @@ instance Binary Chunk where
363 6 -> return Debug
353 6 -> return Debug
364 7 -> return Prod
354 7 -> return Prod
365 _ -> error "problem deserializing Elm.Kernel.Chunk"
355 _ -> 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+65−48
@@ -9,12 +9,14 @@ module Elm.Licenses
9 where
9 where
10
10
11
11
12+import Control.Monad (liftM2)
13+import Data.Binary (Binary, get, put)
14+import Data.Map ((!))
12import qualified Data.Map as Map
15import qualified Data.Map as Map
13import qualified Data.Utf8 as Utf8
16import qualified Data.Utf8 as Utf8
14
17
15import qualified Json.Decode as D
18import qualified Json.Decode as D
16import qualified Json.Encode as E
19import qualified Json.Encode as E
17−import qualified Json.String as Json
18import qualified Reporting.Suggest as Suggest
20import qualified Reporting.Suggest as Suggest
19
21
20
22
@@ -22,21 +24,25 @@ import qualified Reporting.Suggest as Suggest
22-- LICENCES
24-- LICENCES
23
25
24
26
25−newtype License =
27+data License =
26− License Json.String
28+ License
29+ { _name :: Utf8.String
30+ , _code :: Utf8.String
31+ }
32+ deriving (Eq, Ord)
27
33
28
34
29bsd3 :: License
35bsd3 :: License
30bsd3 =
36bsd3 =
31− License (Json.fromChars "BSD-3-Clause")
37+ osiApprovedSpdxLicenses ! "BSD-3-Clause"
32
38
33
39
34encode :: License -> E.Value
40encode :: License -> E.Value
35−encode (License code) =
41+encode (License _ code) =
36 E.string code
42 E.string code
37
43
38
44
39−decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License
45+decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License
40decoder toError =
46decoder toError =
41 do str <- D.string
47 do str <- D.string
42 case check str of
48 case check str of
@@ -51,93 +57,97 @@ decoder toError =
51-- CHECK
57-- CHECK
52
58
53
59
54−check :: Json.String -> Either [Json.String] License
60+check :: Utf8.String -> Either [Utf8.String] License
55−check givenCode =
61+check rawName =
56− if Map.member givenCode osiApprovedSpdxLicenses then
62+ case Map.lookup rawName osiApprovedSpdxLicenses of
57− Right (License givenCode)
63+ Just license ->
64+ Right license
58
65
59− else
66+ Nothing ->
60− let
67+ let
61− pairs =
68+ toPairs (License name code) =
62− map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)
69+ [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]
63− ++
70+
71+ pairs =
64− Map.toList osiApprovedSpdxLicenses
72+ concatMap toPairs (Map.elems osiApprovedSpdxLicenses)
65− in
73+ in
66− Left $ map fst $ take 4 $
74+ Left $ map snd $
67− Suggest.sort (Utf8.toChars givenCode) snd pairs
75+ Suggest.sort (Utf8.toChars rawName) fst pairs
68
76
69
77
70
78
71-- LIST OF LICENCES
79-- LIST OF LICENCES
72
80
73
81
74−(==>) :: [Char] -> [Char] -> (Json.String, [Char])
82+(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)
75−(==>) code fullName =
83+(==>) code name =
76− ( Json.fromChars code, fullName )
84+ ( code, License name code )
77
85
78
86
79--
87--
80-- OSI approved licenses in SPDX format.
88-- OSI approved licenses in SPDX format.
81-- <https://spdx.org/licenses/>
89-- <https://spdx.org/licenses/>
82--
90--
83−osiApprovedSpdxLicenses :: Map.Map Json.String [Char]
91+osiApprovedSpdxLicenses :: Map.Map Utf8.String License
84osiApprovedSpdxLicenses =
92osiApprovedSpdxLicenses =
85 Map.fromList
93 Map.fromList
86− [ "0BSD" ==> "BSD Zero Clause License"
87− , "AAL" ==> "Attribution Assurance License"
88− , "AFL-1.1" ==> "Academic Free License v1.1"
94+ [ "AFL-1.1" ==> "Academic Free License v1.1"
89 , "AFL-1.2" ==> "Academic Free License v1.2"
95 , "AFL-1.2" ==> "Academic Free License v1.2"
90 , "AFL-2.0" ==> "Academic Free License v2.0"
96 , "AFL-2.0" ==> "Academic Free License v2.0"
91 , "AFL-2.1" ==> "Academic Free License v2.1"
97 , "AFL-2.1" ==> "Academic Free License v2.1"
92 , "AFL-3.0" ==> "Academic Free License v3.0"
98 , "AFL-3.0" ==> "Academic Free License v3.0"
93− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
99+ , "APL-1.0" ==> "Adaptive Public License 1.0"
94 , "Apache-1.1" ==> "Apache License 1.1"
100 , "Apache-1.1" ==> "Apache License 1.1"
95 , "Apache-2.0" ==> "Apache License 2.0"
101 , "Apache-2.0" ==> "Apache License 2.0"
96− , "APL-1.0" ==> "Adaptive Public License 1.0"
97 , "APSL-1.0" ==> "Apple Public Source License 1.0"
102 , "APSL-1.0" ==> "Apple Public Source License 1.0"
98 , "APSL-1.1" ==> "Apple Public Source License 1.1"
103 , "APSL-1.1" ==> "Apple Public Source License 1.1"
99 , "APSL-1.2" ==> "Apple Public Source License 1.2"
104 , "APSL-1.2" ==> "Apple Public Source License 1.2"
100 , "APSL-2.0" ==> "Apple Public Source License 2.0"
105 , "APSL-2.0" ==> "Apple Public Source License 2.0"
101 , "Artistic-1.0" ==> "Artistic License 1.0"
106 , "Artistic-1.0" ==> "Artistic License 1.0"
102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
103 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
107 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"
108+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"
104 , "Artistic-2.0" ==> "Artistic License 2.0"
109 , "Artistic-2.0" ==> "Artistic License 2.0"
110+ , "AAL" ==> "Attribution Assurance License"
111+ , "BSL-1.0" ==> "Boost Software License 1.0"
105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"
106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"
107− , "BSL-1.0" ==> "Boost Software License 1.0"
114+ , "0BSD" ==> "BSD Zero Clause License"
108− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"
111 , "CNRI-Python" ==> "CNRI Python License"
116 , "CNRI-Python" ==> "CNRI Python License"
117+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"
112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"
113 , "CPL-1.0" ==> "Common Public License 1.0"
119 , "CPL-1.0" ==> "Common Public License 1.0"
120+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"
114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"
122+ , "EPL-1.0" ==> "Eclipse Public License 1.0"
115 , "ECL-1.0" ==> "Educational Community License v1.0"
123 , "ECL-1.0" ==> "Educational Community License v1.0"
116 , "ECL-2.0" ==> "Educational Community License v2.0"
124 , "ECL-2.0" ==> "Educational Community License v2.0"
117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"
118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"
119 , "Entessa" ==> "Entessa Public License v1.0"
127 , "Entessa" ==> "Entessa Public License v1.0"
120− , "EPL-1.0" ==> "Eclipse Public License 1.0"
121 , "EUDatagrid" ==> "EU DataGrid Software License"
128 , "EUDatagrid" ==> "EU DataGrid Software License"
122 , "EUPL-1.1" ==> "European Union Public License 1.1"
129 , "EUPL-1.1" ==> "European Union Public License 1.1"
123 , "Fair" ==> "Fair License"
130 , "Fair" ==> "Fair License"
124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"
132+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"
125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"
126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
134 , "GPL-3.0" ==> "GNU General Public License v3.0 only"
135+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
136+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
137+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
127 , "HPND" ==> "Historic Permission Notice and Disclaimer"
138 , "HPND" ==> "Historic Permission Notice and Disclaimer"
139+ , "IPL-1.0" ==> "IBM Public License v1.0"
128 , "Intel" ==> "Intel Open Source License"
140 , "Intel" ==> "Intel Open Source License"
129 , "IPA" ==> "IPA Font License"
141 , "IPA" ==> "IPA Font License"
130− , "IPL-1.0" ==> "IBM Public License v1.0"
131 , "ISC" ==> "ISC License"
142 , "ISC" ==> "ISC License"
132− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"
143+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
133− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"
134− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"
135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
144 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"
136− , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
137 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
145 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"
138− , "LPL-1.0" ==> "Lucent Public License Version 1.0"
146+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"
139 , "LPL-1.02" ==> "Lucent Public License v1.02"
147 , "LPL-1.02" ==> "Lucent Public License v1.02"
148+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"
140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"
149+ , "MS-PL" ==> "Microsoft Public License"
150+ , "MS-RL" ==> "Microsoft Reciprocal License"
141 , "MirOS" ==> "MirOS Licence"
151 , "MirOS" ==> "MirOS Licence"
142 , "MIT" ==> "MIT License"
152 , "MIT" ==> "MIT License"
143 , "Motosoto" ==> "Motosoto License"
153 , "Motosoto" ==> "Motosoto License"
@@ -145,41 +155,48 @@ osiApprovedSpdxLicenses =
145 , "MPL-1.1" ==> "Mozilla Public License 1.1"
155 , "MPL-1.1" ==> "Mozilla Public License 1.1"
146 , "MPL-2.0" ==> "Mozilla Public License 2.0"
156 , "MPL-2.0" ==> "Mozilla Public License 2.0"
147 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
157 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"
148− , "MS-PL" ==> "Microsoft Public License"
149− , "MS-RL" ==> "Microsoft Reciprocal License"
150 , "Multics" ==> "Multics License"
158 , "Multics" ==> "Multics License"
151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"
152 , "Naumen" ==> "Naumen Public License"
160 , "Naumen" ==> "Naumen Public License"
153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"
154 , "NGPL" ==> "Nethack General Public License"
161 , "NGPL" ==> "Nethack General Public License"
155 , "Nokia" ==> "Nokia Open Source License"
162 , "Nokia" ==> "Nokia Open Source License"
156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"
157 , "NTP" ==> "NTP License"
164 , "NTP" ==> "NTP License"
158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
165 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"
159− , "OFL-1.1" ==> "SIL Open Font License 1.1"
160 , "OGTSL" ==> "Open Group Test Suite License"
166 , "OGTSL" ==> "Open Group Test Suite License"
161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
162 , "OSL-1.0" ==> "Open Software License 1.0"
167 , "OSL-1.0" ==> "Open Software License 1.0"
163 , "OSL-2.0" ==> "Open Software License 2.0"
168 , "OSL-2.0" ==> "Open Software License 2.0"
164 , "OSL-2.1" ==> "Open Software License 2.1"
169 , "OSL-2.1" ==> "Open Software License 2.1"
165 , "OSL-3.0" ==> "Open Software License 3.0"
170 , "OSL-3.0" ==> "Open Software License 3.0"
171+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"
166 , "PHP-3.0" ==> "PHP License v3.0"
172 , "PHP-3.0" ==> "PHP License v3.0"
167 , "PostgreSQL" ==> "PostgreSQL License"
173 , "PostgreSQL" ==> "PostgreSQL License"
168 , "Python-2.0" ==> "Python License 2.0"
174 , "Python-2.0" ==> "Python License 2.0"
169 , "QPL-1.0" ==> "Q Public License 1.0"
175 , "QPL-1.0" ==> "Q Public License 1.0"
176+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"
171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
178 , "RPL-1.5" ==> "Reciprocal Public License 1.5"
172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"
173 , "RSCPL" ==> "Ricoh Source Code Public License"
179 , "RSCPL" ==> "Ricoh Source Code Public License"
180+ , "OFL-1.1" ==> "SIL Open Font License 1.1"
174 , "SimPL-2.0" ==> "Simple Public License 2.0"
181 , "SimPL-2.0" ==> "Simple Public License 2.0"
175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"
176 , "Sleepycat" ==> "Sleepycat License"
182 , "Sleepycat" ==> "Sleepycat License"
183+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"
177 , "SPL-1.0" ==> "Sun Public License v1.0"
184 , "SPL-1.0" ==> "Sun Public License v1.0"
185+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
178 , "UPL-1.0" ==> "Universal Permissive License v1.0"
186 , "UPL-1.0" ==> "Universal Permissive License v1.0"
187+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"
179 , "VSL-1.0" ==> "Vovida Software License v1.0"
188 , "VSL-1.0" ==> "Vovida Software License v1.0"
180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
189 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"
181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"
182 , "Xnet" ==> "X.Net License"
190 , "Xnet" ==> "X.Net License"
183 , "Zlib" ==> "zlib License"
191 , "Zlib" ==> "zlib License"
184 , "ZPL-2.0" ==> "Zope Public License 2.0"
192 , "ZPL-2.0" ==> "Zope Public License 2.0"
185 ]
193 ]
194+
195+
196+
197+-- BINARY
198+
199+
200+instance Binary License where
201+ get = liftM2 License get get
202+ put (License a b) = put a >> put b
compiler/src/Elm/ModuleName.hs+46−72
@@ -1,19 +1,19 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}
1+{-# LANGUAGE OverloadedStrings #-}
2module Elm.ModuleName
2module Elm.ModuleName
3 ( Raw
3 ( Raw
4 , toChars
4 , toChars
5+ , toString
5 , toFilePath
6 , toFilePath
6 , toHyphenPath
7 , toHyphenPath
7− --
8+ , fromHyphenPath
8 , encode
9 , encode
9 , decoder
10 , decoder
10− , parser
11− --
12 , Canonical(..)
11 , Canonical(..)
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
16+ , debug, bitwise
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,19 +23,15 @@ 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
26import qualified Data.Name as Name
27import qualified Data.Name as Name
27import qualified Data.Utf8 as Utf8
28import qualified Data.Utf8 as Utf8
28−import Data.Word (Word8)
29−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
30import Prelude hiding (maybe)
29import Prelude hiding (maybe)
31import qualified System.FilePath as FP
30import qualified System.FilePath as FP
32
31
33import qualified Elm.Package as Pkg
32import qualified Elm.Package as Pkg
34−import qualified Json.Decode as D
33+import qualified Json.Decode as Decode
35−import qualified Json.Encode as E
34+import qualified Json.Encode as Encode
36−import qualified Parse.Variable as Var
37−import qualified Parse.Primitives as P
38−import Parse.Primitives (Row, Col)
39
35
40
36
41
37
@@ -50,6 +46,11 @@ toChars =
50 Name.toChars
46 Name.toChars
51
47
52
48
49+toString :: Raw -> Utf8.String
50+toString =
51+ Name.toUtf8
52+
53+
53toFilePath :: Raw -> FilePath
54toFilePath :: Raw -> FilePath
54toFilePath name =
55toFilePath name =
55 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)
56 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)
@@ -60,68 +61,38 @@ toHyphenPath name =
60 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
61 map (\c -> if c == '.' then '-' else c) (Name.toChars name)
61
62
62
63
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+
63
75
64-- JSON
76-- JSON
65
77
66
78
67−encode :: Raw -> E.Value
79+encode :: Raw -> Encode.Value
68encode =
80encode =
69− E.name
81+ Encode.name
70
82
71
83
72−decoder :: D.Decoder (Row, Col) Raw
84+decoder :: Decode.Decoder Utf8.String Raw
73decoder =
85decoder =
74− D.customString parser (,)
86+ do str <- Decode.string
87+ if all isGoodChunk (Utf8.split 0x2E {- . -} str)
88+ then return (Name.fromUtf8 str)
89+ else Decode.failure str
75
90
76
91
77−
92+isGoodChunk :: Utf8.String -> Bool
78−-- PARSER
93+isGoodChunk chunk =
79−
94+ Utf8.startsWithChar Char.isUpper chunk
80−
95+ && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk
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)
125
96
126
97
127
98
@@ -133,6 +104,12 @@ data Canonical =
133 { _package :: !Pkg.Name
104 { _package :: !Pkg.Name
134 , _module :: !Name.Name
105 , _module :: !Name.Name
135 }
106 }
107+ deriving (Ord)
108+
109+
110+canonicalIsKernel :: Canonical -> Bool
111+canonicalIsKernel (Canonical _ name) =
112+ Name.isKernel name
136
113
137
114
138
115
@@ -144,14 +121,6 @@ instance Eq Canonical where
144 name1 == name2 && pkg1 == pkg2
121 name1 == name2 && pkg1 == pkg2
145
122
146
123
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−
155instance Binary Canonical where
124instance Binary Canonical where
156 put (Canonical a b) = put a >> put b
125 put (Canonical a b) = put a >> put b
157 get = liftM2 Canonical get get
126 get = liftM2 Canonical get get
@@ -226,6 +195,11 @@ debug :: Canonical
226debug = Canonical Pkg.core Name.debug
195debug = Canonical Pkg.core Name.debug
227
196
228
197
198+{-# NOINLINE bitwise #-}
199+bitwise :: Canonical
200+bitwise = Canonical Pkg.core Name.bitwise
201+
202+
229
203
230-- HTML
204-- HTML
231
205
compiler/src/Elm/Package.hs+89−220
@@ -1,52 +1,38 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}
2+{-# LANGUAGE OverloadedStrings #-}
3module Elm.Package
3module Elm.Package
4 ( Name(..)
4 ( Name(..)
5− , Author
6− , Project
7 , Canonical(..)
5 , Canonical(..)
8 , isKernel
6 , isKernel
7+ , toString
9 , toChars
8 , toChars
10 , toUrl
9 , toUrl
11 , toFilePath
10 , toFilePath
12− , toJsonString
11+ , BadName(..)
13− --
12+ , fromString
14 , dummyName, kernel, core
13 , dummyName, kernel, core
15 , browser, virtualDom, html
14 , browser, virtualDom, html
16 , json, http, url
15 , json, http, url
17 , webgl, linearAlgebra
16 , webgl, linearAlgebra
18− --
19 , suggestions
17 , suggestions
20− , nearbyNames
21− --
22 , decoder
18 , decoder
23 , encode
19 , encode
24− , keyDecoder
25− --
26− , parser
27 )
20 )
28 where
21 where
29
22
30
23
31import Control.Monad (liftM2)
24import Control.Monad (liftM2)
32import Data.Binary (Binary, get, put)
25import Data.Binary (Binary, get, put)
33−import qualified Data.Coerce as Coerce
26+import qualified Data.Char as Char
34−import qualified Data.List as List
35−import qualified Data.Map as Map
36import qualified Data.Name as Name
27import qualified Data.Name as Name
28+import qualified Data.Map as Map
37import Data.Monoid ((<>))
29import Data.Monoid ((<>))
38import qualified Data.Utf8 as Utf8
30import qualified Data.Utf8 as Utf8
39−import Data.Word (Word8)
40−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
41import System.FilePath ((</>))
31import System.FilePath ((</>))
42
32
43import qualified Elm.Version as V
33import qualified Elm.Version as V
44−import qualified Json.Decode as D
34+import qualified Json.Decode as Decode
45−import qualified Json.Encode as E
35+import qualified Json.Encode as Encode
46−import qualified Json.String as Json
47−import qualified Parse.Primitives as P
48−import Parse.Primitives (Row, Col)
49−import qualified Reporting.Suggest as Suggest
50
36
51
37
52
38
@@ -55,17 +41,10 @@ import qualified Reporting.Suggest as Suggest
55
41
56data Name =
42data Name =
57 Name
43 Name
58− { _author :: !Author
44+ { _author :: !Name.Name
59− , _project :: !Project
45+ , _project :: !Name.Name
60 }
46 }
61− deriving (Ord)
47+ deriving (Eq, Ord)
62−
63−
64−type Author = Utf8.Utf8 AUTHOR
65−type Project = Utf8.Utf8 PROJECT
66−
67−data AUTHOR
68−data PROJECT
69
48
70
49
71data Canonical =
50data Canonical =
@@ -73,7 +52,7 @@ data Canonical =
73 { _name :: !Name
52 { _name :: !Name
74 , _version :: !V.Version
53 , _version :: !V.Version
75 }
54 }
76− deriving (Ord)
55+ deriving (Eq, Ord)
77
56
78
57
79
58
@@ -82,114 +61,127 @@ data Canonical =
82
61
83isKernel :: Name -> Bool
62isKernel :: Name -> Bool
84isKernel (Name author _) =
63isKernel (Name author _) =
85− author == elm || author == elm_explorations
64+ 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 ]
86
70
87
71
88toChars :: Name -> String
72toChars :: Name -> String
89toChars (Name author project) =
73toChars (Name author project) =
90− Utf8.toChars author <> "/" <> Utf8.toChars project
74+ Name.toChars author <> "/" <> Name.toChars project
91
75
92
76
93toUrl :: Name -> String
77toUrl :: Name -> String
94toUrl (Name author project) =
78toUrl (Name author project) =
95− Utf8.toChars author ++ "/" ++ Utf8.toChars project
79+ Name.toChars author ++ "/" ++ Name.toChars project
96
80
97
81
98toFilePath :: Name -> FilePath
82toFilePath :: Name -> FilePath
99toFilePath (Name author project) =
83toFilePath (Name author project) =
100− Utf8.toChars author </> Utf8.toChars project
84+ Name.toChars author </> Name.toChars project
101
85
102
86
103−toJsonString :: Name -> Json.String
87+fromString :: Utf8.String -> Either BadName Name
104−toJsonString (Name author project) =
88+fromString str =
89+ case Utf8.split 0x2F {- / -} str of
105− Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]
90+ [author, 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
106
101
102+ _ ->
103+ Left BadStructure
107
104
108
105
109−-- COMMON PACKAGE NAMES
106+data BadName
107+ = BadStructure
108+ | TooLong
109+ | HasDoubleDash
110+ | HasUnderscore
111+ | HasDot
112+ | HasUppercase
113+ | HasDashEnd
114+ | HasNonLowercaseStart
115+
110
116
111
117
112−toName :: Author -> [Char] -> Name
118+-- COMMON PACKAGE NAMES
113−toName author project =
114− Name author (Utf8.fromChars project)
115
119
116
120
117{-# NOINLINE dummyName #-}
121{-# NOINLINE dummyName #-}
118dummyName :: Name
122dummyName :: Name
119dummyName =
123dummyName =
120− toName (Utf8.fromChars "author") "project"
124+ Name "author" "project"
121
125
122
126
123{-# NOINLINE kernel #-}
127{-# NOINLINE kernel #-}
124kernel :: Name
128kernel :: Name
125kernel =
129kernel =
126− toName elm "kernel"
130+ Name "elm" "kernel"
127
131
128
132
129{-# NOINLINE core #-}
133{-# NOINLINE core #-}
130core :: Name
134core :: Name
131core =
135core =
132− toName elm "core"
136+ Name "elm" "core"
133
137
134
138
135{-# NOINLINE browser #-}
139{-# NOINLINE browser #-}
136browser :: Name
140browser :: Name
137browser =
141browser =
138− toName elm "browser"
142+ Name "elm" "browser"
139
143
140
144
141{-# NOINLINE virtualDom #-}
145{-# NOINLINE virtualDom #-}
142virtualDom :: Name
146virtualDom :: Name
143virtualDom =
147virtualDom =
144− toName elm "virtual-dom"
148+ Name "elm" "virtual-dom"
145
149
146
150
147{-# NOINLINE html #-}
151{-# NOINLINE html #-}
148html :: Name
152html :: Name
149html =
153html =
150− toName elm "html"
154+ Name "elm" "html"
151
155
152
156
153{-# NOINLINE json #-}
157{-# NOINLINE json #-}
154json :: Name
158json :: Name
155json =
159json =
156− toName elm "json"
160+ Name "elm" "json"
157
161
158
162
159{-# NOINLINE http #-}
163{-# NOINLINE http #-}
160http :: Name
164http :: Name
161http =
165http =
162− toName elm "http"
166+ Name "elm" "http"
163
167
164
168
165{-# NOINLINE url #-}
169{-# NOINLINE url #-}
166url :: Name
170url :: Name
167url =
171url =
168− toName elm "url"
172+ Name "elm" "url"
169
173
170
174
171{-# NOINLINE webgl #-}
175{-# NOINLINE webgl #-}
172webgl :: Name
176webgl :: Name
173webgl =
177webgl =
174− toName elm_explorations "webgl"
178+ Name "elm-explorations" "webgl"
175
179
176
180
177{-# NOINLINE linearAlgebra #-}
181{-# NOINLINE linearAlgebra #-}
178linearAlgebra :: Name
182linearAlgebra :: Name
179linearAlgebra =
183linearAlgebra =
180− toName elm_explorations "linear-algebra"
184+ Name "elm-explorations" "linear-algebra"
181−
182−
183−{-# NOINLINE elm #-}
184−elm :: Author
185−elm =
186− Utf8.fromChars "elm"
187−
188−
189−{-# NOINLINE elm_explorations #-}
190−elm_explorations :: Author
191−elm_explorations =
192− Utf8.fromChars "elm-explorations"
193
185
194
186
195
187
@@ -198,177 +190,54 @@ elm_explorations =
198
190
199suggestions :: Map.Map Name.Name Name
191suggestions :: Map.Map Name.Name Name
200suggestions =
192suggestions =
201− let
202− random = toName elm "random"
203− time = toName elm "time"
204− file = toName elm "file"
205− in
206 Map.fromList
193 Map.fromList
207− [ "Browser" ==> browser
194+ [ ("Browser", browser)
208− , "File" ==> file
209− , "File.Download" ==> file
210− , "File.Select" ==> file
211− , "Html" ==> html
195+ , ("Html", html)
212− , "Html.Attributes" ==> html
213− , "Html.Events" ==> html
214− , "Http" ==> http
196+ , ("Http", http)
215− , "Json.Decode" ==> json
197+ , ("Json.Decode", json)
216− , "Json.Encode" ==> json
198+ , ("Json.Encode", json)
217− , "Random" ==> random
218− , "Time" ==> time
219− , "Url.Parser" ==> url
199+ , ("Url.Parser", url)
220− , "Url" ==> url
200+ , ("Url", url)
221 ]
201 ]
222
202
223
203
224−(==>) :: [Char] -> Name -> (Name.Name, Name)
225−(==>) moduleName package =
226− ( Utf8.fromChars moduleName, package )
227−
228−
229−
230−-- NEARBY NAMES
231−
232−
233−nearbyNames :: Name -> [Name] -> [Name]
234−nearbyNames (Name author1 project1) possibleNames =
235− let
236− authorDist = authorDistance (Utf8.toChars author1)
237− projectDist = projectDistance (Utf8.toChars project1)
238−
239− nameDistance (Name author2 project2) =
240− authorDist author2 + projectDist project2
241− in
242− take 4 $ List.sortOn nameDistance possibleNames
243−
244−
245−authorDistance :: [Char] -> Author -> Int
246−authorDistance given possibility =
247− if possibility == elm || possibility == elm_explorations
248− then 0
249− else abs (Suggest.distance given (Utf8.toChars possibility))
250−
251−
252−projectDistance :: [Char] -> Project -> Int
253−projectDistance given possibility =
254− abs (Suggest.distance given (Utf8.toChars possibility))
255−
256−
257−
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
204
272-- BINARY
205-- BINARY
273
206
274
207
275−instance Binary Name where -- PERF try storing as a Word16
208+instance Binary Name where
276− get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256
209+ get =
277− put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b
210+ liftM2 Name get get
211+
212+ put (Name author project) =
213+ do put author
214+ put project
278
215
279
216
280instance Binary Canonical where
217instance Binary Canonical where
218+ get =
281− get = liftM2 Canonical get get
219+ liftM2 Canonical get get
220+
282− put (Canonical a b) = put a >> put b
221+ put (Canonical name version) =
222+ do put name
223+ put version
283
224
284
225
285
226
286-- JSON
227-- JSON
287
228
288
229
289−decoder :: D.Decoder (Row, Col) Name
230+decoder :: Decode.Decoder BadName Name
290decoder =
231decoder =
291− D.customString parser (,)
232+ do str <- Decode.string
233+ case fromString str of
234+ Right name ->
235+ return name
236+
237+ Left err ->
238+ Decode.failure err
292
239
293
240
294−encode :: Name -> E.Value
241+encode :: Name -> Encode.Value
295encode name =
242encode name =
296− E.chars (toChars name)
243+ Encode.string (toString name)
297−
298−
299−keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name
300−keyDecoder toError =
301− let
302− keyParser =
303− P.specialize (\(r,c) _ _ -> toError r c) parser
304− in
305− D.KeyDecoder keyParser toError
306−
307−
308−
309−-- PARSER
310−
311−
312−parser :: P.Parser (Row, Col) Name
313−parser =
314− do author <- parseName isAlphaOrDigit isAlphaOrDigit
315− P.word1 0x2F {-/-} (,)
316− project <- parseName isLower isLowerOrDigit
317− return (Name author project)
318−
319−
320−parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)
321−parseName isGoodStart isGoodInner =
322− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
323− if pos >= end then
324− eerr row col (,)
325− else
326− let !word = P.unsafeIndex pos in
327− if not (isGoodStart word) then
328− eerr row col (,)
329− else
330− let
331− (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False
332− !len = fromIntegral (minusPtr newPos pos)
333− !newCol = col + len
334− in
335− if isGood && len < 256 then
336− let !newState = P.State src newPos end indent row newCol in
337− cok (Utf8.fromPtr pos newPos) newState
338− else
339− cerr row newCol (,)
340−
341−
342−isLower :: Word8 -> Bool
343−isLower word =
344− 0x61 {-a-} <= word && word <= 0x7A {-z-}
345−
346−
347−isLowerOrDigit :: Word8 -> Bool
348−isLowerOrDigit word =
349− 0x61 {-a-} <= word && word <= 0x7A {-z-}
350− || 0x30 {-0-} <= word && word <= 0x39 {-9-}
351−
352−
353−isAlphaOrDigit :: Word8 -> Bool
354−isAlphaOrDigit word =
355− 0x61 {-a-} <= word && word <= 0x7A {-z-}
356− || 0x41 {-A-} <= word && word <= 0x5A {-Z-}
357− || 0x30 {-0-} <= word && word <= 0x39 {-9-}
358−
359−
360−chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)
361−chompName isGoodChar pos end prevWasDash =
362− if pos >= end then
363− (# not prevWasDash, pos #)
364− else
365− let !word = P.unsafeIndex pos in
366− if isGoodChar word then
367− chompName isGoodChar (plusPtr pos 1) end False
368− else if word == 0x2D {---} then
369− if prevWasDash then
370− (# False, pos #)
371− else
372− chompName isGoodChar (plusPtr pos 1) end True
373− else
374− (# True, pos #)
compiler/src/Elm/String.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}
3−module Elm.String
4− ( String
5− , toChars
6− , toBuilder
7− , Chunk(..)
8− , fromChunks
9− )
10− where
11−
12−
13−import Prelude hiding (String)
14−import Data.Binary (Binary, get, put)
15−import Data.Bits ((.&.), shiftR)
16−import qualified Data.ByteString.Builder as B
17−import qualified Data.Utf8 as Utf8
18−import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
19−import GHC.Exts (RealWorld, Ptr)
20−import GHC.IO (stToIO, unsafeDupablePerformIO)
21−import GHC.ST (ST)
22−import GHC.Word (Word8)
23−
24−
25−
26−-- STRINGS
27−
28−
29−type String =
30− Utf8.Utf8 ELM_STRING
31−
32−
33−data ELM_STRING
34−
35−
36−
37−-- HELPERS
38−
39−
40−toChars :: String -> [Char]
41−toChars =
42− Utf8.toChars
43−
44−
45−{-# INLINE toBuilder #-}
46−toBuilder :: String -> B.Builder
47−toBuilder =
48− Utf8.toBuilder
49−
50−
51−
52−-- FROM CHUNKS
53−
54−
55−data Chunk
56− = Slice (Ptr Word8) Int
57− | Escape Word8
58− | CodePoint Int
59−
60−
61−fromChunks :: [Chunk] -> String
62−fromChunks chunks =
63− unsafeDupablePerformIO (stToIO (
64− do let !len = sum (map chunkToWidth chunks)
65− mba <- newByteArray len
66− writeChunks mba 0 chunks
67− freeze mba
68− ))
69−
70−
71−chunkToWidth :: Chunk -> Int
72−chunkToWidth chunk =
73− case chunk of
74− Slice _ len -> len
75− Escape _ -> 2
76− CodePoint c -> if c < 0xFFFF then 6 else 12
77−
78−
79−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
80−writeChunks mba offset chunks =
81− case chunks of
82− [] ->
83− return ()
84−
85− chunk : chunks ->
86− case chunk of
87− Slice ptr len ->
88− do copyFromPtr ptr mba offset len
89− let !newOffset = offset + len
90− writeChunks mba newOffset chunks
91−
92− Escape word ->
93− do writeWord8 mba offset 0x5C {- \ -}
94− writeWord8 mba (offset + 1) word
95− let !newOffset = offset + 2
96− writeChunks mba newOffset chunks
97−
98− CodePoint code ->
99− if code < 0xFFFF then
100− do writeCode mba offset code
101− let !newOffset = offset + 6
102− writeChunks mba newOffset chunks
103− else
104− do let (hi,lo) = divMod (code - 0x10000) 0x400
105− writeCode mba (offset ) (hi + 0xD800)
106− writeCode mba (offset + 6) (lo + 0xDC00)
107− let !newOffset = offset + 12
108− writeChunks mba newOffset chunks
109−
110−
111−writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
112−writeCode mba offset code =
113− do writeWord8 mba offset 0x5C {- \ -}
114− writeWord8 mba (offset + 1) 0x75 {- u -}
115− writeHex mba (offset + 2) (shiftR code 12)
116− writeHex mba (offset + 3) (shiftR code 8)
117− writeHex mba (offset + 4) (shiftR code 4)
118− writeHex mba (offset + 5) code
119−
120−
121−writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()
122−writeHex mba !offset !bits =
123− do let !n = fromIntegral bits .&. 0x0F
124− writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)
125−
126−
127−
128−-- BINARY
129−
130−
131−instance Binary (Utf8.Utf8 ELM_STRING) where
132− get = Utf8.getVeryLong
133− put = Utf8.putVeryLong
compiler/src/Elm/Version.hs+50−79
@@ -1,5 +1,3 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE BangPatterns, UnboxedTuples #-}
3module Elm.Version
1module Elm.Version
4 ( Version(..)
2 ( Version(..)
5 , one
3 , one
@@ -9,27 +7,24 @@ module Elm.Version
9 , bumpMinor
7 , bumpMinor
10 , bumpMajor
8 , bumpMajor
11 , toChars
9 , toChars
12− --
10+ , toString
11+ , fromString
13 , decoder
12 , decoder
14 , encode
13 , encode
15− --
16− , parser
17 )
14 )
18 where
15 where
19
16
20
17
21import Prelude hiding (max)
18import Prelude hiding (max)
22−import Control.Monad (liftM3)
19+import Control.Monad (liftM, liftM3)
23import Data.Binary (Binary, get, put, getWord8, putWord8)
20import Data.Binary (Binary, get, put, getWord8, putWord8)
21+import qualified Data.Utf8 as Utf8
24import qualified Data.Version as Version
22import qualified Data.Version as Version
25−import Data.Word (Word8, Word16)
23+import Data.Word (Word16)
26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27import qualified Paths_elm
24import qualified Paths_elm
28
25
29import qualified Json.Decode as D
26import qualified Json.Decode as D
30import qualified Json.Encode as E
27import qualified Json.Encode as E
31−import qualified Parse.Primitives as P
32−import Parse.Primitives (Row, Col)
33
28
34
29
35
30
@@ -91,26 +86,58 @@ bumpMajor (Version major _minor _patch) =
91
86
92
87
93
88
94−-- TO CHARS
89+-- TO STRING
95
90
96
91
97−toChars :: Version -> [Char]
92+toChars :: Version -> String
93+toChars vsn =
94+ Utf8.toChars (toString vsn)
95+
96+
97+toString :: Version -> Utf8.String
98−toChars (Version major minor patch) =
98+toString (Version major minor patch) =
99− show major ++ '.' : show minor ++ '.' : show patch
99+ Utf8.join 0x2E {- . -}
100+ [ Utf8.fromWord16 major
101+ , Utf8.fromWord16 minor
102+ , Utf8.fromWord16 patch
103+ ]
104+
105+
106+
107+-- FROM STRING
108+
109+
110+fromString :: Utf8.String -> Maybe Version
111+fromString str =
112+ case Utf8.split 0x2E {- . -} str of
113+ [major, minor, patch] ->
114+ Version
115+ <$> Utf8.toWord16 major
116+ <*> Utf8.toWord16 minor
117+ <*> Utf8.toWord16 patch
118+
119+ _ ->
120+ Nothing
100
121
101
122
102
123
103-- JSON
124-- JSON
104
125
105
126
106−decoder :: D.Decoder (Row, Col) Version
127+decoder :: D.Decoder Utf8.String Version
107decoder =
128decoder =
108− D.customString parser (,)
129+ do str <- D.string
130+ case fromString str of
131+ Just version ->
132+ return version
133+
134+ Nothing ->
135+ D.failure str
109
136
110
137
111encode :: Version -> E.Value
138encode :: Version -> E.Value
112encode version =
139encode version =
113− E.chars (toChars version)
140+ E.string (toString version)
114
141
115
142
116
143
@@ -120,77 +147,21 @@ encode version =
120instance Binary Version where
147instance Binary Version where
121 get =
148 get =
122 do word <- getWord8
149 do word <- getWord8
123− if word == 255
150+ if word == 0
124 then liftM3 Version get get get
151 then liftM3 Version get get get
125 else
152 else
126− do minor <- getWord8
153+ do minor <- liftM fromIntegral getWord8
127− patch <- getWord8
154+ patch <- liftM fromIntegral getWord8
128− return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch))
155+ return (Version (fromIntegral word) minor patch)
129
156
130 put (Version major minor patch) =
157 put (Version major minor patch) =
131− if major < 255 && minor < 256 && patch < 256 then
158+ if major < 256 && minor < 256 && patch < 256 then
132 do putWord8 (fromIntegral major)
159 do putWord8 (fromIntegral major)
133 putWord8 (fromIntegral minor)
160 putWord8 (fromIntegral minor)
134 putWord8 (fromIntegral patch)
161 putWord8 (fromIntegral patch)
135 else
162 else
136− do putWord8 255
163+ do putWord8 0
137 put major
164 put major
138 put minor
165 put minor
139 put patch
166 put patch
140
167
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+4−17
@@ -24,31 +24,18 @@ 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>
28</head>
27</head>
29
28
30<body>
29<body>
31−
30+<div id="elm-df98db9626"></div>
32−<pre id="elm"></pre>
33−
34<script>
31<script>
35−try {
36|] <> javascript <> [r|
32|] <> javascript <> [r|
37
33
38− var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });
34+var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm-df98db9626") });
39−}
35+if (document.getElementById("elm-df98db9626"))
40−catch (e)
41{
36{
42− // display initialization errors (e.g. bad flags, infinite recursion)
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.';
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;
50}
38}
51</script>
39</script>
52−
53</body>
40</body>
54</html>|]
41</html>|]
compiler/src/Generate/JavaScript.hs+87−97
@@ -1,8 +1,8 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module Generate.JavaScript
2module Generate.JavaScript
3+ ( Output(..)
3− ( generate
4+ , generate
4 , generateForRepl
5 , 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
23import qualified Elm.Kernel as K
24import qualified Elm.Kernel as K
24import qualified Elm.ModuleName as ModuleName
25import qualified Elm.ModuleName as ModuleName
25import qualified Generate.JavaScript.Builder as JS
26import qualified Generate.JavaScript.Builder as JS
26import qualified Generate.JavaScript.Expression as Expr
27import 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,27 +33,33 @@ import qualified Reporting.Render.Type.Localizer as L
33
33
34
34
35
35
36−-- GENERATE
36+-- GENERATE MAINS
37
37
38
38
39−type Graph = Map.Map Opt.Global Opt.Node
39+data Output
40−type Mains = Map.Map ModuleName.Canonical Opt.Main
40+ = None
41+ | Some Name.Name [Name.Name] B.Builder
41
42
42
43
43−generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder
44+generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output
44−generate mode (Opt.GlobalGraph graph _) mains =
45+generate mode (Opt.Graph mains graph _) roots =
45 let
46 let
46− state = Map.foldrWithKey (addMain mode graph) emptyState mains
47+ rootSet = Set.fromList roots
48+ rootMap = Map.restrictKeys mains rootSet
47 in
49 in
48− "(function(scope){\n'use strict';"
50+ case map ModuleName._module (Map.keys rootMap) of
49− <> Functions.functions
51+ [] ->
50− <> perfNote mode
52+ None
53+
54+ name:names ->
55+ let
56+ state = Map.foldrWithKey (addMain mode graph) emptyState rootMap
51− <> stateToBuilder state
57+ builder = perfNote mode <> stateToBuilder state <> toMainExports mode rootMap
52− <> toMainExports mode mains
58+ in
53− <> "}(this));"
59+ Some name names builder
54
60
55
61
56−addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
62+addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State
57addMain mode graph home _ state =
63addMain mode graph home _ state =
58 addGlobal mode graph state (Opt.Global home "main")
64 addGlobal mode graph state (Opt.Global home "main")
59
65
@@ -79,68 +85,34 @@ perfNote mode =
79-- GENERATE FOR REPL
85-- GENERATE FOR REPL
80
86
81
87
82−generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
88+generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder
83−generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =
89+generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =
84 let
90 let
85 mode = Mode.Dev Nothing
91 mode = Mode.Dev Nothing
86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
92 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
87 evalState = addGlobal mode graph debugState (Opt.Global home name)
93 evalState = addGlobal mode graph debugState (Opt.Global home name)
88 in
94 in
89− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"
90− <> Functions.functions
91− <> stateToBuilder evalState
95+ stateToBuilder evalState
96+ <>
92− <> print ansi localizer home name tipe
97+ print ansi localizer home name (I._values iface ! name)
93
98
94
99
95−print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder
100+print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder
96−print ansi localizer home name tipe =
101+print ansi localizer home name (Can.Forall _ tipe) =
97 let
102 let
98 value = JsName.toBuilder (JsName.fromGlobal home name)
103 value = JsName.toBuilder (JsName.fromGlobal home name)
99 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
104 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
100 tipeDoc = RT.canToDoc localizer RT.None tipe
105 tipeDoc = RT.canToDoc localizer RT.None tipe
101 bool = if ansi then "true" else "false"
106 bool = if ansi then "true" else "false"
102 in
107 in
103− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
108+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\
104− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
109+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\
105− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
110+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\
106− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
111+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\
107− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
112+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\
108− \} else {\n\
113+ \} else {\n\
109− \ _print(' : ' + _type);\n\
114+ \ _print(' : ' + _type);\n\
110− \}\n"
111−
112−
113−
114−-- GENERATE FOR REPL ENDPOINT
115−
116−
117−generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
118−generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
119− let
120− name = maybe Name.replValueToPrint id maybeName
121− mode = Mode.Dev Nothing
122− debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
123− evalState = addGlobal mode graph debugState (Opt.Global home name)
124− in
125− Functions.functions
126− <> stateToBuilder evalState
127− <> postMessage localizer home maybeName tipe
128−
129−
130−postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
131−postMessage localizer home maybeName tipe =
132− let
133− name = maybe Name.replValueToPrint id maybeName
134− value = JsName.toBuilder (JsName.fromGlobal home name)
135− toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
136− tipeDoc = RT.canToDoc localizer RT.None tipe
137− toName n = "\"" <> Name.toBuilder n <> "\""
138− in
139− "self.postMessage({\n\
140− \ name: " <> maybe "null" toName maybeName <> ",\n\
141− \ value: " <> toString <> "(true, " <> value <> "),\n\
142− \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\
143− \});\n"
115+ \}\n"
144
116
145
117
146
118
@@ -174,6 +146,9 @@ prependBuilders revBuilders monolith =
174-- ADD DEPENDENCIES
146-- ADD DEPENDENCIES
175
147
176
148
149+type Graph = Map.Map Opt.Global Opt.Node
150+
151+
177addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
152addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State
178addGlobal mode graph state@(State revKernels builders seen) global =
153addGlobal mode graph state@(State revKernels builders seen) global =
179 if Set.member global seen then
154 if Set.member global seen then
@@ -261,7 +236,7 @@ addKernel (State revKernels revBuilders seen) kernel =
261
236
262var :: Opt.Global -> Expr.Code -> JS.Stmt
237var :: Opt.Global -> Expr.Code -> JS.Stmt
263var (Opt.Global home name) code =
238var (Opt.Global home name) code =
264− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)
239+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]
265
240
266
241
267isDebugger :: Opt.Global -> Bool
242isDebugger :: Opt.Global -> Bool
@@ -292,7 +267,7 @@ generateCycle mode (Opt.Global home _) names values functions =
292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
267 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
293 <> drawCycle names
268 <> drawCycle names
294 <> "\\n\\nThese errors are very tricky, so read "
269 <> "\\n\\nThese errors are very tricky, so read "
295− <> B.stringUtf8 (D.makeNakedLink "bad-recursion")
270+ <> B.stringUtf8 (D.makeNakedLink "halting-problem")
296 <> " to learn how to fix it!"
271 <> " to learn how to fix it!"
297 ]
272 ]
298
273
@@ -301,10 +276,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt
301generateCycleFunc mode home def =
276generateCycleFunc mode home def =
302 case def of
277 case def of
303 Opt.Def name expr ->
278 Opt.Def name expr ->
304− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))
279+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]
305
280
306 Opt.TailDef name args expr ->
281 Opt.TailDef name args expr ->
307− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))
282+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]
308
283
309
284
310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
285generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt
@@ -320,9 +295,9 @@ generateRealCycle home (name, _) =
320 realName = JsName.fromGlobal home name
295 realName = JsName.fromGlobal home name
321 in
296 in
322 JS.Block
297 JS.Block
323− [ JS.Var realName (JS.Call (JS.Ref safeName) [])
298+ [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]
324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
299 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $
325− JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]
300+ JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]
326 ]
301 ]
327
302
328
303
@@ -350,7 +325,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder
350addChunk mode chunk builder =
325addChunk mode chunk builder =
351 case chunk of
326 case chunk of
352 K.JS javascript ->
327 K.JS javascript ->
353− B.byteString javascript <> builder
328+ Utf8.toBuilder javascript <> builder
354
329
355 K.ElmVar home name ->
330 K.ElmVar home name ->
356 JsName.toBuilder (JsName.fromGlobal home name) <> builder
331 JsName.toBuilder (JsName.fromGlobal home name) <> builder
@@ -390,13 +365,16 @@ addChunk mode chunk builder =
390
365
391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
366generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt
392generateEnum mode global@(Opt.Global home name) index =
367generateEnum mode global@(Opt.Global home name) index =
393− JS.Var (JsName.fromGlobal home name) $
368+ let
369+ definition =
394− case mode of
370+ case mode of
395− Mode.Dev _ ->
371+ Mode.Dev _ ->
396− Expr.codeToExpr (Expr.generateCtor mode global index 0)
372+ Expr.codeToExpr (Expr.generateCtor mode global index 0)
397
373
398− Mode.Prod _ ->
374+ Mode.Prod _ ->
399− JS.Int (Index.toMachine index)
375+ JS.Int (Index.toMachine index)
376+ in
377+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
400
378
401
379
402
380
@@ -405,13 +383,16 @@ generateEnum mode global@(Opt.Global home name) index =
405
383
406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
384generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt
407generateBox mode global@(Opt.Global home name) =
385generateBox mode global@(Opt.Global home name) =
408− JS.Var (JsName.fromGlobal home name) $
386+ let
387+ definition =
409− case mode of
388+ case mode of
410− Mode.Dev _ ->
389+ Mode.Dev _ ->
411− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
390+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)
412
391
413− Mode.Prod _ ->
392+ Mode.Prod _ ->
414− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
393+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)
394+ in
395+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
415
396
416
397
417{-# NOINLINE identity #-}
398{-# NOINLINE identity #-}
@@ -426,11 +407,14 @@ identity =
426
407
427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
408generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt
428generatePort mode (Opt.Global home name) makePort converter =
409generatePort mode (Opt.Global home name) makePort converter =
429− JS.Var (JsName.fromGlobal home name) $
410+ let
411+ definition =
430− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
412+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))
431− [ JS.String (Name.toBuilder name)
413+ [ JS.String (Name.toBuilder name)
432− , Expr.codeToExpr (Expr.generate mode converter)
414+ , Expr.codeToExpr (Expr.generate mode converter)
433− ]
415+ ]
416+ in
417+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
434
418
435
419
436
420
@@ -458,9 +442,11 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)
458
442
459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
443generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt
460generateLeaf home@(ModuleName.Canonical _ moduleName) name =
444generateLeaf home@(ModuleName.Canonical _ moduleName) name =
461− JS.Var (JsName.fromGlobal home name) $
445+ let
446+ definition =
462− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
447+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]
463−
448+ in
449+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]
464
450
465
451
466{-# NOINLINE leaf #-}
452{-# NOINLINE leaf #-}
@@ -501,7 +487,7 @@ generateManagerHelp home effectsType =
501-- MAIN EXPORTS
487-- MAIN EXPORTS
502
488
503
489
504−toMainExports :: Mode.Mode -> Mains -> B.Builder
490+toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder
505toMainExports mode mains =
491toMainExports mode mains =
506 let
492 let
507 export = JsName.fromKernel Name.platform "export"
493 export = JsName.fromKernel Name.platform "export"
@@ -534,7 +520,7 @@ generateExports mode (Trie maybeMain subs) =
534 <> List.foldl' (addSubTrie mode) "}" otherSubTries
520 <> List.foldl' (addSubTrie mode) "}" otherSubTries
535
521
536
522
537−addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder
523+addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder
538addSubTrie mode end (name, trie) =
524addSubTrie mode end (name, trie) =
539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
525 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end
540
526
@@ -546,7 +532,7 @@ addSubTrie mode end (name, trie) =
546data Trie =
532data Trie =
547 Trie
533 Trie
548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
534 { _main :: Maybe (ModuleName.Canonical, Opt.Main)
549− , _subs :: Map.Map Name.Name Trie
535+ , _subs :: Map.Map Utf8.String Trie
550 }
536 }
551
537
552
538
@@ -557,10 +543,14 @@ emptyTrie =
557
543
558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
544addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie
559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
545addToTrie home@(ModuleName.Canonical _ moduleName) main trie =
546+ let
547+ segments =
548+ Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)
549+ in
560− merge trie $ segmentsToTrie home (Name.splitDots moduleName) main
550+ merge trie $ segmentsToTrie home segments main
561
551
562
552
563−segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie
553+segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie
564segmentsToTrie home segments main =
554segmentsToTrie home segments main =
565 case segments of
555 case segments of
566 [] ->
556 [] ->
compiler/src/Generate/JavaScript/Builder.hs+217−207
@@ -16,7 +16,6 @@ module Generate.JavaScript.Builder
16
16
17import Prelude hiding (lines)
17import Prelude hiding (lines)
18import qualified Data.List as List
18import qualified Data.List as List
19−import qualified Data.ByteString as BS
20import Data.ByteString.Builder as B
19import Data.ByteString.Builder as B
21import Data.Monoid ((<>))
20import Data.Monoid ((<>))
22import qualified Generate.JavaScript.Name as Name
21import qualified Generate.JavaScript.Name as Name
@@ -28,19 +27,6 @@ import qualified Json.Encode as Json
28-- EXPRESSIONS
27-- EXPRESSIONS
29
28
30
29
31−-- NOTE: I tried making this create a B.Builder directly.
32−--
33−-- The hope was that it'd allocate less and speed things up, but it seemed
34−-- to be neutral for perf.
35−--
36−-- The downside is that Generate.JavaScript.Expression inspects the
37−-- structure of Expr and Stmt on some occassions to try to strip out
38−-- unnecessary closures. I think these closures are already avoided
39−-- by other logic in code gen these days, but I am not 100% certain.
40−--
41−-- For this to be worth it, I think it would be necessary to avoid
42−-- returning tuples when generating expressions.
43−--
44data Expr
30data Expr
45 = String Builder
31 = String Builder
46 | Float Builder
32 | Float Builder
@@ -51,13 +37,13 @@ data Expr
51 | Array [Expr]
37 | Array [Expr]
52 | Object [(Name, Expr)]
38 | Object [(Name, Expr)]
53 | Ref Name
39 | Ref Name
54− | Access Expr Name -- foo.bar
40+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1
55− | Index Expr Expr -- foo[bar]
41+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1
56 | Prefix PrefixOp Expr
42 | Prefix PrefixOp Expr
57 | Infix InfixOp Expr Expr
43 | Infix InfixOp Expr Expr
58 | If Expr Expr Expr
44 | If Expr Expr Expr
59 | Assign LValue Expr
45 | Assign LValue Expr
60− | Call Expr [Expr]
46+ | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3
61 | Function (Maybe Name) [Name] [Stmt]
47 | Function (Maybe Name) [Name] [Stmt]
62
48
63
49
@@ -72,21 +58,20 @@ data LValue
72
58
73
59
74data Stmt
60data Stmt
75− = Block [Stmt]
61+ = Block [Stmt] -- {stmts}
76− | EmptyStmt
62+ | EmptyStmt -- ;
77− | ExprStmt Expr
63+ | ExprStmt Expr -- expr;
78− | IfStmt Expr Stmt Stmt
64+ | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2
79− | Switch Expr [Case]
65+ | Switch Expr [Case] -- switch (e) clauses
80− | While Expr Stmt
66+ | While Expr Stmt -- while (e) do stmt
81− | Break (Maybe Name)
67+ | Break (Maybe Name) -- break lab;
82− | Continue (Maybe Name)
68+ | Continue (Maybe Name) -- continue lab;
83− | Labelled Name Stmt
69+ | Labelled Name Stmt -- lab: stmt
84− | Try Stmt Name Stmt
70+ | Try Stmt Name Stmt -- try stmt catch (x) stmt
85− | Throw Expr
71+ | Throw Expr -- throw expr;
86− | Return Expr
72+ | Return (Maybe Expr) -- return expr;
87− | Var Name Expr
88− | Vars [(Name, Expr)]
73+ | Var [(Name, Maybe Expr)] -- var x, y=42;
89− | FunctionStmt Name [Name] [Stmt]
74+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}
90
75
91
76
92data Case
77data Case
@@ -99,31 +84,37 @@ data Case
99
84
100
85
101data InfixOp
86data InfixOp
102− = OpAdd -- +
87+ = OpLT -- <
103− | OpSub -- -
88+ | OpLEq -- <=
89+ | OpGT -- >
90+ | OpGEq -- >=
91+ | OpIn -- in
92+ | OpInstanceof -- instanceof
93+ | OpEq -- ==
94+ | OpNEq -- !=
95+ | OpStrictEq -- ===
96+ | OpStrictNEq -- !==
97+ | OpLAnd -- &&
98+ | OpLOr -- ||
104 | OpMul -- *
99 | OpMul -- *
105 | OpDiv -- /
100 | OpDiv -- /
106 | OpMod -- %
101 | OpMod -- %
107− | OpEq -- ===
102+ | OpSub -- -
108− | OpNe -- !==
109− | OpLt -- <
110− | OpLe -- <=
111− | OpGt -- >
112− | OpGe -- >=
113− | OpAnd -- &&
114− | OpOr -- ||
115− | OpBitwiseAnd -- &
116− | OpBitwiseXor -- ^
117− | OpBitwiseOr -- |
118− | OpLShift -- <<
103+ | OpLShift -- <<
119− | OpSpRShift -- >>
104+ | OpSpRShift -- >>
120− | OpZfRShift -- >>>
105+ | OpZfRShift -- >>>
106+ | OpBAnd -- &
107+ | OpBXor -- ^
108+ | OpBOr -- |
109+ | OpAdd -- +
121
110
122
111
123data PrefixOp
112data PrefixOp
124− = PrefixNot -- !
113+ = PrefixLNot -- !
125− | PrefixNegate -- -
114+ | PrefixBNot -- ~
126− | PrefixComplement -- ~
115+ | PrefixPlus -- +
116+ | PrefixMinus -- -
117+ | PrefixTypeof -- typeof
127
118
128
119
129
120
@@ -132,40 +123,21 @@ data PrefixOp
132
123
133stmtToBuilder :: Stmt -> Builder
124stmtToBuilder :: Stmt -> Builder
134stmtToBuilder stmts =
125stmtToBuilder stmts =
135− fromStmt levelZero stmts
126+ fromStmt "" stmts
136
127
137
128
138exprToBuilder :: Expr -> Builder
129exprToBuilder :: Expr -> Builder
139exprToBuilder expr =
130exprToBuilder expr =
140− snd $ fromExpr levelZero Whatever expr
131+ snd $ fromExpr "" Whatever expr
141−
142−
143−
144−-- INDENT LEVEL
145−
146−
147−data Level =
148− Level Builder Level
149−
150
132
151−levelZero :: Level
152−levelZero =
153− Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
154
133
155
134
156−makeLevel :: Int -> BS.ByteString -> Level
135+-- HELPERS
157−makeLevel level oldTabs =
158− let
159− tabs =
160− if level <= BS.length oldTabs
161− then oldTabs
162− else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
163− in
164− Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
165−
166
136
167
137
168−-- HELPERS
138+deeper :: Builder -> Builder
139+deeper indent =
140+ "\t" <> indent
169
141
170
142
171commaSep :: [Builder] -> Builder
143commaSep :: [Builder] -> Builder
@@ -173,52 +145,52 @@ commaSep builders =
173 mconcat (List.intersperse ", " builders)
145 mconcat (List.intersperse ", " builders)
174
146
175
147
176−commaNewlineSep :: Level -> [Builder] -> Builder
148+commaNewlineSep :: Builder -> [Builder] -> Builder
177−commaNewlineSep (Level _ (Level deeperIndent _)) builders =
149+commaNewlineSep indent builders =
178− mconcat (List.intersperse (",\n" <> deeperIndent) builders)
150+ mconcat (List.intersperse (",\n" <> deeper indent) builders)
179
151
180
152
181
153
182-- STATEMENTS
154-- STATEMENTS
183
155
184
156
185−fromStmtBlock :: Level -> [Stmt] -> Builder
157+fromStmtBlock :: Builder -> [Stmt] -> Builder
186−fromStmtBlock level stmts =
158+fromStmtBlock indent stmts =
187− mconcat (map (fromStmt level) stmts)
159+ mconcat (map (fromStmt indent) stmts)
188
160
189
161
190−fromStmt :: Level -> Stmt -> Builder
162+fromStmt :: Builder -> Stmt -> Builder
191−fromStmt level@(Level indent nextLevel) statement =
163+fromStmt indent statement =
192 case statement of
164 case statement of
193 Block stmts ->
165 Block stmts ->
194− fromStmtBlock level stmts
166+ fromStmtBlock indent stmts
195
167
196 EmptyStmt ->
168 EmptyStmt ->
197 mempty
169 mempty
198
170
199 ExprStmt expr ->
171 ExprStmt expr ->
200− indent <> snd (fromExpr level Whatever expr) <> ";\n"
172+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"
201
173
202 IfStmt condition thenStmt elseStmt ->
174 IfStmt condition thenStmt elseStmt ->
203 mconcat
175 mconcat
204− [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
176+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"
205− , fromStmt nextLevel thenStmt
177+ , fromStmt (deeper indent) thenStmt
206 , indent, "} else {\n"
178 , indent, "} else {\n"
207− , fromStmt nextLevel elseStmt
179+ , fromStmt (deeper indent) elseStmt
208 , indent, "}\n"
180 , indent, "}\n"
209 ]
181 ]
210
182
211 Switch expr clauses ->
183 Switch expr clauses ->
212 mconcat
184 mconcat
213− [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
185+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"
214− , mconcat (map (fromClause nextLevel) clauses)
186+ , mconcat (map (fromClause (deeper indent)) clauses)
215 , indent, "}\n"
187 , indent, "}\n"
216 ]
188 ]
217
189
218 While expr stmt ->
190 While expr stmt ->
219 mconcat
191 mconcat
220− [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
192+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"
221− , fromStmt nextLevel stmt
193+ , fromStmt (deeper indent) stmt
222 , indent, "}\n"
194 , indent, "}\n"
223 ]
195 ]
224
196
@@ -237,37 +209,37 @@ fromStmt level@(Level indent nextLevel) statement =
237 Labelled label stmt ->
209 Labelled label stmt ->
238 mconcat
210 mconcat
239 [ indent, Name.toBuilder label, ":\n"
211 [ indent, Name.toBuilder label, ":\n"
240− , fromStmt level stmt
212+ , fromStmt indent stmt
241 ]
213 ]
242
214
243 Try tryStmt errorName catchStmt ->
215 Try tryStmt errorName catchStmt ->
244 mconcat
216 mconcat
245 [ indent, "try {\n"
217 [ indent, "try {\n"
246− , fromStmt nextLevel tryStmt
218+ , fromStmt (deeper indent) tryStmt
247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"
248− , fromStmt nextLevel catchStmt
220+ , fromStmt (deeper indent) catchStmt
249 , indent, "}\n"
221 , indent, "}\n"
250 ]
222 ]
251
223
252 Throw expr ->
224 Throw expr ->
253− indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
225+ "throw " <> snd (fromExpr indent Whatever expr) <> ";"
254
226
255− Return expr ->
227+ Return Nothing ->
256− indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
228+ indent <> "return;\n"
257
229
258− Var name expr ->
230+ Return (Just expr) ->
259− indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
231+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"
260
232
261− Vars [] ->
233+ Var [] ->
262 mempty
234 mempty
263
235
264− Vars vars ->
236+ Var vars ->
265− indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
237+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"
266
238
267 FunctionStmt name args stmts ->
239 FunctionStmt name args stmts ->
268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
269 <>
241 <>
270− fromStmtBlock nextLevel stmts
242+ fromStmtBlock (deeper indent) stmts
271 <>
243 <>
272 indent <> "}\n"
244 indent <> "}\n"
273
245
@@ -276,25 +248,30 @@ fromStmt level@(Level indent nextLevel) statement =
276-- SWITCH CLAUSES
248-- SWITCH CLAUSES
277
249
278
250
279−fromClause :: Level -> Case -> Builder
251+fromClause :: Builder -> Case -> Builder
280−fromClause level@(Level indent nextLevel) clause =
252+fromClause indent clause =
281 case clause of
253 case clause of
282 Case expr stmts ->
254 Case expr stmts ->
283− indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
255+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"
284− <> fromStmtBlock nextLevel stmts
256+ <> fromStmtBlock (deeper indent) stmts
285
257
286 Default stmts ->
258 Default stmts ->
287 indent <> "default:\n"
259 indent <> "default:\n"
288− <> fromStmtBlock nextLevel stmts
260+ <> fromStmtBlock (deeper indent) stmts
289
261
290
262
291
263
292-- VAR DECLS
264-- VAR DECLS
293
265
294
266
295−varToBuilder :: Level -> (Name, Expr) -> Builder
267+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder
296−varToBuilder level (name, expr) =
268+varToBuilder indent (name, maybeExpr) =
269+ case maybeExpr of
270+ Nothing ->
271+ Name.toBuilder name
272+
273+ Just expr ->
297− Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
274+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)
298
275
299
276
300
277
@@ -312,11 +289,12 @@ merge a b =
312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
313linesMap func xs =
290linesMap func xs =
314 let
291 let
292+ pairs =
315− pairs = map func xs
293+ map func xs
316 in
294 in
317− ( any ((==) Many . fst) pairs
295+ ( any ((==) Many . fst) pairs
318− , map snd pairs
296+ , map snd pairs
319− )
297+ )
320
298
321
299
322data Grouping = Atomic | Whatever
300data Grouping = Atomic | Whatever
@@ -332,23 +310,23 @@ parensFor grouping builder =
332 builder
310 builder
333
311
334
312
335−fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
313+fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)
336−fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
314+fromExpr indent grouping expression =
337 case expression of
315 case expression of
338 String string ->
316 String string ->
339− ( One, "'" <> string <> "'" )
317+ (One, "'" <> string <> "'")
340
318
341 Float float ->
319 Float float ->
342− ( One, float )
320+ (One, float)
343
321
344 Int n ->
322 Int n ->
345− ( One, B.intDec n )
323+ (One, B.intDec n)
346
324
347 Bool bool ->
325 Bool bool ->
348− ( One, if bool then "true" else "false" )
326+ (One, if bool then "true" else "false")
349
327
350 Null ->
328 Null ->
351− ( One, "null" )
329+ (One, "null")
352
330
353 Json json ->
331 Json json ->
354 ( One, Json.encodeUgly json )
332 ( One, Json.encodeUgly json )
@@ -356,90 +334,111 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
356 Array exprs ->
334 Array exprs ->
357 (,) Many $
335 (,) Many $
358 let
336 let
337+ (anyMany, builders) =
359− (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
338+ linesMap (fromExpr indent Whatever) exprs
360 in
339 in
361− if anyMany then
340+ if anyMany then
362− "[\n"
341+ "[\n"
363− <> deeperIndent
342+ <> deeper indent
364− <> commaNewlineSep level builders
343+ <> commaNewlineSep indent builders
365− <> "\n" <> indent <> "]"
344+ <> "\n" <> indent <> "]"
345+
366− else
346+ else
367− "[" <> commaSep builders <> "]"
347+ "[" <> commaSep builders <> "]"
368
348
369 Object fields ->
349 Object fields ->
370 (,) Many $
350 (,) Many $
371 let
351 let
352+ deeperIndent =
353+ deeper indent
354+
355+ (anyMany, builders) =
372− (anyMany, builders) = linesMap (fromField nextLevel) fields
356+ linesMap (fromField deeperIndent) fields
373 in
357 in
374− if anyMany then
358+ if anyMany then
375− "{\n"
359+ "{\n"
376− <> deeperIndent
360+ <> deeperIndent
377− <> commaNewlineSep level builders
361+ <> commaNewlineSep indent builders
378− <> "\n" <> indent <> "}"
362+ <> "\n" <> indent <> "}"
363+
379− else
364+ else
380− "{" <> commaSep builders <> "}"
365+ "{" <> commaSep builders <> "}"
381
366
382 Ref name ->
367 Ref name ->
383− ( One, Name.toBuilder name )
368+ (One, Name.toBuilder name)
384
369
385 Access expr field ->
370 Access expr field ->
386− makeDot level expr field
371+ makeDot indent expr field
387
372
388 Index expr bracketedExpr ->
373 Index expr bracketedExpr ->
389− makeBracketed level expr bracketedExpr
374+ makeBracketed indent expr bracketedExpr
390
375
391 Prefix op expr ->
376 Prefix op expr ->
392 let
377 let
378+ (lines, builder) =
393− (lines, builder) = fromExpr level Atomic expr
379+ fromExpr indent Atomic expr
394 in
380 in
395− ( lines
381+ ( lines
396− , parensFor grouping (fromPrefix op <> builder)
382+ , parensFor grouping (fromPrefix op <> builder)
397− )
383+ )
398
384
399 Infix op leftExpr rightExpr ->
385 Infix op leftExpr rightExpr ->
400 let
386 let
387+ (leftLines, left) =
401− (leftLines , left ) = fromExpr level Atomic leftExpr
388+ fromExpr indent Atomic leftExpr
389+
390+ (rightLines, right) =
402− (rightLines, right) = fromExpr level Atomic rightExpr
391+ fromExpr indent Atomic rightExpr
403 in
392 in
404− ( merge leftLines rightLines
393+ ( merge leftLines rightLines
405− , parensFor grouping (left <> fromInfix op <> right)
394+ , parensFor grouping (left <> fromInfix op <> right)
406− )
395+ )
407
396
408 If condExpr thenExpr elseExpr ->
397 If condExpr thenExpr elseExpr ->
409 let
398 let
410− condB = snd (fromExpr level Atomic condExpr)
399+ condB = snd (fromExpr indent Atomic condExpr)
411− thenB = snd (fromExpr level Atomic thenExpr)
400+ thenB = snd (fromExpr indent Atomic thenExpr)
412− elseB = snd (fromExpr level Atomic elseExpr)
401+ elseB = snd (fromExpr indent Atomic elseExpr)
413 in
402 in
414− ( Many
403+ ( Many
415− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
404+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
416− )
405+ )
417
406
418 Assign lValue expr ->
407 Assign lValue expr ->
419 let
408 let
409+ (leftLines, left) =
420− (leftLines , left ) = fromLValue level lValue
410+ fromLValue indent lValue
411+
412+ (rightLines, right) =
421− (rightLines, right) = fromExpr level Whatever expr
413+ fromExpr indent Whatever expr
422 in
414 in
423− ( merge leftLines rightLines
415+ ( merge leftLines rightLines
424− , parensFor grouping (left <> " = " <> right)
416+ , parensFor grouping (left <> " = " <> right)
425− )
417+ )
426
418
427 Call function args ->
419 Call function args ->
428 (,) Many $
420 (,) Many $
429 let
421 let
422+ deeperIndent =
423+ deeper indent
424+
425+ funcB =
430− (_ , funcB) = fromExpr level Atomic function
426+ snd (fromExpr indent Atomic function)
427+
428+ (anyMany, argsB) =
431− (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
429+ linesMap (fromExpr deeperIndent Whatever) args
432 in
430 in
433− if anyMany then
431+ if anyMany then
434− funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
432+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"
433+
435− else
434+ else
436− funcB <> "(" <> commaSep argsB <> ")"
435+ funcB <> "(" <> commaSep argsB <> ")"
437
436
438 Function maybeName args stmts ->
437 Function maybeName args stmts ->
439 (,) Many $
438 (,) Many $
440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
441 <>
440 <>
442− fromStmtBlock nextLevel stmts
441+ fromStmtBlock (deeper indent) stmts
443 <>
442 <>
444 indent <> "}"
443 indent <> "}"
445
444
@@ -448,50 +447,55 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
448-- FIELDS
447-- FIELDS
449
448
450
449
451−fromField :: Level -> (Name, Expr) -> (Lines, Builder)
450+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)
452−fromField level (field, expr) =
451+fromField indent (field, expr) =
453 let
452 let
453+ (lines, builder) =
454− (lines, builder) = fromExpr level Whatever expr
454+ fromExpr indent Whatever expr
455 in
455 in
456− ( lines
456+ ( lines
457− , Name.toBuilder field <> ": " <> builder
457+ , Name.toBuilder field <> ": " <> builder
458− )
458+ )
459
459
460
460
461
461
462-- VALUES
462-- VALUES
463
463
464
464
465−fromLValue :: Level -> LValue -> (Lines, Builder)
465+fromLValue :: Builder -> LValue -> (Lines, Builder)
466−fromLValue level lValue =
466+fromLValue indent lValue =
467 case lValue of
467 case lValue of
468 LRef name ->
468 LRef name ->
469 (One, Name.toBuilder name)
469 (One, Name.toBuilder name)
470
470
471 LDot expr field ->
471 LDot expr field ->
472− makeDot level expr field
472+ makeDot indent expr field
473
473
474 LBracket expr bracketedExpr ->
474 LBracket expr bracketedExpr ->
475− makeBracketed level expr bracketedExpr
475+ makeBracketed indent expr bracketedExpr
476
476
477
477
478−makeDot :: Level -> Expr -> Name -> (Lines, Builder)
478+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)
479−makeDot level expr field =
479+makeDot indent expr field =
480 let
480 let
481+ (lines, builder) =
481− (lines, builder) = fromExpr level Atomic expr
482+ fromExpr indent Atomic expr
482 in
483 in
483− (lines, builder <> "." <> Name.toBuilder field)
484+ (lines, builder <> "." <> Name.toBuilder field)
484
485
485
486
486−makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
487+makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)
487−makeBracketed level expr bracketedExpr =
488+makeBracketed indent expr bracketedExpr =
488 let
489 let
490+ (lines, builder) =
489− (lines , builder ) = fromExpr level Atomic expr
491+ fromExpr indent Atomic expr
492+
490− (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
493+ (bracketedLines, bracketedBuilder) =
494+ fromExpr indent Whatever bracketedExpr
491 in
495 in
492− ( merge lines bracketedLines
496+ ( merge lines bracketedLines
493− , builder <> "[" <> bracketedBuilder <> "]"
497+ , builder <> "[" <> bracketedBuilder <> "]"
494− )
498+ )
495
499
496
500
497
501
@@ -501,30 +505,36 @@ makeBracketed level expr bracketedExpr =
501fromPrefix :: PrefixOp -> Builder
505fromPrefix :: PrefixOp -> Builder
502fromPrefix op =
506fromPrefix op =
503 case op of
507 case op of
504− PrefixNot -> "!"
508+ PrefixLNot -> "!"
505− PrefixNegate -> "-"
509+ PrefixBNot -> "~"
506− PrefixComplement -> "~"
510+ PrefixPlus -> "+"
511+ PrefixMinus -> "-"
512+ PrefixTypeof -> "typeof "
507
513
508
514
509fromInfix :: InfixOp -> Builder
515fromInfix :: InfixOp -> Builder
510fromInfix op =
516fromInfix op =
511 case op of
517 case op of
512− OpAdd -> " + "
518+ OpLT -> " < "
513− OpSub -> " - "
519+ OpLEq -> " <= "
520+ OpGT -> " > "
521+ OpGEq -> " >= "
522+ OpIn -> " in "
523+ OpInstanceof -> " instanceof "
524+ OpEq -> " == "
525+ OpNEq -> " != "
526+ OpStrictEq -> " === "
527+ OpStrictNEq -> " !== "
528+ OpLAnd -> " && "
529+ OpLOr -> " || "
514 OpMul -> " * "
530 OpMul -> " * "
515 OpDiv -> " / "
531 OpDiv -> " / "
516 OpMod -> " % "
532 OpMod -> " % "
517− OpEq -> " === "
533+ OpSub -> " - "
518− OpNe -> " !== "
519− OpLt -> " < "
520− OpLe -> " <= "
521− OpGt -> " > "
522− OpGe -> " >= "
523− OpAnd -> " && "
524− OpOr -> " || "
525− OpBitwiseAnd -> " & "
526− OpBitwiseXor -> " ^ "
527− OpBitwiseOr -> " | "
528 OpLShift -> " << "
534 OpLShift -> " << "
529 OpSpRShift -> " >> "
535 OpSpRShift -> " >> "
530 OpZfRShift -> " >>> "
536 OpZfRShift -> " >>> "
537+ OpBAnd -> " & "
538+ OpBXor -> " ^ "
539+ OpBOr -> " | "
540+ OpAdd -> " + "
compiler/src/Generate/JavaScript/Expression.hs+45−46
@@ -22,7 +22,6 @@ import qualified Data.Utf8 as Utf8
22
22
23import qualified AST.Canonical as Can
23import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
24import qualified AST.Optimized as Opt
25−import qualified AST.Utils.Shader as Shader
26import qualified Data.Index as Index
25import qualified Data.Index as Index
27import qualified Elm.Compiler.Type as Type
26import qualified Elm.Compiler.Type as Type
28import qualified Elm.Compiler.Type.Extract as Extract
27import qualified Elm.Compiler.Type.Extract as Extract
@@ -33,7 +32,6 @@ import qualified Generate.JavaScript.Builder as JS
33import qualified Generate.JavaScript.Name as JsName
32import qualified Generate.JavaScript.Name as JsName
34import qualified Generate.Mode as Mode
33import qualified Generate.Mode as Mode
35import qualified Json.Encode as Encode
34import qualified Json.Encode as Encode
36−import Json.Encode ((==>))
37import qualified Optimize.DecisionTree as DT
35import qualified Optimize.DecisionTree as DT
38import qualified Reporting.Annotation as A
36import qualified Reporting.Annotation as A
39
37
@@ -130,7 +128,8 @@ generate mode expression =
130
128
131 Opt.Destruct (Opt.Destructor name path) body ->
129 Opt.Destruct (Opt.Destructor name path) body ->
132 let
130 let
131+ pathExpr = generatePath mode path
133− pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)
132+ pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]
134 in
133 in
135 JsBlock $ pathDef : codeToStmtList (generate mode body)
134 JsBlock $ pathDef : codeToStmtList (generate mode body)
136
135
@@ -139,7 +138,7 @@ generate mode expression =
139
138
140 Opt.Accessor field ->
139 Opt.Accessor field ->
141 JsExpr $ JS.Function Nothing [JsName.dollar]
140 JsExpr $ JS.Function Nothing [JsName.dollar]
142− [ JS.Return $
141+ [ JS.Return $ Just $
143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)
144 ]
143 ]
145
144
@@ -191,7 +190,7 @@ generate mode expression =
191 JS.Object (map toTranlation (Set.toList fields))
190 JS.Object (map toTranlation (Set.toList fields))
192 in
191 in
193 JsExpr $ JS.Object $
192 JsExpr $ JS.Object $
194− [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )
193+ [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )
195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )
196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )
197 ]
196 ]
@@ -212,7 +211,7 @@ codeToExpr code =
212 JsExpr expr ->
211 JsExpr expr ->
213 expr
212 expr
214
213
215− JsBlock [ JS.Return expr ] ->
214+ JsBlock [ JS.Return (Just expr) ] ->
216 expr
215 expr
217
216
218 JsBlock stmts ->
217 JsBlock stmts ->
@@ -226,7 +225,7 @@ codeToStmtList code =
226 stmts
225 stmts
227
226
228 JsExpr expr ->
227 JsExpr expr ->
229− [ JS.Return expr ]
228+ [ JS.Return (Just expr) ]
230
229
231 JsBlock stmts ->
230 JsBlock stmts ->
232 stmts
231 stmts
@@ -239,7 +238,7 @@ codeToStmt code =
239 JS.Block stmts
238 JS.Block stmts
240
239
241 JsExpr expr ->
240 JsExpr expr ->
242− JS.Return expr
241+ JS.Return (Just expr)
243
242
244 JsBlock [stmt] ->
243 JsBlock [stmt] ->
245 stmt
244 stmt
@@ -483,17 +482,17 @@ generateBitwiseCall home name args =
483 case args of
482 case args of
484 [arg] ->
483 [arg] ->
485 case name of
484 case name of
486− "complement" -> JS.Prefix JS.PrefixComplement arg
485+ "complement" -> JS.Prefix JS.PrefixBNot arg
487 _ -> generateGlobalCall home name args
486 _ -> generateGlobalCall home name args
488
487
489 [left,right] ->
488 [left,right] ->
490 case name of
489 case name of
491− "and" -> JS.Infix JS.OpBitwiseAnd left right
490+ "and" -> JS.Infix JS.OpBAnd left right
492− "or" -> JS.Infix JS.OpBitwiseOr left right
491+ "or" -> JS.Infix JS.OpBOr left right
493− "xor" -> JS.Infix JS.OpBitwiseXor left right
492+ "xor" -> JS.Infix JS.OpBXor left right
494− "shiftLeftBy" -> JS.Infix JS.OpLShift right left
493+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left
495− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
494+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left
496− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
495+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left
497 _ -> generateGlobalCall home name args
496 _ -> generateGlobalCall home name args
498
497
499 _ ->
498 _ ->
@@ -506,10 +505,10 @@ generateBasicsCall mode home name args =
506 [elmArg] ->
505 [elmArg] ->
507 let arg = generateJsExpr mode elmArg in
506 let arg = generateJsExpr mode elmArg in
508 case name of
507 case name of
509− "not" -> JS.Prefix JS.PrefixNot arg
508+ "not" -> JS.Prefix JS.PrefixLNot arg
510− "negate" -> JS.Prefix JS.PrefixNegate arg
509+ "negate" -> JS.Prefix JS.PrefixMinus arg
511 "toFloat" -> arg
510 "toFloat" -> arg
512− "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)
511+ "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)
513 _ -> generateGlobalCall home name [arg]
512 _ -> generateGlobalCall home name [arg]
514
513
515 [elmLeft, elmRight] ->
514 [elmLeft, elmRight] ->
@@ -529,16 +528,16 @@ generateBasicsCall mode home name args =
529 "sub" -> JS.Infix JS.OpSub left right
528 "sub" -> JS.Infix JS.OpSub left right
530 "mul" -> JS.Infix JS.OpMul left right
529 "mul" -> JS.Infix JS.OpMul left right
531 "fdiv" -> JS.Infix JS.OpDiv left right
530 "fdiv" -> JS.Infix JS.OpDiv left right
532− "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
531+ "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)
533 "eq" -> equal left right
532 "eq" -> equal left right
534 "neq" -> notEqual left right
533 "neq" -> notEqual left right
535− "lt" -> cmp JS.OpLt JS.OpLt 0 left right
534+ "lt" -> cmp JS.OpLT JS.OpLT 0 left right
536− "gt" -> cmp JS.OpGt JS.OpGt 0 left right
535+ "gt" -> cmp JS.OpGT JS.OpGT 0 left right
537− "le" -> cmp JS.OpLe JS.OpLt 1 left right
536+ "le" -> cmp JS.OpLEq JS.OpLT 1 left right
538− "ge" -> cmp JS.OpGe JS.OpGt (-1) left right
537+ "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right
539− "or" -> JS.Infix JS.OpOr left right
538+ "or" -> JS.Infix JS.OpLOr left right
540− "and" -> JS.Infix JS.OpAnd left right
539+ "and" -> JS.Infix JS.OpLAnd left right
541− "xor" -> JS.Infix JS.OpNe left right
540+ "xor" -> JS.Infix JS.OpStrictNEq left right
542 "remainderBy" -> JS.Infix JS.OpMod right left
541 "remainderBy" -> JS.Infix JS.OpMod right left
543 _ -> generateGlobalCall home name [left, right]
542 _ -> generateGlobalCall home name [left, right]
544
543
@@ -559,7 +558,7 @@ notEqual left right =
559 if isLiteral left || isLiteral right then
558 if isLiteral left || isLiteral right then
560 strictNEq left right
559 strictNEq left right
561 else
560 else
562− JS.Prefix JS.PrefixNot $
561+ JS.Prefix JS.PrefixLNot $
563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]
564
563
565
564
@@ -648,42 +647,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr
648strictEq left right =
647strictEq left right =
649 case left of
648 case left of
650 JS.Int 0 ->
649 JS.Int 0 ->
651− JS.Prefix JS.PrefixNot right
650+ JS.Prefix JS.PrefixLNot right
652
651
653 JS.Bool bool ->
652 JS.Bool bool ->
654− if bool then right else JS.Prefix JS.PrefixNot right
653+ if bool then right else JS.Prefix JS.PrefixLNot right
655
654
656 _ ->
655 _ ->
657 case right of
656 case right of
658 JS.Int 0 ->
657 JS.Int 0 ->
659− JS.Prefix JS.PrefixNot left
658+ JS.Prefix JS.PrefixLNot left
660
659
661 JS.Bool bool ->
660 JS.Bool bool ->
662− if bool then left else JS.Prefix JS.PrefixNot left
661+ if bool then left else JS.Prefix JS.PrefixLNot left
663
662
664 _ ->
663 _ ->
665− JS.Infix JS.OpEq left right
664+ JS.Infix JS.OpStrictEq left right
666
665
667
666
668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr
669strictNEq left right =
668strictNEq left right =
670 case left of
669 case left of
671 JS.Int 0 ->
670 JS.Int 0 ->
672− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)
671+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)
673
672
674 JS.Bool bool ->
673 JS.Bool bool ->
675− if bool then JS.Prefix JS.PrefixNot right else right
674+ if bool then JS.Prefix JS.PrefixLNot right else right
676
675
677 _ ->
676 _ ->
678 case right of
677 case right of
679 JS.Int 0 ->
678 JS.Int 0 ->
680− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)
679+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)
681
680
682 JS.Bool bool ->
681 JS.Bool bool ->
683− if bool then JS.Prefix JS.PrefixNot left else left
682+ if bool then JS.Prefix JS.PrefixLNot left else left
684
683
685 _ ->
684 _ ->
686− JS.Infix JS.OpNe left right
685+ JS.Infix JS.OpStrictNEq left right
687
686
688
687
689
688
@@ -696,13 +695,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm
696generateTailCall mode name args =
695generateTailCall mode name args =
697 let
696 let
698 toTempVars (argName, arg) =
697 toTempVars (argName, arg) =
699− ( JsName.makeTemp argName, generateJsExpr mode arg )
698+ ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )
700
699
701 toRealVars (argName, _) =
700 toRealVars (argName, _) =
702 JS.ExprStmt $
701 JS.ExprStmt $
703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
704 in
703 in
705− JS.Vars (map toTempVars args)
704+ JS.Var (map toTempVars args)
706 : map toRealVars args
705 : map toRealVars args
707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]
708
707
@@ -715,10 +714,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt
715generateDef mode def =
714generateDef mode def =
716 case def of
715 case def of
717 Opt.Def name body ->
716 Opt.Def name body ->
718− JS.Var (JsName.fromLocal name) (generateJsExpr mode body)
717+ JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]
719
718
720 Opt.TailDef name argNames body ->
719 Opt.TailDef name argNames body ->
721− JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))
720+ JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]
722
721
723
722
724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code
@@ -851,7 +850,7 @@ generateDecider mode label root decisionTree =
851
850
852 Opt.Chain testChain success failure ->
851 Opt.Chain testChain success failure ->
853 [ JS.IfStmt
852 [ JS.IfStmt
854− (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))
853+ (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))
855 (JS.Block $ generateDecider mode label root success)
854 (JS.Block $ generateDecider mode label root success)
856 (JS.Block $ generateDecider mode label root failure)
855 (JS.Block $ generateDecider mode label root failure)
857 ]
856 ]
@@ -893,7 +892,7 @@ generateIfTest mode root (path, test) =
893 value
892 value
894
893
895 DT.IsBool False ->
894 DT.IsBool False ->
896− JS.Prefix JS.PrefixNot value
895+ JS.Prefix JS.PrefixLNot value
897
896
898 DT.IsInt int ->
897 DT.IsInt int ->
899 strictEq value (JS.Int int)
898 strictEq value (JS.Int int)
@@ -911,7 +910,7 @@ generateIfTest mode root (path, test) =
911 JS.Access value (JsName.fromLocal "b")
910 JS.Access value (JsName.fromLocal "b")
912
911
913 DT.IsNil ->
912 DT.IsNil ->
914− JS.Prefix JS.PrefixNot $
913+ JS.Prefix JS.PrefixLNot $
915 JS.Access value (JsName.fromLocal "b")
914 JS.Access value (JsName.fromLocal "b")
916
915
917 DT.IsTuple ->
916 DT.IsTuple ->
@@ -1065,6 +1064,6 @@ toDebugMetadata mode msgType =
1065
1064
1066 Mode.Dev (Just interfaces) ->
1065 Mode.Dev (Just interfaces) ->
1067 JS.Json $ Encode.object $
1066 JS.Json $ Encode.object $
1068− [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]
1067+ [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])
1069− , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)
1068+ , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))
1070 ]
1069 ]
compiler/src/Generate/JavaScript/Functions.hs+3−2
@@ -1,5 +1,6 @@
1−{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE QuasiQuotes #-}
2−module Generate.JavaScript.Functions
3+module Generate.Functions
3 ( functions
4 ( functions
4 )
5 )
5 where
6 where
compiler/src/Generate/JavaScript/Name.hs+12−22
@@ -62,13 +62,19 @@ fromLocal name =
62
62
63
63
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name
65−fromGlobal home name =
65+fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =
66+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
67+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
68+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
66− Name $ homeToBuilder home <> usd <> Name.toBuilder name
69+ <> "$" <> Name.toBuilder name
67
70
68
71
69fromCycle :: ModuleName.Canonical -> Name.Name -> Name
72fromCycle :: ModuleName.Canonical -> Name.Name -> Name
70−fromCycle home name =
73+fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =
74+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
75+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
76+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
71− Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name
77+ <> "$cyclic$" <> Name.toBuilder name
72
78
73
79
74fromKernel :: Name.Name -> Name.Name -> Name
80fromKernel :: Name.Name -> Name.Name -> Name
@@ -76,17 +82,6 @@ fromKernel home name =
76 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
82 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)
77
83
78
84
79−{-# INLINE homeToBuilder #-}
80−homeToBuilder :: ModuleName.Canonical -> B.Builder
81−homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =
82− usd <>
83− Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author
84− <> usd <>
85− Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project
86− <> usd <>
87− Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home
88−
89−
90
85
91-- TEMPORARY NAMES
86-- TEMPORARY NAMES
92
87
@@ -103,7 +98,7 @@ makeA n =
103
98
104makeLabel :: Name.Name -> Int -> Name
99makeLabel :: Name.Name -> Int -> Name
105makeLabel name index =
100makeLabel name index =
106− Name (Name.toBuilder name <> usd <> B.intDec index)
101+ Name (Name.toBuilder name <> "$" <> B.intDec index)
107
102
108
103
109makeTemp :: Name.Name -> Name
104makeTemp :: Name.Name -> Name
@@ -113,12 +108,7 @@ makeTemp name =
113
108
114dollar :: Name
109dollar :: Name
115dollar =
110dollar =
116− Name usd
117−
118−
119−usd :: B.Builder
120−usd =
121− Name.toBuilder Name.dollar
111+ Name (Name.toBuilder Name.dollar)
122
112
123
113
124
114
compiler/src/Generate/Mode.hs+3−2
@@ -41,14 +41,15 @@ type ShortFieldNames =
41 Map.Map Name.Name JsName.Name
41 Map.Map Name.Name JsName.Name
42
42
43
43
44−shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames
44+shortenFieldNames :: Opt.Graph -> ShortFieldNames
45−shortenFieldNames (Opt.GlobalGraph _ frequencies) =
45+shortenFieldNames (Opt.Graph _ _ 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
52 Map.insertWith (++) frequency [field] buckets
53 Map.insertWith (++) frequency [field] buckets
53
54
54
55
compiler/src/Json/Decode.hs+180−333
@@ -2,112 +2,69 @@
2{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
2{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}
3module Json.Decode
3module Json.Decode
4 ( fromByteString
4 ( fromByteString
5+ , fromFile
5 , Decoder
6 , Decoder
6 , string
7 , string
7− , customString
8 , bool
8 , bool
9 , int
9 , int
10− , list
10+ , list, pair
11− , nonEmptyList
12− , pair
13− --
14− , KeyDecoder(..)
15− , dict
16− , pairs
11+ , dict, pairs, field
17− , field
18− --
19 , oneOf
12 , oneOf
20 , failure
13 , failure
21 , mapError
14 , mapError
22− --
23− , Error(..)
24− , Problem(..)
25− , DecodeExpectation(..)
26− , ParseError(..)
27− , StringProblem(..)
28 )
15 )
29 where
16 where
30
17
31
18
32−import qualified Data.ByteString.Internal as B
19+import qualified Data.ByteString as B
20+import qualified Data.List as List
33import qualified Data.Map as Map
21import qualified Data.Map as Map
34−import qualified Data.NonEmptyList as NE
22+import qualified Data.Utf8 as Utf8
35−import Data.Word (Word8)
23+import Data.Word (Word8, Word16)
36import Foreign.Ptr (Ptr, plusPtr, minusPtr)
24import Foreign.Ptr (Ptr, plusPtr, minusPtr)
37−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
38
25
39−import qualified Json.String as Json
40import qualified Parse.Keyword as K
26import qualified Parse.Keyword as K
41import qualified Parse.Primitives as P
27import qualified Parse.Primitives as P
42−import Parse.Primitives (Row, Col)
43−import qualified Reporting.Annotation as A
28+import qualified Reporting.Error.Json as E
44
29
45
30
46
31
47-- RUNNERS
32-- RUNNERS
48
33
49
34
50−fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a
35+fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a
51−fromByteString (Decoder decode) src =
36+fromByteString decoder src =
52− case P.fromByteString pFile BadEnd src of
37+ fromAST decoder (P.fromByteString pFile src)
53− Right ast ->
54− decode ast Right (Left . DecodeProblem src)
55
38
56− Left problem ->
57− Left (ParseProblem src problem)
58
39
40+fromFile :: Decoder e a -> FilePath -> IO (Either (E.Error e) a)
41+fromFile decoder path =
42+ fromAST decoder <$> P.fromFile pFile path
59
43
60
44
61−-- DECODERS
45+fromAST :: Decoder e a -> P.Result E.Context E.ParseExpectation AST -> Either (E.Error e) a
62−
46+fromAST (Decoder decode) parserResult =
63−
47+ case parserResult of
64−newtype Decoder x a =
48+ P.Ok ast _ ->
65− Decoder
66− (
67− forall b.
68− AST
69− -> (a -> b)
70− -> (Problem x -> b)
71− -> b
72− )
73−
74−
75−
76−-- ERRORS
77−
78−
79−data Error x
80− = DecodeProblem B.ByteString (Problem x)
49+ decode ast Right (Left . E.DecodeProblem)
81− | ParseProblem B.ByteString ParseError
82
50
51+ P.Err row col ctx expectation ->
52+ Left (E.ParseProblem row col ctx expectation)
83
53
84
54
85−-- DECODE PROBLEMS
86
55
87−
56+-- DECODERS
88−data Problem x
89− = Field B.ByteString (Problem x)
90− | Index Int (Problem x)
91− | OneOf (Problem x) [Problem x]
92− | Failure A.Region x
93− | Expecting A.Region DecodeExpectation
94
57
95
58
96−data DecodeExpectation
59+newtype Decoder e a =
97− = TObject
60+ Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)
98− | TArray
99− | TString
100− | TBool
101− | TInt
102− | TObjectWith B.ByteString
103− | TArrayPair Int
104
61
105
62
106
63
107-- INSTANCES
64-- INSTANCES
108
65
109
66
110−instance Functor (Decoder x) where
67+instance Functor (Decoder e) where
111 {-# INLINE fmap #-}
68 {-# INLINE fmap #-}
112 fmap func (Decoder decodeA) =
69 fmap func (Decoder decodeA) =
113 Decoder $ \ast ok err ->
70 Decoder $ \ast ok err ->
@@ -117,7 +74,7 @@ instance Functor (Decoder x) where
117 decodeA ast ok' err
74 decodeA ast ok' err
118
75
119
76
120−instance Applicative (Decoder x) where
77+instance Applicative (Decoder e) where
121 {-# INLINE pure #-}
78 {-# INLINE pure #-}
122 pure = return
79 pure = return
123
80
@@ -134,7 +91,7 @@ instance Applicative (Decoder x) where
134 decodeFunc ast okF err
91 decodeFunc ast okF err
135
92
136
93
137−instance Monad (Decoder x) where
94+instance Monad (Decoder e) where
138 {-# INLINE return #-}
95 {-# INLINE return #-}
139 return a =
96 return a =
140 Decoder $ \_ ok _ ->
97 Decoder $ \_ ok _ ->
@@ -155,37 +112,24 @@ instance Monad (Decoder x) where
155-- STRINGS
112-- STRINGS
156
113
157
114
158−string :: Decoder x Json.String
115+string :: Decoder e Utf8.String
159string =
116string =
160− Decoder $ \(A.At region ast) ok err ->
161− case ast of
162− String snippet ->
163− ok (Json.fromSnippet snippet)
164−
165− _ ->
166− err (Expecting region TString)
167−
168−
169−customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a
170−customString parser toBadEnd =
171− Decoder $ \(A.At region ast) ok err ->
117+ Decoder $ \ast ok err ->
172 case ast of
118 case ast of
173− String snippet ->
119+ String bits ->
174− case P.fromSnippet parser toBadEnd snippet of
120+ ok bits
175− Right a -> ok a
176− Left x -> err (Failure region x)
177
121
178 _ ->
122 _ ->
179− err (Expecting region TString)
123+ err (E.Expecting E.TString)
180
124
181
125
182
126
183-- BOOL
127-- BOOL
184
128
185
129
186−bool :: Decoder x Bool
130+bool :: Decoder e Bool
187bool =
131bool =
188− Decoder $ \(A.At region ast) ok err ->
132+ Decoder $ \ast ok err ->
189 case ast of
133 case ast of
190 TRUE ->
134 TRUE ->
191 ok True
135 ok True
@@ -194,40 +138,40 @@ bool =
194 ok False
138 ok False
195
139
196 _ ->
140 _ ->
197− err (Expecting region TBool)
141+ err (E.Expecting E.TBool)
198
142
199
143
200
144
201-- INT
145-- INT
202
146
203
147
204−int :: Decoder x Int
148+int :: Decoder e Int
205int =
149int =
206− Decoder $ \(A.At region ast) ok err ->
150+ Decoder $ \ast ok err ->
207 case ast of
151 case ast of
208 Int n ->
152 Int n ->
209 ok n
153 ok n
210
154
211 _ ->
155 _ ->
212− err (Expecting region TInt)
156+ err (E.Expecting E.TInt)
213
157
214
158
215
159
216−-- LISTS
160+-- ARRAYS
217
161
218
162
219−list :: Decoder x a -> Decoder x [a]
163+list :: Decoder e a -> Decoder e [a]
220list decoder =
164list decoder =
221− Decoder $ \(A.At region ast) ok err ->
165+ Decoder $ \ast ok err ->
222 case ast of
166 case ast of
223 Array asts ->
167 Array asts ->
224 listHelp decoder ok err 0 asts []
168 listHelp decoder ok err 0 asts []
225
169
226 _ ->
170 _ ->
227− err (Expecting region TArray)
171+ err (E.Expecting E.TArray)
228
172
229
173
230−listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b
174+listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b
231listHelp decoder@(Decoder decodeA) ok err !i asts revs =
175listHelp decoder@(Decoder decodeA) ok err !i asts revs =
232 case asts of
176 case asts of
233 [] ->
177 [] ->
@@ -235,40 +179,24 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =
235
179
236 ast:asts ->
180 ast:asts ->
237 let
181 let
238− ok' value = listHelp decoder ok err (i+1) asts (value:revs)
182+ ok' a = listHelp decoder ok err (i+1) asts (a:revs)
239− err' prob = err (Index i prob)
183+ err' e = err (E.Index i e)
240 in
184 in
241 decodeA ast ok' err'
185 decodeA ast ok' err'
242
186
243
187
244−
245−-- NON-EMPTY LISTS
246−
247−
248−nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)
249−nonEmptyList decoder x =
250− do values <- list decoder
251− case values of
252− v:vs -> return (NE.List v vs)
253− [] -> failure x
254−
255−
256−
257−-- PAIR
258−
259−
260−pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)
188+pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)
261pair (Decoder decodeA) (Decoder decodeB) =
189pair (Decoder decodeA) (Decoder decodeB) =
262− Decoder $ \(A.At region ast) ok err ->
190+ Decoder $ \ast ok err ->
263 case ast of
191 case ast of
264 Array vs ->
192 Array vs ->
265 case vs of
193 case vs of
266 [astA,astB] ->
194 [astA,astB] ->
267 let
195 let
268− err0 e = err (Index 0 e)
196+ err0 e = err (E.Index 0 e)
269 ok0 a =
197 ok0 a =
270 let
198 let
271− err1 e = err (Index 1 e)
199+ err1 e = err (E.Index 1 e)
272 ok1 b = ok (a,b)
200 ok1 b = ok (a,b)
273 in
201 in
274 decodeB astB ok1 err1
202 decodeB astB ok1 err1
@@ -276,103 +204,70 @@ pair (Decoder decodeA) (Decoder decodeB) =
276 decodeA astA ok0 err0
204 decodeA astA ok0 err0
277
205
278 _ ->
206 _ ->
279− err (Expecting region (TArrayPair (length vs)))
207+ err (E.Expecting (E.TArrayPair (length vs)))
280
208
281 _ ->
209 _ ->
282− err (Expecting region TArray)
210+ err (E.Expecting E.TArray)
283−
284−
285
211
286−-- OBJECTS
287
212
288
213
289−data KeyDecoder x a =
214+-- OBJECT
290− KeyDecoder (P.Parser x a) (Row -> Col -> x)
291
215
292
216
293−dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)
217+dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)
294−dict keyDecoder valueDecoder =
218+dict decoder =
295− Map.fromList <$> pairs keyDecoder valueDecoder
219+ Map.fromList <$> pairs decoder
296
220
297
221
298−pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]
222+pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]
299−pairs keyDecoder valueDecoder =
223+pairs decoder =
300− Decoder $ \(A.At region ast) ok err ->
224+ Decoder $ \ast ok err ->
301 case ast of
225 case ast of
302 Object kvs ->
226 Object kvs ->
303− pairsHelp keyDecoder valueDecoder ok err kvs []
227+ pairsHelp decoder ok err kvs []
304
228
305 _ ->
229 _ ->
306− err (Expecting region TObject)
230+ err (E.Expecting E.TObject)
307
231
308
232
309−pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b
233+pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b
310−pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =
234+pairsHelp decoder@(Decoder decodeA) ok err kvs revs =
311 case kvs of
235 case kvs of
312 [] ->
236 [] ->
313 ok (reverse revs)
237 ok (reverse revs)
314
238
315− (snippet, ast) : kvs ->
239+ (key, ast) : kvs ->
316− case P.fromSnippet keyParser toBadEnd snippet of
317− Left x ->
318− err (Failure (snippetToRegion snippet) x)
319−
320− Right key ->
321− let
240+ let
322− ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)
241+ ok' a = pairsHelp decoder ok err kvs ((key,a):revs)
323− err' prob =
242+ err' e = err (E.Field key e)
324− let (P.Snippet fptr off len _ _) = snippet in
325− err (Field (B.PS fptr off len) prob)
326− in
243+ in
327− decodeA ast ok' err'
244+ decodeA ast ok' err'
328−
329−
330−snippetToRegion :: P.Snippet -> A.Region
331−snippetToRegion (P.Snippet _ _ len row col) =
332− A.Region (A.Position row col) (A.Position row (col + fromIntegral len))
333−
334−
335−
336−-- FIELDS
337
245
338
246
339−field :: B.ByteString -> Decoder x a -> Decoder x a
247+field :: Utf8.String -> Decoder e a -> Decoder e a
340field key (Decoder decodeA) =
248field key (Decoder decodeA) =
341− Decoder $ \(A.At region ast) ok err ->
249+ Decoder $ \ast ok err ->
342 case ast of
250 case ast of
343 Object kvs ->
251 Object kvs ->
344− case findField key kvs of
252+ case List.lookup key kvs of
345− Just value ->
253+ Just v ->
346 let
254 let
347− err' prob =
348− err (Field key prob)
255+ err' e = err (E.Field key e)
349 in
256 in
350− decodeA value ok err'
257+ decodeA v ok err'
351
258
352 Nothing ->
259 Nothing ->
353− err (Expecting region (TObjectWith key))
260+ err (E.Expecting (E.TObjectWith key))
354
261
355 _ ->
262 _ ->
356− err (Expecting region TObject)
263+ err (E.Expecting E.TObject)
357−
358−
359−findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST
360−findField key pairs =
361− case pairs of
362− [] ->
363− Nothing
364−
365− (P.Snippet fptr off len _ _, value) : remainingPairs ->
366− if key == B.PS fptr off len
367− then Just value
368− else findField key remainingPairs
369
264
370
265
371
266
372-- ONE OF
267-- ONE OF
373
268
374
269
375−oneOf :: [Decoder x a] -> Decoder x a
270+oneOf :: [Decoder e a] -> Decoder e a
376oneOf decoders =
271oneOf decoders =
377 Decoder $ \ast ok err ->
272 Decoder $ \ast ok err ->
378 case decoders of
273 case decoders of
@@ -387,75 +282,71 @@ oneOf decoders =
387 error "Ran into (Json.Decode.oneOf [])"
282 error "Ran into (Json.Decode.oneOf [])"
388
283
389
284
390−oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b
285+oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b
391−oneOfHelp ast ok err decoders p ps =
286+oneOfHelp ast ok err decoders e es =
392 case decoders of
287 case decoders of
393 Decoder decodeA : decoders ->
288 Decoder decodeA : decoders ->
394 let
289 let
395− err' p' =
290+ err' e' =
396− oneOfHelp ast ok err decoders p' (p:ps)
291+ oneOfHelp ast ok err decoders e' (e:es)
397 in
292 in
398 decodeA ast ok err'
293 decodeA ast ok err'
399
294
400 [] ->
295 [] ->
401− err (oneOfError [] p ps)
296+ err (oneOfError [] e es)
402
297
403
298
404−oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x
299+oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e
405−oneOfError problems prob ps =
300+oneOfError errors err es =
406− case ps of
301+ case es of
407 [] ->
302 [] ->
408− OneOf prob problems
303+ E.OneOf err errors
409
304
410− p:ps ->
305+ e:es ->
411− oneOfError (prob:problems) p ps
306+ oneOfError (err:errors) e es
412
307
413
308
414
309
415-- FAILURE
310-- FAILURE
416
311
417
312
418−failure :: x -> Decoder x a
313+failure :: e -> Decoder e a
419−failure x =
314+failure e =
420− Decoder $ \(A.At region _) _ err ->
315+ Decoder $ \_ _ err ->
421− err (Failure region x)
316+ err (E.Failure e)
422
317
423
318
424
319
425-- ERRORS
320-- ERRORS
426
321
427
322
428−mapError :: (x -> y) -> Decoder x a -> Decoder y a
323+mapError :: (e -> e') -> Decoder e a -> Decoder e' a
429mapError func (Decoder decodeA) =
324mapError func (Decoder decodeA) =
430 Decoder $ \ast ok err ->
325 Decoder $ \ast ok err ->
431 let
326 let
432− err' prob = err (mapErrorHelp func prob)
327+ err' e = err (mapErrorHelp func e)
433 in
328 in
434 decodeA ast ok err'
329 decodeA ast ok err'
435
330
436
331
437−mapErrorHelp :: (x -> y) -> Problem x -> Problem y
332+mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'
438−mapErrorHelp func problem =
333+mapErrorHelp func err =
439− case problem of
334+ case err of
440− Field k p -> Field k (mapErrorHelp func p)
335+ E.Field k e -> E.Field k (mapErrorHelp func e)
441− Index i p -> Index i (mapErrorHelp func p)
336+ E.Index i e -> E.Index i (mapErrorHelp func e)
442− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)
337+ E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)
443− Failure r x -> Failure r (func x)
338+ E.Failure e -> E.Failure (func e)
444− Expecting r e -> Expecting r e
339+ E.Expecting e -> E.Expecting e
445
340
446
341
447
342
448-- AST
343-- AST
449
344
450
345
451−type AST =
452− A.Located AST_
453−
454−
455−data AST_
346+data AST
456 = Array [AST]
347 = Array [AST]
457− | Object [(P.Snippet, AST)]
348+ | Object [(Utf8.String, AST)]
458− | String P.Snippet
349+ | String Utf8.String
459 | Int Int
350 | Int Int
460 | TRUE
351 | TRUE
461 | FALSE
352 | FALSE
@@ -467,33 +358,7 @@ data AST_
467
358
468
359
469type Parser a =
360type Parser a =
470− P.Parser ParseError a
361+ P.Parser E.Context E.ParseExpectation a
471−
472−
473−data ParseError
474− = Start Row Col
475− | ObjectField Row Col
476− | ObjectColon Row Col
477− | ObjectEnd Row Col
478− | ArrayEnd Row Col
479− | StringProblem StringProblem Row Col
480− | NoLeadingZeros Row Col
481− | NoFloats Row Col
482− | BadEnd Row Col
483−
484−-- PIndex Int ParseError Row Col
485−-- PField Json.String ParseError Row Col
486−
487−
488−data StringProblem
489− = BadStringEnd
490− | BadStringControlChar
491− | BadStringEscapeChar
492− | BadStringEscapeHex
493−
494−
495−
496−-- PARSE AST
497
362
498
363
499pFile :: Parser AST
364pFile :: Parser AST
@@ -501,60 +366,69 @@ pFile =
501 do spaces
366 do spaces
502 value <- pValue
367 value <- pValue
503 spaces
368 spaces
369+ endOfFile
504 return value
370 return value
505
371
506
372
507pValue :: Parser AST
373pValue :: Parser AST
508pValue =
374pValue =
509− P.addLocation $
510− P.oneOf Start
375+ P.oneOf E.Value
511− [ String <$> pString Start
376+ [ fmap String pString
512 , pObject
377 , pObject
513 , pArray
378 , pArray
514 , pInt
379 , pInt
515− , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE
380+ , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE
516− , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE
381+ , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE
517− , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL
382+ , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL
518 ]
383 ]
519
384
520
385
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+
521
395
522-- OBJECT
396-- OBJECT
523
397
524
398
525−pObject :: Parser AST_
399+pObject :: Parser AST
526pObject =
400pObject =
527− do P.word1 0x7B {- { -} Start
401+ do P.word1 0x7B {- { -} E.ObjectStart
528 spaces
402 spaces
529− P.oneOf ObjectField
403+ P.oneOf E.ObjectMore
530 [ do entry <- pField
404 [ do entry <- pField
531 spaces
405 spaces
532 pObjectHelp [entry]
406 pObjectHelp [entry]
533− , do P.word1 0x7D {-}-} ObjectEnd
407+ , do P.word1 0x7D {-}-} E.ObjectEnd
534 return (Object [])
408 return (Object [])
535 ]
409 ]
536
410
537
411
538−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_
412+pObjectHelp :: [(Utf8.String, AST)] -> Parser AST
539pObjectHelp revEntries =
413pObjectHelp revEntries =
540− P.oneOf ObjectEnd
414+ P.oneOf E.ObjectMore
541 [
415 [
542− do P.word1 0x2C {-,-} ObjectEnd
416+ do P.word1 0x2C {-,-} E.ObjectMore
543 spaces
417 spaces
544 entry <- pField
418 entry <- pField
545 spaces
419 spaces
546 pObjectHelp (entry:revEntries)
420 pObjectHelp (entry:revEntries)
547 ,
421 ,
548− do P.word1 0x7D {-}-} ObjectEnd
422+ do P.word1 0x7D {-}-} E.ObjectEnd
549 return (Object (reverse revEntries))
423 return (Object (reverse revEntries))
550 ]
424 ]
551
425
552
426
553−pField :: Parser (P.Snippet, AST)
427+pField :: Parser (Utf8.String, AST)
554pField =
428pField =
555− do key <- pString ObjectField
429+ do key <- pString
556 spaces
430 spaces
557− P.word1 0x3A {-:-} ObjectColon
431+ P.word1 0x3A {-:-} E.Colon
558 spaces
432 spaces
559 value <- pValue
433 value <- pValue
560 return (key, value)
434 return (key, value)
@@ -564,30 +438,30 @@ pField =
564-- ARRAY
438-- ARRAY
565
439
566
440
567−pArray :: Parser AST_
441+pArray :: Parser AST
568pArray =
442pArray =
569− do P.word1 0x5B {-[-} Start
443+ do P.word1 0x5B {-[-} E.ArrayStart
570 spaces
444 spaces
571− P.oneOf Start
445+ P.oneOf E.ArrayMore
572 [ do entry <- pValue
446 [ do entry <- pValue
573 spaces
447 spaces
574 pArrayHelp 1 [entry]
448 pArrayHelp 1 [entry]
575− , do P.word1 0x5D {-]-} ArrayEnd
449+ , do P.word1 0x5D {-]-} E.ArrayEnd
576 return (Array [])
450 return (Array [])
577 ]
451 ]
578
452
579
453
580−pArrayHelp :: Int -> [AST] -> Parser AST_
454+pArrayHelp :: Int -> [AST] -> Parser AST
581pArrayHelp !len revEntries =
455pArrayHelp !len revEntries =
582− P.oneOf ArrayEnd
456+ P.oneOf E.ArrayMore
583 [
457 [
584− do P.word1 0x2C {-,-} ArrayEnd
458+ do P.word1 0x2C {-,-} E.ArrayMore
585 spaces
459 spaces
586 entry <- pValue
460 entry <- pValue
587 spaces
461 spaces
588 pArrayHelp (len + 1) (entry:revEntries)
462 pArrayHelp (len + 1) (entry:revEntries)
589 ,
463 ,
590− do P.word1 0x5D {-]-} ArrayEnd
464+ do P.word1 0x5D {-]-} E.ArrayEnd
591 return (Array (reverse revEntries))
465 return (Array (reverse revEntries))
592 ]
466 ]
593
467
@@ -596,44 +470,41 @@ pArrayHelp !len revEntries =
596-- STRING
470-- STRING
597
471
598
472
599−pString :: (Row -> Col -> ParseError) -> Parser P.Snippet
473+pString :: Parser Utf8.String
600−pString start =
474+pString =
601− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
475+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
476 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then
603
477
604 let
478 let
605 !pos1 = plusPtr pos 1
479 !pos1 = plusPtr pos 1
606− !col1 = col + 1
607
480
608 (# status, newPos, newRow, newCol #) =
481 (# status, newPos, newRow, newCol #) =
609− pStringHelp pos1 end row col1
482+ pStringHelp pos1 end row (col + 1)
610 in
483 in
611 case status of
484 case status of
612 GoodString ->
485 GoodString ->
613 let
486 let
614− !off = minusPtr pos1 (unsafeForeignPtrToPtr src)
615− !len = minusPtr newPos pos1 - 1
616− !snp = P.Snippet src off len row col1
617− !newState = P.State src newPos end indent newRow newCol
487+ !newState = P.State newPos end indent newRow newCol ctx
488+ !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))
618 in
489 in
619− cok snp newState
490+ cok content newState
620
491
621− BadString problem ->
492+ BadStringEnd ->
622− cerr newRow newCol (StringProblem problem)
493+ cerr newRow newCol ctx E.StringEnd
623
494
624 else
495 else
625− eerr row col start
496+ eerr row col ctx E.StringStart
626
497
627
498
628data StringStatus
499data StringStatus
629 = GoodString
500 = GoodString
630− | BadString StringProblem
501+ | BadStringEnd
631
502
632
503
633−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)
504+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)
634pStringHelp pos end row col =
505pStringHelp pos end row col =
635 if pos >= end then
506 if pos >= end then
636− (# BadString BadStringEnd, pos, row, col #)
507+ (# BadStringEnd, pos, row, col #)
637
508
638 else
509 else
639 case P.unsafeIndex pos of
510 case P.unsafeIndex pos of
@@ -641,50 +512,26 @@ pStringHelp pos end row col =
641 (# GoodString, plusPtr pos 1, row, col + 1 #)
512 (# GoodString, plusPtr pos 1, row, col + 1 #)
642
513
643 0x0A {-\n-} ->
514 0x0A {-\n-} ->
644− (# BadString BadStringEnd, pos, row, col #)
515+ (# BadStringEnd, pos, row, col #)
645
516
646 0x5C {-\-} ->
517 0x5C {-\-} ->
518+ let
647− let !pos1 = plusPtr pos 1 in
519+ !pos1 = plusPtr pos 1
648− if pos1 >= end then
520+ in
649− (# BadString BadStringEnd, pos1, row + 1, col #)
650− else
651− case P.unsafeIndex pos1 of
652− 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
653− 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
654− 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
655− 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
656− 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
657− 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
658− 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
659− 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)
660− 0x75 {-u-} ->
661− let !pos6 = plusPtr pos 6 in
662− if pos6 <= end
663− && isHex (P.unsafeIndex (plusPtr pos 2))
664− && isHex (P.unsafeIndex (plusPtr pos 3))
665− && isHex (P.unsafeIndex (plusPtr pos 4))
666− && isHex (P.unsafeIndex (plusPtr pos 5))
667− then
521+ if pos1 < end then
668− pStringHelp pos6 end row (col + 6)
669− else
670− (# BadString BadStringEscapeHex, pos, row, col #)
671−
672− _ ->
673− (# BadString BadStringEscapeChar, pos, row, col #)
674
522
675− word ->
523+ let
676− if word < 0x20 then
524+ !word = P.unsafeIndex pos1
677− (# BadString BadStringControlChar, pos, row, col #)
678− else
679− let !newPos = plusPtr pos (P.getCharWidth word) in
525+ !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)
526+ in
680− pStringHelp newPos end row (col + 1)
527+ pStringHelp newPos end row (col + 2)
681
528
529+ else
530+ (# BadStringEnd, pos1, row + 1, col #)
682
531
683−isHex :: Word8 -> Bool
532+ word ->
684−isHex word =
533+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in
685− 0x30 {-0-} <= word && word <= 0x39 {-9-}
534+ pStringHelp newPos end row (col + 1)
686− || 0x61 {-a-} <= word && word <= 0x66 {-f-}
687− || 0x41 {-A-} <= word && word <= 0x46 {-F-}
688
535
689
536
690
537
@@ -693,7 +540,7 @@ isHex word =
693
540
694spaces :: Parser ()
541spaces :: Parser ()
695spaces =
542spaces =
696− P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->
543+ P.Parser $ \state@(P.State pos end indent row col ctx) cok eok _ _ ->
697 let
544 let
698 (# newPos, newRow, newCol #) =
545 (# newPos, newRow, newCol #) =
699 eatSpaces pos end row col
546 eatSpaces pos end row col
@@ -703,12 +550,12 @@ spaces =
703 else
550 else
704 let
551 let
705 !newState =
552 !newState =
706− P.State src newPos end indent newRow newCol
553+ P.State newPos end indent newRow newCol ctx
707 in
554 in
708 cok () newState
555 cok () newState
709
556
710
557
711−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)
558+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)
712eatSpaces pos end row col =
559eatSpaces pos end row col =
713 if pos >= end then
560 if pos >= end then
714 (# pos, row, col #)
561 (# pos, row, col #)
@@ -727,29 +574,29 @@ eatSpaces pos end row col =
727-- INTS
574-- INTS
728
575
729
576
730−pInt :: Parser AST_
577+pInt :: Parser AST
731pInt =
578pInt =
732− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
579+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->
733 if pos >= end then
580 if pos >= end then
734− eerr row col Start
581+ eerr row col ctx E.IntStart
735
582
736 else
583 else
737 let !word = P.unsafeIndex pos in
584 let !word = P.unsafeIndex pos in
738 if not (isDecimalDigit word) then
585 if not (isDecimalDigit word) then
739− eerr row col Start
586+ eerr row col ctx E.IntStart
740
587
741 else if word == 0x30 {-0-} then
588 else if word == 0x30 {-0-} then
742
589
743 let
590 let
744 !pos1 = plusPtr pos 1
591 !pos1 = plusPtr pos 1
745− !newState = P.State src pos1 end indent row (col + 1)
592+ !newState = P.State pos1 end indent row (col + 1) ctx
746 in
593 in
747 if pos1 < end then
594 if pos1 < end then
748 let !word1 = P.unsafeIndex pos1 in
595 let !word1 = P.unsafeIndex pos1 in
749 if isDecimalDigit word1 then
596 if isDecimalDigit word1 then
750− cerr row (col + 1) NoLeadingZeros
597+ cerr row (col + 1) ctx E.NoLeadingZeros
751 else if word1 == 0x2E {-.-} then
598 else if word1 == 0x2E {-.-} then
752− cerr row (col + 1) NoFloats
599+ cerr row (col + 1) ctx E.NoFloats
753 else
600 else
754 cok (Int 0) newState
601 cok (Int 0) newState
755 else
602 else
@@ -766,12 +613,12 @@ pInt =
766 GoodInt ->
613 GoodInt ->
767 let
614 let
768 !newState =
615 !newState =
769− P.State src newPos end indent row (col + len)
616+ P.State newPos end indent row (col + len) ctx
770 in
617 in
771 cok (Int n) newState
618 cok (Int n) newState
772
619
773 BadIntEnd ->
620 BadIntEnd ->
774− cerr row (col + len) NoFloats
621+ cerr row (col + len) ctx E.NoFloats
775
622
776
623
777data IntStatus = GoodInt | BadIntEnd
624data IntStatus = GoodInt | BadIntEnd
compiler/src/Json/Encode.hs+26−41
@@ -10,7 +10,6 @@ module Json.Encode
10 , object
10 , object
11 , string
11 , string
12 , name
12 , name
13− , chars
14 , bool
13 , bool
15 , int
14 , int
16 , number
15 , number
@@ -31,9 +30,7 @@ import qualified Data.Scientific as Sci
31import Data.Monoid ((<>))
30import Data.Monoid ((<>))
32import qualified Data.Name as Name
31import qualified Data.Name as Name
33import qualified Data.Utf8 as Utf8
32import qualified Data.Utf8 as Utf8
34−
33+import System.IO (IOMode(WriteMode), withBinaryFile)
35−import qualified File
36−import qualified Json.String as Json
37
34
38
35
39
36
@@ -42,7 +39,7 @@ import qualified Json.String as Json
42
39
43data Value
40data Value
44 = Array [Value]
41 = Array [Value]
45− | Object [(Json.String, Value)]
42+ | Object [(Utf8.String, Value)]
46 | String B.Builder
43 | String B.Builder
47 | Boolean Bool
44 | Boolean Bool
48 | Integer Int
45 | Integer Int
@@ -55,14 +52,14 @@ array =
55 Array
52 Array
56
53
57
54
58−object :: [(Json.String, Value)] -> Value
55+object :: [(Utf8.String,Value)] -> Value
59object =
56object =
60 Object
57 Object
61
58
62
59
63−string :: Json.String -> Value
60+string :: Utf8.String -> Value
64string str =
61string str =
65− String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')
62+ String (encodeUtf8 str)
66
63
67
64
68name :: Name.Name -> Value
65name :: Name.Name -> Value
@@ -90,7 +87,7 @@ null =
90 Null
87 Null
91
88
92
89
93−dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value
90+dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value
94dict encodeKey encodeValue pairs =
91dict encodeKey encodeValue pairs =
95 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
92 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
96
93
@@ -101,35 +98,12 @@ list encodeEntry entries =
101
98
102
99
103
100
104−-- CHARS
105−
106−
107−chars :: [Char] -> Value -- PERF can this be done better? Look for examples.
108−chars chrs =
109− String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')
110−
111−
112−escape :: [Char] -> [Char]
113−escape chrs =
114− case chrs of
115− [] ->
116− []
117−
118− c:cs
119− | c == '\r' -> '\\' : 'r' : escape cs
120− | c == '\n' -> '\\' : 'n' : escape cs
121− | c == '\"' -> '\\' : '"' : escape cs
122− | c == '\\' -> '\\' : '\\' : escape cs
123− | otherwise -> c : escape cs
124−
125−
126−
127-- HELPERS
101-- HELPERS
128
102
129
103
130−(==>) :: [Char] -> value -> (Json.String, value)
104+(==>) :: a -> b -> (a, b)
131−(==>) key value =
105+(==>) a b =
132− (Json.fromChars key, value)
106+ (a, b)
133
107
134
108
135
109
@@ -138,12 +112,14 @@ escape chrs =
138
112
139write :: FilePath -> Value -> IO ()
113write :: FilePath -> Value -> IO ()
140write path value =
114write path value =
141− File.writeBuilder path (encode value <> "\n")
115+ withBinaryFile path WriteMode $ \handle ->
116+ B.hPutBuilder handle (encode value <> "\n")
142
117
143
118
144writeUgly :: FilePath -> Value -> IO ()
119writeUgly :: FilePath -> Value -> IO ()
145writeUgly path value =
120writeUgly path value =
121+ withBinaryFile path WriteMode $ \handle ->
146− File.writeBuilder path (encodeUgly value)
122+ B.hPutBuilder handle (encodeUgly value)
147
123
148
124
149
125
@@ -169,7 +145,7 @@ encodeUgly value =
169 Object (first : rest) ->
145 Object (first : rest) ->
170 let
146 let
171 encodeEntry char (key, entry) =
147 encodeEntry char (key, entry) =
172− B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry
148+ B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry
173 in
149 in
174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
150 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
175
151
@@ -230,6 +206,15 @@ encodeHelp indent value =
230
206
231
207
232
208
209+-- ENCODE UTF-8
210+
211+
212+encodeUtf8 :: Utf8.String -> B.Builder
213+encodeUtf8 str =
214+ B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'
215+
216+
217+
233-- ENCODE ARRAY
218-- ENCODE ARRAY
234
219
235
220
@@ -252,7 +237,7 @@ arrayClose =
252-- ENCODE OBJECT
237-- ENCODE OBJECT
253
238
254
239
255−encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder
240+encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder
256encodeObject =
241encodeObject =
257 encodeSequence objectOpen objectClose encodeField
242 encodeSequence objectOpen objectClose encodeField
258
243
@@ -267,9 +252,9 @@ objectClose =
267 B.char7 '}'
252 B.char7 '}'
268
253
269
254
270−encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder
255+encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder
271encodeField indent (key, value) =
256encodeField indent (key, value) =
272− B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value
257+ encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value
273
258
274
259
275
260
compiler/src/Json/String.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
2−{-# LANGUAGE BangPatterns, EmptyDataDecls #-}
3−module Json.String
4− ( String
5− , isEmpty
6− --
7− , fromPtr
8− , fromName
9− , fromChars
10− , fromSnippet
11− , fromComment
12− --
13− , toChars
14− , toBuilder
15− )
16− where
17−
18−
19−import Prelude hiding (String)
20−import qualified Data.ByteString.Builder as B
21−import qualified Data.Coerce as Coerce
22−import qualified Data.Name as Name
23−import qualified Data.Utf8 as Utf8
24−import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)
25−import Data.Word (Word8)
26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)
27−import Foreign.ForeignPtr (withForeignPtr)
28−import GHC.Exts (RealWorld)
29−import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
30−import GHC.ST (ST)
31−
32−import qualified Parse.Primitives as P
33−
34−
35−
36−-- JSON STRINGS
37−
38−
39−-- INVARIANT: any Json.String is appropriately escaped already
40−-- PERF: is this the right representation for Json.String? Maybe ByteString instead?
41−--
42−type String =
43− Utf8.Utf8 JSON_STRING
44−
45−
46−data JSON_STRING
47−
48−
49−isEmpty :: String -> Bool
50−isEmpty =
51− Utf8.isEmpty
52−
53−
54−
55−-- FROM
56−
57−
58−fromPtr :: Ptr Word8 -> Ptr Word8 -> String
59−fromPtr =
60− Utf8.fromPtr
61−
62−
63−fromChars :: [Char] -> String
64−fromChars =
65− Utf8.fromChars
66−
67−
68−fromSnippet :: P.Snippet -> String
69−fromSnippet =
70− Utf8.fromSnippet
71−
72−
73−fromName :: Name.Name -> String
74−fromName =
75− Coerce.coerce
76−
77−
78−
79−-- TO
80−
81−
82−toChars :: String -> [Char]
83−toChars =
84− Utf8.toChars
85−
86−
87−{-# INLINE toBuilder #-}
88−toBuilder :: String -> B.Builder
89−toBuilder =
90− Utf8.toBuilder
91−
92−
93−
94−-- FROM COMMENT
95−
96−
97−fromComment :: P.Snippet -> String
98−fromComment (P.Snippet fptr off len _ _) =
99− unsafePerformIO $ withForeignPtr fptr $ \ptr ->
100− let
101− !pos = plusPtr ptr off
102− !end = plusPtr pos len
103− !str = fromChunks (chompChunks pos end pos [])
104− in
105− return str
106−
107−
108−chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
109−chompChunks pos end start revChunks =
110− if pos >= end then
111− reverse (addSlice start end revChunks)
112− else
113− let
114− !word = P.unsafeIndex pos
115− in
116− case word of
117− 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks
118− 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks
119− 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks
120− 0x0D {-\r-} ->
121− let
122− !newPos = plusPtr pos 1
123− in
124− chompChunks newPos end newPos (addSlice start pos revChunks)
125−
126− _ ->
127− let
128− !width = P.getCharWidth word
129− !newPos = plusPtr pos width
130− in
131− chompChunks newPos end start revChunks
132−
133−
134−chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
135−chompEscape escape pos end start revChunks =
136− let
137− !pos1 = plusPtr pos 1
138− in
139− chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)
140−
141−
142−addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]
143−addSlice start end revChunks =
144− if start == end
145− then revChunks
146− else Slice start (minusPtr end start) : revChunks
147−
148−
149−
150−-- FROM CHUNKS
151−
152−
153−data Chunk
154− = Slice (Ptr Word8) Int
155− | Escape Word8
156−
157−
158−fromChunks :: [Chunk] -> String
159−fromChunks chunks =
160− unsafeDupablePerformIO (stToIO (
161− do let !len = sum (map chunkToWidth chunks)
162− mba <- newByteArray len
163− writeChunks mba 0 chunks
164− freeze mba
165− ))
166−
167−
168−chunkToWidth :: Chunk -> Int
169−chunkToWidth chunk =
170− case chunk of
171− Slice _ len -> len
172− Escape _ -> 2
173−
174−
175−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()
176−writeChunks mba offset chunks =
177− case chunks of
178− [] ->
179− return ()
180−
181− chunk : chunks ->
182− case chunk of
183− Slice ptr len ->
184− do copyFromPtr ptr mba offset len
185− let !newOffset = offset + len
186− writeChunks mba newOffset chunks
187−
188− Escape word ->
189− do writeWord8 mba offset 0x5C {- \ -}
190− writeWord8 mba (offset + 1) word
191− let !newOffset = offset + 2
192− writeChunks mba newOffset chunks
compiler/src/Nitpick/Debug.hs+18−6
@@ -1,21 +1,33 @@
1module Nitpick.Debug
1module Nitpick.Debug
2− ( hasDebugUses
2+ ( findDebugUses
3 )
3 )
4 where
4 where
5
5
6
6
7−import qualified Data.Map.Utils as Map
7+import qualified Data.Map as Map
8+import qualified Data.Name as Name
9+import qualified Data.Set as Set
8
10
9import qualified AST.Optimized as Opt
11import qualified AST.Optimized as Opt
12+import qualified Elm.ModuleName as ModuleName
13+import qualified Elm.Package as Pkg
10
14
11
15
12
16
13−-- HAS DEBUG USES
17+-- FIND DEBUG USES
14
18
15
19
16−hasDebugUses :: Opt.LocalGraph -> Bool
20+findDebugUses :: Pkg.Name -> Opt.Graph -> [Name.Name]
17−hasDebugUses (Opt.LocalGraph _ graph _) =
21+findDebugUses pkg (Opt.Graph _ 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 =
18− Map.any nodeHasDebug graph
27+ if pkg == here && nodeHasDebug node then
28+ Set.insert home uses
29+ else
30+ uses
19
31
20
32
21nodeHasDebug :: Opt.Node -> Bool
33nodeHasDebug :: Opt.Node -> Bool
compiler/src/Nitpick/PatternMatches.hs+9−10
@@ -21,12 +21,11 @@ import qualified Data.List as List
21import qualified Data.Map as Map
21import qualified Data.Map as Map
22import qualified Data.Maybe as Maybe
22import qualified Data.Maybe as Maybe
23import qualified Data.Name as Name
23import qualified Data.Name as Name
24−import qualified Data.NonEmptyList as NE
24+import qualified Data.Utf8 as Utf8
25
25
26import qualified AST.Canonical as Can
26import qualified AST.Canonical as Can
27import qualified Data.Index as Index
27import qualified Data.Index as Index
28import qualified Elm.ModuleName as ModuleName
28import qualified Elm.ModuleName as ModuleName
29−import qualified Elm.String as ES
30import qualified Reporting.Annotation as A
29import qualified Reporting.Annotation as A
31
30
32
31
@@ -41,8 +40,8 @@ data Pattern
41
40
42
41
43data Literal
42data Literal
44− = Chr ES.String
43+ = Chr Utf8.String
45− | Str ES.String
44+ | Str Utf8.String
46 | Int Int
45 | Int Int
47 deriving (Eq)
46 deriving (Eq)
48
47
@@ -203,14 +202,14 @@ data Context
203-- CHECK
202-- CHECK
204
203
205
204
206−check :: Can.Module -> Either (NE.List Error) ()
205+check :: Can.Module -> Either [Error] ()
207−check (Can.Module _ _ _ decls _ _ _ _) =
206+check (Can.Module _ _ decls _ _ _ _) =
208 case checkDecls decls [] of
207 case checkDecls decls [] of
209 [] ->
208 [] ->
210 Right ()
209 Right ()
211
210
212− e:es ->
211+ errors ->
213− Left (NE.List e es)
212+ Left errors
214
213
215
214
216
215
@@ -223,8 +222,8 @@ checkDecls decls errors =
223 Can.Declare def subDecls ->
222 Can.Declare def subDecls ->
224 checkDef def $ checkDecls subDecls errors
223 checkDef def $ checkDecls subDecls errors
225
224
226− Can.DeclareRec def defs subDecls ->
225+ Can.DeclareRec defs subDecls ->
227− checkDef def (foldr checkDef (checkDecls subDecls errors) defs)
226+ foldr checkDef (checkDecls subDecls errors) defs
228
227
229 Can.SaveTheEnvironment ->
228 Can.SaveTheEnvironment ->
230 errors
229 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
30
31
31import qualified AST.Canonical as Can
32import qualified AST.Canonical as Can
32import qualified Data.Index as Index
33import qualified Data.Index as Index
33import qualified Elm.ModuleName as ModuleName
34import qualified Elm.ModuleName as ModuleName
34−import qualified Elm.String as ES
35import qualified Reporting.Annotation as A
35import qualified Reporting.Annotation as A
36
36
37
37
@@ -77,8 +77,8 @@ data Test
77 | IsNil
77 | IsNil
78 | IsTuple
78 | IsTuple
79 | IsInt Int
79 | IsInt Int
80− | IsChr ES.String
80+ | IsChr Utf8.String
81− | IsStr ES.String
81+ | IsStr Utf8.String
82 | IsBool Bool
82 | IsBool Bool
83 deriving (Eq, Ord)
83 deriving (Eq, Ord)
84
84
@@ -618,7 +618,7 @@ instance Binary Test where
618 5 -> liftM IsStr get
618 5 -> liftM IsStr get
619 6 -> liftM IsInt get
619 6 -> liftM IsInt get
620 7 -> liftM IsBool get
620 7 -> liftM IsBool get
621− _ -> fail "problem getting DecisionTree.Test binary"
621+ _ -> error "problem getting DecisionTree.Test binary"
622
622
623
623
624instance Binary Path where
624instance Binary Path where
@@ -634,4 +634,4 @@ instance Binary Path where
634 0 -> liftM2 Index get get
634 0 -> liftM2 Index get get
635 1 -> liftM Unbox get
635 1 -> liftM Unbox get
636 2 -> pure Empty
636 2 -> pure Empty
637− _ -> fail "problem getting DecisionTree.Path binary"
637+ _ -> error "problem getting DecisionTree.Path binary"
compiler/src/Optimize/Module.hs+38−35
@@ -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.LocalGraph
43+optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.Graph
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.LocalGraph Nothing Map.empty Map.empty
49+ Opt.Graph Map.empty 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.LocalGraph -> Opt.LocalGraph
60+addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.Graph -> Opt.Graph
61−addUnions home unions (Opt.LocalGraph main nodes fields) =
61+addUnions home unions (Opt.Graph mains nodes fields) =
62− Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields
62+ Opt.Graph mains (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.LocalGraph -> Opt.LocalGraph
86+addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.Graph -> Opt.Graph
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.LocalGraph -> Opt.LocalGraph
91+addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.Graph -> Opt.Graph
92−addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) =
92+addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains 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.LocalGraph main nodes fieldCoun
100 node =
100 node =
101 Opt.Define function Set.empty
101 Opt.Define function Set.empty
102 in
102 in
103− Opt.LocalGraph
103+ Opt.Graph
104− main
104+ mains
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.LocalGraph -> Opt.LocalGraph
121+addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph
122−addEffects home effects graph@(Opt.LocalGraph main nodes fields) =
122+addEffects home effects graph@(Opt.Graph mains 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.LocalGraph main 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.LocalGraph main newNodes fields
151+ Opt.Graph mains newNodes fields
152
152
153
153
154−addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph
154+addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.Graph -> Opt.Graph
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.LocalGraph -> Opt.LocalGraph
176+addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.Graph -> Opt.Graph
177−addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
177+addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =
178− Opt.LocalGraph
178+ Opt.Graph
179− main
179+ mains
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,20 +185,19 @@ addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
185-- ADD DECLS
185-- ADD DECLS
186
186
187
187
188−addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
188+addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph
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 d ds subDecls ->
194+ Can.DeclareRec defs subDecls ->
195− let defs = d:ds in
196 case findMain defs of
195 case findMain defs of
197 Nothing ->
196 Nothing ->
198 addDecls home annotations subDecls (addRecDefs home defs graph)
197 addDecls home annotations subDecls (addRecDefs home defs graph)
199
198
200 Just region ->
199 Just region ->
201− Result.throw $ E.BadCycle region (defToName d) (map defToName ds)
200+ Result.throw $ E.BadCycle region (map defToName defs)
202
201
203 Can.SaveTheEnvironment ->
202 Can.SaveTheEnvironment ->
204 Result.ok graph
203 Result.ok graph
@@ -213,10 +212,10 @@ findMain defs =
213 def:rest ->
212 def:rest ->
214 case def of
213 case def of
215 Can.Def (A.At region name) _ _ ->
214 Can.Def (A.At region name) _ _ ->
216− if name == Name._main then Just region else findMain rest
215+ if name == Name.main then Just region else findMain rest
217
216
218 Can.TypedDef (A.At region name) _ _ _ _ ->
217 Can.TypedDef (A.At region name) _ _ _ _ ->
219− if name == Name._main then Just region else findMain rest
218+ if name == Name.main then Just region else findMain rest
220
219
221
220
222defToName :: Can.Def -> Name.Name
221defToName :: Can.Def -> Name.Name
@@ -230,7 +229,7 @@ defToName def =
230-- ADD DEFS
229-- ADD DEFS
231
230
232
231
233−addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
232+addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph
234addDef home annotations def graph =
233addDef home annotations def graph =
235 case def of
234 case def of
236 Can.Def (A.At region name) args body ->
235 Can.Def (A.At region name) args body ->
@@ -242,17 +241,21 @@ addDef home annotations def graph =
242 addDefHelp region annotations home name (map fst typedArgs) body graph
241 addDefHelp region annotations home name (map fst typedArgs) body graph
243
242
244
243
245−addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
244+addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph
246−addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
245+addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =
247− if name /= Name._main then
246+ if name /= Name.main then
248 Result.ok (addDefNode home name args body Set.empty graph)
247 Result.ok (addDefNode home name args body Set.empty graph)
249 else
248 else
250 let
249 let
251 (Can.Forall _ tipe) = annotations ! name
250 (Can.Forall _ tipe) = annotations ! name
252
251
253 addMain (deps, fields, main) =
252 addMain (deps, fields, main) =
253+ let
254+ newMains = Map.insert home main mains
255+ newFields = Map.unionWith (+) fields fieldCounts
256+ in
254 addDefNode home name args body deps $
257 addDefNode home name args body deps $
255− Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)
258+ Opt.Graph newMains nodes newFields
256 in
259 in
257 case Type.deepDealias tipe of
260 case Type.deepDealias tipe of
258 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
261 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->
@@ -272,7 +275,7 @@ addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes
272 Result.throw (E.BadType region tipe)
275 Result.throw (E.BadType region tipe)
273
276
274
277
275−addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph
278+addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph
276addDefNode home name args body mainDeps graph =
279addDefNode home name args body mainDeps graph =
277 let
280 let
278 (deps, fields, def) =
281 (deps, fields, def) =
@@ -301,8 +304,8 @@ data State =
301 }
304 }
302
305
303
306
304−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph
307+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph
305−addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
308+addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =
306 let
309 let
307 names = reverse (map toName defs)
310 names = reverse (map toName defs)
308 cycleName = Opt.Global home (Name.fromManyNames names)
311 cycleName = Opt.Global home (Name.fromManyNames names)
@@ -313,8 +316,8 @@ addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =
313 Names.run $
316 Names.run $
314 foldM (addRecDef cycle) (State [] []) defs
317 foldM (addRecDef cycle) (State [] []) defs
315 in
318 in
316− Opt.LocalGraph
319+ Opt.Graph
317− main
320+ mains
318 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
321 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))
319 (Map.unionWith (+) fields fieldCounts)
322 (Map.unionWith (+) fields fieldCounts)
320
323
compiler/src/Optimize/Names.hs+7−1
@@ -24,6 +24,7 @@ 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
27import qualified Reporting.Annotation as A
28import qualified Reporting.Annotation as A
28
29
29
30
@@ -57,7 +58,12 @@ generate =
57registerKernel :: Name.Name -> a -> Tracker a
58registerKernel :: Name.Name -> a -> Tracker a
58registerKernel home value =
59registerKernel home value =
59 Tracker $ \uid deps fields ok ->
60 Tracker $ \uid deps fields ok ->
60− ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value
61+ ok uid (Set.insert (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
61
67
62
68
63registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr
69registerGlobal :: 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 custom type"
61+ error "toEncoder: bad union type"
62
62
63 Can.TRecord _ (Just _) ->
63 Can.TRecord _ (Just _) ->
64 error "toEncoder: bad record"
64 error "toEncoder: bad record"
@@ -68,7 +68,7 @@ toEncoder tipe =
68 encodeField (name, Can.FieldType _ fieldType) =
68 encodeField (name, Can.FieldType _ fieldType) =
69 do encoder <- toEncoder fieldType
69 do encoder <- toEncoder fieldType
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
71− return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
71+ return $ Opt.Tuple (Opt.Str (Name.toUtf8 name)) value Nothing
72 in
72 in
73 do object <- encode "object"
73 do object <- encode "object"
74 keyValuePairs <- traverse encodeField (Map.toList fields)
74 keyValuePairs <- traverse encodeField (Map.toList fields)
@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =
309 return $
309 return $
310 Opt.Call andThen
310 Opt.Call andThen
311 [ Opt.Function [key] decoder
311 [ Opt.Function [key] decoder
312− , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
312+ , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]
313 ]
313 ]
314
314
315
315
compiler/src/Parse/Declaration.hs+131−180
@@ -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
20import qualified Parse.Symbol as Symbol
19import qualified Parse.Symbol as Symbol
21import qualified Parse.Type as Type
20import qualified Parse.Type as Type
22import qualified Parse.Variable as Var
21import qualified Parse.Variable as Var
22+import Parse.Utils
23−import Parse.Primitives hiding (State)
23+import Parse.Primitives hiding (Parser, 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,182 +31,141 @@ import qualified Reporting.Error.Syntax as E
31
31
32
32
33data Decl
33data Decl
34− = Value (Maybe Src.Comment) (A.Located Src.Value)
34+ = Value (A.Located Src.Value)
35− | Union (Maybe Src.Comment) (A.Located Src.Union)
35+ | Union (A.Located Src.Union)
36− | Alias (Maybe Src.Comment) (A.Located Src.Alias)
36+ | Alias (A.Located Src.Alias)
37− | Port (Maybe Src.Comment) Src.Port
37+ | Port Src.Port
38
38
39
39
40−declaration :: Space.Parser E.Decl Decl
40+declaration :: SParser Decl
41declaration =
41declaration =
42− do maybeDocs <- chompDocComment
43− start <- getPosition
42+ do start <- getPosition
44− oneOf E.DeclStart
43+ oneOf E.XXX
45− [ typeDecl maybeDocs start
44+ [ typeDecl start
46− , portDecl maybeDocs
45+ , portDecl
47− , valueDecl maybeDocs start
46+ , valueDecl start
48 ]
47 ]
49
48
50
49
51
50
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−
68-- DEFINITION and ANNOTATION
51-- DEFINITION and ANNOTATION
69
52
70
53
71{-# INLINE valueDecl #-}
54{-# INLINE valueDecl #-}
72−valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
55+valueDecl :: A.Position -> SParser Decl
73−valueDecl maybeDocs start =
56+valueDecl start =
74− do name <- Var.lower E.DeclStart
57+ do name <- Var.lower
75 end <- getPosition
58 end <- getPosition
76− specialize (E.DeclDef name) $
59+ spaces
77− do Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
78− oneOf E.DeclDefEquals
60+ oneOf E.XXX
79− [
61+ [
80− do word1 0x3A {-:-} E.DeclDefEquals
62+ do word1 0x3A {-:-} E.XXX
81− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType
63+ pushContext start (E.Annotation name)
64+ spaces
82− (tipe, _) <- specialize E.DeclDefType Type.expression
65+ (tipe, _, space) <- Type.expression
83− Space.checkFreshLine E.DeclDefNameRepeat
66+ popContext ()
67+ checkAligned space
84− defName <- chompMatchingName name
68+ defName <- matchingName name
85− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
69+ let (A.At (A.Region defStart _) _) = defName
70+ pushContext defStart (E.Definition name)
71+ spaces
86− chompDefArgsAndBody maybeDocs start defName (Just tipe) []
72+ decl <- valueHelp start defName (Just tipe) []
73+ popContext decl
87− ,
74+ ,
75+ do pushContext start (E.Definition name)
88− chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []
76+ decl <- valueHelp start (A.at start end name) Nothing []
77+ popContext decl
89− ]
78+ ]
90−
79+
91−
80+
92−chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl
81+valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl
93−chompDefArgsAndBody maybeDocs start name tipe revArgs =
82+valueHelp start name tipe revArgs =
94− oneOf E.DeclDefEquals
83+ oneOf E.XXX
95− [ do arg <- specialize E.DeclDefArg Pattern.term
84+ [ do arg <- Pattern.term
96− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals
85+ spaces
97− chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs)
86+ valueHelp start name tipe (arg : revArgs)
98− , do word1 0x3D {-=-} E.DeclDefEquals
87+ , do word1 0x3D {-=-} E.XXX
99− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody
88+ spaces
100− (body, end) <- specialize E.DeclDefBody Expr.expression
89+ (body, end, space) <- Expr.expression
101− let value = Src.Value name (reverse revArgs) body tipe
90+ let value = A.at start end (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)
104 ]
92 ]
105
93
106
94
107−chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)
95+matchingName :: Name.Name -> Parser (A.Located Name.Name)
108−chompMatchingName expectedName =
96+matchingName expectedName =
109− let
110− (P.Parser parserL) = Var.lower E.DeclDefNameRepeat
97+ let (P.Parser parserL) = Var.lower in
111− in
112− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->
98+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->
113 let
99 let
114− cokL name newState@(P.State _ _ _ _ er ec) =
100+ cokL name newState@(P.State _ _ _ er ec _) =
115 if expectedName == name
101 if expectedName == name
116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
102 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
117− else cerr sr sc (E.DeclDefNameMatch name)
103+ else cerr sr sc ctx (E.MatchingName expectedName)
118
104
119− eokL name newState@(P.State _ _ _ _ er ec) =
105+ eokL name newState@(P.State _ _ _ er ec _) =
120 if expectedName == name
106 if expectedName == name
121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
107 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState
122− else eerr sr sc (E.DeclDefNameMatch name)
108+ else eerr sr sc ctx (E.MatchingName expectedName)
123 in
109 in
124 parserL state cokL eokL cerr eerr
110 parserL state cokL eokL cerr eerr
125
111
126
112
127
113
128−-- TYPE DECLARATIONS
114+-- TYPE ALIAS and UNION TYPES
129
115
130
116
131{-# INLINE typeDecl #-}
117{-# INLINE typeDecl #-}
132−typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl
118+typeDecl :: A.Position -> SParser Decl
133−typeDecl maybeDocs start =
119+typeDecl start =
134− inContext E.DeclType (Keyword.type_ E.DeclStart) $
120+ do Keyword.type_
135− do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName
121+ spaces
136− oneOf E.DT_Name
122+ oneOf E.XXX
137− [
123+ [
138− inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $
124+ inContext E.TypeAlias Keyword.alias_ $
139− do Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals
125+ do spaces
140− (name, args) <- chompAliasNameToEquals
126+ (name, args) <- nameArgsEquals
141− (tipe, end) <- specialize E.AliasBody Type.expression
127+ (tipe, end, pos) <- Type.expression
142− let alias = A.at start end (Src.Alias name args tipe)
128+ let alias = A.at start end (Src.Alias name args tipe)
143− return (Alias maybeDocs alias, end)
129+ return (Alias alias, end, pos)
144− ,
130+ ,
145− specialize E.DT_Union $
131+ do pushContext start E.TypeUnion
146− do (name, args) <- chompCustomNameToEquals
132+ (name, args) <- nameArgsEquals
147− (firstVariant, firstEnd) <- Type.variant
133+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
148− (variants, end) <- chompVariants [firstVariant] firstEnd
134+ (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace
149− let union = A.at start end (Src.Union name args variants)
135+ let union = A.at start end (Src.Union name args ctors)
150− return (Union maybeDocs union, end)
136+ popContext (Union union, end, pos)
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 )
174− ]
137+ ]
175−
176−
177−
178−-- CUSTOM TYPES
179
138
180
139
181−chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
140+nameArgsEquals :: Parser (A.Located Name.Name, [A.Located Name.Name])
182−chompCustomNameToEquals =
141+nameArgsEquals =
183− do name <- addLocation (Var.upper E.CT_Name)
142+ do name <- addLocation Var.upper
184− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
143+ spaces
185− chompCustomNameToEqualsHelp name []
144+ nameArgsEqualsHelp name []
186
145
187
146
188−chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])
147+nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])
189−chompCustomNameToEqualsHelp name args =
148+nameArgsEqualsHelp name args =
190− oneOf E.CT_Equals
149+ oneOf E.XXX
191− [ do arg <- addLocation (Var.lower E.CT_Equals)
150+ [ do arg <- addLocation Var.lower
192− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals
151+ spaces
193− chompCustomNameToEqualsHelp name (arg:args)
152+ nameArgsEqualsHelp name (arg:args)
194− , do word1 0x3D {-=-} E.CT_Equals
153+ , do word1 0x3D {-=-} E.XXX
195− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals
154+ spaces
196 return ( name, reverse args )
155 return ( name, reverse args )
197 ]
156 ]
198
157
199
158
200−chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])]
159+chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]
201−chompVariants variants end =
160+chompConstructors ctors end pos =
202− oneOfWithFallback
161+ oneOf E.XXX
203− [ do Space.checkIndent end E.CT_IndentBar
162+ [ do checkSpace pos
204− word1 0x7C {-|-} E.CT_Bar
163+ word1 0x7C {-|-} E.XXX
205− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar
164+ spaces
206− (variant, newEnd) <- Type.variant
165+ (ctor, newEnd, newSpace) <- Type.unionConstructor
207− chompVariants (variant:variants) newEnd
166+ chompConstructors (ctor:ctors) newEnd newSpace
167+ , return ( reverse ctors, end, pos )
208 ]
168 ]
209− (reverse variants, end)
210
169
211
170
212
171
@@ -214,19 +173,16 @@ chompVariants variants end =
214
173
215
174
216{-# INLINE portDecl #-}
175{-# INLINE portDecl #-}
217−portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl
176+portDecl :: SParser Decl
218−portDecl maybeDocs =
177+portDecl =
219− inContext E.Port (Keyword.port_ E.DeclStart) $
178+ inContext E.Port Keyword.port_ $
220− do Space.chompAndCheckIndent E.PortSpace E.PortIndentName
179+ do spaces
221− name <- addLocation (Var.lower E.PortName)
180+ name <- addLocation Var.lower
222− Space.chompAndCheckIndent E.PortSpace E.PortIndentColon
181+ spaces
223− word1 0x3A {-:-} E.PortColon
182+ word1 0x3A {-:-} E.XXX
224− Space.chompAndCheckIndent E.PortSpace E.PortIndentType
183+ spaces
225− (tipe, end) <- specialize E.PortType Type.expression
184+ (tipe, end, pos) <- Type.expression
226− return
227− ( Port maybeDocs (Src.Port name tipe)
185+ return ( Port (Src.Port name tipe), end, pos )
228− , end
229− )
230
186
231
187
232
188
@@ -235,32 +191,27 @@ portDecl maybeDocs =
235
191
236-- INVARIANT: always chomps to a freshline
192-- INVARIANT: always chomps to a freshline
237--
193--
238−infix_ :: Parser E.Module (A.Located Src.Infix)
194+infix_ :: Parser (A.Located Src.Binop)
239infix_ =
195infix_ =
240− let
241− err = E.Infix
242− _err = \_ -> E.Infix
243− in
244 do start <- getPosition
196 do start <- getPosition
245− Keyword.infix_ err
197+ inContext E.Infix Keyword.infix_ $
246− Space.chompAndCheckIndent _err err
198+ do spaces
247− associativity <-
199+ associativity <-
248− oneOf err
200+ oneOf E.XXX
249− [ Keyword.left_ err >> return Binop.Left
201+ [ Keyword.left_ >> return Binop.Left
250− , Keyword.right_ err >> return Binop.Right
202+ , Keyword.right_ >> return Binop.Right
251− , Keyword.non_ err >> return Binop.Non
203+ , Keyword.non_ >> return Binop.Non
252− ]
204+ ]
253− Space.chompAndCheckIndent _err err
205+ spaces
254− precedence <- Number.precedence err
206+ precedence <- Number.precedence
255− Space.chompAndCheckIndent _err err
207+ spaces
256− word1 0x28 {-(-} err
208+ word1 0x28 {-(-} E.XXX
257− op <- Symbol.operator err _err
209+ op <- Symbol.binop
258− word1 0x29 {-)-} err
210+ word1 0x29 {-)-} E.XXX
259− Space.chompAndCheckIndent _err err
211+ spaces
260− word1 0x3D {-=-} err
212+ word1 0x3D {-=-} E.XXX
261− Space.chompAndCheckIndent _err err
213+ spaces
262− name <- Var.lower err
214+ name <- Var.lower
263− end <- getPosition
215+ end <- getPosition
264− Space.chomp _err
265− Space.checkFreshLine err
216+ checkFreshLine =<< whitespace
266− return (A.at start end (Src.Infix op associativity precedence name))
217+ return (A.at start end (Src.Binop op associativity precedence name))
compiler/src/Parse/Docs.hsnew file+275

This diff is too big to show here.

compiler/src/Parse/Expression.hs+341−330

This diff is too big to show here.

compiler/src/Parse/Keyword.hs+84−83

This diff is too big to show here.

compiler/src/Parse/Module.hs+259−330

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Parse/Repl.hsnew file+117

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Parse/Space.hsdeleted−273

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Parse/Utils.hsnew file+259

This diff is too big to show here.

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

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+54−96

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Error/Import.hsdeleted−162

This diff is too big to show here.

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

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+8−9

This diff is too big to show here.

compiler/src/Reporting/Error/Syntax.hs+626−5687

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Report.hs+63

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

docs/upgrade-instructions/0.19.1.mddeleted−60

This diff is too big to show here.

elm.cabal+98−69

This diff is too big to show here.

hints/bad-recursion.mddeleted−133

This diff is too big to show here.

hints/comparing-custom-types.mddeleted−98

This diff is too big to show here.

hints/comparing-records.mddeleted−85

This diff is too big to show here.

hints/implicit-casts.mddeleted−50

This diff is too big to show here.

hints/import-cycles.mddeleted−184

This diff is too big to show here.

hints/imports.mddeleted−126

This diff is too big to show here.

hints/infinite-type.mddeleted−42

This diff is too big to show here.

hints/init.mddeleted−55

This diff is too big to show here.

hints/missing-patterns.mddeleted−139

This diff is too big to show here.

hints/optimize.mddeleted−59

This diff is too big to show here.

hints/port-modules.mddeleted−32

This diff is too big to show here.

hints/recursive-alias.mddeleted−162

This diff is too big to show here.

hints/repl.mddeleted−73

This diff is too big to show here.

hints/shadowing.mddeleted−70

This diff is too big to show here.

hints/tuples.mddeleted−19

This diff is too big to show here.

hints/type-annotations.mddeleted−60

This diff is too big to show here.

installers/README.mddeleted−32

This diff is too big to show here.

installers/linux/Dockerfiledeleted−39

This diff is too big to show here.

installers/linux/README.mddeleted−93

This diff is too big to show here.

installers/mac/Distribution.xml+3−5

This diff is too big to show here.

installers/mac/README.mddeleted−93

This diff is too big to show here.

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

Binary file not shown.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/PUBLISHING.md+141−29

This diff is too big to show here.

installers/npm/README.md+23−30

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/download.jsdeleted−114

This diff is too big to show here.

installers/npm/index.jsnew file+21

This diff is too big to show here.

installers/npm/install.jsdeleted−4

This diff is too big to show here.

installers/npm/package.json+15−13

This diff is too big to show here.

installers/npm/troubleshooting.mddeleted−76

This diff is too big to show here.

installers/win/Nsisfile.nsi+16−16

This diff is too big to show here.

installers/win/README.md+3−18

This diff is too big to show here.

installers/win/file.iconew file

Binary file not shown.

installers/win/inst.dat+2−1

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+2−1

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifnew file

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+15−20

This diff is too big to show here.

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

This diff is too big to show here.

roadmap.mddeleted−29

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsdeleted−148

This diff is too big to show here.

terminal/src/Bump.hs+8−158

This diff is too big to show here.

terminal/src/Develop.hs+77−70

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hs+6−348

This diff is too big to show here.

terminal/src/Init.hs+36−40

This diff is too big to show here.

terminal/src/Install.hs+14−401

This diff is too big to show here.

terminal/src/Main.hs+36−32

This diff is too big to show here.

terminal/src/Make.hs+32−257

This diff is too big to show here.

terminal/src/Publish.hs+8−529

This diff is too big to show here.

terminal/src/Repl.hs+197−522

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

worker/elm.cabaldeleted−210

This diff is too big to show here.

worker/elm.jsondeleted−26

This diff is too big to show here.

worker/nginx.confdeleted−22

This diff is too big to show here.

worker/outlines/compile/elm.jsondeleted−32

This diff is too big to show here.

worker/outlines/repl/elm.jsondeleted−19

This diff is too big to show here.

worker/src/Artifacts.hsdeleted−155

This diff is too big to show here.

worker/src/Cors.hsdeleted−48

This diff is too big to show here.

worker/src/Endpoint/Compile.hsdeleted−323

This diff is too big to show here.

worker/src/Endpoint/Quotes.hsdeleted−114

This diff is too big to show here.

worker/src/Endpoint/Repl.hsdeleted−244

This diff is too big to show here.

worker/src/Errors.elmdeleted−217

This diff is too big to show here.

worker/src/Main.hsdeleted−73

This diff is too big to show here.