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

No changes to the content.

.travis.yml+23−20
@@ -1,25 +1,28 @@
1−sudo: false
1+language: minimal
2−
2+services: docker
3−addons:
4− apt:
5− sources:
6− - hvr-ghc
7− packages:
8− - ghc-7.10.1
9− - cabal-install-1.22
10− - happy
11− - alex
12
3
4+env:
5+ global:
6+ - LINUX_ARCHIVE=binary-for-linux-64-bit.gz
13
7
14before_install:
8before_install:
15−- export PATH=/opt/ghc/7.10.1/bin:/opt/cabal/1.22/bin:$PATH
9+ - docker build -t elm -f installers/linux/Dockerfile .
16−
10+ - docker cp $(docker create elm):/usr/local/bin/elm .
17−
11+ - gzip -9 -c elm > $LINUX_ARCHIVE
18−install:
19− - travis_retry cabal update
20− - cabal install --only-dependencies --enable-tests
21
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
22
23−script:
23+notifications:
24− - cabal configure --enable-tests
24+ email:
25− - cabal test
25+ recipients:
26+ - rlefevre@dmy.fr
27+ on_success: change
28+ on_failure: change
ContributorAgreement.pdfdeleted

Binary file not shown.

How to Request Features.mddeleted−93
@@ -1,93 +0,0 @@
1−# How to make a Feature Request
2−
3−Adding features is hard work and has long term implications for Elm.
4−If you think your particular feature is important, help make it happen
5−by doing some of the background work that goes into actually adding it.
6−
7−### Before making a Request / Formatting:
8−
9− - Make sure your feature has not already been requested. Look through the
10− email list to find similar requests.
11− - Submit feature requests by emailing the list. This allows the broadest
12− discussion and does not clutter up the GitHub repository with speculative
13− issues. I'd prefer to use the GitHub issue tracker for bug tracking and
14− issues with the existing code base.
15− - Label all feature requests with a subject like "Request: _____". For
16− example, if you want to be the umpteenth person to request type classes,
17− you would use the subject "Request: Type Classes".
18−
19−### Body of the Request:
20−
21−Your request should address all of the following issues:
22−
23−**General Problem:** Clearly define the purpose of adding the feature.
24−What general problem do you want to solve? Why is that problem important?
25−Why is it important for a functional GUI language?
26−
27−**Specific Use-Cases:** What are the specific cases when the general problem
28−is actually an issue? How often does this case come up? Why are these cases
29−important to easily designing graphical user interfaces? Why are existing
30−solutions in Elm unsuitable?
31−
32−**Background Materials:** Are there relevant papers on the topic? Are there
33−languages or libraries that already have this feature? Organize this material
34−and provide a concise and helpful overview.
35−
36−**Alternatives:** What are all the ways to address the general problem or a
37−closely related problem? For example, the semantic flexibility of type classes
38−can be largely replicated with a module system in the style of ML.
39−What are the strengths and weakness of each of the alternative solutions?
40−
41−**Suggested Approach:** Outline your specific approach. How does it address
42−the general problem? How does it work? How hard is it going to be to add?
43−What other language features does it depend on that need to be added first?
44−Try to take a look at the relevant code to see if it would require significant
45−changes. If you are suggesting an API or library changes, include an interface
46−(a list of type signatures) for the functions you would like to add (perhaps
47−multiple interfaces if there are many good approaches).
48−
49−**Known Issues:** Search for issues that people have already found. Think of
50−any other possible downside and list them too. For example, one downside of
51−typeclasses is that they are globally defined for each type, so you cannot
52−have multiple `Ord` instances for Strings. This can lead to namespace pollution
53−within a project. In general you can only implement an "interface" once per
54−type, so it is very tricky to get the flexibility of ML's module functors.
55−
56−**Justification:** Why is the added complexity of your feature worth it? Discuss
57−both implementation complexity in the compiler, and conceptual complexity that
58−users must deal with. Why is your feature better than the alternative solutions?
59−Why is it okay to ignore the known issues? Is there any way to overcome the known
60−issues? Will it be difficult or confusing for users coming from JavaScript?
61−
62−### Some final notes:
63−
64−If for some reason you cannot provide details for some of these categories,
65−explain why the category is not applicable.
66−
67−Re-read before posting. Is your request constructive? Is it well organized?
68−Are there any details you forgot? Can anything be clarified or trimmed down?
69−Considering a request takes time, so be considerate about how much work a
70−reader has to do to take it seriously.
71−
72−A feature request is not an opportunity to be sassy or glib. Try to present
73−the information and argument clearly, concisely, thoroughly, and in an unbiased
74−manner.
75−
76−This is likely to be an iterative process. People will have comments and
77−questions. Everyone please be kind. Commenters, if you think you have a
78−concern, raise it as a question: "But what happens when you do blah?" instead
79−of "This will break when you do blah". Assume you have misunderstood their
80−proposal or only have a shallow understanding of it. Seek clarification, not victory.
81−
82−Comments are not a place for flame wars. Discuss specific issues. Vague
83−complaining and unsupported claims should either be forgotten or developed
84−into specific and well-supported concerns.
85−
86−I am always working hard to add cool stuff to Elm, and it is a lot of work.
87−I must prioritize issues to focus on the things that have the highest impact
88−for improving the quality of Elm, addressing the concerns of current users,
89−and making Elm more appealing for new users. I do not have infinite time,
90−so some things must receive more attention than others. I apologize in advance.
91−
92−And to summarize, just be cool! I want Elm to be really fun and easy to use,
93−and I want your projects to be amazing!
LICENSE+6−25
@@ -1,30 +1,11 @@
1−Copyright (c) 2012-present, Evan Czaplicki
1+Copyright 2012-present Evan Czaplicki
2
2
3−All rights reserved.
3+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
4
4
5−Redistribution and use in source and binary forms, with or without
5+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
6−modification, are permitted provided that the following conditions are met:
7
6
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
7+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
10
8
11− * Redistributions in binary form must reproduce the above
9+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15
10
16− * Neither the name of Evan Czaplicki nor the names of other
11+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md+10−5
@@ -1,17 +1,22 @@
1−# The Elm Compiler [![Build Status](https://travis-ci.org/elm-lang/elm-compiler.svg?branch=master)](https://travis-ci.org/elm-lang/elm-compiler)
1+# Elm
2
2
3−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
3+A delightful language for reliable webapps.
4
4
5+Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)
6+
7+
8+<br>
5
9
6## Install
10## Install
7
11
8−Follow [these instructions][installer]!
12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
9
13
10− [installer]: https://guide.elm-lang.org/install.html
14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
11
15
16+<br>
12
17
13## Help
18## Help
14
19
15If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
20If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
16
21
17−[slack]: http://elmlang.herokuapp.com/
22+[slack]: http://elmlang.herokuapp.com/
Setup.hsdeleted−2
@@ -1,2 +0,0 @@
1−import Distribution.Simple
2−main = defaultMain
builder/builder.cabaldeleted−123
@@ -1,123 +0,0 @@
1−Name: builder
2−Version: 0.19.0
3−
4−Synopsis:
5− Library to download and build Elm projects
6−Description:
7− Solves dependencies, crawls Elm files, parallelizes downloads,
8− parallelizes compilation, reports coherent errors, etc.
9−
10−Homepage:
11− http://github.com/evancz/builder
12−
13−License: BSD3
14−License-file: LICENSE
15−
16−Author: Evan Czaplicki
17−Maintainer: info@elm-lang.org
18−Copyright: Copyright: (c) 2013-present Evan Czaplicki
19−
20−Category: Language
21−
22−Build-type: Simple
23−Cabal-version: >=1.9
24−
25−source-repository head
26− type: git
27− location: git://github.com/evancz/builder.git
28−
29−Flag dev {
30− Description: Turn off optimization and make warnings errors
31− Default: False
32−}
33−
34−
35−Library
36− if flag(dev)
37− ghc-options: -O0 -Wall -Werror
38− else
39− ghc-options: -threaded -O2 -fsimpl-tick-factor=140
40−
41− Hs-Source-Dirs:
42− src
43−
44− exposed-modules:
45− Elm.Bump,
46− Elm.Diff,
47− Elm.Install,
48− Elm.PerUserCache,
49− Elm.Project,
50− Elm.Project.Constraint,
51− Elm.Project.Flags,
52− Elm.Project.Json,
53− Elm.Project.Licenses,
54− Elm.Publish,
55− File.IO,
56− Reporting.Progress.Repl,
57− Reporting.Progress.Terminal,
58− Reporting.Task
59−
60− other-modules:
61− Deps.Diff,
62− Deps.Explorer,
63− Deps.Get,
64− Deps.Solver,
65− Deps.Verify,
66− Deps.Website,
67− Elm.Project.Root,
68− Elm.Project.Summary,
69− File.Args,
70− File.Artifacts,
71− File.Compile,
72− File.Crawl,
73− File.Find,
74− File.Hash,
75− File.Header,
76− File.Plan,
77− Generate.Functions,
78− Generate.Output,
79− Reporting.Error,
80− Reporting.Error.Assets,
81− Reporting.Error.Bump,
82− Reporting.Error.Compile,
83− Reporting.Error.Crawl,
84− Reporting.Error.Deps,
85− Reporting.Error.Diff,
86− Reporting.Error.Help,
87− Reporting.Error.Http,
88− Reporting.Error.Publish,
89− Reporting.Progress,
90− Reporting.Progress.Bar,
91− Reporting.Task.Http,
92− Stuff.Paths,
93− Stuff.Verify
94−
95− Build-depends:
96− ansi-wl-pprint >= 0.6.7.3,
97− base >=4.2 && <5,
98− binary >= 0.8 && < 0.9,
99− blaze-html,
100− blaze-markup,
101− containers >= 0.3 && < 0.6,
102− bytestring >= 0.9 && < 0.11,
103− directory >= 1.2.3.0 && < 2.0,
104− elm-compiler == 0.19.0,
105− filepath >= 1 && < 2.0,
106− fsnotify >= 0.2.1,
107− HTTP >= 4000.2.5 && < 4000.4,
108− http-client >= 0.5 && < 0.6,
109− http-client-tls >= 0.3 && < 0.4,
110− http-types >= 0.9 && < 1.0,
111− logict,
112− mtl >= 2.2.1 && < 3,
113− pretty,
114− process,
115− raw-strings-qq,
116− scientific,
117− semigroups,
118− SHA,
119− text,
120− time,
121− unordered-containers,
122− vector,
123− zip-archive
builder/src/BackgroundWriter.hsnew file+42
@@ -0,0 +1,42 @@
1+{-# LANGUAGE BangPatterns #-}
2+module BackgroundWriter
3+ ( Scope
4+ , withScope
5+ , writeBinary
6+ )
7+ where
8+
9+
10+import Control.Concurrent (forkIO)
11+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
12+import qualified Data.Binary as Binary
13+import Data.Foldable (traverse_)
14+
15+import qualified File
16+
17+
18+
19+-- BACKGROUND WRITER
20+
21+
22+newtype Scope =
23+ Scope (MVar [MVar ()])
24+
25+
26+withScope :: (Scope -> IO a) -> IO a
27+withScope callback =
28+ do workList <- newMVar []
29+ result <- callback (Scope workList)
30+ mvars <- takeMVar workList
31+ traverse_ takeMVar mvars
32+ return result
33+
34+
35+writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()
36+writeBinary (Scope workList) path value =
37+ do mvar <- newEmptyMVar
38+ _ <- forkIO (File.writeBinary path value >> putMVar mvar ())
39+ oldWork <- takeMVar workList
40+ let !newWork = mvar:oldWork
41+ putMVar workList newWork
42+
builder/src/Build.hsnew file+1251
@@ -0,0 +1,1251 @@
1+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3+module Build
4+ ( fromExposed
5+ , fromPaths
6+ , fromRepl
7+ , Artifacts(..)
8+ , Root(..)
9+ , Module(..)
10+ , CachedInterface(..)
11+ , ReplArtifacts(..)
12+ , DocsGoal(..)
13+ , getRootNames
14+ )
15+ where
16+
17+
18+import Control.Concurrent (forkIO)
19+import Control.Concurrent.MVar
20+import Control.Monad (filterM, mapM_, sequence_)
21+import qualified Data.ByteString as B
22+import qualified Data.Char as Char
23+import qualified Data.Graph as Graph
24+import qualified Data.List as List
25+import qualified Data.Map.Utils as Map
26+import qualified Data.Map.Strict as Map
27+import Data.Map.Strict ((!))
28+import qualified Data.Maybe as Maybe
29+import qualified Data.Name as Name
30+import qualified Data.NonEmptyList as NE
31+import qualified Data.OneOrMore as OneOrMore
32+import qualified Data.Set as Set
33+import qualified System.Directory as Dir
34+import qualified System.FilePath as FP
35+import System.FilePath ((</>), (<.>))
36+
37+import qualified AST.Canonical as Can
38+import qualified AST.Source as Src
39+import qualified AST.Optimized as Opt
40+import qualified Compile
41+import qualified Elm.Details as Details
42+import qualified Elm.Docs as Docs
43+import qualified Elm.Interface as I
44+import qualified Elm.ModuleName as ModuleName
45+import qualified Elm.Outline as Outline
46+import qualified Elm.Package as Pkg
47+import qualified File
48+import qualified Json.Encode as E
49+import qualified Parse.Module as Parse
50+import qualified Reporting
51+import qualified Reporting.Annotation as A
52+import qualified Reporting.Error as Error
53+import qualified Reporting.Error.Docs as EDocs
54+import qualified Reporting.Error.Syntax as Syntax
55+import qualified Reporting.Error.Import as Import
56+import qualified Reporting.Exit as Exit
57+import qualified Reporting.Render.Type.Localizer as L
58+import qualified Stuff
59+
60+
61+
62+-- ENVIRONMENT
63+
64+
65+data Env =
66+ Env
67+ { _key :: Reporting.BKey
68+ , _root :: FilePath
69+ , _project :: Parse.ProjectType
70+ , _srcDirs :: [AbsoluteSrcDir]
71+ , _buildID :: Details.BuildID
72+ , _locals :: Map.Map ModuleName.Raw Details.Local
73+ , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
74+ }
75+
76+
77+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
78+makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
79+ case validOutline of
80+ Details.ValidApp givenSrcDirs ->
81+ do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82+ return $ Env key root Parse.Application srcDirs buildID locals foreigns
83+
84+ Details.ValidPkg pkg _ _ ->
85+ do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
86+ return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
87+
88+
89+
90+-- SOURCE DIRECTORY
91+
92+
93+newtype AbsoluteSrcDir =
94+ AbsoluteSrcDir FilePath
95+
96+
97+toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98+toAbsoluteSrcDir root srcDir =
99+ AbsoluteSrcDir <$> Dir.canonicalizePath
100+ (
101+ case srcDir of
102+ Outline.AbsoluteSrcDir dir -> dir
103+ Outline.RelativeSrcDir dir -> root </> dir
104+ )
105+
106+
107+addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108+addRelative (AbsoluteSrcDir srcDir) path =
109+ srcDir </> path
110+
111+
112+
113+-- FORK
114+
115+
116+-- PERF try using IORef semephore on file crawl phase?
117+-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
118+-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
119+--
120+fork :: IO a -> IO (MVar a)
121+fork work =
122+ do mvar <- newEmptyMVar
123+ _ <- forkIO $ putMVar mvar =<< work
124+ return mvar
125+
126+
127+{-# INLINE forkWithKey #-}
128+forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
129+forkWithKey func dict =
130+ Map.traverseWithKey (\k v -> fork (func k v)) dict
131+
132+
133+
134+-- FROM EXPOSED
135+
136+
137+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
138+fromExposed style root details docsGoal exposed@(NE.List e es) =
139+ Reporting.trackBuild style $ \key ->
140+ do env <- makeEnv key root details
141+ dmvar <- Details.loadInterfaces root details
142+
143+ -- crawl
144+ mvar <- newEmptyMVar
145+ let docsNeed = toDocsNeed docsGoal
146+ roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
147+ putMVar mvar roots
148+ mapM_ readMVar roots
149+ statuses <- traverse readMVar =<< readMVar mvar
150+
151+ -- compile
152+ midpoint <- checkMidpoint dmvar statuses
153+ case midpoint of
154+ Left problem ->
155+ return (Left (Exit.BuildProjectProblem problem))
156+
157+ Right foreigns ->
158+ do rmvar <- newEmptyMVar
159+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
160+ putMVar rmvar resultMVars
161+ results <- traverse readMVar resultMVars
162+ writeDetails root details results
163+ finalizeExposed root docsGoal exposed results
164+
165+
166+
167+-- FROM PATHS
168+
169+
170+data Artifacts =
171+ Artifacts
172+ { _name :: Pkg.Name
173+ , _deps :: Dependencies
174+ , _roots :: NE.List Root
175+ , _modules :: [Module]
176+ }
177+
178+
179+data Module
180+ = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
181+ | Cached ModuleName.Raw Bool (MVar CachedInterface)
182+
183+
184+type Dependencies =
185+ Map.Map ModuleName.Canonical I.DependencyInterface
186+
187+
188+fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189+fromPaths style root details paths =
190+ Reporting.trackBuild style $ \key ->
191+ do env <- makeEnv key root details
192+
193+ elroots <- findRoots env paths
194+ case elroots of
195+ Left problem ->
196+ return (Left (Exit.BuildProjectProblem problem))
197+
198+ Right lroots ->
199+ do -- crawl
200+ dmvar <- Details.loadInterfaces root details
201+ smvar <- newMVar Map.empty
202+ srootMVars <- traverse (fork . crawlRoot env smvar) lroots
203+ sroots <- traverse readMVar srootMVars
204+ statuses <- traverse readMVar =<< readMVar smvar
205+
206+ midpoint <- checkMidpointAndRoots dmvar statuses sroots
207+ case midpoint of
208+ Left problem ->
209+ return (Left (Exit.BuildProjectProblem problem))
210+
211+ Right foreigns ->
212+ do -- compile
213+ rmvar <- newEmptyMVar
214+ resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
215+ putMVar rmvar resultsMVars
216+ rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
217+ results <- traverse readMVar resultsMVars
218+ writeDetails root details results
219+ toArtifacts env foreigns results <$> traverse readMVar rrootMVars
220+
221+
222+
223+-- GET ROOT NAMES
224+
225+
226+getRootNames :: Artifacts -> NE.List ModuleName.Raw
227+getRootNames (Artifacts _ _ roots _) =
228+ fmap getRootName roots
229+
230+
231+getRootName :: Root -> ModuleName.Raw
232+getRootName root =
233+ case root of
234+ Inside name -> name
235+ Outside name _ _ -> name
236+
237+
238+
239+-- CRAWL
240+
241+
242+type StatusDict =
243+ Map.Map ModuleName.Raw (MVar Status)
244+
245+
246+data Status
247+ = SCached Details.Local
248+ | SChanged Details.Local B.ByteString Src.Module DocsNeed
249+ | SBadImport Import.Problem
250+ | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
251+ | SForeign Pkg.Name
252+ | SKernel
253+
254+
255+crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
256+crawlDeps env mvar deps blockedValue =
257+ do statusDict <- takeMVar mvar
258+ let depsDict = Map.fromKeys (\_ -> ()) deps
259+ let newsDict = Map.difference depsDict statusDict
260+ statuses <- Map.traverseWithKey crawlNew newsDict
261+ putMVar mvar (Map.union statuses statusDict)
262+ mapM_ readMVar statuses
263+ return blockedValue
264+ where
265+ crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
266+
267+
268+crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
269+crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
270+ do let fileName = ModuleName.toFilePath name <.> "elm"
271+
272+ paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
273+
274+ case paths of
275+ [path] ->
276+ case Map.lookup name foreigns of
277+ Just (Details.Foreign dep deps) ->
278+ return $ SBadImport $ Import.Ambiguous path [] dep deps
279+
280+ Nothing ->
281+ do newTime <- File.getTime path
282+ case Map.lookup name locals of
283+ Nothing ->
284+ crawlFile env mvar docsNeed name path newTime buildID
285+
286+ Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
287+ if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
288+ then crawlFile env mvar docsNeed name path newTime lastChange
289+ else crawlDeps env mvar deps (SCached local)
290+
291+ p1:p2:ps ->
292+ return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
293+
294+ [] ->
295+ case Map.lookup name foreigns of
296+ Just (Details.Foreign dep deps) ->
297+ case deps of
298+ [] ->
299+ return $ SForeign dep
300+
301+ d:ds ->
302+ return $ SBadImport $ Import.AmbiguousForeign dep d ds
303+
304+ Nothing ->
305+ if Name.isKernel name && Parse.isKernel projectType then
306+ do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
307+ return $ if exists then SKernel else SBadImport Import.NotFound
308+ else
309+ return $ SBadImport Import.NotFound
310+
311+
312+crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
313+crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
314+ do source <- File.readUtf8 (root </> path)
315+
316+ case Parse.fromByteString projectType source of
317+ Left err ->
318+ return $ SBadSyntax path time source err
319+
320+ Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
321+ case maybeActualName of
322+ Nothing ->
323+ return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
324+
325+ Just name@(A.At _ actualName) ->
326+ if expectedName == actualName then
327+ let
328+ deps = map Src.getImportName imports
329+ local = Details.Local path time deps (any isMain values) lastChange buildID
330+ in
331+ crawlDeps env mvar deps (SChanged local source modul docsNeed)
332+ else
333+ return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
334+
335+
336+isMain :: A.Located Src.Value -> Bool
337+isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
338+ name == Name._main
339+
340+
341+
342+-- CHECK MODULE
343+
344+
345+type ResultDict =
346+ Map.Map ModuleName.Raw (MVar Result)
347+
348+
349+data Result
350+ = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
351+ | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
352+ | RCached Bool Details.BuildID (MVar CachedInterface)
353+ | RNotFound Import.Problem
354+ | RProblem Error.Module
355+ | RBlocked
356+ | RForeign I.Interface
357+ | RKernel
358+
359+
360+data CachedInterface
361+ = Unneeded
362+ | Loaded I.Interface
363+ | Corrupted
364+
365+
366+checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
367+checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
368+ case status of
369+ SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
370+ do results <- readMVar resultsMVar
371+ depsStatus <- checkDeps root results deps lastCompile
372+ case depsStatus of
373+ DepsChange ifaces ->
374+ do source <- File.readUtf8 path
375+ case Parse.fromByteString projectType source of
376+ Right modul -> compile env (DocsNeed False) local source ifaces modul
377+ Left err ->
378+ return $ RProblem $
379+ Error.Module name path time source (Error.BadSyntax err)
380+
381+ DepsSame _ _ ->
382+ do mvar <- newMVar Unneeded
383+ return (RCached hasMain lastChange mvar)
384+
385+ DepsBlock ->
386+ return RBlocked
387+
388+ DepsNotFound problems ->
389+ do source <- File.readUtf8 path
390+ return $ RProblem $ Error.Module name path time source $
391+ case Parse.fromByteString projectType source of
392+ Right (Src.Module _ _ _ imports _ _ _ _ _) ->
393+ Error.BadImports (toImportErrors env results imports problems)
394+
395+ Left err ->
396+ Error.BadSyntax err
397+
398+ SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
399+ do results <- readMVar resultsMVar
400+ depsStatus <- checkDeps root results deps lastCompile
401+ case depsStatus of
402+ DepsChange ifaces ->
403+ compile env docsNeed local source ifaces modul
404+
405+ DepsSame same cached ->
406+ do maybeLoaded <- loadInterfaces root same cached
407+ case maybeLoaded of
408+ Nothing -> return RBlocked
409+ Just ifaces -> compile env docsNeed local source ifaces modul
410+
411+ DepsBlock ->
412+ return RBlocked
413+
414+ DepsNotFound problems ->
415+ return $ RProblem $ Error.Module name path time source $
416+ Error.BadImports (toImportErrors env results imports problems)
417+
418+ SBadImport importProblem ->
419+ return (RNotFound importProblem)
420+
421+ SBadSyntax path time source err ->
422+ return $ RProblem $ Error.Module name path time source $
423+ Error.BadSyntax err
424+
425+ SForeign home ->
426+ case foreigns ! ModuleName.Canonical home name of
427+ I.Public iface -> return (RForeign iface)
428+ I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
429+
430+ SKernel ->
431+ return RKernel
432+
433+
434+
435+-- CHECK DEPS
436+
437+
438+data DepsStatus
439+ = DepsChange (Map.Map ModuleName.Raw I.Interface)
440+ | DepsSame [Dep] [CDep]
441+ | DepsBlock
442+ | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
443+
444+
445+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
446+checkDeps root results deps lastCompile =
447+ checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
448+
449+
450+type Dep = (ModuleName.Raw, I.Interface)
451+type CDep = (ModuleName.Raw, MVar CachedInterface)
452+
453+
454+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
455+checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
456+ case deps of
457+ dep:otherDeps ->
458+ do result <- readMVar (results ! dep)
459+ case result of
460+ RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
461+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
462+
463+ RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
464+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
465+
466+ RCached _ lastChange mvar ->
467+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
468+
469+ RNotFound prob ->
470+ checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471+
472+ RProblem _ ->
473+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
474+
475+ RBlocked ->
476+ checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
477+
478+ RForeign iface ->
479+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
480+
481+ RKernel ->
482+ checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
483+
484+
485+ [] ->
486+ case reverse importProblems of
487+ p:ps ->
488+ return $ DepsNotFound (NE.List p ps)
489+
490+ [] ->
491+ if isBlocked then
492+ return $ DepsBlock
493+
494+ else if null new && lastDepChange <= lastCompile then
495+ return $ DepsSame same cached
496+
497+ else
498+ do maybeLoaded <- loadInterfaces root same cached
499+ case maybeLoaded of
500+ Nothing -> return DepsBlock
501+ Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
502+
503+
504+
505+-- TO IMPORT ERROR
506+
507+
508+toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
509+toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
510+ let
511+ knownModules =
512+ Set.unions
513+ [ Map.keysSet foreigns
514+ , Map.keysSet locals
515+ , Map.keysSet results
516+ ]
517+
518+ unimportedModules =
519+ Set.difference knownModules (Set.fromList (map Src.getImportName imports))
520+
521+ regionDict =
522+ Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
523+
524+ toError (name, problem) =
525+ Import.Error (regionDict ! name) name unimportedModules problem
526+ in
527+ fmap toError problems
528+
529+
530+
531+-- LOAD CACHED INTERFACES
532+
533+
534+loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535+loadInterfaces root same cached =
536+ do loading <- traverse (fork . loadInterface root) cached
537+ maybeLoaded <- traverse readMVar loading
538+ case sequence maybeLoaded of
539+ Nothing ->
540+ return Nothing
541+
542+ Just loaded ->
543+ return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
544+
545+
546+loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
547+loadInterface root (name, ciMvar) =
548+ do cachedInterface <- takeMVar ciMvar
549+ case cachedInterface of
550+ Corrupted ->
551+ do putMVar ciMvar cachedInterface
552+ return Nothing
553+
554+ Loaded iface ->
555+ do putMVar ciMvar cachedInterface
556+ return (Just (name, iface))
557+
558+ Unneeded ->
559+ do maybeIface <- File.readBinary (Stuff.elmi root name)
560+ case maybeIface of
561+ Nothing ->
562+ do putMVar ciMvar Corrupted
563+ return Nothing
564+
565+ Just iface ->
566+ do putMVar ciMvar (Loaded iface)
567+ return (Just (name, iface))
568+
569+
570+
571+-- CHECK PROJECT
572+
573+
574+checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575+checkMidpoint dmvar statuses =
576+ case checkForCycles statuses of
577+ Nothing ->
578+ do maybeForeigns <- readMVar dmvar
579+ case maybeForeigns of
580+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)
581+ Just fs -> return (Right fs)
582+
583+ Just (NE.List name names) ->
584+ do _ <- readMVar dmvar
585+ return (Left (Exit.BP_Cycle name names))
586+
587+
588+checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589+checkMidpointAndRoots dmvar statuses sroots =
590+ case checkForCycles statuses of
591+ Nothing ->
592+ case checkUniqueRoots statuses sroots of
593+ Nothing ->
594+ do maybeForeigns <- readMVar dmvar
595+ case maybeForeigns of
596+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)
597+ Just fs -> return (Right fs)
598+
599+ Just problem ->
600+ do _ <- readMVar dmvar
601+ return (Left problem)
602+
603+ Just (NE.List name names) ->
604+ do _ <- readMVar dmvar
605+ return (Left (Exit.BP_Cycle name names))
606+
607+
608+
609+-- CHECK FOR CYCLES
610+
611+
612+checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
613+checkForCycles modules =
614+ let
615+ !graph = Map.foldrWithKey addToGraph [] modules
616+ !sccs = Graph.stronglyConnComp graph
617+ in
618+ checkForCyclesHelp sccs
619+
620+
621+checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
622+checkForCyclesHelp sccs =
623+ case sccs of
624+ [] ->
625+ Nothing
626+
627+ scc:otherSccs ->
628+ case scc of
629+ Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
630+ Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
631+ Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
632+
633+
634+type Node =
635+ ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
636+
637+
638+addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
639+addToGraph name status graph =
640+ let
641+ dependencies =
642+ case status of
643+ SCached (Details.Local _ _ deps _ _ _) -> deps
644+ SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
645+ SBadImport _ -> []
646+ SBadSyntax _ _ _ _ -> []
647+ SForeign _ -> []
648+ SKernel -> []
649+ in
650+ (name, name, dependencies) : graph
651+
652+
653+
654+-- CHECK UNIQUE ROOTS
655+
656+
657+checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
658+checkUniqueRoots insides sroots =
659+ let
660+ outsidesDict =
661+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
662+ in
663+ case Map.traverseWithKey checkOutside outsidesDict of
664+ Left problem ->
665+ Just problem
666+
667+ Right outsides ->
668+ case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
669+ Right () -> Nothing
670+ Left problem -> Just problem
671+
672+
673+rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
674+rootStatusToNamePathPair sroot =
675+ case sroot of
676+ SInside _ -> Nothing
677+ SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
678+ SOutsideErr _ -> Nothing
679+
680+
681+checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
682+checkOutside name paths =
683+ case OneOrMore.destruct NE.List paths of
684+ NE.List p [] -> Right p
685+ NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
686+
687+
688+checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
689+checkInside name p1 status =
690+ case status of
691+ SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
692+ SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
693+ SBadImport _ -> Right ()
694+ SBadSyntax _ _ _ _ -> Right ()
695+ SForeign _ -> Right ()
696+ SKernel -> Right ()
697+
698+
699+
700+-- COMPILE MODULE
701+
702+
703+compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
704+compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
705+ let
706+ pkg = projectTypeToPkg projectType
707+ in
708+ case Compile.compile pkg ifaces modul of
709+ Right (Compile.Artifacts canonical annotations objects) ->
710+ case makeDocs docsNeed canonical of
711+ Left err ->
712+ return $ RProblem $
713+ Error.Module (Src.getName modul) path time source (Error.BadDocs err)
714+
715+ Right docs ->
716+ do let name = Src.getName modul
717+ let iface = I.fromModule pkg canonical annotations
718+ let elmi = Stuff.elmi root name
719+ File.writeBinary (Stuff.elmo root name) objects
720+ maybeOldi <- File.readBinary elmi
721+ case maybeOldi of
722+ Just oldi | oldi == iface ->
723+ do -- iface should be fully forced by equality check
724+ Reporting.report key Reporting.BDone
725+ let local = Details.Local path time deps main lastChange buildID
726+ return (RSame local iface objects docs)
727+
728+ _ ->
729+ do -- iface may be lazy still
730+ File.writeBinary elmi iface
731+ Reporting.report key Reporting.BDone
732+ let local = Details.Local path time deps main buildID buildID
733+ return (RNew local iface objects docs)
734+
735+ Left err ->
736+ return $ RProblem $
737+ Error.Module (Src.getName modul) path time source err
738+
739+
740+projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741+projectTypeToPkg projectType =
742+ case projectType of
743+ Parse.Package pkg -> pkg
744+ Parse.Application -> Pkg.dummyName
745+
746+
747+
748+-- WRITE DETAILS
749+
750+
751+writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
752+writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
753+ File.writeBinary (Stuff.details root) $
754+ Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
755+
756+
757+addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
758+addNewLocal name result locals =
759+ case result of
760+ RNew local _ _ _ -> Map.insert name local locals
761+ RSame local _ _ _ -> Map.insert name local locals
762+ RCached _ _ _ -> locals
763+ RNotFound _ -> locals
764+ RProblem _ -> locals
765+ RBlocked -> locals
766+ RForeign _ -> locals
767+ RKernel -> locals
768+
769+
770+
771+-- FINALIZE EXPOSED
772+
773+
774+finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
775+finalizeExposed root docsGoal exposed results =
776+ case foldr (addImportProblems results) [] (NE.toList exposed) of
777+ p:ps ->
778+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
779+
780+ [] ->
781+ case Map.foldr addErrors [] results of
782+ [] -> Right <$> finalizeDocs docsGoal results
783+ e:es -> return $ Left $ Exit.BuildBadModules root e es
784+
785+
786+addErrors :: Result -> [Error.Module] -> [Error.Module]
787+addErrors result errors =
788+ case result of
789+ RNew _ _ _ _ -> errors
790+ RSame _ _ _ _ -> errors
791+ RCached _ _ _ -> errors
792+ RNotFound _ -> errors
793+ RProblem e -> e:errors
794+ RBlocked -> errors
795+ RForeign _ -> errors
796+ RKernel -> errors
797+
798+
799+addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
800+addImportProblems results name problems =
801+ case results ! name of
802+ RNew _ _ _ _ -> problems
803+ RSame _ _ _ _ -> problems
804+ RCached _ _ _ -> problems
805+ RNotFound p -> (name, p) : problems
806+ RProblem _ -> problems
807+ RBlocked -> problems
808+ RForeign _ -> problems
809+ RKernel -> problems
810+
811+
812+
813+-- DOCS
814+
815+
816+data DocsGoal a where
817+ KeepDocs :: DocsGoal Docs.Documentation
818+ WriteDocs :: FilePath -> DocsGoal ()
819+ IgnoreDocs :: DocsGoal ()
820+
821+
822+newtype DocsNeed =
823+ DocsNeed { needsDocs :: Bool }
824+
825+
826+toDocsNeed :: DocsGoal a -> DocsNeed
827+toDocsNeed goal =
828+ case goal of
829+ IgnoreDocs -> DocsNeed False
830+ WriteDocs _ -> DocsNeed True
831+ KeepDocs -> DocsNeed True
832+
833+
834+makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
835+makeDocs (DocsNeed isNeeded) modul =
836+ if isNeeded then
837+ case Docs.fromModule modul of
838+ Right docs -> Right (Just docs)
839+ Left err -> Left err
840+ else
841+ Right Nothing
842+
843+
844+finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
845+finalizeDocs goal results =
846+ case goal of
847+ KeepDocs ->
848+ return $ Map.mapMaybe toDocs results
849+
850+ WriteDocs path ->
851+ E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
852+
853+ IgnoreDocs ->
854+ return ()
855+
856+
857+toDocs :: Result -> Maybe Docs.Module
858+toDocs result =
859+ case result of
860+ RNew _ _ _ d -> d
861+ RSame _ _ _ d -> d
862+ RCached _ _ _ -> Nothing
863+ RNotFound _ -> Nothing
864+ RProblem _ -> Nothing
865+ RBlocked -> Nothing
866+ RForeign _ -> Nothing
867+ RKernel -> Nothing
868+
869+
870+
871+--------------------------------------------------------------------------------
872+------ NOW FOR SOME REPL STUFF -------------------------------------------------
873+--------------------------------------------------------------------------------
874+
875+
876+-- FROM REPL
877+
878+
879+data ReplArtifacts =
880+ ReplArtifacts
881+ { _repl_home :: ModuleName.Canonical
882+ , _repl_modules :: [Module]
883+ , _repl_localizer :: L.Localizer
884+ , _repl_annotations :: Map.Map Name.Name Can.Annotation
885+ }
886+
887+
888+fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
889+fromRepl root details source =
890+ do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
891+ case Parse.fromByteString projectType source of
892+ Left syntaxError ->
893+ return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
894+
895+ Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
896+ do dmvar <- Details.loadInterfaces root details
897+
898+ let deps = map Src.getImportName imports
899+ mvar <- newMVar Map.empty
900+ crawlDeps env mvar deps ()
901+
902+ statuses <- traverse readMVar =<< readMVar mvar
903+ midpoint <- checkMidpoint dmvar statuses
904+
905+ case midpoint of
906+ Left problem ->
907+ return $ Left $ Exit.ReplProjectProblem problem
908+
909+ Right foreigns ->
910+ do rmvar <- newEmptyMVar
911+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
912+ putMVar rmvar resultMVars
913+ results <- traverse readMVar resultMVars
914+ writeDetails root details results
915+ depsStatus <- checkDeps root resultMVars deps 0
916+ finalizeReplArtifacts env source modul depsStatus resultMVars results
917+
918+
919+finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
920+finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
921+ let
922+ pkg =
923+ projectTypeToPkg projectType
924+
925+ compileInput ifaces =
926+ case Compile.compile pkg ifaces modul of
927+ Right (Compile.Artifacts canonical annotations objects) ->
928+ let
929+ h = Can._name canonical
930+ m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
931+ ms = Map.foldrWithKey addInside [] results
932+ in
933+ return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
934+
935+ Left errors ->
936+ return $ Left $ Exit.ReplBadInput source errors
937+ in
938+ case depsStatus of
939+ DepsChange ifaces ->
940+ compileInput ifaces
941+
942+ DepsSame same cached ->
943+ do maybeLoaded <- loadInterfaces root same cached
944+ case maybeLoaded of
945+ Just ifaces -> compileInput ifaces
946+ Nothing -> return $ Left $ Exit.ReplBadCache
947+
948+ DepsBlock ->
949+ case Map.foldr addErrors [] results of
950+ [] -> return $ Left $ Exit.ReplBlocked
951+ e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
952+
953+ DepsNotFound problems ->
954+ return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
955+ toImportErrors env resultMVars imports problems
956+
957+
958+
959+--------------------------------------------------------------------------------
960+--------------------------------------------------------------------------------
961+------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
962+--------------------------------------------------------------------------------
963+--------------------------------------------------------------------------------
964+
965+
966+
967+-- FIND ROOT
968+
969+
970+data RootLocation
971+ = LInside ModuleName.Raw
972+ | LOutside FilePath
973+
974+
975+findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
976+findRoots env paths =
977+ do mvars <- traverse (fork . getRootInfo env) paths
978+ einfos <- traverse readMVar mvars
979+ return $ checkRoots =<< sequence einfos
980+
981+
982+checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
983+checkRoots infos =
984+ let
985+ toOneOrMore loc@(RootInfo absolute _ _) =
986+ (absolute, OneOrMore.one loc)
987+
988+ fromOneOrMore loc locs =
989+ case locs of
990+ [] -> Right ()
991+ loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
992+ in
993+ fmap (\_ -> fmap _location infos) $
994+ traverse (OneOrMore.destruct fromOneOrMore) $
995+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
996+
997+
998+
999+-- ROOT INFO
1000+
1001+
1002+data RootInfo =
1003+ RootInfo
1004+ { _absolute :: FilePath
1005+ , _relative :: FilePath
1006+ , _location :: RootLocation
1007+ }
1008+
1009+
1010+getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1011+getRootInfo env path =
1012+ do exists <- File.exists path
1013+ if exists
1014+ then getRootInfoHelp env path =<< Dir.canonicalizePath path
1015+ else return (Left (Exit.BP_PathUnknown path))
1016+
1017+
1018+getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1019+getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
1020+ let
1021+ (dirs, file) = FP.splitFileName absolutePath
1022+ (final, ext) = FP.splitExtension file
1023+ in
1024+ if ext /= ".elm"
1025+ then
1026+ return $ Left $ Exit.BP_WithBadExtension path
1027+ else
1028+ let
1029+ absoluteSegments = FP.splitDirectories dirs ++ [final]
1030+ in
1031+ case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
1032+ [] ->
1033+ return $ Right $ RootInfo absolutePath path (LOutside path)
1034+
1035+ [(_, Right names)] ->
1036+ do let name = Name.fromChars (List.intercalate "." names)
1037+ matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
1038+ case matchingDirs of
1039+ d1:d2:_ ->
1040+ do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
1041+ let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042+ return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1043+
1044+ _ ->
1045+ return $ Right $ RootInfo absolutePath path (LInside name)
1046+
1047+ [(s, Left names)] ->
1048+ return $ Left $ Exit.BP_RootNameInvalid path s names
1049+
1050+ (s1,_):(s2,_):_ ->
1051+ return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1052+
1053+
1054+
1055+isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
1056+isInsideSrcDirByName names srcDir =
1057+ File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1058+
1059+
1060+isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061+isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1062+ case dropPrefix (FP.splitDirectories srcDir) segments of
1063+ Nothing ->
1064+ Nothing
1065+
1066+ Just names ->
1067+ if all isGoodName names
1068+ then Just (srcDir, Right names)
1069+ else Just (srcDir, Left names)
1070+
1071+
1072+isGoodName :: [Char] -> Bool
1073+isGoodName name =
1074+ case name of
1075+ [] ->
1076+ False
1077+
1078+ char:chars ->
1079+ Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1080+
1081+
1082+-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1083+--
1084+dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1085+dropPrefix roots paths =
1086+ case roots of
1087+ [] ->
1088+ Just paths
1089+
1090+ r:rs ->
1091+ case paths of
1092+ [] -> Nothing
1093+ p:ps -> if r == p then dropPrefix rs ps else Nothing
1094+
1095+
1096+
1097+-- CRAWL ROOTS
1098+
1099+
1100+data RootStatus
1101+ = SInside ModuleName.Raw
1102+ | SOutsideOk Details.Local B.ByteString Src.Module
1103+ | SOutsideErr Error.Module
1104+
1105+
1106+crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
1107+crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1108+ case root of
1109+ LInside name ->
1110+ do statusMVar <- newEmptyMVar
1111+ statusDict <- takeMVar mvar
1112+ putMVar mvar (Map.insert name statusMVar statusDict)
1113+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1114+ return (SInside name)
1115+
1116+ LOutside path ->
1117+ do time <- File.getTime path
1118+ source <- File.readUtf8 path
1119+ case Parse.fromByteString projectType source of
1120+ Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1121+ do let deps = map Src.getImportName imports
1122+ let local = Details.Local path time deps (any isMain values) buildID buildID
1123+ crawlDeps env mvar deps (SOutsideOk local source modul)
1124+
1125+ Left syntaxError ->
1126+ return $ SOutsideErr $
1127+ Error.Module "???" path time source (Error.BadSyntax syntaxError)
1128+
1129+
1130+
1131+-- CHECK ROOTS
1132+
1133+
1134+data RootResult
1135+ = RInside ModuleName.Raw
1136+ | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1137+ | ROutsideErr Error.Module
1138+ | ROutsideBlocked
1139+
1140+
1141+checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
1142+checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1143+ case rootStatus of
1144+ SInside name ->
1145+ return (RInside name)
1146+
1147+ SOutsideErr err ->
1148+ return (ROutsideErr err)
1149+
1150+ SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1151+ do depsStatus <- checkDeps root results deps lastCompile
1152+ case depsStatus of
1153+ DepsChange ifaces ->
1154+ compileOutside env local source ifaces modul
1155+
1156+ DepsSame same cached ->
1157+ do maybeLoaded <- loadInterfaces root same cached
1158+ case maybeLoaded of
1159+ Nothing -> return ROutsideBlocked
1160+ Just ifaces -> compileOutside env local source ifaces modul
1161+
1162+ DepsBlock ->
1163+ return ROutsideBlocked
1164+
1165+ DepsNotFound problems ->
1166+ return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1167+ Error.BadImports (toImportErrors env results imports problems)
1168+
1169+
1170+compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
1171+compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1172+ let
1173+ pkg = projectTypeToPkg projectType
1174+ name = Src.getName modul
1175+ in
1176+ case Compile.compile pkg ifaces modul of
1177+ Right (Compile.Artifacts canonical annotations objects) ->
1178+ do Reporting.report key Reporting.BDone
1179+ return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1180+
1181+ Left errors ->
1182+ return $ ROutsideErr $ Error.Module name path time source errors
1183+
1184+
1185+
1186+-- TO ARTIFACTS
1187+
1188+
1189+data Root
1190+ = Inside ModuleName.Raw
1191+ | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1192+
1193+
1194+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
1195+toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
1196+ case gatherProblemsOrMains results rootResults of
1197+ Left (NE.List e es) ->
1198+ Left (Exit.BuildBadModules root e es)
1199+
1200+ Right roots ->
1201+ Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
1202+ Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
1203+
1204+
1205+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
1206+gatherProblemsOrMains results (NE.List rootResult rootResults) =
1207+ let
1208+ addResult result (es, roots) =
1209+ case result of
1210+ RInside n -> ( es, Inside n : roots)
1211+ ROutsideOk n i o -> ( es, Outside n i o : roots)
1212+ ROutsideErr e -> (e:es, roots)
1213+ ROutsideBlocked -> ( es, roots)
1214+
1215+ errors = Map.foldr addErrors [] results
1216+ in
1217+ case (rootResult, foldr addResult (errors, []) rootResults) of
1218+ (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1219+ (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1220+ (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1221+ (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1222+ (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1223+ (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1224+ (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1225+
1226+
1227+addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1228+addInside name result modules =
1229+ case result of
1230+ RNew _ iface objs _ -> Fresh name iface objs : modules
1231+ RSame _ iface objs _ -> Fresh name iface objs : modules
1232+ RCached main _ mvar -> Cached name main mvar : modules
1233+ RNotFound _ -> error (badInside name)
1234+ RProblem _ -> error (badInside name)
1235+ RBlocked -> error (badInside name)
1236+ RForeign _ -> modules
1237+ RKernel -> modules
1238+
1239+
1240+badInside :: ModuleName.Raw -> [Char]
1241+badInside name =
1242+ "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1243+
1244+
1245+addOutside :: RootResult -> [Module] -> [Module]
1246+addOutside root modules =
1247+ case root of
1248+ RInside _ -> modules
1249+ ROutsideOk name iface objs -> Fresh name iface objs : modules
1250+ ROutsideErr _ -> modules
1251+ ROutsideBlocked -> modules
builder/src/Deps/Bump.hsnew file+37
@@ -0,0 +1,37 @@
1+module Deps.Bump
2+ ( getPossibilities
3+ )
4+ where
5+
6+
7+import qualified Data.List as List
8+
9+import qualified Deps.Registry as Registry
10+import qualified Elm.Magnitude as M
11+import qualified Elm.Version as V
12+
13+
14+
15+-- GET POSSIBILITIES
16+
17+
18+getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]
19+getPossibilities (Registry.KnownVersions latest previous) =
20+ let
21+ allVersions = reverse (latest:previous)
22+ minorPoints = map last (List.groupBy sameMajor allVersions)
23+ patchPoints = map last (List.groupBy sameMinor allVersions)
24+ in
25+ (latest, V.bumpMajor latest, M.MAJOR)
26+ : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
27+ ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
28+
29+
30+sameMajor :: V.Version -> V.Version -> Bool
31+sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =
32+ major1 == major2
33+
34+
35+sameMinor :: V.Version -> V.Version -> Bool
36+sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =
37+ major1 == major2 && minor1 == minor2
builder/src/Deps/Diff.hs+94−67
@@ -1,15 +1,13 @@
1−{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3module Deps.Diff
2module Deps.Diff
4 ( diff
3 ( diff
5 , PackageChanges(..)
4 , PackageChanges(..)
6 , ModuleChanges(..)
5 , ModuleChanges(..)
7 , Changes(..)
6 , Changes(..)
8− , Magnitude(..)
9 , moduleChangeMagnitude
7 , moduleChangeMagnitude
10− , magnitudeToString
11 , toMagnitude
8 , toMagnitude
12 , bump
9 , bump
10+ , getDocs
13 )
11 )
14 where
12 where
15
13
@@ -18,14 +16,23 @@ import Control.Monad (zipWithM)
18import Data.Function (on)
16import Data.Function (on)
19import qualified Data.List as List
17import qualified Data.List as List
20import qualified Data.Map as Map
18import qualified Data.Map as Map
19+import qualified Data.Name as Name
21import qualified Data.Set as Set
20import qualified Data.Set as Set
22−import qualified Data.Text as Text
21+import qualified System.Directory as Dir
22+import System.FilePath ((</>))
23
23
24−import qualified Elm.Compiler.Module as Module
24+import qualified Deps.Website as Website
25import qualified Elm.Compiler.Type as Type
25import qualified Elm.Compiler.Type as Type
26import qualified Elm.Docs as Docs
26import qualified Elm.Docs as Docs
27−import qualified Elm.Name as N
27+import qualified Elm.Magnitude as M
28+import qualified Elm.ModuleName as ModuleName
28import qualified Elm.Package as Pkg
29import qualified Elm.Package as Pkg
30+import qualified Elm.Version as V
31+import qualified File
32+import qualified Http
33+import qualified Json.Decode as D
34+import qualified Reporting.Exit as Exit
35+import qualified Stuff
29
36
30
37
31
38
@@ -34,18 +41,18 @@ import qualified Elm.Package as Pkg
34
41
35data PackageChanges =
42data PackageChanges =
36 PackageChanges
43 PackageChanges
37− { _modules_added :: [Module.Raw]
44+ { _modules_added :: [ModuleName.Raw]
38− , _modules_changed :: Map.Map Module.Raw ModuleChanges
45+ , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
39− , _modules_removed :: [Module.Raw]
46+ , _modules_removed :: [ModuleName.Raw]
40 }
47 }
41
48
42
49
43data ModuleChanges =
50data ModuleChanges =
44 ModuleChanges
51 ModuleChanges
45− { _unions :: Changes N.Name Docs.Union
52+ { _unions :: Changes Name.Name Docs.Union
46− , _aliases :: Changes N.Name Docs.Alias
53+ , _aliases :: Changes Name.Name Docs.Alias
47− , _values :: Changes N.Name Docs.Value
54+ , _values :: Changes Name.Name Docs.Value
48− , _binops :: Changes N.Name Docs.Binop
55+ , _binops :: Changes Name.Name Docs.Binop
49 }
56 }
50
57
51
58
@@ -74,7 +81,7 @@ diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
74diff oldDocs newDocs =
81diff oldDocs newDocs =
75 let
82 let
76 filterOutPatches chngs =
83 filterOutPatches chngs =
77− Map.filter (\chng -> moduleChangeMagnitude chng /= PATCH) chngs
84+ Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
78
85
79 (Changes added changed removed) =
86 (Changes added changed removed) =
80 getChanges (\_ _ -> False) oldDocs newDocs
87 getChanges (\_ _ -> False) oldDocs newDocs
@@ -145,7 +152,7 @@ isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
145-- DIFF TYPES
152-- DIFF TYPES
146
153
147
154
148−diffType :: Type.Type -> Type.Type -> Maybe [(N.Name,N.Name)]
155+diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
149diffType oldType newType =
156diffType oldType newType =
150 case (oldType, newType) of
157 case (oldType, newType) of
151 (Type.Var oldName, Type.Var newName) ->
158 (Type.Var oldName, Type.Var newName) ->
@@ -176,16 +183,28 @@ diffType oldType newType =
176 (Just oldExt, Just newExt) ->
183 (Just oldExt, Just newExt) ->
177 (:) (oldExt, newExt) <$> diffFields fields fields'
184 (:) (oldExt, newExt) <$> diffFields fields fields'
178
185
186+ (Type.Unit, Type.Unit) ->
187+ Just []
188+
189+ (Type.Tuple a b cs, Type.Tuple x y zs) ->
190+ if length cs /= length zs then
191+ Nothing
192+ else
193+ do aVars <- diffType a x
194+ bVars <- diffType b y
195+ cVars <- concat <$> zipWithM diffType cs zs
196+ return (aVars ++ bVars ++ cVars)
197+
179 (_, _) ->
198 (_, _) ->
180 Nothing
199 Nothing
181
200
182
201
183-- handle very old docs that do not use qualified names
202-- handle very old docs that do not use qualified names
184−isSameName :: N.Name -> N.Name -> Bool
203+isSameName :: Name.Name -> Name.Name -> Bool
185isSameName oldFullName newFullName =
204isSameName oldFullName newFullName =
186 let
205 let
187 dedot name =
206 dedot name =
188− reverse (Text.splitOn "." (N.toText name))
207+ reverse (Name.splitDots name)
189 in
208 in
190 case ( dedot oldFullName, dedot newFullName ) of
209 case ( dedot oldFullName, dedot newFullName ) of
191 (oldName:[], newName:_) ->
210 (oldName:[], newName:_) ->
@@ -198,7 +217,7 @@ isSameName oldFullName newFullName =
198 oldFullName == newFullName
217 oldFullName == newFullName
199
218
200
219
201−diffFields :: [(N.Name, Type.Type)] -> [(N.Name, Type.Type)] -> Maybe [(N.Name,N.Name)]
220+diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
202diffFields oldRawFields newRawFields =
221diffFields oldRawFields newRawFields =
203 let
222 let
204 sort = List.sortBy (compare `on` fst)
223 sort = List.sortBy (compare `on` fst)
@@ -219,7 +238,7 @@ diffFields oldRawFields newRawFields =
219-- TYPE VARIABLES
238-- TYPE VARIABLES
220
239
221
240
222−isEquivalentRenaming :: [(N.Name,N.Name)] -> Bool
241+isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
223isEquivalentRenaming varPairs =
242isEquivalentRenaming varPairs =
224 let
243 let
225 renamings =
244 renamings =
@@ -247,22 +266,18 @@ isEquivalentRenaming varPairs =
247 False
266 False
248
267
249 Just verifiedRenamings ->
268 Just verifiedRenamings ->
250− all compatableVars verifiedRenamings
269+ all compatibleVars verifiedRenamings
251 &&
270 &&
252 allUnique (map snd verifiedRenamings)
271 allUnique (map snd verifiedRenamings)
253
272
254
273
255−compatableVars :: (N.Name, N.Name) -> Bool
274+compatibleVars :: (Name.Name, Name.Name) -> Bool
256−compatableVars (old, new) =
275+compatibleVars (old, new) =
257 case (categorizeVar old, categorizeVar new) of
276 case (categorizeVar old, categorizeVar new) of
258 (CompAppend, CompAppend) -> True
277 (CompAppend, CompAppend) -> True
259 (Comparable, Comparable) -> True
278 (Comparable, Comparable) -> True
260 (Appendable, Appendable) -> True
279 (Appendable, Appendable) -> True
261 (Number , Number ) -> True
280 (Number , Number ) -> True
262−
263− (Comparable, CompAppend) -> True
264− (Appendable, CompAppend) -> True
265− (Number , CompAppend) -> True
266 (Number , Comparable) -> True
281 (Number , Comparable) -> True
267
282
268 (_, Var) -> True
283 (_, Var) -> True
@@ -278,63 +293,43 @@ data TypeVarCategory
278 | Var
293 | Var
279
294
280
295
281−categorizeVar :: N.Name -> TypeVarCategory
296+categorizeVar :: Name.Name -> TypeVarCategory
282categorizeVar name
297categorizeVar name
283− | N.startsWith "compappend" name = CompAppend
298+ | Name.isCompappendType name = CompAppend
284− | N.startsWith "comparable" name = Comparable
299+ | Name.isComparableType name = Comparable
285− | N.startsWith "appendable" name = Appendable
300+ | Name.isAppendableType name = Appendable
286− | N.startsWith "number" name = Number
301+ | Name.isNumberType name = Number
287− | otherwise = Var
302+ | otherwise = Var
288
303
289
304
290
305
291-- MAGNITUDE
306-- MAGNITUDE
292
307
293
308
294−data Magnitude
295− = PATCH
296− | MINOR
297− | MAJOR
298− deriving (Eq, Ord)
299−
300−
301−magnitudeToString :: Magnitude -> String
302−magnitudeToString magnitude =
303− case magnitude of
304− PATCH ->
305− "PATCH"
306−
307− MINOR ->
308− "MINOR"
309−
310− MAJOR ->
311− "MAJOR"
312−
313−
314−bump :: PackageChanges -> Pkg.Version -> Pkg.Version
309+bump :: PackageChanges -> V.Version -> V.Version
315bump changes version =
310bump changes version =
316 case toMagnitude changes of
311 case toMagnitude changes of
317− PATCH ->
312+ M.PATCH ->
318− Pkg.bumpPatch version
313+ V.bumpPatch version
319
314
320− MINOR ->
315+ M.MINOR ->
321− Pkg.bumpMinor version
316+ V.bumpMinor version
322
317
323− MAJOR ->
318+ M.MAJOR ->
324− Pkg.bumpMajor version
319+ V.bumpMajor version
325
320
326
321
327−toMagnitude :: PackageChanges -> Magnitude
322+toMagnitude :: PackageChanges -> M.Magnitude
328toMagnitude (PackageChanges added changed removed) =
323toMagnitude (PackageChanges added changed removed) =
329 let
324 let
330− addMag = if null added then PATCH else MINOR
325+ addMag = if null added then M.PATCH else M.MINOR
331− removeMag = if null removed then PATCH else MAJOR
326+ removeMag = if null removed then M.PATCH else M.MAJOR
332 changeMags = map moduleChangeMagnitude (Map.elems changed)
327 changeMags = map moduleChangeMagnitude (Map.elems changed)
333 in
328 in
334 maximum (addMag : removeMag : changeMags)
329 maximum (addMag : removeMag : changeMags)
335
330
336
331
337−moduleChangeMagnitude :: ModuleChanges -> Magnitude
332+moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
338moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
333moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
339 maximum
334 maximum
340 [ changeMagnitude unions
335 [ changeMagnitude unions
@@ -344,13 +339,45 @@ moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
344 ]
339 ]
345
340
346
341
347−changeMagnitude :: Changes k v -> Magnitude
342+changeMagnitude :: Changes k v -> M.Magnitude
348changeMagnitude (Changes added changed removed) =
343changeMagnitude (Changes added changed removed) =
349 if Map.size removed > 0 || Map.size changed > 0 then
344 if Map.size removed > 0 || Map.size changed > 0 then
350− MAJOR
345+ M.MAJOR
351
346
352 else if Map.size added > 0 then
347 else if Map.size added > 0 then
353− MINOR
348+ M.MINOR
354
349
355 else
350 else
356− PATCH
351+ M.PATCH
352+
353+
354+
355+-- GET DOCS
356+
357+
358+getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)
359+getDocs cache manager name version =
360+ do let home = Stuff.package cache name version
361+ let path = home </> "docs.json"
362+ exists <- File.exists path
363+ if exists
364+ then
365+ do bytes <- File.readUtf8 path
366+ case D.fromByteString Docs.decoder bytes of
367+ Right docs ->
368+ return $ Right docs
369+
370+ Left _ ->
371+ do File.remove path
372+ return $ Left Exit.DP_Cache
373+ else
374+ do let url = Website.metadata name version "docs.json"
375+ Http.get manager url [] Exit.DP_Http $ \body ->
376+ case D.fromByteString Docs.decoder body of
377+ Right docs ->
378+ do Dir.createDirectoryIfMissing True home
379+ File.writeUtf8 path body
380+ return $ Right docs
381+
382+ Left _ ->
383+ return $ Left $ Exit.DP_Data url body
builder/src/Deps/Explorer.hsdeleted−100
@@ -1,100 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Deps.Explorer
3− ( Explorer
4− , Metadata
5− , Info(..)
6− , run
7− , getVersions
8− , getConstraints
9− )
10− where
11−
12−{-| It is expensive to load ALL package metadata. You would need to:
13−
14− 1. Know all the packages and all their versions.
15− 2. Download or read the elm.json file for each version.
16−
17−The goal of this module is to only pay for (1) and pay for (2) as needed.
18−-}
19−
20−
21−import Control.Monad.Except (lift, throwError)
22−import Control.Monad.State (StateT, evalStateT, gets, modify)
23−import Data.Map (Map)
24−import qualified Data.Map as Map
25−
26−import Elm.Package (Name, Version)
27−
28−import qualified Deps.Get as Get
29−import qualified Elm.Project.Json as Project
30−import Elm.Project.Constraint (Constraint)
31−import qualified Reporting.Error as Error
32−import qualified Reporting.Error.Deps as E
33−import qualified Reporting.Task as Task
34−
35−
36−
37−-- EXPLORER
38−
39−
40−type Explorer =
41− StateT Metadata Task.Task
42−
43−
44−data Metadata =
45− Metadata
46− { _vsns :: Get.AllPackages
47− , _info :: Map (Name, Version) Info
48− }
49−
50−
51−data Info =
52− Info
53− { _elm :: Constraint
54− , _pkgs :: Map Name Constraint
55− }
56−
57−
58−run :: Explorer a -> Task.Task a
59−run explorer =
60− do versions <- Get.all Get.AllowOffline
61− evalStateT explorer (Metadata versions Map.empty)
62−
63−
64−
65−-- VERSIONS
66−
67−
68−getVersions :: Name -> Explorer [Version]
69−getVersions name =
70− do pkgs <- gets _vsns
71− case Get.versions name pkgs of
72− Right versions ->
73− return versions
74−
75− Left _suggestions ->
76− throwError (Error.Deps (E.CorruptVersionCache name))
77−
78−
79−
80−-- CONSTRAINTS
81−
82−
83−getConstraints :: Name -> Version -> Explorer Info
84−getConstraints name version =
85− do allInfo <- gets _info
86− case Map.lookup (name, version) allInfo of
87− Just info ->
88− return info
89−
90− Nothing ->
91− do pkgInfo <- lift $ Get.info name version
92−
93− let elm = Project._pkg_elm_version pkgInfo
94− let pkgs = Project._pkg_deps pkgInfo
95− let info = Info elm pkgs
96−
97− modify $ \(Metadata vsns infos) ->
98− Metadata vsns $ Map.insert (name, version) info infos
99−
100− return info
builder/src/Deps/Get.hsdeleted−182
@@ -1,182 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Deps.Get
4− ( all
5− , AllPackages
6− , Mode(..)
7− , versions
8− , info
9− , docs
10− )
11− where
12−
13−import Prelude hiding (all)
14−import Control.Monad.Except (catchError, liftIO)
15−import qualified Data.ByteString as BS
16−import qualified Data.List as List
17−import qualified Data.Map as Map
18−import Data.Map (Map)
19−import qualified System.Directory as Dir
20−import System.FilePath ((</>))
21−import qualified Text.PrettyPrint.ANSI.Leijen as P
22−
23−import qualified Elm.Docs as Docs
24−import qualified Elm.Package as Pkg
25−import Elm.Package (Name, Version)
26−
27−import qualified Deps.Website as Website
28−import qualified Elm.Project.Json as Project
29−import qualified Elm.Utils as Utils
30−import qualified File.IO as IO
31−import qualified Reporting.Error as Error
32−import qualified Reporting.Error.Assets as E
33−import qualified Reporting.Progress as Progress
34−import qualified Reporting.Task as Task
35−import qualified Json.Decode as Decode
36−
37−
38−
39−-- ALL VERSIONS
40−
41−
42−data Mode = RequireLatest | AllowOffline
43−
44−
45−newtype AllPackages = AllPackages (Map Name [Version])
46−
47−
48−all :: Mode -> Task.Task AllPackages
49−all mode =
50− do dir <- Task.getPackageCacheDir
51− let versionsFile = dir </> "versions.dat"
52− exists <- liftIO $ Dir.doesFileExist versionsFile
53− if exists
54− then fetchNew versionsFile mode
55− else fetchAll versionsFile
56−
57−
58−fetchAll :: FilePath -> Task.Task AllPackages
59−fetchAll versionsFile =
60− do packages <- Website.getAllPackages
61− let size = Map.foldr ((+) . length) 0 packages
62− IO.writeBinary versionsFile (size, packages)
63− return (AllPackages packages)
64−
65−
66−fetchNew :: FilePath -> Mode -> Task.Task AllPackages
67−fetchNew versionsFile mode =
68− do (size, packages) <- IO.readBinary versionsFile
69−
70− news <-
71− case mode of
72− RequireLatest ->
73− Website.getNewPackages size
74−
75− AllowOffline ->
76− Website.getNewPackages size `catchError` \_ ->
77− do Task.report Progress.UnableToLoadLatestPackages
78− return []
79−
80− if null news
81− then return (AllPackages packages)
82− else
83− do let newAllPkgs = List.foldl' addNew packages news
84− IO.writeBinary versionsFile (size + length news, newAllPkgs)
85− return (AllPackages newAllPkgs)
86−
87−
88−addNew :: Map Name [Version] -> (Name, Version) -> Map Name [Version]
89−addNew packages (name, version) =
90− Map.insertWith (++) name [version] packages
91−
92−
93−
94−-- VERSIONS
95−
96−
97−versions :: Name -> AllPackages -> Either [Name] [Version]
98−versions name (AllPackages pkgs) =
99− case Map.lookup name pkgs of
100− Just vsns ->
101− Right vsns
102−
103− Nothing ->
104− Left (Utils.nearbyNames Pkg.toString name (Map.keys pkgs))
105−
106−
107−
108−-- PACKAGE INFO
109−
110−
111−info :: Name -> Version -> Task.Task Project.PkgInfo
112−info name version =
113− do dir <- Task.getPackageCacheDirFor name version
114− let elmJson = dir </> "elm.json"
115−
116− exists <- liftIO $ Dir.doesFileExist elmJson
117−
118− json <-
119− if exists
120− then liftIO (BS.readFile elmJson)
121− else
122− do bits <- Website.getElmJson name version
123− liftIO (BS.writeFile elmJson bits)
124− return bits
125−
126− case Decode.parse "elm.json" "project" E.badContentToDocs Project.pkgDecoder json of
127− Right pkgInfo ->
128− return pkgInfo
129−
130− Left _ ->
131− do IO.remove elmJson
132− Task.throw $ Error.Assets $ E.CorruptElmJson name version
133−
134−
135−
136−-- DOCS
137−
138−
139−docs :: Name -> Version -> Task.Task Docs.Documentation
140−docs name version =
141− do dir <- Task.getPackageCacheDirFor name version
142− let docsJson = dir </> "docs.json"
143−
144− exists <- liftIO $ Dir.doesFileExist docsJson
145−
146− json <-
147− if exists
148− then liftIO (BS.readFile docsJson)
149− else
150− do bits <- Website.getDocs name version
151− liftIO (BS.writeFile docsJson bits)
152− return bits
153−
154− case Decode.parse "docs.json" "docs" errorToDocs (Docs.toDict <$> Decode.list Docs.decoder) json of
155− Right pkgInfo ->
156− return pkgInfo
157−
158− Left _ ->
159− do IO.remove docsJson
160− Task.throw $ Error.Assets $ E.CorruptDocumentation name version
161−
162−
163−errorToDocs :: Docs.Error -> [P.Doc]
164−errorToDocs err =
165− let
166− details =
167− case err of
168− Docs.BadAssociativity txt ->
169− ["Binary","operators","cannot","have",P.red (P.text (show txt)),"as","their","associativity."]
170−
171− Docs.BadName ->
172− ["It","is","not","a","valid","module","name."]
173−
174− Docs.BadType ->
175− ["It","is","not","a","valid","Elm","type."]
176− in
177− details
178− ++
179− ["This","should","not","happen","in","general,","so","please","report","this","at"
180− ,"<https://github.com/elm-lang/package.elm-lang.org/issues>"
181− ,"if","you","think","it","is","on","the","Elm","side!"
182− ]
builder/src/Deps/Plan.hsdeleted−63
@@ -1,63 +0,0 @@
1−module Install.Plan where
2−
3−import qualified Data.Map as Map
4−
5−import qualified Elm.Package.Solution as S
6−import qualified Elm.Package as Package
7−
8−
9−data Plan = Plan
10− { installs :: Map.Map Package.Name Package.Version
11− , upgrades :: Map.Map Package.Name (Package.Version, Package.Version)
12− , removals :: Map.Map Package.Name Package.Version
13− }
14−
15−
16−create :: S.Solution -> S.Solution -> Plan
17−create old new =
18− Plan
19− { installs = Map.difference new old
20− , upgrades = discardNoOps (Map.intersectionWith (,) old new)
21− , removals = Map.difference old new
22− }
23− where
24− discardNoOps updates =
25− Map.mapMaybe isChanged updates
26−
27− isChanged upgrade@(oldVersion,newVersion) =
28− if oldVersion == newVersion
29− then Nothing
30− else Just upgrade
31−
32−
33−isEmpty :: Plan -> Bool
34−isEmpty (Plan installs upgrades removals) =
35− Map.null installs
36− && Map.null upgrades
37− && Map.null removals
38−
39−
40−-- DISPLAY
41−
42−display :: Plan -> String
43−display (Plan installs upgrades removals) =
44− "\n"
45− ++ displayCategory "Install" displayInstall installs
46− ++ displayCategory "Upgrade" displayUpgrade upgrades
47− ++ displayCategory "Remove" displayRemove removals
48− where
49− displayCategory name render category =
50− if Map.null category then "" else
51− " " ++ name ++ ":"
52− ++ concatMap (\entry -> "\n " ++ render entry) (Map.toList category)
53− ++ "\n"
54−
55− displayInstall (name, version) =
56− Package.toString name ++ " " ++ Package.versionToString version
57−
58− displayUpgrade (name, (old, new)) =
59− Package.toString name ++ " ("
60− ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")"
61−
62− displayRemove (name, _version) =
63− Package.toString name
builder/src/Deps/Registry.hsnew file+213
@@ -0,0 +1,213 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3+module Deps.Registry
4+ ( Registry(..)
5+ , KnownVersions(..)
6+ , read
7+ , fetch
8+ , update
9+ , latest
10+ , getVersions
11+ , getVersions'
12+ )
13+ where
14+
15+
16+import Prelude hiding (read)
17+import Control.Monad (liftM2)
18+import Data.Binary (Binary, get, put)
19+import qualified Data.List as List
20+import qualified Data.Map.Strict as Map
21+
22+import qualified Deps.Website as Website
23+import qualified Elm.Package as Pkg
24+import qualified Elm.Version as V
25+import qualified File
26+import qualified Http
27+import qualified Json.Decode as D
28+import qualified Parse.Primitives as P
29+import qualified Reporting.Exit as Exit
30+import qualified Stuff
31+
32+
33+
34+-- REGISTRY
35+
36+
37+data Registry =
38+ Registry
39+ { _count :: !Int
40+ , _versions :: !(Map.Map Pkg.Name KnownVersions)
41+ }
42+
43+
44+data KnownVersions =
45+ KnownVersions
46+ { _newest :: V.Version
47+ , _previous :: ![V.Version]
48+ }
49+
50+
51+
52+-- READ
53+
54+
55+read :: Stuff.PackageCache -> IO (Maybe Registry)
56+read cache =
57+ File.readBinary (Stuff.registry cache)
58+
59+
60+
61+-- FETCH
62+
63+
64+fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
65+fetch manager cache =
66+ post manager "/all-packages" allPkgsDecoder $
67+ \versions ->
68+ do let size = Map.foldr' addEntry 0 versions
69+ let registry = Registry size versions
70+ let path = Stuff.registry cache
71+ File.writeBinary path registry
72+ return registry
73+
74+
75+addEntry :: KnownVersions -> Int -> Int
76+addEntry (KnownVersions _ vs) count =
77+ count + 1 + length vs
78+
79+
80+allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
81+allPkgsDecoder =
82+ let
83+ keyDecoder =
84+ Pkg.keyDecoder bail
85+
86+ versionsDecoder =
87+ D.list (D.mapError (\_ -> ()) V.decoder)
88+
89+ toKnownVersions versions =
90+ case List.sortBy (flip compare) versions of
91+ v:vs -> return (KnownVersions v vs)
92+ [] -> D.failure ()
93+ in
94+ D.dict keyDecoder (toKnownVersions =<< versionsDecoder)
95+
96+
97+
98+-- UPDATE
99+
100+
101+update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
102+update manager cache oldRegistry@(Registry size packages) =
103+ post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
104+ \news ->
105+ case news of
106+ [] ->
107+ return oldRegistry
108+
109+ _:_ ->
110+ let
111+ newSize = size + length news
112+ newPkgs = foldr addNew packages news
113+ newRegistry = Registry newSize newPkgs
114+ in
115+ do File.writeBinary (Stuff.registry cache) newRegistry
116+ return newRegistry
117+
118+
119+addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions
120+addNew (name, version) versions =
121+ let
122+ add maybeKnowns =
123+ case maybeKnowns of
124+ Just (KnownVersions v vs) ->
125+ KnownVersions version (v:vs)
126+
127+ Nothing ->
128+ KnownVersions version []
129+ in
130+ Map.alter (Just . add) name versions
131+
132+
133+
134+-- NEW PACKAGE DECODER
135+
136+
137+newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
138+newPkgDecoder =
139+ D.customString newPkgParser bail
140+
141+
142+newPkgParser :: P.Parser () (Pkg.Name, V.Version)
143+newPkgParser =
144+ do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
145+ P.word1 0x40 {-@-} bail
146+ vsn <- P.specialize (\_ _ _ -> ()) V.parser
147+ return (pkg, vsn)
148+
149+
150+bail :: row -> col -> ()
151+bail _ _ =
152+ ()
153+
154+
155+
156+-- LATEST
157+
158+
159+latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
160+latest manager cache =
161+ do maybeOldRegistry <- read cache
162+ case maybeOldRegistry of
163+ Just oldRegistry ->
164+ update manager cache oldRegistry
165+
166+ Nothing ->
167+ fetch manager cache
168+
169+
170+
171+-- GET VERSIONS
172+
173+
174+getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions
175+getVersions name (Registry _ versions) =
176+ Map.lookup name versions
177+
178+
179+getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
180+getVersions' name (Registry _ versions) =
181+ case Map.lookup name versions of
182+ Just kvs -> Right kvs
183+ Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)
184+
185+
186+
187+-- POST
188+
189+
190+post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
191+post manager path decoder callback =
192+ let
193+ url = Website.route path []
194+ in
195+ Http.post manager url [] Exit.RP_Http $
196+ \body ->
197+ case D.fromByteString decoder body of
198+ Right a -> Right <$> callback a
199+ Left _ -> return $ Left $ Exit.RP_Data url body
200+
201+
202+
203+-- BINARY
204+
205+
206+instance Binary Registry where
207+ get = liftM2 Registry get get
208+ put (Registry a b) = put a >> put b
209+
210+
211+instance Binary KnownVersions where
212+ get = liftM2 KnownVersions get get
213+ put (KnownVersions a b) = put a >> put b
builder/src/Deps/Solver.hs+399−58
@@ -1,89 +1,243 @@
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
1module Deps.Solver
2module Deps.Solver
2 ( Solver
3 ( Solver
3− , run
4+ , Result(..)
4− , solve
5+ , Connection(..)
6+ --
7+ , Details(..)
8+ , verify
9+ --
10+ , AppSolution(..)
11+ , addToApp
12+ --
13+ , Env(..)
14+ , initEnv
5 )
15 )
6 where
16 where
7
17
8
18
9−import Control.Monad (foldM, guard, mzero, msum)
19+import Control.Monad (foldM)
10−import Control.Monad.Logic (LogicT, runLogicT, lift)
20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
11−import qualified Data.List as List
12import qualified Data.Map as Map
21import qualified Data.Map as Map
13−import Data.Map (Map)
22+import Data.Map ((!))
23+import qualified System.Directory as Dir
24+import System.FilePath ((</>))
14
25
15−import Elm.Package (Name, Version)
26+import qualified Deps.Registry as Registry
27+import qualified Deps.Website as Website
28+import qualified Elm.Constraint as C
29+import qualified Elm.Package as Pkg
30+import qualified Elm.Outline as Outline
31+import qualified Elm.Version as V
32+import qualified File
33+import qualified Http
34+import qualified Json.Decode as D
35+import qualified Reporting.Exit as Exit
36+import qualified Stuff
16
37
17−import Deps.Explorer (Explorer)
18−import qualified Deps.Explorer as Explorer
19−import Elm.Project.Constraint (Constraint)
20−import qualified Elm.Project.Constraint as Con
21
38
22
39
40+-- SOLVER
41+
42+
43+newtype Solver a =
44+ Solver
45+ (
46+ forall b.
47+ State
48+ -> (State -> a -> (State -> IO b) -> IO b)
49+ -> (State -> IO b)
50+ -> (Exit.Solver -> IO b)
51+ -> IO b
52+ )
53+
23
54
24−-- SOLVE
55+data State =
56+ State
57+ { _cache :: Stuff.PackageCache
58+ , _connection :: Connection
59+ , _registry :: Registry.Registry
60+ , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints
61+ }
25
62
26
63
27−solve :: Map Name Constraint -> Solver (Map Name Version)
64+data Constraints =
28−solve cons =
65+ Constraints
29− mkSolver (State Map.empty cons)
66+ { _elm :: C.Constraint
67+ , _deps :: Map.Map Pkg.Name C.Constraint
68+ }
30
69
31
70
32−type Solver a =
71+data Connection
33− LogicT Explorer a
72+ = Online Http.Manager
73+ | Offline
34
74
35
75
36−run :: Solver a -> Explorer (Maybe a)
37−run solver =
38− runLogicT solver (const . return . Just) (return Nothing)
39
76
77+-- RESULT
40
78
41
79
42−-- SOLVER
80+data Result a
81+ = Ok a
82+ | NoSolution
83+ | NoOfflineSolution
84+ | Err Exit.Solver
43
85
44
86
87+
88+-- VERIFY -- used by Elm.Details
89+
90+
45−data State =
91+data Details =
46− State
92+ Details V.Version (Map.Map Pkg.Name C.Constraint)
93+
94+
95+verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96+verify cache connection registry constraints =
97+ Stuff.withRegistryLock cache $
98+ case try constraints of
99+ Solver solver ->
100+ solver (State cache connection registry Map.empty)
101+ (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
102+ (\_ -> return $ noSolution connection)
103+ (\e -> return $ Err e)
104+
105+
106+addDeps :: State -> Pkg.Name -> V.Version -> Details
107+addDeps (State _ _ _ constraints) name vsn =
108+ case Map.lookup (name, vsn) constraints of
109+ Just (Constraints _ deps) -> Details vsn deps
110+ Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
111+
112+
113+noSolution :: Connection -> Result a
114+noSolution connection =
115+ case connection of
116+ Online _ -> NoSolution
117+ Offline -> NoOfflineSolution
118+
119+
120+
121+-- ADD TO APP - used in Install
122+
123+
124+data AppSolution =
125+ AppSolution
47− { _solution :: Map Name Version
126+ { _old :: Map.Map Pkg.Name V.Version
48− , _unsolved :: Map Name Constraint
127+ , _new :: Map.Map Pkg.Name V.Version
128+ , _app :: Outline.AppOutline
49 }
129 }
50
130
51
131
52−mkSolver :: State -> Solver (Map Name Version)
132+addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
53−mkSolver (State solution unsolved) =
133+addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
54− case Map.minViewWithKey unsolved of
134+ Stuff.withRegistryLock cache $
55− Nothing ->
135+ let
56− return solution
136+ allIndirects = Map.union indirect testIndirect
137+ allDirects = Map.union direct testDirect
138+ allDeps = Map.union allDirects allIndirects
139+
140+ attempt toConstraint deps =
141+ try (Map.insert pkg C.anything (Map.map toConstraint deps))
142+ in
143+ case
144+ oneOf
145+ ( attempt C.exactly allDeps )
146+ [ attempt C.exactly allDirects
147+ , attempt C.untilNextMinor allDirects
148+ , attempt C.untilNextMajor allDirects
149+ , attempt (\_ -> C.anything) allDirects
150+ ]
151+ of
152+ Solver solver ->
153+ solver (State cache connection registry Map.empty)
154+ (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
155+ (\_ -> return $ noSolution connection)
156+ (\e -> return $ Err e)
157+
158+
159+toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
160+toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
161+ let
162+ d = Map.intersection new (Map.insert pkg V.one direct)
163+ i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
164+ td = Map.intersection new (Map.delete pkg testDirect)
165+ ti = Map.difference new (Map.unions [d,i,td])
166+ in
167+ AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
168+
169+
170+getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
171+getTransitive constraints solution unvisited visited =
172+ case unvisited of
173+ [] ->
174+ visited
175+
176+ info@(pkg,vsn) : infos ->
177+ if Map.member pkg visited
178+ then getTransitive constraints solution infos visited
179+ else
180+ let
181+ newDeps = _deps (constraints ! info)
182+ newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
183+ newVisited = Map.insert pkg vsn visited
184+ in
185+ getTransitive constraints solution infos $
186+ getTransitive constraints solution newUnvisited newVisited
187+
188+
57
189
58− Just ((name, constraint), otherUnsolved) ->
190+-- TRY
59− do allVersions <- lift $ Explorer.getVersions name
60− let versions =
61− reverse $ List.sort $
62− filter (Con.satisfies constraint) allVersions
63
191
64− let state1 = State solution otherUnsolved
65− state2 <- msum (map (addVersion state1 name) versions)
66− mkSolver state2
67
192
193+try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
194+try constraints =
195+ exploreGoals (Goals constraints Map.empty)
68
196
69−addVersion :: State -> Name -> Version -> Solver State
70−addVersion (State solution unsolved) name version =
71− do (Explorer.Info elm cons) <-
72− lift $ Explorer.getConstraints name version
73
197
74− guard (Con.goodElm elm)
75− newUnsolved <- foldM (addConstraint solution) unsolved (Map.toList cons)
76− return (State (Map.insert name version solution) newUnsolved)
77
198
199+-- EXPLORE GOALS
78
200
201+
202+data Goals =
203+ Goals
204+ { _pending :: Map.Map Pkg.Name C.Constraint
205+ , _solved :: Map.Map Pkg.Name V.Version
206+ }
207+
208+
209+exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
210+exploreGoals (Goals pending solved) =
211+ case Map.minViewWithKey pending of
212+ Nothing ->
213+ return solved
214+
215+ Just ((name, constraint), otherPending) ->
216+ do let goals1 = Goals otherPending solved
217+ let addVsn = addVersion goals1 name
218+ (v,vs) <- getRelevantVersions name constraint
219+ goals2 <- oneOf (addVsn v) (map addVsn vs)
220+ exploreGoals goals2
221+
222+
223+addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
224+addVersion (Goals pending solved) name version =
225+ do (Constraints elm deps) <- getConstraints name version
226+ if C.goodElm elm
227+ then
228+ do newPending <- foldM (addConstraint solved) pending (Map.toList deps)
229+ return (Goals newPending (Map.insert name version solved))
230+ else
231+ backtrack
232+
233+
79−addConstraint :: Map Name Version -> Map Name Constraint -> (Name, Constraint) -> Solver (Map Name Constraint)
234+addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
80−addConstraint solution unsolved (name, newConstraint) =
235+addConstraint solved unsolved (name, newConstraint) =
81− case Map.lookup name solution of
236+ case Map.lookup name solved of
82 Just version ->
237 Just version ->
83− if Con.satisfies newConstraint version then
238+ if C.satisfies newConstraint version
84− return unsolved
239+ then return unsolved
85− else
240+ else backtrack
86− mzero
87
241
88 Nothing ->
242 Nothing ->
89 case Map.lookup name unsolved of
243 case Map.lookup name unsolved of
@@ -91,13 +245,200 @@ addConstraint solution unsolved (name, newConstraint) =
91 return $ Map.insert name newConstraint unsolved
245 return $ Map.insert name newConstraint unsolved
92
246
93 Just oldConstraint ->
247 Just oldConstraint ->
94− case Con.intersect oldConstraint newConstraint of
248+ case C.intersect oldConstraint newConstraint of
95 Nothing ->
249 Nothing ->
96− mzero
250+ backtrack
97
251
98 Just mergedConstraint ->
252 Just mergedConstraint ->
99− if oldConstraint == mergedConstraint then
253+ if oldConstraint == mergedConstraint
100− return unsolved
254+ then return unsolved
101− else
102− return (Map.insert name mergedConstraint unsolved)
255+ else return (Map.insert name mergedConstraint unsolved)
256+
257+
258+
259+-- GET RELEVANT VERSIONS
260+
261+
262+getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
263+getRelevantVersions name constraint =
264+ Solver $ \state@(State _ _ registry _) ok back _ ->
265+ case Registry.getVersions name registry of
266+ Just (Registry.KnownVersions newest previous) ->
267+ case filter (C.satisfies constraint) (newest:previous) of
268+ [] -> back state
269+ v:vs -> ok state (v,vs) back
270+
271+ Nothing ->
272+ back state
273+
274+
275+
276+-- GET CONSTRAINTS
277+
278+
279+getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
280+getConstraints pkg vsn =
281+ Solver $ \state@(State cache connection registry cDict) ok back err ->
282+ do let key = (pkg, vsn)
283+ case Map.lookup key cDict of
284+ Just cs ->
285+ ok state cs back
286+
287+ Nothing ->
288+ do let toNewState cs = State cache connection registry (Map.insert key cs cDict)
289+ let home = Stuff.package cache pkg vsn
290+ let path = home </> "elm.json"
291+ outlineExists <- File.exists path
292+ if outlineExists
293+ then
294+ do bytes <- File.readUtf8 path
295+ case D.fromByteString constraintsDecoder bytes of
296+ Right cs ->
297+ case connection of
298+ Online _ ->
299+ ok (toNewState cs) cs back
300+
301+ Offline ->
302+ do srcExists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
303+ if srcExists
304+ then ok (toNewState cs) cs back
305+ else back state
306+
307+ Left _ ->
308+ do File.remove path
309+ err (Exit.SolverBadCacheData pkg vsn)
310+ else
311+ case connection of
312+ Offline ->
313+ back state
314+
315+ Online manager ->
316+ do let url = Website.metadata pkg vsn "elm.json"
317+ result <- Http.get manager url [] id (return . Right)
318+ case result of
319+ Left httpProblem ->
320+ err (Exit.SolverBadHttp pkg vsn httpProblem)
321+
322+ Right body ->
323+ case D.fromByteString constraintsDecoder body of
324+ Right cs ->
325+ do Dir.createDirectoryIfMissing True home
326+ File.writeUtf8 path body
327+ ok (toNewState cs) cs back
328+
329+ Left _ ->
330+ err (Exit.SolverBadHttpData pkg vsn url)
331+
332+
333+constraintsDecoder :: D.Decoder () Constraints
334+constraintsDecoder =
335+ do outline <- D.mapError (const ()) Outline.decoder
336+ case outline of
337+ Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) ->
338+ return (Constraints elmConstraint deps)
339+
340+ Outline.App _ ->
341+ D.failure ()
342+
343+
344+
345+-- ENVIRONMENT
346+
347+
348+data Env =
349+ Env Stuff.PackageCache Http.Manager Connection Registry.Registry
350+
351+
352+initEnv :: IO (Either Exit.RegistryProblem Env)
353+initEnv =
354+ do mvar <- newEmptyMVar
355+ _ <- forkIO $ putMVar mvar =<< Http.getManager
356+ cache <- Stuff.getPackageCache
357+ Stuff.withRegistryLock cache $
358+ do maybeRegistry <- Registry.read cache
359+ manager <- readMVar mvar
360+
361+ case maybeRegistry of
362+ Nothing ->
363+ do eitherRegistry <- Registry.fetch manager cache
364+ case eitherRegistry of
365+ Right latestRegistry ->
366+ return $ Right $ Env cache manager (Online manager) latestRegistry
367+
368+ Left problem ->
369+ return $ Left $ problem
370+
371+ Just cachedRegistry ->
372+ do eitherRegistry <- Registry.update manager cache cachedRegistry
373+ case eitherRegistry of
374+ Right latestRegistry ->
375+ return $ Right $ Env cache manager (Online manager) latestRegistry
376+
377+ Left _ ->
378+ return $ Right $ Env cache manager Offline cachedRegistry
379+
380+
381+
382+-- INSTANCES
383+
384+
385+instance Functor Solver where
386+ fmap func (Solver solver) =
387+ Solver $ \state ok back err ->
388+ let
389+ okA stateA arg backA = ok stateA (func arg) backA
390+ in
391+ solver state okA back err
392+
393+
394+instance Applicative Solver where
395+ pure a =
396+ Solver $ \state ok back _ -> ok state a back
397+
398+ (<*>) (Solver solverFunc) (Solver solverArg) =
399+ Solver $ \state ok back err ->
400+ let
401+ okF stateF func backF =
402+ let
403+ okA stateA arg backA = ok stateA (func arg) backA
404+ in
405+ solverArg stateF okA backF err
406+ in
407+ solverFunc state okF back err
408+
409+
410+instance Monad Solver where
411+ return a =
412+ Solver $ \state ok back _ -> ok state a back
413+
414+ (>>=) (Solver solverA) callback =
415+ Solver $ \state ok back err ->
416+ let
417+ okA stateA a backA =
418+ case callback a of
419+ Solver solverB -> solverB stateA ok backA err
420+ in
421+ solverA state okA back err
422+
423+
424+oneOf :: Solver a -> [Solver a] -> Solver a
425+oneOf solver@(Solver solverHead) solvers =
426+ case solvers of
427+ [] ->
428+ solver
429+
430+ s:ss ->
431+ Solver $ \state0 ok back err ->
432+ let
433+ tryTail state1 =
434+ let
435+ (Solver solverTail) = oneOf s ss
436+ in
437+ solverTail state1 ok back err
438+ in
439+ solverHead state0 ok tryTail err
440+
103
441
442+backtrack :: Solver a
443+backtrack =
444+ Solver $ \state _ back _ -> back state
builder/src/Deps/Verify.hsdeleted−362
@@ -1,362 +0,0 @@
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.Set as Set
13−import Data.Map (Map)
14−import Data.Set (Set)
15−import System.Directory (doesDirectoryExist)
16−import System.FilePath ((</>))
17−
18−import qualified Elm.Compiler.Module as Module
19−import qualified Elm.Compiler.Objects as Obj
20−import qualified Elm.Docs as Docs
21−import Elm.Package (Name, Version)
22−import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))
23−import qualified Json.Encode as Encode
24−
25−import qualified Deps.Explorer as Explorer
26−import qualified Deps.Get as Get
27−import qualified Deps.Solver as Solver
28−import qualified Deps.Website as Website
29−import qualified Elm.Compiler as Compiler
30−import qualified Elm.Project.Json as Project
31−import qualified Elm.Project.Constraint as Con
32−import qualified Elm.Project.Summary as Summary
33−import qualified File.Args as Args
34−import qualified File.Artifacts as Artifacts
35−import qualified File.Compile as Compile
36−import qualified File.Crawl as Crawl
37−import qualified File.IO as IO
38−import qualified File.Plan as Plan
39−import qualified Reporting.Error as Error
40−import qualified Reporting.Error.Deps as E
41−import qualified Reporting.Progress as Progress
42−import qualified Reporting.Task as Task
43−import qualified Stuff.Paths as Paths
44−
45−
46−
47−-- VERIFY
48−
49−
50−verify :: FilePath -> Project -> Task.Task (Map Name Version, Summary.Summary)
51−verify root project =
52− do solution <- Project.get verifyApp verifyPkg project
53− (RawInfo infos ifaces) <- verifyArtifacts solution
54− let summary = Summary.init root project infos ifaces
55− return (solution, summary)
56−
57−
58−throw :: E.Error -> Task.Task a
59−throw err =
60− Task.throw (Error.Deps err)
61−
62−
63−
64−-- VERIFY SOLUTION
65−
66−
67−verifyApp :: AppInfo -> Task.Task (Map Name Version)
68−verifyApp info =
69− if _app_elm_version info /= Compiler.version then
70− throw (E.AppBadElm (_app_elm_version info))
71−
72− else
73− do let oldSolution = Project.appSolution info
74− let solver = Solver.solve (Map.map Con.exactly oldSolution)
75− maybeSolution <- Explorer.run (Solver.run solver)
76− case maybeSolution of
77− Nothing ->
78− throw E.BadDeps
79−
80− Just solution ->
81− return solution
82−
83−
84−verifyPkg :: PkgInfo -> Task.Task (Map Name Version)
85−verifyPkg info =
86− if not (Con.goodElm (_pkg_elm_version info)) then
87− throw (E.PkgBadElm (_pkg_elm_version info))
88−
89− else
90− do let deps = Map.union (_pkg_deps info) (_pkg_test_deps info)
91− let solver = Solver.solve deps
92− maybeSolution <- Explorer.run (Solver.run solver)
93− case maybeSolution of
94− Nothing ->
95− throw E.BadDeps
96−
97− Just solution ->
98− return solution
99−
100−
101−
102−-- VERIFY ARTIFACTS
103−
104−
105−verifyArtifacts :: Map Name Version -> Task.Task RawInfo
106−verifyArtifacts solution =
107− do Website.download =<< filterM noSrc (Map.toList solution)
108− verifyBuildArtifacts solution
109−
110−
111−noSrc :: (Name, Version) -> Task.Task Bool
112−noSrc (name, version) =
113− do root <- Task.getPackageCacheDirFor name version
114− liftIO $ not <$> doesDirectoryExist (root </> "src")
115−
116−
117−
118−-- VERIFY BUILD ARTIFACTS
119−
120−
121−verifyBuildArtifacts :: Map Name Version -> Task.Task RawInfo
122−verifyBuildArtifacts solution =
123− do Task.report (Progress.BuildDepsStart (Map.size solution))
124− startMVar <- liftIO newEmptyMVar
125− ifacesMVar <- liftIO $ newMVar Map.empty
126− pkgInfoMVars <- Map.traverseWithKey (verifyBuild startMVar ifacesMVar) solution
127− liftIO $ putMVar startMVar pkgInfoMVars
128− answers <- liftIO $ traverse readMVar pkgInfoMVars
129− Task.report Progress.BuildDepsEnd
130− RawInfo
131− <$> Map.traverseMaybeWithKey toInfo answers
132− <*> liftIO (readMVar ifacesMVar)
133−
134−
135−data RawInfo =
136− RawInfo (Map Name PkgInfo) Module.Interfaces
137−
138−
139−verifyBuild
140− :: MVar (Map Name (MVar Answer))
141− -> MVar Module.Interfaces
142− -> Name
143− -> Version
144− -> Task.Task (MVar Answer)
145−verifyBuild pkgInfoMVar ifacesMVar name version =
146− do mvar <- liftIO newEmptyMVar
147− info <- Get.info name version
148− report <- Task.getReporter
149− runner <- Task.getSilentRunner
150−
151− liftIO $ void $ forkIO $
152− do allMVars <- readMVar pkgInfoMVar
153− let deps = Project._pkg_deps info
154− let depsMVars = Map.intersection allMVars deps
155− depAnswers <- traverse readMVar depsMVars
156−
157− answer <- ifNotBlocked depAnswers $ \infos ->
158− do ifacesBefore <- readMVar ifacesMVar
159− result <- runner (getIface name version info infos ifacesBefore)
160− case result of
161− Right ifaces ->
162− do ifacesNow <- takeMVar ifacesMVar
163− putMVar ifacesMVar (Map.union ifacesNow ifaces)
164− return (Ok info)
165−
166− Left _ ->
167− return (Err name version)
168−
169− report Progress.BuildDepsProgress
170− putMVar mvar answer
171−
172− return mvar
173−
174−
175−
176−-- ANSWERS
177−
178−
179−data Answer
180− = Ok PkgInfo
181− | Blocked
182− | Err Name Version
183−
184−
185−toInfo :: Name -> Answer -> Task.Task (Maybe PkgInfo)
186−toInfo _ answer =
187− case answer of
188− Ok info ->
189− return (Just info)
190−
191− Blocked ->
192− return Nothing
193−
194− Err name version ->
195− throw (E.BuildFailure name version)
196−
197−
198−ifNotBlocked :: Map Name Answer -> (Map Name PkgInfo -> IO Answer) -> IO Answer
199−ifNotBlocked answers callback =
200− case traverse isOk answers of
201− Nothing ->
202− return Blocked
203−
204− Just infos ->
205− callback infos
206−
207−
208−isOk :: Answer -> Maybe PkgInfo
209−isOk answer =
210− case answer of
211− Ok info -> Just info
212− Blocked -> Nothing
213− Err _ _ -> Nothing
214−
215−
216−
217−-- GET INTERFACE
218−
219−
220−getIface
221− :: Name
222− -> Version
223− -> PkgInfo
224− -> Map Name PkgInfo
225− -> Module.Interfaces
226− -> Task.Task Module.Interfaces
227−getIface name version info infos depIfaces =
228− do root <- Task.getPackageCacheDirFor name version
229− let solution = Map.map _pkg_version infos
230−
231− cached <- isCached root solution
232−
233− if cached
234− then IO.readBinary (root </> "ifaces.dat")
235− else
236− do Paths.removeStuff root
237−
238− let summary = Summary.cheapInit root info infos depIfaces
239− args <- Args.fromSummary summary
240− graph <- Crawl.crawl summary args
241− (dirty, cachedIfaces) <- Plan.plan summary graph
242− answers <- Compile.compile (Pkg info) cachedIfaces dirty
243− results <- Artifacts.ignore answers
244− _ <- Artifacts.writeDocs (root </> "docs.json") results
245−
246− Paths.removeStuff root
247−
248− updateCache root name info solution graph results
249−
250−
251−
252−-- IS CACHED?
253−
254−
255−isCached :: FilePath -> Map Name Version -> Task.Task Bool
256−isCached root solution =
257− IO.andM
258− [ IO.exists (root </> "cached.dat")
259− , IO.exists (root </> "ifaces.dat")
260− , IO.exists (root </> "objs.dat")
261− , IO.exists (root </> "documentation.json")
262− , isCachedHelp solution <$> IO.readBinary (root </> "cached.dat")
263− ]
264−
265−
266−isCachedHelp :: Map Name Version -> Map Name (Set Version) -> Bool
267−isCachedHelp solution cachedDeps =
268− let
269− matches =
270− Map.intersectionWith Set.member solution cachedDeps
271− in
272− Map.size solution == Map.size matches
273− && Map.foldr (&&) True matches
274−
275−
276−
277−-- UPDATE CACHE
278−
279−
280−updateCache
281− :: FilePath
282− -> Name
283− -> PkgInfo
284− -> Map Name Version
285− -> Crawl.Result
286− -> Map Module.Raw Compiler.Artifacts
287− -> Task.Task Module.Interfaces
288−updateCache root name info solution graph results =
289− do let path = root </> "cached.dat"
290− let deps = Map.map Set.singleton solution
291− let elmi = crush name info results
292−
293− exists <- IO.exists path
294−
295− if exists
296− then
297− do oldDeps <- IO.readBinary path
298− IO.writeBinary path (Map.unionWith Set.union deps oldDeps)
299− else
300− do IO.writeBinary (root </> "ifaces.dat") elmi
301−
302− IO.writeBinary path deps
303−
304− IO.writeBinary (root </> "objs.dat") $
305− Map.foldr addGraph (objGraphFromKernels graph) results
306−
307− liftIO $ Encode.write (root </> "documentation.json") $
308− Encode.list Docs.encode $
309− Map.foldr addDocs [] results
310−
311− return elmi
312−
313−
314−
315−-- CRUSH INTERFACES
316−
317−
318−crush :: Name -> PkgInfo -> Map Module.Raw Compiler.Artifacts -> Module.Interfaces
319−crush pkg info results =
320− let
321− exposed =
322− Set.fromList (Project.getExposed info)
323− in
324− Map.mapKeys (Module.Canonical pkg) $
325− Map.mapMaybeWithKey (crushHelp exposed) results
326−
327−
328−crushHelp :: Set Module.Raw -> Module.Raw -> Compiler.Artifacts -> Maybe Module.Interface
329−crushHelp exposed name (Compiler.Artifacts elmi _ _) =
330− if Set.member name exposed then
331− Just elmi
332−
333− else
334− Nothing
335−
336−
337−
338−-- DOCUMENTATION
339−
340−
341−addDocs :: Compiler.Artifacts -> [Docs.Module] -> [Docs.Module]
342−addDocs (Compiler.Artifacts _ _ maybeDocs) docsList =
343− case maybeDocs of
344− Nothing ->
345− docsList
346−
347− Just docs ->
348− docs : docsList
349−
350−
351−
352−-- OBJECT GRAPH
353−
354−
355−addGraph :: Compiler.Artifacts -> Obj.Graph -> Obj.Graph
356−addGraph (Compiler.Artifacts _ elmo _) graph =
357− Obj.union elmo graph
358−
359−
360−objGraphFromKernels :: Crawl.Result -> Obj.Graph
361−objGraphFromKernels (Crawl.Graph _ _ kernels _ _) =
362− Obj.fromKernels kernels
builder/src/Deps/Website.hs+14−332
@@ -1,344 +1,26 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module Deps.Website
1module Deps.Website
4− ( getElmJson
2+ ( domain
5− , getDocs
3+ , route
6− , getNewPackages
4+ , metadata
7− , getAllPackages
8− , download
9− , githubCommit
10− , githubDownload
11− , Sha
12− , register
13 )
5 )
14 where
6 where
15
7
16−import Prelude hiding (zip)
17−import qualified Codec.Archive.Zip as Zip
18−import Control.Monad (void)
19−import qualified Data.Binary as Binary
20−import qualified Data.Binary.Get as Binary
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Data.ByteString.Lazy as LBS
23−import qualified Data.Digest.Pure.SHA as SHA
24−import qualified Data.HashMap.Lazy as HashMap
25−import qualified Data.Map as Map
26−import qualified Data.Text as Text
27−import qualified Network.HTTP.Client as Client
28−import qualified Network.HTTP.Client.MultipartFormData as Multi
29−import qualified Network.HTTP.Types as Http
30−import qualified System.Directory as Dir
31−import System.FilePath ((</>), splitFileName)
32−import qualified Text.PrettyPrint.ANSI.Leijen as P
33
8
34−import Elm.Package (Name, Version)
35import qualified Elm.Package as Pkg
9import qualified Elm.Package as Pkg
36−import qualified Json.Decode as D
10+import qualified Elm.Version as V
11+import qualified Http
37
12
38−import qualified Reporting.Error.Http as E
39−import qualified Reporting.Progress as Progress
40−import qualified Reporting.Task as Task
41−import qualified Reporting.Task.Http as Http
42−import qualified Stuff.Paths as Path
43
13
14+domain :: String
15+domain =
16+ "https://package.elm-lang.org"
44
17
45
18
46−-- GET PACKAGE INFO
19+route :: String -> [(String,String)] -> String
20+route path params =
21+ Http.toUrl (domain ++ path) params
47
22
48
23
49−getElmJson :: Name -> Version -> Task.Task BS.ByteString
24+metadata :: Pkg.Name -> V.Version -> String -> String
50−getElmJson name version =
25+metadata name version file =
51− Http.run $ fetchByteString $
52− "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/elm.json"
53−
54−
55−getDocs :: Name -> Version -> Task.Task BS.ByteString
56−getDocs name version =
57− Http.run $ fetchByteString $
58− "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/docs.json"
26+ domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file
59−
60−
61−
62−-- NEW PACKAGES
63−
64−
65−getNewPackages :: Int -> Task.Task [(Name, Version)]
66−getNewPackages index =
67− Http.run $ fetchJson "packages" E.badJsonToDocs (D.list newPkgDecoder) ("all-packages/since/" ++ show index)
68−
69−
70−newPkgDecoder :: D.Decoder E.BadJson ( Name, Version )
71−newPkgDecoder =
72− do txt <- D.text
73− case Text.splitOn "@" txt of
74− [key, value] ->
75− case Pkg.fromText key of
76− Right pkg ->
77− case Pkg.versionFromText value of
78− Just vsn ->
79− D.succeed (pkg, vsn)
80−
81− Nothing ->
82− D.fail (E.BadNewPkg txt)
83−
84− Left _ ->
85− D.fail (E.BadNewPkg txt)
86−
87− _ ->
88− D.fail (E.BadNewPkg txt)
89−
90−
91−
92−-- ALL PACKAGES
93−
94−
95−getAllPackages :: Task.Task (Map.Map Name [Version])
96−getAllPackages =
97− Http.run $ fetchJson "packages" E.badJsonToDocs allPkgsDecoder "all-packages"
98−
99−
100−allPkgsDecoder :: D.Decoder E.BadJson (Map.Map Name [Version])
101−allPkgsDecoder =
102− let
103− checkKeys pairs pkgs =
104− case pairs of
105− [] ->
106− D.succeed pkgs
107−
108− (key, versions) : rest ->
109− case Pkg.fromText key of
110− Left msg ->
111− D.fail (E.BadAllPkg key msg)
112−
113− Right pkg ->
114− checkKeys rest (Map.insert pkg versions pkgs)
115− in
116− do dict <- D.dict (D.list (D.mapError E.BadAllVsn Pkg.versionDecoder))
117− checkKeys (HashMap.toList dict) Map.empty
118−
119−
120−
121−-- HELPERS
122−
123−
124−fetchByteString :: String -> Http.Fetch BS.ByteString
125−fetchByteString path =
126− Http.package path [] $ \request manager ->
127− do response <- Client.httpLbs request manager
128− return $ Right $ LBS.toStrict $ Client.responseBody response
129−
130−
131−fetchJson :: String -> (e -> [P.Doc]) -> D.Decoder e a -> String -> Http.Fetch a
132−fetchJson rootName errorToDocs decoder path =
133− Http.package path [] $ \request manager ->
134− do response <- Client.httpLbs request manager
135− let bytes = LBS.toStrict (Client.responseBody response)
136− case D.parse path rootName errorToDocs decoder bytes of
137− Right value ->
138− return $ Right value
139−
140− Left jsonProblem ->
141− return $ Left $ E.BadJson jsonProblem
142−
143−
144−
145−-- DOWNLOAD
146−
147−
148−download :: [(Name, Version)] -> Task.Task ()
149−download packages =
150− case packages of
151− [] ->
152− Task.report Progress.DownloadSkip
153−
154− _ ->
155− do cache <- Task.getPackageCacheDir
156−
157− let start = Progress.DownloadStart packages
158− let toEnd = Progress.DownloadEnd
159−
160− void $ Http.run $ Http.report start toEnd $
161− Http.parallel $ map (downloadHelp cache) packages
162−
163−
164−downloadHelp :: FilePath -> (Name, Version) -> Http.Fetch ()
165−downloadHelp cache (name, version) =
166− let
167− endpointUrl =
168− "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/endpoint.json"
169− in
170− Http.andThen (fetchJson "version" id endpointDecoder endpointUrl) $ \(endpoint, hash) ->
171− let
172− start = Progress.DownloadPkgStart name version
173− toEnd = Progress.DownloadPkgEnd name version
174− in
175− Http.report start toEnd $
176− Http.anything endpoint $ \request manager ->
177− Client.withResponse request manager (downloadArchive cache name version hash)
178−
179−
180−endpointDecoder :: D.Decoder e (String, String)
181−endpointDecoder =
182− D.map2 (,)
183− (D.field "url" D.string)
184− (D.field "hash" D.string)
185−
186−
187−
188−-- DOWNLOAD ZIP ARCHIVE
189−
190−
191−downloadArchive :: FilePath -> Name -> Version -> String -> Client.Response Client.BodyReader -> IO (Either E.Error ())
192−downloadArchive cache name version expectedHash response =
193− do result <- readArchive (Client.responseBody response) initialArchiveState
194− case result of
195− Left msg ->
196− return (Left msg)
197−
198− Right (sha, archive) ->
199− if expectedHash == SHA.showDigest sha then
200− Right <$> writeArchive archive (cache </> Pkg.toFilePath name) (Pkg.versionToString version)
201− else
202− return $ Left $ E.BadZipSha expectedHash (SHA.showDigest sha)
203−
204−
205−
206−-- READ ARCHIVE
207−
208−
209−data ArchiveState =
210− AS
211− { _len :: !Int
212− , _sha :: !(Binary.Decoder SHA.SHA1State)
213− , _zip :: !(Binary.Decoder Zip.Archive)
214− }
215−
216−
217−initialArchiveState :: ArchiveState
218−initialArchiveState =
219− AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
220−
221−
222−type Sha = SHA.Digest SHA.SHA1State
223−
224−
225−readArchive :: Client.BodyReader -> ArchiveState -> IO (Either E.Error (Sha, Zip.Archive))
226−readArchive body (AS len sha zip) =
227− case zip of
228− Binary.Fail _ _ _ ->
229− return $ Left E.BadZipData
230−
231− Binary.Partial k ->
232− do chunk <- Client.brRead body
233− readArchive body $ AS
234− { _len = len + BS.length chunk
235− , _sha = Binary.pushChunk sha chunk
236− , _zip = k (if BS.null chunk then Nothing else Just chunk)
237− }
238−
239− Binary.Done _ _ archive ->
240− return $ Right ( SHA.completeSha1Incremental sha len, archive )
241−
242−
243−
244−-- WRITE ARCHIVE
245−
246−
247−writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
248−writeArchive archive destination newRoot =
249− do Dir.createDirectoryIfMissing True destination
250− let opts = [Zip.OptDestination destination]
251− mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)
252−
253−
254−replaceRoot :: String -> Zip.Entry -> Zip.Entry
255−replaceRoot root entry =
256− let
257− rootless =
258− dropWhile (/='/') (Zip.eRelativePath entry)
259− in
260− entry { Zip.eRelativePath = root ++ rootless }
261−
262−
263−
264−-- FIND TAGGED COMMIT ON GITHUB
265−
266−
267−githubCommit :: Name -> Version -> Task.Task String
268−githubCommit name version =
269− let
270− endpoint =
271− "https://api.github.com/repos/" ++ Pkg.toUrl name ++ "/git/refs/tags/temp-" ++ Pkg.versionToString version
272−
273− headers =
274− [ ( Http.hUserAgent, "elm-cli" )
275− , ( Http.hAccept, "application/json" )
276− ]
277−
278− decoder =
279− D.at ["object","sha"] D.string
280− in
281− Http.run $ Http.anything endpoint $ \request manager ->
282− do response <- Client.httpLbs (request { Client.requestHeaders = headers }) manager
283− let bytes = LBS.toStrict (Client.responseBody response)
284− case D.parse "github.json" "github" id decoder bytes of
285− Right value ->
286− return $ Right value
287−
288− Left jsonProblem ->
289− return $ Left $ E.BadJson jsonProblem
290−
291−
292−
293−-- DOWNLOAD FROM GITHUB
294−
295−
296−githubDownload :: Name -> Version -> FilePath -> Task.Task Sha
297−githubDownload name version dir =
298− let
299− endpoint =
300− "https://github.com/" ++ Pkg.toUrl name ++ "/zipball/temp-" ++ Pkg.versionToString version ++ "/"
301− in
302− Http.run $ Http.anything endpoint $ \request manager ->
303− Client.withResponse request manager (githubDownloadHelp dir)
304−
305−
306−githubDownloadHelp :: FilePath -> Client.Response Client.BodyReader -> IO (Either E.Error Sha)
307−githubDownloadHelp targetDir response =
308− do result <- readArchive (Client.responseBody response) initialArchiveState
309− case result of
310− Left msg ->
311− return (Left msg)
312−
313− Right (sha, archive) ->
314− do let (dir, root) = splitFileName targetDir
315− writeArchive archive dir root
316− return $ Right sha
317−
318−
319−
320−-- REGISTER PACKAGES
321−
322−
323−register :: Name -> Version -> String -> Sha -> Task.Task ()
324−register name version commitHash digest =
325− let
326− params =
327− [ ("name", Pkg.toString name)
328− , ("version", Pkg.versionToString version)
329− , ("commit-hash", commitHash)
330− ]
331−
332− files =
333− [ Multi.partFileSource "elm.json" "elm.json"
334− , Multi.partFileSource "docs.json" Path.docs
335− , Multi.partFileSource "README.md" "README.md"
336− , Multi.partFileRequestBody "github-hash" "github-hash" $
337− Client.RequestBodyBS (BS.pack (SHA.showDigest digest))
338− ]
339− in
340− Http.run $ Http.package "register" params $ \rawRequest manager ->
341− do requestWithBody <- Multi.formDataBody files rawRequest
342− let request = requestWithBody { Client.responseTimeout = Client.responseTimeoutNone }
343− void $ Client.httpLbs request manager
344− return $ Right ()
builder/src/Elm/Bump.hsdeleted−140
@@ -1,140 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Bump
4− ( bump
5− , toPossibleBumps
6− )
7− where
8−
9−
10−import Control.Monad.Trans (liftIO)
11−import qualified Data.List as List
12−import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
13−import qualified Text.PrettyPrint.ANSI.Leijen as P
14−
15−import qualified Deps.Diff as Diff
16−import qualified Deps.Get as Get
17−import qualified Elm.Package as Pkg
18−import qualified Elm.Project as Project
19−import qualified Elm.Project.Json as Project
20−import qualified Elm.Project.Summary as Summary
21−import qualified Reporting.Error as Error
22−import qualified Reporting.Error.Bump as E
23−import qualified Reporting.Error.Help as Help
24−import qualified Reporting.Progress.Terminal as Terminal
25−import qualified Reporting.Task as Task
26−
27−
28−
29−-- BUMP
30−
31−
32−bump :: Summary.Summary -> Task.Task ()
33−bump summary@(Summary.Summary root project _ _ _) =
34− case project of
35− Project.App _ ->
36− Task.throw (Error.Bump E.Application)
37−
38− Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->
39− do pkgs <- Get.all Get.RequireLatest
40− case Get.versions name pkgs of
41− Left _suggestions ->
42− checkNewPackage root info
43−
44− Right publishedVersions ->
45− let
46− bumpableVersions =
47− map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)
48− in
49− if elem version bumpableVersions then
50− suggestVersion summary info
51− else
52− Task.throw $ Error.Bump $ E.Unbumpable version $
53− map head (List.group (List.sort bumpableVersions))
54−
55−
56−
57−-- VALID BUMPS
58−
59−
60−toPossibleBumps :: [Pkg.Version] -> [(Pkg.Version, Pkg.Version, Diff.Magnitude)]
61−toPossibleBumps publishedVersions =
62− case publishedVersions of
63− [] ->
64− []
65−
66− _ ->
67− let
68− patchPoints =
69− Pkg.filterLatest Pkg.majorAndMinor publishedVersions
70−
71− minorPoints =
72− Pkg.filterLatest Pkg._major publishedVersions
73−
74− majorPoint =
75− maximum publishedVersions
76− in
77− (majorPoint, Pkg.bumpMajor majorPoint, Diff.MAJOR)
78− : map (\v -> (v, Pkg.bumpMinor v, Diff.MINOR)) minorPoints
79− ++ map (\v -> (v, Pkg.bumpPatch v, Diff.PATCH)) patchPoints
80−
81−
82−
83−-- CHECK NEW PACKAGE
84−
85−
86−checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()
87−checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =
88− do liftIO $ putStrLn Terminal.newPackageOverview
89− if version == Pkg.initialVersion
90− then
91− liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"
92− else
93− changeVersion root info Pkg.initialVersion $
94− "It looks like the version in elm.json has been changed though!\n\
95− \Would you like me to change it back to "
96− <> P.text (Pkg.versionToString Pkg.initialVersion) <> "? [Y/n] "
97−
98−
99−
100−-- SUGGEST VERSION
101−
102−
103−suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()
104−suggestVersion summary@(Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =
105− do oldDocs <- Get.docs name version
106− newDocs <- Task.silently (Project.generateDocs summary)
107− let changes = Diff.diff oldDocs newDocs
108− let newVersion = Diff.bump changes version
109− changeVersion root info newVersion $
110− let
111− old = P.text $ Pkg.versionToString version
112− new = P.text $ Pkg.versionToString newVersion
113− mag = P.text $ Diff.magnitudeToString (Diff.toMagnitude changes)
114− in
115− "Based on your new API, this should be a" <+> P.green mag <+> "change (" <> old <> " => " <> new <> ")\n"
116− <> "Bail out of this command and run 'elm diff' for a full explanation.\n"
117− <> "\n"
118− <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "
119−
120−
121−
122−-- CHANGE VERSION
123−
124−
125−changeVersion :: FilePath -> Project.PkgInfo -> Pkg.Version -> P.Doc -> Task.Task ()
126−changeVersion root info targetVersion explanation =
127− do liftIO $ Help.toStdout explanation
128− approved <- Task.getApproval
129− if not approved
130− then
131− liftIO $ putStrLn "Okay, no changes were made."
132−
133− else
134− do liftIO $ Project.write root $ Project.Pkg $
135− info { Project._pkg_version = targetVersion }
136−
137− liftIO $ Help.toStdout $
138− "Version changed to "
139− <> P.green (P.text (Pkg.versionToString targetVersion))
140− <> "!\n"
builder/src/Elm/Details.hsnew file+833
@@ -0,0 +1,833 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3+module Elm.Details
4+ ( Details(..)
5+ , BuildID
6+ , ValidOutline(..)
7+ , Local(..)
8+ , Foreign(..)
9+ , load
10+ , loadObjects
11+ , loadInterfaces
12+ , verifyInstall
13+ )
14+ where
15+
16+
17+import Control.Concurrent (forkIO)
18+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
19+import Control.Monad (liftM, liftM2, liftM3)
20+import Data.Binary (Binary, get, put, getWord8, putWord8)
21+import qualified Data.Either as Either
22+import qualified Data.Map as Map
23+import qualified Data.Map.Utils as Map
24+import 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
29+import qualified Data.Set as Set
30+import qualified Data.Utf8 as Utf8
31+import Data.Word (Word64)
32+import qualified System.Directory as Dir
33+import System.FilePath ((</>), (<.>))
34+
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
40+import qualified Deps.Registry as Registry
41+import qualified Deps.Solver as Solver
42+import qualified Deps.Website as Website
43+import qualified Elm.Constraint as Con
44+import qualified Elm.Docs as Docs
45+import qualified Elm.Interface as I
46+import qualified Elm.Kernel as Kernel
47+import qualified Elm.ModuleName as ModuleName
48+import qualified Elm.Outline as Outline
49+import qualified Elm.Package as Pkg
50+import qualified Elm.Version as V
51+import qualified File
52+import qualified Http
53+import 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
58+import qualified Reporting.Exit as Exit
59+import qualified Reporting.Task as Task
60+import qualified Stuff
61+
62+
63+
64+-- DETAILS
65+
66+
67+data Details =
68+ Details
69+ { _outlineTime :: File.Time
70+ , _outline :: ValidOutline
71+ , _buildID :: BuildID
72+ , _locals :: Map.Map ModuleName.Raw Local
73+ , _foreigns :: Map.Map ModuleName.Raw Foreign
74+ , _extras :: Extras
75+ }
76+
77+
78+type BuildID = Word64
79+
80+
81+data ValidOutline
82+ = ValidApp (NE.List Outline.SrcDir)
83+ | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
84+
85+
86+-- NOTE: we need two ways to detect if a file must be recompiled:
87+--
88+-- (1) _time is the modification time from the last time we compiled the file.
89+-- By checking EQUALITY with the current modification time, we can detect file
90+-- saves and `git checkout` of previous versions. Both need a recompile.
91+--
92+-- (2) _lastChange is the BuildID from the last time a new interface file was
93+-- generated, and _lastCompile is the BuildID from the last time the file was
94+-- compiled. These may be different if a file is recompiled but the interface
95+-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any
96+-- imports, we need to recompile. This can happen when a project has multiple
97+-- entrypoints and some modules are compiled less often than their imports.
98+--
99+data Local =
100+ Local
101+ { _path :: FilePath
102+ , _time :: File.Time
103+ , _deps :: [ModuleName.Raw]
104+ , _main :: Bool
105+ , _lastChange :: BuildID
106+ , _lastCompile :: BuildID
107+ }
108+
109+
110+data Foreign =
111+ Foreign Pkg.Name [Pkg.Name]
112+
113+
114+data Extras
115+ = ArtifactsCached
116+ | ArtifactsFresh Interfaces Opt.GlobalGraph
117+
118+
119+type Interfaces =
120+ Map.Map ModuleName.Canonical I.DependencyInterface
121+
122+
123+
124+-- LOAD ARTIFACTS
125+
126+
127+loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))
128+loadObjects root (Details _ _ _ _ _ extras) =
129+ case extras of
130+ ArtifactsFresh _ o -> newMVar (Just o)
131+ ArtifactsCached -> fork (File.readBinary (Stuff.objects root))
132+
133+
134+loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))
135+loadInterfaces root (Details _ _ _ _ _ extras) =
136+ case extras of
137+ ArtifactsFresh i _ -> newMVar (Just i)
138+ ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))
139+
140+
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+
781+-- BINARY
782+
783+
784+instance Binary Details where
785+ put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e
786+ get =
787+ do a <- get
788+ b <- get
789+ c <- get
790+ d <- get
791+ e <- get
792+ return (Details a b c d e ArtifactsCached)
793+
794+
795+instance Binary ValidOutline where
796+ put outline =
797+ case outline of
798+ ValidApp a -> putWord8 0 >> put a
799+ ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
800+
801+ get =
802+ do n <- getWord8
803+ case n of
804+ 0 -> liftM ValidApp get
805+ 1 -> liftM3 ValidPkg get get get
806+ _ -> fail "binary encoding of ValidOutline was corrupted"
807+
808+
809+instance Binary Local where
810+ put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f
811+ get =
812+ do a <- get
813+ b <- get
814+ c <- get
815+ d <- get
816+ e <- get
817+ f <- get
818+ return (Local a b c d e f)
819+
820+
821+instance Binary Foreign where
822+ get = liftM2 Foreign get get
823+ put (Foreign a b) = put a >> put b
824+
825+
826+instance Binary Artifacts where
827+ get = liftM2 Artifacts get get
828+ put (Artifacts a b) = put a >> put b
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.hsdeleted−279
@@ -1,279 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Diff
4− ( Args(..)
5− , diff
6− )
7− where
8−
9−
10−import Control.Monad.Except (liftIO)
11−import qualified Data.List as List
12−import qualified Data.Map as Map
13−import qualified Data.Maybe as Maybe
14−import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
15−import qualified Text.PrettyPrint.ANSI.Leijen as P
16−
17−import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))
18−import qualified Deps.Diff as Diff
19−import qualified Deps.Get as Get
20−import qualified Elm.Compiler.Module as Module
21−import qualified Elm.Compiler.Type as Type
22−import qualified Elm.Docs as Docs
23−import qualified Elm.Name as N
24−import qualified Elm.Package as Pkg
25−import qualified Elm.Project as Project
26−import qualified Elm.Project.Json as Project
27−import qualified Elm.Project.Summary as Summary
28−import qualified Reporting.Error as Error
29−import qualified Reporting.Error.Diff as E
30−import qualified Reporting.Error.Help as Help
31−import qualified Reporting.Task as Task
32−
33−
34−
35−-- DIFF
36−
37−
38−data Args
39− = CodeVsLatest
40− | CodeVsExactly Pkg.Version
41− | LocalInquiry Pkg.Version Pkg.Version
42− | GlobalInquiry Pkg.Name Pkg.Version Pkg.Version
43−
44−
45−diff :: Args -> Task.Task ()
46−diff args =
47− case args of
48− GlobalInquiry name v1 v2 ->
49− do pkgs <- Get.all Get.RequireLatest
50− case Get.versions name pkgs of
51− Left suggestions ->
52− throw $ E.UnknownPackage name suggestions
53−
54− Right vsns ->
55− do oldDocs <- getDocs name vsns (min v1 v2)
56− newDocs <- getDocs name vsns (max v1 v2)
57− writeDoc (toDoc (Diff.diff oldDocs newDocs))
58−
59− LocalInquiry v1 v2 ->
60− do (_, name, vsns) <- getPackageInfo
61− oldDocs <- getDocs name vsns (min v1 v2)
62− newDocs <- getDocs name vsns (max v1 v2)
63− writeDoc (toDoc (Diff.diff oldDocs newDocs))
64−
65− CodeVsLatest ->
66− do (summary, name, vsns) <- getPackageInfo
67− oldDocs <- getDocs name vsns (maximum vsns)
68− newDocs <- Task.silently (Project.generateDocs summary)
69− writeDoc (toDoc (Diff.diff oldDocs newDocs))
70−
71− CodeVsExactly version ->
72− do (summary, name, vsns) <- getPackageInfo
73− oldDocs <- getDocs name vsns version
74− newDocs <- Task.silently (Project.generateDocs summary)
75− writeDoc (toDoc (Diff.diff oldDocs newDocs))
76−
77−
78−throw :: E.Error -> Task.Task a
79−throw err =
80− Task.throw $ Error.Diff err
81−
82−
83−
84−-- DIFF HELPERS
85−
86−
87−getDocs :: Pkg.Name -> [Pkg.Version] -> Pkg.Version -> Task.Task Docs.Documentation
88−getDocs name allVersions version =
89− if elem version allVersions then
90− Get.docs name version
91− else
92− throw $ E.UnknownVersion name version allVersions
93−
94−
95−getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [Pkg.Version])
96−getPackageInfo =
97− do summary <- Project.getRoot
98− case Summary._project summary of
99− Project.App _ ->
100− throw $ E.Application
101−
102− Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->
103− do pkgs <- Get.all Get.RequireLatest
104− let vsns = either (const []) id (Get.versions name pkgs)
105− return ( summary, name, vsns )
106−
107−
108−
109−-- WRITE DOC
110−
111−
112−writeDoc :: P.Doc -> Task.Task ()
113−writeDoc doc =
114− liftIO $ Help.toStdout (doc <> "\n")
115−
116−
117−
118−-- TO DOC
119−
120−
121−toDoc :: PackageChanges -> P.Doc
122−toDoc changes@(PackageChanges added changed removed) =
123− if null added && Map.null changed && null removed then
124− "No API changes detected, so this is a" <+> P.green "PATCH" <+> "change."
125− else
126− let
127− magDoc =
128− P.text (Diff.magnitudeToString (Diff.toMagnitude changes))
129−
130− header =
131− "This is a" <+> P.green magDoc <+> "change."
132−
133− addedChunk =
134− if null added then [] else
135− [ Chunk "ADDED MODULES" MINOR $
136− P.vcat $ map (P.text . Module.nameToString) added
137− ]
138−
139− removedChunk =
140− if null removed then [] else
141− [ Chunk "REMOVED MODULES" MAJOR $
142− P.vcat $ map (P.text . Module.nameToString) removed
143− ]
144−
145− chunks =
146− addedChunk ++ removedChunk ++ map changesToChunk (Map.toList changed)
147− in
148− P.vcat (header : "" : map chunkToDoc chunks)
149−
150−
151−data Chunk =
152− Chunk
153− { _title :: String
154− , _magnitude :: Magnitude
155− , _details :: P.Doc
156− }
157−
158−
159−chunkToDoc :: Chunk -> P.Doc
160−chunkToDoc (Chunk title magnitude details) =
161− let
162− magDoc =
163− Diff.magnitudeToString magnitude
164−
165− header =
166− "----" <+> P.text title <+> "-" <+> P.text magDoc <+> "----"
167− in
168− P.vcat
169− [ P.dullcyan header
170− , ""
171− , P.indent 4 details
172− , ""
173− , ""
174− ]
175−
176−
177−changesToChunk :: (N.Name, ModuleChanges) -> Chunk
178−changesToChunk (name, changes@(ModuleChanges unions aliases values binops)) =
179− let
180− magnitude =
181− Diff.moduleChangeMagnitude changes
182−
183− (unionAdd, unionChange, unionRemove) =
184− changesToDocTriple unionToDoc unions
185−
186− (aliasAdd, aliasChange, aliasRemove) =
187− changesToDocTriple aliasToDoc aliases
188−
189− (valueAdd, valueChange, valueRemove) =
190− changesToDocTriple valueToDoc values
191−
192− (binopAdd, binopChange, binopRemove) =
193− changesToDocTriple binopToDoc binops
194− in
195− Chunk (N.toString name) magnitude $
196− P.vcat $ List.intersperse "" $ Maybe.catMaybes $
197− [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd
198− , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove
199− , changesToDoc "Changed" unionChange aliasChange valueChange binopChange
200− ]
201−
202−
203−changesToDocTriple :: (k -> v -> P.Doc) -> Changes k v -> ([P.Doc], [P.Doc], [P.Doc])
204−changesToDocTriple entryToDoc (Changes added changed removed) =
205− let
206− indented (name, value) =
207− P.indent 4 (entryToDoc name value)
208−
209− diffed (name, (oldValue, newValue)) =
210− P.vcat
211− [ " - " <> entryToDoc name oldValue
212− , " + " <> entryToDoc name newValue
213− , ""
214− ]
215− in
216− ( map indented (Map.toList added)
217− , map diffed (Map.toList changed)
218− , map indented (Map.toList removed)
219− )
220−
221−
222−changesToDoc :: String -> [P.Doc] -> [P.Doc] -> [P.Doc] -> [P.Doc] -> Maybe P.Doc
223−changesToDoc categoryName unions aliases values binops =
224− if null unions && null aliases && null values && null binops then
225− Nothing
226−
227− else
228− Just $ P.vcat $
229− P.text categoryName <> ":" : unions ++ aliases ++ binops ++ values
230−
231−
232−unionToDoc :: N.Name -> Docs.Union -> P.Doc
233−unionToDoc name (Docs.Union _ tvars ctors) =
234− let
235− setup =
236− "type" <+> nameToDoc name <+> P.hsep (map nameToDoc tvars)
237−
238− ctorDoc (ctor, tipes) =
239− typeDoc (Type.Type ctor tipes)
240− in
241− P.hang 4 (P.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))
242−
243−
244−aliasToDoc :: N.Name -> Docs.Alias -> P.Doc
245−aliasToDoc name (Docs.Alias _ tvars tipe) =
246− let
247− declaration =
248− "type" <+> "alias" <+> P.hsep (map nameToDoc (name:tvars)) <+> "="
249− in
250− P.hang 4 (P.sep [ declaration, typeDoc tipe ])
251−
252−
253−valueToDoc :: N.Name -> Docs.Value -> P.Doc
254−valueToDoc name (Docs.Value _ tipe) =
255− nameToDoc name <+> P.colon <+> typeDoc tipe
256−
257−
258−binopToDoc :: N.Name -> Docs.Binop -> P.Doc
259−binopToDoc name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =
260− "(" <> nameToDoc name <> ")" <+> P.colon <+> typeDoc tipe <> P.black details
261− where
262− details =
263− " (" <> nameToDoc assoc <> "/" <> P.int n <> ")"
264−
265− assoc =
266− case associativity of
267− Docs.Left -> "left"
268− Docs.Non -> "non"
269− Docs.Right -> "right"
270−
271−
272−typeDoc :: Type.Type -> P.Doc
273−typeDoc tipe =
274− P.text (Type.toString Type.OneLine tipe)
275−
276−
277−nameToDoc :: N.Name -> P.Doc
278−nameToDoc name =
279− P.text (N.toString name)
builder/src/Elm/Install.hsdeleted−356
@@ -1,356 +0,0 @@
1−module Elm.Install
2− ( install
3− )
4− where
5−
6−
7−import Control.Monad (filterM, forM, msum, void)
8−import Control.Monad.Except (catchError, lift, liftIO)
9−import Data.Map (Map, (!))
10−import qualified Data.Map as Map
11−import qualified Data.Map.Merge.Lazy as Map
12−import qualified System.IO as IO
13−import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
14−import qualified Text.PrettyPrint.ANSI.Leijen as P
15−
16−import qualified Elm.Package as Pkg
17−import Elm.Package (Name, Version)
18−
19−import Deps.Explorer (Explorer)
20−import qualified Deps.Explorer as Explorer
21−import qualified Deps.Verify as Verify
22−import qualified Deps.Solver as Solver
23−import Elm.Project.Constraint (Constraint)
24−import qualified Elm.Project.Constraint as Con
25−import qualified Elm.Project.Json as Project
26−import qualified Elm.Project.Root as Root
27−import qualified Reporting.Error as Error
28−import qualified Reporting.Task as Task
29−
30−
31−
32−-- INSTALL
33−
34−
35−install :: Name -> Task.Task ()
36−install pkg =
37− do (root, oldProject) <- Root.unsafeGet
38− makePlan pkg oldProject $ \newProject ->
39− let
40− upgrade =
41− do liftIO $ Project.write root newProject
42− void $ Verify.verify root newProject
43−
44− revert err =
45− do liftIO $ Project.write root oldProject
46− Task.throw err
47− in
48− upgrade `catchError` revert
49−
50−
51−
52−-- MAKE PLAN
53−
54−
55−makePlan :: Name -> Project.Project -> (Project.Project -> Task.Task ()) -> Task.Task ()
56−makePlan pkg project attemptInstall =
57− case project of
58− Project.App info@(Project.AppInfo elm srcDirs deps test trans) ->
59− do changes <- addToApp pkg info
60−
61− let news = Map.mapMaybe keepNew changes
62− let newDeps = addNews (Just pkg) news deps
63− let newTest = addNews Nothing news test
64− let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans
65− let newInfo = Project.AppInfo elm srcDirs newDeps newTest newTrans
66− let newProject = Project.App newInfo
67−
68− withApproval Pkg.versionToString changes (attemptInstall newProject)
69−
70− Project.Pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) ->
71− do changes <- addToPkg pkg info
72−
73− let news = Map.mapMaybe keepNew changes
74− let newProject = Project.Pkg $
75− info
76− { Project._pkg_deps = addNews (Just pkg) news deps
77− , Project._pkg_test_deps = addNews Nothing news test
78− }
79−
80− withApproval (show . Con.toString) changes (attemptInstall newProject)
81−
82−
83−addNews :: Maybe Name -> Map Name a -> Map Name a -> Map Name a
84−addNews pkg new old =
85− Map.merge
86− Map.preserveMissing
87− (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))
88− (Map.zipWithMatched (\_ _ n -> n))
89− old
90− new
91−
92−
93−
94−-- CHANGES
95−
96−
97−data Change a
98− = Insert a
99− | Change a a
100− | Remove a
101−
102−
103−detectChanges :: (Eq a) => Map Name a -> Map Name a -> Map Name (Change a)
104−detectChanges old new =
105− Map.merge
106− (Map.mapMissing (\_ v -> Remove v))
107− (Map.mapMissing (\_ v -> Insert v))
108− (Map.zipWithMaybeMatched keepChange)
109− old
110− new
111−
112−
113−keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)
114−keepChange _ old new =
115− if old == new then
116− Nothing
117− else
118− Just (Change old new)
119−
120−
121−keepNew :: Change a -> Maybe a
122−keepNew change =
123− case change of
124− Insert a ->
125− Just a
126−
127− Change _ a ->
128− Just a
129−
130− Remove _ ->
131− Nothing
132−
133−
134−
135−-- ADD TO APP
136−
137−
138−addToApp :: Name -> Project.AppInfo -> Task.Task (Map Name (Change Version))
139−addToApp pkg info@(Project.AppInfo _ _ deps tests trans) =
140− Explorer.run $
141− do let old = Map.unions [ deps, tests, trans ]
142− result <- Solver.run (addToAppHelp pkg info)
143− case result of
144− Just new ->
145− return $ detectChanges old new
146−
147− Nothing ->
148− do badNames <- filterM isBadElm (pkg : Map.keys old)
149− lift $ Task.throw (Error.NoSolution badNames)
150−
151−
152−addToAppHelp :: Name -> Project.AppInfo -> Solver.Solver (Map Name Version)
153−addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
154− let
155− directs =
156− Map.union deps tests
157−
158− everything =
159− Map.union directs trans
160−
161− try constraints =
162− Solver.solve $ Map.insert pkg Con.anything constraints
163− in
164− msum $ map try $
165− [ Map.map Con.exactly everything
166− , Map.map Con.exactly directs
167− , Map.map Con.untilNextMinor directs
168− , Map.map Con.untilNextMajor directs
169− , Map.map (\_ -> Con.anything) directs
170− ]
171−
172−
173−
174−-- ADD TO PKG
175−
176−
177−addToPkg :: Name -> Project.PkgInfo -> Task.Task (Map Name (Change Constraint))
178−addToPkg pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
179− Explorer.run $
180− do let old = Map.union deps tests
181− result <- Solver.run (addToPkgHelp pkg info)
182− case result of
183− Just new ->
184− return $ detectChanges old new
185−
186− Nothing ->
187− do let pkgs = Map.keys deps ++ Map.keys tests
188− badNames <- filterM isBadElm (pkg : pkgs)
189− lift $ Task.throw (Error.NoSolution badNames)
190−
191−
192−addToPkgHelp :: Name -> Project.PkgInfo -> Solver.Solver (Map Name Constraint)
193−addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
194− do let directs = Map.union deps tests
195− let newCons = Map.insert pkg Con.anything directs
196− solution <- Solver.solve newCons
197− let con = Con.untilNextMajor (solution ! pkg)
198− return $ Map.insert pkg con directs
199−
200−
201−
202−-- FAILURE HINTS
203−
204−
205−isBadElm :: Name -> Explorer Bool
206−isBadElm name =
207− do versions <- Explorer.getVersions name
208−
209− elmVersions <- forM versions $ \vsn ->
210− Explorer._elm <$> Explorer.getConstraints name vsn
211−
212− return (not (any Con.goodElm elmVersions))
213−
214−
215−
216−-- VIEW
217−
218−
219−withApproval :: (a -> String) -> Map Name (Change a) -> Task.Task () -> Task.Task ()
220−withApproval toString changes attemptInstall =
221− let
222− widths =
223− Map.foldrWithKey (widen toString) (Widths 0 0 0) changes
224−
225− changeDocs =
226− Map.foldrWithKey (addChange toString widths) (Docs [] [] []) changes
227−
228− printDoc doc =
229− P.displayIO IO.stdout $ P.renderPretty 1 80 doc
230− in
231− case changeDocs of
232− Docs [] [] [] ->
233− do liftIO $ putStrLn "Already installed. No changes necessary!"
234−
235− Docs inserts [] [] ->
236− do liftIO $ putStrLn "Adding the following dependencies:\n"
237− liftIO $ printDoc $ P.indent 2 (P.vcat (reverse inserts))
238− liftIO $ putStrLn "\n"
239− attemptInstall
240−
241− Docs _ _ _ ->
242− do liftIO $ putStrLn "Here is my plan:"
243− liftIO $ printDoc $ viewChangeDocs changeDocs
244− liftIO $ putStrLn "\nDo you approve? [Y/n]: "
245− Task.withApproval attemptInstall
246−
247−
248−
249−-- VIEW CHANGE DOCS
250−
251−
252−data ChangeDocs =
253− Docs
254− { _doc_inserts :: [P.Doc]
255− , _doc_changes :: [P.Doc]
256− , _doc_removes :: [P.Doc]
257− }
258−
259−
260−viewChangeDocs :: ChangeDocs -> P.Doc
261−viewChangeDocs (Docs inserts changes removes) =
262− P.indent 2 $ P.vcat $ concat $
263− [ viewNonZero "Add:" inserts
264− , viewNonZero "Change:" changes
265− , viewNonZero "Remove:" removes
266− ]
267−
268−
269−viewNonZero :: String -> [P.Doc] -> [P.Doc]
270−viewNonZero title entries =
271− if null entries then
272− []
273− else
274− [ P.text ""
275− , P.text title
276− , P.indent 2 (P.vcat (reverse entries))
277− ]
278−
279−
280−
281−-- VIEW CHANGE
282−
283−
284−addChange :: (a -> String) -> Widths -> Name -> Change a -> ChangeDocs -> ChangeDocs
285−addChange toString widths name change (Docs inserts changes removes) =
286− case change of
287− Insert new ->
288− Docs (viewInsert toString widths name new : inserts) changes removes
289−
290− Change old new ->
291− Docs inserts (viewChange toString widths name old new : changes) removes
292−
293− Remove old ->
294− Docs inserts changes (viewRemove toString widths name old : removes)
295−
296−
297−viewInsert :: (a -> String) -> Widths -> Name -> a -> P.Doc
298−viewInsert toString (Widths nameWidth leftWidth _) name new =
299− viewName nameWidth name <+> pad leftWidth (toString new)
300−
301−
302−viewChange :: (a -> String) -> Widths -> Name -> a -> a -> P.Doc
303−viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =
304− P.hsep
305− [ viewName nameWidth name
306− , pad leftWidth (toString old)
307− , P.text "=>"
308− , pad rightWidth (toString new)
309− ]
310−
311−
312−viewRemove :: (a -> String) -> Widths -> Name -> a -> P.Doc
313−viewRemove toString (Widths nameWidth leftWidth _) name old =
314− viewName nameWidth name <+> pad leftWidth (toString old)
315−
316−
317−viewName :: Int -> Name -> P.Doc
318−viewName width name =
319− P.fill (width + 3) (P.text (Pkg.toString name))
320−
321−
322−pad :: Int -> String -> P.Doc
323−pad width string =
324− P.text (replicate (width - length string) ' ') <> P.text string
325−
326−
327−
328−-- WIDTHS
329−
330−
331−data Widths =
332− Widths
333− { _name :: !Int
334− , _left :: !Int
335− , _right :: !Int
336− }
337−
338−
339−widen :: (a -> String) -> Name -> Change a -> Widths -> Widths
340−widen toString pkg change (Widths name left right) =
341− let
342− toLength a =
343− length (toString a)
344−
345− newName =
346− max name (length (Pkg.toString pkg))
347− in
348− case change of
349− Insert new ->
350− Widths newName (max left (toLength new)) right
351−
352− Change old new ->
353− Widths newName (max left (toLength old)) (max right (toLength new))
354−
355− Remove old ->
356− Widths newName (max left (toLength old)) right
builder/src/Elm/Outline.hsnew file+407
@@ -0,0 +1,407 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE MultiWayIf, OverloadedStrings #-}
3+module Elm.Outline
4+ ( Outline(..)
5+ , AppOutline(..)
6+ , PkgOutline(..)
7+ , Exposed(..)
8+ , SrcDir(..)
9+ , read
10+ , write
11+ , encode
12+ , decoder
13+ , defaultSummary
14+ , flattenExposed
15+ )
16+ where
17+
18+
19+import Prelude hiding (read)
20+import Control.Monad (filterM, liftM)
21+import Data.Binary (Binary, get, put, getWord8, putWord8)
22+import qualified Data.Map as Map
23+import qualified Data.NonEmptyList as NE
24+import qualified Data.OneOrMore as OneOrMore
25+import Foreign.Ptr (minusPtr)
26+import qualified System.Directory as Dir
27+import qualified System.FilePath as FP
28+import System.FilePath ((</>))
29+
30+import qualified Elm.Constraint as Con
31+import qualified Elm.Licenses as Licenses
32+import qualified Elm.ModuleName as ModuleName
33+import qualified Elm.Package as Pkg
34+import qualified Elm.Version as V
35+import qualified File
36+import qualified Json.Decode as D
37+import qualified Json.Encode as E
38+import Json.Encode ((==>))
39+import qualified Json.String as Json
40+import qualified Parse.Primitives as P
41+import qualified Reporting.Exit as Exit
42+
43+
44+
45+-- OUTLINE
46+
47+
48+data Outline
49+ = App AppOutline
50+ | Pkg PkgOutline
51+
52+
53+data AppOutline =
54+ AppOutline
55+ { _app_elm_version :: V.Version
56+ , _app_source_dirs :: NE.List SrcDir
57+ , _app_deps_direct :: Map.Map Pkg.Name V.Version
58+ , _app_deps_indirect :: Map.Map Pkg.Name V.Version
59+ , _app_test_direct :: Map.Map Pkg.Name V.Version
60+ , _app_test_indirect :: Map.Map Pkg.Name V.Version
61+ }
62+
63+
64+data PkgOutline =
65+ PkgOutline
66+ { _pkg_name :: Pkg.Name
67+ , _pkg_summary :: Json.String
68+ , _pkg_license :: Licenses.License
69+ , _pkg_version :: V.Version
70+ , _pkg_exposed :: Exposed
71+ , _pkg_deps :: Map.Map Pkg.Name Con.Constraint
72+ , _pkg_test_deps :: Map.Map Pkg.Name Con.Constraint
73+ , _pkg_elm_version :: Con.Constraint
74+ }
75+
76+
77+data Exposed
78+ = ExposedList [ModuleName.Raw]
79+ | ExposedDict [(Json.String, [ModuleName.Raw])]
80+
81+
82+data SrcDir
83+ = AbsoluteSrcDir FilePath
84+ | RelativeSrcDir FilePath
85+
86+
87+
88+-- DEFAULTS
89+
90+
91+defaultSummary :: Json.String
92+defaultSummary =
93+ Json.fromChars "helpful summary of your project, less than 80 characters"
94+
95+
96+
97+-- HELPERS
98+
99+
100+flattenExposed :: Exposed -> [ModuleName.Raw]
101+flattenExposed exposed =
102+ case exposed of
103+ ExposedList names ->
104+ names
105+
106+ ExposedDict sections ->
107+ concatMap snd sections
108+
109+
110+
111+-- WRITE
112+
113+
114+write :: FilePath -> Outline -> IO ()
115+write root outline =
116+ E.write (root </> "elm.json") (encode outline)
117+
118+
119+
120+-- JSON ENCODE
121+
122+
123+encode :: Outline -> E.Value
124+encode outline =
125+ case outline of
126+ App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->
127+ E.object
128+ [ "type" ==> E.chars "application"
129+ , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)
130+ , "elm-version" ==> V.encode elm
131+ , "dependencies" ==>
132+ E.object
133+ [ "direct" ==> encodeDeps V.encode depsDirect
134+ , "indirect" ==> encodeDeps V.encode depsTrans
135+ ]
136+ , "test-dependencies" ==>
137+ E.object
138+ [ "direct" ==> encodeDeps V.encode testDirect
139+ , "indirect" ==> encodeDeps V.encode testTrans
140+ ]
141+ ]
142+
143+ Pkg (PkgOutline name summary license version exposed deps tests elm) ->
144+ E.object
145+ [ "type" ==> E.string (Json.fromChars "package")
146+ , "name" ==> Pkg.encode name
147+ , "summary" ==> E.string summary
148+ , "license" ==> Licenses.encode license
149+ , "version" ==> V.encode version
150+ , "exposed-modules" ==> encodeExposed exposed
151+ , "elm-version" ==> Con.encode elm
152+ , "dependencies" ==> encodeDeps Con.encode deps
153+ , "test-dependencies" ==> encodeDeps Con.encode tests
154+ ]
155+
156+
157+encodeExposed :: Exposed -> E.Value
158+encodeExposed exposed =
159+ case exposed of
160+ ExposedList modules ->
161+ E.list encodeModule modules
162+
163+ ExposedDict chunks ->
164+ E.object (map (fmap (E.list encodeModule)) chunks)
165+
166+
167+encodeModule :: ModuleName.Raw -> E.Value
168+encodeModule name =
169+ E.name name
170+
171+
172+encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value
173+encodeDeps encodeValue deps =
174+ E.dict Pkg.toJsonString encodeValue deps
175+
176+
177+encodeSrcDir :: SrcDir -> E.Value
178+encodeSrcDir srcDir =
179+ case srcDir of
180+ AbsoluteSrcDir dir -> E.chars dir
181+ RelativeSrcDir dir -> E.chars dir
182+
183+
184+
185+-- PARSE AND VERIFY
186+
187+
188+read :: FilePath -> IO (Either Exit.Outline Outline)
189+read root =
190+ do bytes <- File.readUtf8 (root </> "elm.json")
191+ case D.fromByteString decoder bytes of
192+ Left err ->
193+ return $ Left (Exit.OutlineHasBadStructure err)
194+
195+ Right outline ->
196+ case outline of
197+ Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->
198+ return $
199+ if Map.notMember Pkg.core deps && pkg /= Pkg.core
200+ then Left Exit.OutlineNoPkgCore
201+ else Right outline
202+
203+ App (AppOutline _ srcDirs direct indirect _ _)
204+ | Map.notMember Pkg.core direct ->
205+ return $ Left Exit.OutlineNoAppCore
206+
207+ | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
208+ return $ Left Exit.OutlineNoAppJson
209+
210+ | otherwise ->
211+ do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
212+ case map toGiven badDirs of
213+ d:ds ->
214+ return $ Left (Exit.OutlineHasMissingSrcDirs d ds)
215+
216+ [] ->
217+ do maybeDups <- detectDuplicates root (NE.toList srcDirs)
218+ case maybeDups of
219+ Nothing ->
220+ return $ Right outline
221+
222+ Just (canonicalDir, (dir1,dir2)) ->
223+ return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)
224+
225+
226+isSrcDirMissing :: FilePath -> SrcDir -> IO Bool
227+isSrcDirMissing root srcDir =
228+ not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)
229+
230+
231+toGiven :: SrcDir -> FilePath
232+toGiven srcDir =
233+ case srcDir of
234+ AbsoluteSrcDir dir -> dir
235+ RelativeSrcDir dir -> dir
236+
237+
238+toAbsolute :: FilePath -> SrcDir -> FilePath
239+toAbsolute root srcDir =
240+ case srcDir of
241+ AbsoluteSrcDir dir -> dir
242+ RelativeSrcDir dir -> root </> dir
243+
244+
245+detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))
246+detectDuplicates root srcDirs =
247+ do pairs <- traverse (toPair root) srcDirs
248+ return $ Map.lookupMin $ Map.mapMaybe isDup $
249+ Map.fromListWith OneOrMore.more pairs
250+
251+
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+
264+
265+
266+-- JSON DECODE
267+
268+
269+type Decoder a =
270+ D.Decoder Exit.OutlineProblem a
271+
272+
273+decoder :: Decoder Outline
274+decoder =
275+ let
276+ application = Json.fromChars "application"
277+ package = Json.fromChars "package"
278+ in
279+ do tipe <- D.field "type" D.string
280+ if | tipe == application -> App <$> appDecoder
281+ | tipe == package -> Pkg <$> pkgDecoder
282+ | otherwise -> D.failure Exit.OP_BadType
283+
284+
285+appDecoder :: Decoder AppOutline
286+appDecoder =
287+ AppOutline
288+ <$> D.field "elm-version" versionDecoder
289+ <*> D.field "source-directories" dirsDecoder
290+ <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
291+ <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
292+ <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
293+ <*> D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder))
294+
295+
296+pkgDecoder :: Decoder PkgOutline
297+pkgDecoder =
298+ PkgOutline
299+ <$> D.field "name" nameDecoder
300+ <*> D.field "summary" summaryDecoder
301+ <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)
302+ <*> D.field "version" versionDecoder
303+ <*> D.field "exposed-modules" exposedDecoder
304+ <*> D.field "dependencies" (depsDecoder constraintDecoder)
305+ <*> D.field "test-dependencies" (depsDecoder constraintDecoder)
306+ <*> D.field "elm-version" constraintDecoder
307+
308+
309+
310+-- JSON DECODE HELPERS
311+
312+
313+nameDecoder :: Decoder Pkg.Name
314+nameDecoder =
315+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder
316+
317+
318+summaryDecoder :: Decoder Json.String
319+summaryDecoder =
320+ D.customString
321+ (boundParser 80 Exit.OP_BadSummaryTooLong)
322+ (\_ _ -> Exit.OP_BadSummaryTooLong)
323+
324+
325+versionDecoder :: Decoder V.Version
326+versionDecoder =
327+ D.mapError (uncurry Exit.OP_BadVersion) V.decoder
328+
329+
330+constraintDecoder :: Decoder Con.Constraint
331+constraintDecoder =
332+ D.mapError Exit.OP_BadConstraint Con.decoder
333+
334+
335+depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)
336+depsDecoder valueDecoder =
337+ D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder
338+
339+
340+dirsDecoder :: Decoder (NE.List SrcDir)
341+dirsDecoder =
342+ fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs
343+
344+
345+toSrcDir :: FilePath -> SrcDir
346+toSrcDir path =
347+ if FP.isRelative path
348+ then RelativeSrcDir path
349+ else AbsoluteSrcDir path
350+
351+
352+
353+-- EXPOSED MODULES DECODER
354+
355+
356+exposedDecoder :: Decoder Exposed
357+exposedDecoder =
358+ D.oneOf
359+ [ ExposedList <$> D.list moduleDecoder
360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)
361+ ]
362+
363+
364+moduleDecoder :: Decoder ModuleName.Raw
365+moduleDecoder =
366+ D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder
367+
368+
369+headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String
370+headerKeyDecoder =
371+ D.KeyDecoder
372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)
373+ (\_ _ -> Exit.OP_BadModuleHeaderTooLong)
374+
375+
376+
377+-- BOUND PARSER
378+
379+
380+boundParser :: Int -> x -> P.Parser x Json.String
381+boundParser bound tooLong =
382+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
383+ let
384+ len = minusPtr end pos
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+
391+
392+
393+-- BINARY
394+
395+
396+instance Binary SrcDir where
397+ put outline =
398+ case outline of
399+ AbsoluteSrcDir a -> putWord8 0 >> put a
400+ RelativeSrcDir a -> putWord8 1 >> put a
401+
402+ get =
403+ do n <- getWord8
404+ case n of
405+ 0 -> liftM AbsoluteSrcDir get
406+ 1 -> liftM RelativeSrcDir get
407+ _ -> fail "binary encoding of SrcDir was corrupted"
builder/src/Elm/PerUserCache.hsdeleted−41
@@ -1,41 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.PerUserCache
3− ( getPackageRoot
4− , getReplRoot
5− )
6− where
7−
8−import qualified System.Directory as Dir
9−import qualified System.Environment as Env
10−import System.FilePath ((</>))
11−
12−import qualified Elm.Compiler as Compiler
13−import qualified Elm.Package as Pkg
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 maybeHome <- Env.lookupEnv "ELM_HOME"
33− home <- maybe (Dir.getAppUserDataDirectory "elm") return maybeHome
34− let root = home </> version </> projectName
35− Dir.createDirectoryIfMissing True root
36− return root
37−
38−
39−version :: FilePath
40−version =
41− Pkg.versionToString Compiler.version
builder/src/Elm/Project.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Project
4− ( getRoot
5− , getRootWithReplFallback
6− , compile
7− , compileForRepl
8− , generateDocs
9− )
10− where
11−
12−
13−import qualified Data.ByteString as BS
14−import System.FilePath ((</>))
15−
16−import qualified Elm.Docs as Docs
17−import qualified Elm.Name as N
18−import qualified Elm.Project.Flags as Flags
19−import qualified Elm.Project.Root as Root
20−import qualified Elm.Project.Summary as Summary
21−import Elm.Project.Summary (Summary)
22−import qualified File.Args as Args
23−import qualified File.Artifacts as Artifacts
24−import qualified File.Compile as Compile
25−import qualified File.Crawl as Crawl
26−import qualified File.Plan as Plan
27−import qualified Generate.Output as Output
28−import qualified Reporting.Task as Task
29−import qualified Stuff.Paths as Path
30−
31−
32−
33−-- GET ROOT
34−
35−
36−getRoot :: Task.Task Summary
37−getRoot =
38− Root.get
39−
40−
41−getRootWithReplFallback :: IO FilePath
42−getRootWithReplFallback =
43− Root.getWithReplFallback
44−
45−
46−
47−-- COMPILE
48−
49−
50−compile :: Flags.Options -> Summary -> [FilePath] -> Task.Task ()
51−compile options summary@(Summary.Summary root project _ _ _) paths =
52− do args <- Args.fromPaths summary paths
53− graph <- Crawl.crawl summary args
54− (dirty, ifaces) <- Plan.plan summary graph
55− answers <- Compile.compile project ifaces dirty
56− results <- Artifacts.write root answers
57− Output.generate options summary graph
58−
59−
60−
61−-- COMPILE FOR REPL
62−
63−
64−compileForRepl :: BS.ByteString -> Maybe N.Name -> Task.Task (Maybe FilePath)
65−compileForRepl source maybeName =
66− do summary@(Summary.Summary root project _ _ _) <- getRoot
67− graph <- Crawl.crawlFromSource summary source
68− (dirty, ifaces) <- Plan.plan summary graph
69− answers <- Compile.compile project ifaces dirty
70− results <- Artifacts.write root answers
71− traverse (Output.generateReplFile summary graph) maybeName
72−
73−
74−
75−-- GENERATE DOCS
76−
77−
78−generateDocs :: Summary.Summary -> Task.Task Docs.Documentation
79−generateDocs summary@(Summary.Summary root project _ _ _) =
80− do args <- Args.fromSummary summary
81− graph <- Crawl.crawl summary args
82− (dirty, ifaces) <- Plan.plan summary graph
83− answers <- Compile.compile project ifaces dirty
84− results <- Artifacts.ignore answers
85− Artifacts.writeDocs (root </> Path.docs) results
builder/src/Elm/Project/Constraint.hsdeleted−234
@@ -1,234 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Project.Constraint
4− ( Constraint
5− , exactly
6− , anything
7− , fromText
8− , toString
9− , toText
10− , satisfies
11− , check
12− , intersect
13− , goodElm
14− , defaultElm
15− , untilNextMajor
16− , untilNextMinor
17− , expand
18− )
19− where
20−
21−import qualified Data.Text as Text
22−import Data.Text (Text)
23−
24−import qualified Elm.Compiler as Compiler
25−import qualified Elm.Package as Pkg
26−import Elm.Package (Version(..))
27−
28−
29−
30−-- CONSTRAINTS
31−
32−
33−data Constraint
34− = Range Version Op Op Version
35− deriving (Eq)
36−
37−
38−data Op
39− = Less
40− | LessOrEqual
41− deriving (Eq)
42−
43−
44−
45−-- COMMON CONSTRAINTS
46−
47−
48−exactly :: Version -> Constraint
49−exactly version =
50− Range version LessOrEqual LessOrEqual version
51−
52−
53−anything :: Constraint
54−anything =
55− Range (Version 1 0 0) LessOrEqual LessOrEqual (Version 30000 0 0)
56−
57−
58−
59−-- TEXT CONVERSION
60−
61−
62−toString :: Constraint -> String
63−toString constraint =
64− Text.unpack (toText constraint)
65−
66−
67−toText :: Constraint -> Text
68−toText constraint =
69− case constraint of
70− Range lower lowerOp upperOp upper ->
71− Text.intercalate " "
72− [ Pkg.versionToText lower
73− , opToText lowerOp
74− , "v"
75− , opToText upperOp
76− , Pkg.versionToText upper
77− ]
78−
79−
80−opToText :: Op -> Text
81−opToText op =
82− case op of
83− Less ->
84− "<"
85−
86− LessOrEqual ->
87− "<="
88−
89−
90−fromText :: Text -> Either String Constraint
91−fromText text =
92− case Text.splitOn " " text of
93− [lower, lowerOp, "v", upperOp, upper] ->
94− do lo <- versionFromText "lower" lower
95− lop <- opFromText lowerOp
96− hop <- opFromText upperOp
97− hi <- versionFromText "upper" upper
98− if lo < hi
99− then Right (Range lo lop hop hi)
100− else
101− Left $
102− "The lower bound (" ++ Text.unpack lower
103− ++ ") must be less than the upper bound ("
104− ++ Text.unpack upper ++ ")"
105−
106− _ ->
107− Left "The standard format is \"1.0.0 <= v < 2.0.0\""
108−
109−
110−versionFromText :: String -> Text -> Either String Version
111−versionFromText lowerOrUpper text =
112− case Pkg.versionFromText text of
113− Just vsn ->
114− Right vsn
115−
116− Nothing ->
117− Left $ "The " ++ lowerOrUpper ++ " bound (" ++ Text.unpack text ++ ") is not a valid version number."
118−
119−
120−opFromText :: Text -> Either String Op
121−opFromText text =
122− case text of
123− "<=" ->
124− Right LessOrEqual
125−
126− "<" ->
127− Right Less
128−
129− _ ->
130− Left $ "The operator (" ++ Text.unpack text ++ ") is not valid. Must be (<=) or (<)."
131−
132−
133−
134−-- IS SATISFIED
135−
136−
137−satisfies :: Constraint -> Version -> Bool
138−satisfies constraint version =
139− case constraint of
140− Range lower lowerOp upperOp upper ->
141− isLess lowerOp lower version
142− &&
143− isLess upperOp version upper
144−
145−
146−isLess :: (Ord a) => Op -> (a -> a -> Bool)
147−isLess op =
148− case op of
149− Less ->
150− (<)
151−
152− LessOrEqual ->
153− (<=)
154−
155−
156−check :: Constraint -> Version -> Ordering
157−check constraint version =
158− case constraint of
159− Range lower lowerOp upperOp upper ->
160− if not (isLess lowerOp lower version) then
161− LT
162−
163− else if not (isLess upperOp version upper) then
164− GT
165−
166− else
167− EQ
168−
169−
170−
171−-- INTERSECT
172−
173−
174−intersect :: Constraint -> Constraint -> Maybe Constraint
175−intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) =
176− let
177− (newLo, newLop) =
178− case compare lo lo_ of
179− LT -> (lo_, lop_)
180− EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual)
181− GT -> (lo, lop)
182−
183− (newHi, newHop) =
184− case compare hi hi_ of
185− LT -> (hi, hop)
186− EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual)
187− GT -> (hi_, hop_)
188− in
189− if newLo <= newHi then
190− Just (Range newLo newLop newHop newHi)
191− else
192− Nothing
193−
194−
195−
196−-- ELM CONSTRAINT
197−
198−
199−goodElm :: Constraint -> Bool
200−goodElm constraint =
201− satisfies constraint Compiler.version
202−
203−
204−defaultElm :: Constraint
205−defaultElm =
206− if Pkg._major Compiler.version > 0
207− then untilNextMajor Compiler.version
208− else untilNextMinor Compiler.version
209−
210−
211−
212−-- CREATE CONSTRAINTS
213−
214−
215−untilNextMajor :: Version -> Constraint
216−untilNextMajor version =
217− Range version LessOrEqual Less (Pkg.bumpMajor version)
218−
219−
220−untilNextMinor :: Version -> Constraint
221−untilNextMinor version =
222− Range version LessOrEqual Less (Pkg.bumpMinor version)
223−
224−
225−expand :: Constraint -> Version -> Constraint
226−expand constraint@(Range lower lowerOp upperOp upper) version
227− | version < lower =
228− Range version LessOrEqual upperOp upper
229−
230− | version > upper =
231− Range lower lowerOp Less (Pkg.bumpMajor version)
232−
233− | otherwise =
234− constraint
builder/src/Elm/Project/Flags.hsdeleted−38
@@ -1,38 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.Project.Flags
3− ( Options(..)
4− , Output(..)
5− , safeCustomPath
6− )
7− where
8−
9−
10−import qualified System.Directory as Dir
11−import System.FilePath ((</>))
12−
13−import qualified Elm.Compiler.Objects as Obj
14−
15−
16−
17−data Options =
18− Options
19− { _mode :: Obj.Mode
20− , _target :: Obj.Target
21− , _output :: Maybe Output
22− }
23−
24−
25−data Output
26− = None
27− | Custom (Maybe FilePath) FilePath
28−
29−
30−safeCustomPath :: Maybe FilePath -> FilePath -> IO FilePath
31−safeCustomPath maybeDirectory fileName =
32− case maybeDirectory of
33− Nothing ->
34− do return fileName
35−
36− Just dir ->
37− do Dir.createDirectoryIfMissing True dir
38− return (dir </> fileName)
builder/src/Elm/Project/Json.hsdeleted−439
@@ -1,439 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Project.Json
4− ( Project(..)
5− , AppInfo(..)
6− , PkgInfo(..)
7− , Exposed(..)
8− , defaultSummary
9− -- json
10− , write
11− , encode
12− , read
13− , pkgDecoder
14− -- queries
15− , appSolution
16− , isPlatformPackage
17− , isPackageRoot
18− , get
19− , getName
20− , getExposed
21− )
22− where
23−
24−
25−import Prelude hiding (read)
26−import Control.Monad.Trans (liftIO)
27−import qualified Data.ByteString as BS
28−import Data.Foldable (traverse_)
29−import Data.Map (Map)
30−import Data.Text (Text)
31−import qualified Data.Map as Map
32−import qualified Data.Text as Text
33−import qualified System.Directory as Dir
34−import System.FilePath ((</>))
35−
36−import qualified Elm.Compiler.Module as Module
37−import qualified Elm.Package as Pkg
38−import Elm.Package (Name, Version)
39−
40−import qualified Elm.Project.Constraint as Con
41−import qualified Elm.Project.Licenses as Licenses
42−import qualified Json.Decode as D
43−import qualified Json.Encode as E
44−import qualified Reporting.Error as Error
45−import qualified Reporting.Error.Assets as E
46−import qualified Reporting.Task as Task
47−
48−
49−
50−-- PROJECT
51−
52−
53−data Project
54− = App AppInfo
55− | Pkg PkgInfo
56−
57−
58−
59−-- APPLICATION
60−
61−
62−data AppInfo =
63− AppInfo
64− { _app_elm_version :: Version
65− , _app_source_dirs :: [FilePath]
66− , _app_deps :: Map Name Version
67− , _app_test_deps :: Map Name Version
68− , _app_trans_deps :: Map Name Version
69− }
70−
71−
72−
73−-- PACKAGE
74−
75−
76−data PkgInfo =
77− PkgInfo
78− { _pkg_name :: Name
79− , _pkg_summary :: Text
80− , _pkg_license :: Licenses.License
81− , _pkg_version :: Version
82− , _pkg_exposed :: Exposed
83− , _pkg_deps :: Map Name Con.Constraint
84− , _pkg_test_deps :: Map Name Con.Constraint
85− , _pkg_elm_version :: Con.Constraint
86− }
87−
88−
89−data Exposed
90− = ExposedList [Module.Raw]
91− | ExposedDict [(Text, [Module.Raw])]
92−
93−
94−
95−-- DEFAULTS
96−
97−
98−defaultSummary :: Text
99−defaultSummary =
100− "helpful summary of your project, less than 80 characters"
101−
102−
103−
104−-- QUERIES
105−
106−
107−appSolution :: AppInfo -> Map Name Version
108−appSolution info =
109− Map.unions
110− [ _app_deps info
111− , _app_test_deps info
112− , _app_trans_deps info
113− ]
114−
115−
116−isPlatformPackage :: Project -> Bool
117−isPlatformPackage project =
118− case project of
119− App _ ->
120− False
121−
122− Pkg info ->
123− let
124− (Pkg.Name user _) =
125− _pkg_name info
126− in
127− user == "elm-lang" || user == "elm-explorations"
128−
129−
130−isPackageRoot :: Module.Raw -> Project -> Bool
131−isPackageRoot name project =
132− case project of
133− App _ ->
134− False
135−
136− Pkg info ->
137− case _pkg_exposed info of
138− ExposedList modules ->
139− elem name modules
140−
141− ExposedDict chunks ->
142− elem name (concatMap snd chunks)
143−
144−
145−get :: (AppInfo -> a) -> (PkgInfo -> a) -> Project -> a
146−get appFunc pkgFunc project =
147− case project of
148− App info ->
149− appFunc info
150−
151− Pkg info ->
152− pkgFunc info
153−
154−
155−getName :: Project -> Name
156−getName project =
157− get (\_ -> Pkg.dummyName) _pkg_name project
158−
159−
160−getExposed :: PkgInfo -> [Module.Raw]
161−getExposed info =
162− case _pkg_exposed info of
163− ExposedList modules ->
164− modules
165−
166− ExposedDict chunks ->
167− concatMap snd chunks
168−
169−
170−
171−-- WRITE
172−
173−
174−write :: FilePath -> Project -> IO ()
175−write root project =
176− E.write (root </> "elm.json") (encode project)
177−
178−
179−
180−-- JSON ENCODE
181−
182−
183−encode :: Project -> E.Value
184−encode project =
185− case project of
186− App (AppInfo elm srcDirs deps tests trans) ->
187− E.object
188− [ "type" ==> E.text "browser"
189− , "source-directories" ==> E.list (E.text . Text.pack) srcDirs
190− , "elm-version" ==> encodeVersion elm
191− , "dependencies" ==> encodeDeps encodeVersion deps
192− , "test-dependencies" ==> encodeDeps encodeVersion tests
193− , "do-not-edit-this-by-hand" ==>
194− E.object [ "transitive-dependencies" ==> encodeDeps encodeVersion trans ]
195− ]
196−
197− Pkg (PkgInfo name summary license version exposed deps tests elm) ->
198− E.object
199− [ "type" ==> E.text "package"
200− , "name" ==> E.text (Pkg.toText name)
201− , "summary" ==> E.text summary
202− , "license" ==> Licenses.encode license
203− , "version" ==> E.text (Pkg.versionToText version)
204− , "exposed-modules" ==> encodeExposed exposed
205− , "elm-version" ==> encodeConstraint elm
206− , "dependencies" ==> encodeDeps encodeConstraint deps
207− , "test-dependencies" ==> encodeDeps encodeConstraint tests
208− ]
209−
210−
211−(==>) :: a -> b -> (a, b)
212−(==>) a b =
213− (a, b)
214−
215−
216−encodeExposed :: Exposed -> E.Value
217−encodeExposed exposed =
218− case exposed of
219− ExposedList modules ->
220− E.list encodeModule modules
221−
222− ExposedDict chunks ->
223− E.object (map (fmap (E.list encodeModule)) chunks)
224−
225−
226−encodeModule :: Module.Raw -> E.Value
227−encodeModule name =
228− E.name name
229−
230−
231−encodeDeps :: (a -> E.Value) -> Map Pkg.Name a -> E.Value
232−encodeDeps encodeValue deps =
233− E.dict Pkg.toText encodeValue deps
234−
235−
236−encodeConstraint :: Con.Constraint -> E.Value
237−encodeConstraint constraint =
238− E.text (Con.toText constraint)
239−
240−
241−encodeVersion :: Pkg.Version -> E.Value
242−encodeVersion version =
243− E.text (Pkg.versionToText version)
244−
245−
246−
247−-- PARSE AND VERIFY
248−
249−
250−read :: FilePath -> Task.Task Project
251−read path =
252− do bytes <- liftIO $ BS.readFile path
253− case D.parse path "project" E.badContentToDocs decoder bytes of
254− Left err ->
255− throwBadJson (E.BadJson err)
256−
257− Right project@(Pkg (PkgInfo _ _ _ _ _ deps tests _)) ->
258− do checkOverlap "dependencies" "test-dependencies" deps tests
259− return project
260−
261− Right project@(App (AppInfo _ srcDirs deps tests trans)) ->
262− do checkOverlap "dependencies" "test-dependencies" deps tests
263− checkOverlap "dependencies" "transitive-dependencies" deps trans
264− checkOverlap "test-dependencies" "transitive-dependencies" tests trans
265− mapM_ doesDirectoryExist srcDirs
266− return project
267−
268−
269−throwBadJson :: E.ElmJsonProblem -> Task.Task a
270−throwBadJson problem =
271− Task.throw (Error.Assets (E.BadElmJson problem))
272−
273−
274−checkOverlap :: String -> String -> Map Name a -> Map Name a -> Task.Task ()
275−checkOverlap field1 field2 deps1 deps2 =
276− case Map.keys (Map.intersection deps1 deps2) of
277− [] ->
278− return ()
279−
280− dup : dups ->
281− throwBadJson (E.BadDepDup field1 field2 dup dups)
282−
283−
284−doesDirectoryExist :: FilePath -> Task.Task ()
285−doesDirectoryExist dir =
286− do exists <- liftIO $ Dir.doesDirectoryExist dir
287− if exists
288− then return ()
289− else throwBadJson (E.BadSrcDir dir)
290−
291−
292−
293−-- JSON DECODE
294−
295−
296−type Decoder a =
297− D.Decoder E.BadElmJsonContent a
298−
299−
300−decoder :: Decoder Project
301−decoder =
302− do tipe <- D.field "type" D.text
303− case tipe of
304− "browser" ->
305− D.map App appDecoder
306−
307− "package" ->
308− D.map Pkg pkgDecoder
309−
310− other ->
311− D.fail (E.BadType other)
312−
313−
314−appDecoder :: Decoder AppInfo
315−appDecoder =
316− AppInfo
317− <$> D.field "elm-version" versionDecoder
318− <*> D.field "source-directories" (D.list dirDecoder)
319− <*> D.field "dependencies" (depsDecoder versionDecoder)
320− <*> D.field "test-dependencies" (depsDecoder versionDecoder)
321− <*> D.at ["do-not-edit-this-by-hand", "transitive-dependencies"] (depsDecoder versionDecoder)
322−
323−
324−pkgDecoder :: Decoder PkgInfo
325−pkgDecoder =
326− PkgInfo
327− <$> D.field "name" pkgNameDecoder
328− <*> D.field "summary" summaryDecoder
329− <*> D.field "license" licenseDecoder
330− <*> D.field "version" versionDecoder
331− <*> D.field "exposed-modules" exposedDecoder
332− <*> D.field "dependencies" (depsDecoder constraintDecoder)
333− <*> D.field "test-dependencies" (depsDecoder constraintDecoder)
334− <*> D.field "elm-version" constraintDecoder
335−
336−
337−
338−-- JSON DECODE HELPERS
339−
340−
341−pkgNameDecoder :: Decoder Pkg.Name
342−pkgNameDecoder =
343− D.mapError E.BadPkgName Pkg.decoder
344−
345−
346−summaryDecoder :: Decoder Text
347−summaryDecoder =
348− do summary <- D.text
349− if Text.length summary < 80
350− then D.succeed summary
351− else D.fail E.BadSummaryTooLong
352−
353−
354−licenseDecoder :: Decoder Licenses.License
355−licenseDecoder =
356− do txt <- D.text
357− case Licenses.check txt of
358− Left suggestions ->
359− D.fail (E.BadLicense txt suggestions)
360−
361− Right license ->
362− D.succeed license
363−
364−
365−versionDecoder :: Decoder Version
366−versionDecoder =
367− do txt <- D.text
368− case Pkg.versionFromText txt of
369− Just version ->
370− D.succeed version
371−
372− Nothing ->
373− D.fail (E.BadVersion txt)
374−
375−
376−constraintDecoder :: Decoder Con.Constraint
377−constraintDecoder =
378− do txt <- D.text
379− case Con.fromText txt of
380− Right constraint ->
381− D.succeed constraint
382−
383− Left msg ->
384− D.fail (E.BadConstraint msg)
385−
386−
387−depsDecoder :: Decoder a -> Decoder (Map Name a)
388−depsDecoder valueDecoder =
389− Map.fromList <$> (
390− traverse validateKey =<< D.pairs valueDecoder
391− )
392−
393−
394−validateKey :: (Text, a) -> Decoder (Name, a)
395−validateKey (key, value) =
396− case Pkg.fromText key of
397− Right name ->
398− D.succeed (name, value)
399−
400− Left _ ->
401− D.fail (E.BadDependencyName key)
402−
403−
404−dirDecoder :: Decoder FilePath
405−dirDecoder =
406− do maybeText <- D.maybe D.text
407− case maybeText of
408− Nothing ->
409− D.fail E.BadDirectoryNotString
410−
411− Just txt ->
412− D.succeed (Text.unpack txt)
413−
414−
415−
416−-- EXPOSED MODULES DECODER
417−
418−
419−exposedDecoder :: Decoder Exposed
420−exposedDecoder =
421− D.oneOf
422− [ ExposedList <$> D.list moduleDecoder
423− , do pairs <- D.pairs (D.list moduleDecoder)
424− traverse_ (checkHeader . fst) pairs
425− return (ExposedDict pairs)
426− ]
427−
428−
429−moduleDecoder :: Decoder Module.Raw
430−moduleDecoder =
431− D.mapError E.BadModuleName Module.decoder
432−
433−
434−checkHeader :: Text -> Decoder ()
435−checkHeader header =
436− if Text.length header < 20 then
437− D.succeed ()
438− else
439− D.fail (E.BadModuleHeaderTooLong header)
builder/src/Elm/Project/Root.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Elm.Project.Root
4− ( get
5− , unsafeGet
6− , getWithReplFallback
7− )
8− where
9−
10−import Control.Monad.Trans (liftIO)
11−import qualified Data.Map as Map
12−import qualified System.Directory as Dir
13−import System.FilePath ((</>))
14−
15−import qualified Elm.Package as Pkg
16−import qualified Elm.Project.Constraint as Con
17−import qualified Elm.Project.Json as Project
18−import qualified Elm.Project.Licenses as Licenses
19−import Elm.Project.Json (Project(..), PkgInfo(..))
20−import Elm.Project.Summary (Summary)
21−import qualified Elm.PerUserCache as PerUserCache
22−import qualified File.IO as IO
23−import qualified Reporting.Error as Error
24−import qualified Reporting.Task as Task
25−import qualified Stuff.Verify as Verify
26−import qualified Json.Encode as Encode
27−
28−
29−
30−-- GET
31−
32−
33−get :: Task.Task Summary
34−get =
35− do root <- moveToRoot
36− project <- Project.read "elm.json"
37− Verify.verify root project
38−
39−
40−unsafeGet :: Task.Task (FilePath, Project)
41−unsafeGet =
42− (,) <$> moveToRoot <*> Project.read "elm.json"
43−
44−
45−
46−-- MOVE TO ROOT
47−
48−
49−moveToRoot :: Task.Task FilePath
50−moveToRoot =
51− do maybeRoot <- liftIO $ IO.find "elm.json"
52− case maybeRoot of
53− Just root ->
54− do liftIO $ Dir.setCurrentDirectory root
55− return root
56−
57− Nothing ->
58− Task.throw Error.NoElmJson
59−
60−
61−
62−-- GET WITH FALLBACK
63−
64−
65−getWithReplFallback :: IO FilePath
66−getWithReplFallback =
67− do maybeRoot <- IO.find "elm.json"
68−
69− case maybeRoot of
70− Just root ->
71− do Dir.setCurrentDirectory root
72− return root
73−
74− Nothing ->
75− do cache <- PerUserCache.getReplRoot
76− let root = cache </> "tmp"
77− Dir.createDirectoryIfMissing True root
78− Dir.setCurrentDirectory root
79− IO.removeDir "elm-stuff"
80− Encode.write "elm.json" (Project.encode (Pkg replInfo))
81− return root
82−
83−
84−replInfo :: PkgInfo
85−replInfo =
86− PkgInfo
87− { _pkg_name = Pkg.dummyName
88− , _pkg_summary = "dummy code for the REPL"
89− , _pkg_license = Licenses.bsd3
90− , _pkg_version = Pkg.dummyVersion
91− , _pkg_exposed = Project.ExposedList []
92− , _pkg_deps = Map.singleton Pkg.core Con.anything
93− , _pkg_test_deps = Map.empty
94− , _pkg_elm_version = Con.defaultElm
95− }
builder/src/Elm/Project/Summary.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.Project.Summary
3− ( Summary(..)
4− , ExposedModules
5− , DepsGraph
6− , init
7− , cheapInit
8− )
9− where
10−
11−
12−import Prelude hiding (init)
13−import qualified Data.List as List
14−import qualified Data.Map as Map
15−import Data.Map (Map)
16−
17−import qualified Elm.Compiler.Module as Module
18−import Elm.Package (Package(..), Name, Version)
19−import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))
20−import qualified Elm.Project.Json as Project
21−
22−
23−
24−-- SUMMARY
25−
26−
27−data Summary =
28− Summary
29− { _root :: FilePath
30− , _project :: Project
31− , _exposed :: ExposedModules
32− , _ifaces :: Module.Interfaces
33− , _depsGraph :: DepsGraph
34− }
35−
36−
37−type ExposedModules =
38− Map.Map Module.Raw [Package]
39−
40−
41−type DepsGraph =
42− Map.Map Name ( Version, [Name] )
43−
44−
45−
46−-- MAKE SUMMARY
47−
48−
49−init :: FilePath -> Project -> Map Name PkgInfo -> Module.Interfaces -> Summary
50−init root project deps ifaces =
51− let
52− exposed =
53− Project.get
54− (getExposed deps . _app_deps)
55− (getExposed deps . _pkg_deps)
56− project
57−
58− privatizedInterfaces =
59− Map.mapMaybeWithKey (privatize exposed) ifaces
60−
61− depsGraph =
62− Map.foldr toNode Map.empty deps
63− in
64− Summary root project exposed privatizedInterfaces depsGraph
65−
66−
67−privatize :: ExposedModules -> Module.Canonical -> Module.Interface -> Maybe Module.Interface
68−privatize exposed (Module.Canonical _ name) iface =
69− case Map.lookup name exposed of
70− Just [_] ->
71− Just iface
72−
73− _ ->
74− Nothing
75−
76−
77−toNode :: PkgInfo -> DepsGraph -> DepsGraph
78−toNode (PkgInfo name _ _ version _ deps _ _) graph =
79− Map.insert name (version, Map.keys deps) graph
80−
81−
82−
83−-- MAKE CHEAP SUMMARY
84−
85−
86−cheapInit :: FilePath -> PkgInfo -> Map Name PkgInfo -> Module.Interfaces -> Summary
87−cheapInit root info deps ifaces =
88− Summary root (Pkg info) (getExposed deps (_pkg_deps info)) ifaces Map.empty
89−
90−
91−getExposed :: Map Name PkgInfo -> Map Name a -> ExposedModules
92−getExposed deps directs =
93− Map.foldl insertExposed Map.empty (Map.intersection deps directs)
94−
95−
96−insertExposed :: ExposedModules -> PkgInfo -> ExposedModules
97−insertExposed exposed info =
98− let
99− home =
100− Package (_pkg_name info) (_pkg_version info)
101−
102− insertModule dict modul =
103− Map.insertWith (++) modul [home] dict
104− in
105− List.foldl' insertModule exposed (Project.getExposed info)
builder/src/Elm/Publish.hsdeleted−255
@@ -1,255 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Elm.Publish (publish) where
3−
4−
5−import Control.Monad (when)
6−import Control.Monad.Except (catchError, runExceptT)
7−import Control.Monad.Trans (liftIO, lift)
8−import qualified Data.List as List
9−import qualified Data.Text as Text
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.Diff as Diff
17−import qualified Deps.Get as Get
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 as Project
23−import qualified Elm.Project.Json as Project
24−import qualified Elm.Project.Summary as Summary
25−import qualified Reporting.Error as Error
26−import qualified Reporting.Error.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− pkgs <- Get.all Get.RequireLatest
45− let maybePublishedVersions = either (const Nothing) Just (Get.versions name pkgs)
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 (Project.generateDocs 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.Error -> Task.Task a
66−throw err =
67− Task.throw (Error.Publish err)
68−
69−
70−
71−-- VERIFY SUMMARY
72−
73−
74−badSummary :: Text.Text -> Bool
75−badSummary summary =
76− Text.null 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 -> Pkg.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 -> Pkg.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 -> Pkg.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 $ 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` \err ->
195− do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)
196− Task.throw err
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 -> Pkg.Version -> Docs.Documentation -> Maybe [Pkg.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 == Pkg.initialVersion 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` \err ->
229− do reportBumpPhase Progress.BadBump
230− Task.throw err
231−
232−
233−verifyBump :: Pkg.Name -> Pkg.Version -> Docs.Documentation -> [Pkg.Version] -> Task.Task (Pkg.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 <- Get.docs 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.hsnew file+231
@@ -0,0 +1,231 @@
1+module File
2+ ( Time
3+ , getTime
4+ , zeroTime
5+ , writeBinary
6+ , readBinary
7+ , writeUtf8
8+ , readUtf8
9+ , writeBuilder
10+ , writePackage
11+ , exists
12+ , remove
13+ , removeDir
14+ )
15+ where
16+
17+
18+import qualified Codec.Archive.Zip as Zip
19+import Control.Exception (catch)
20+import qualified Data.Binary as Binary
21+import qualified Data.ByteString as BS
22+import qualified Data.ByteString.Internal as BS
23+import qualified Data.ByteString.Builder as B
24+import qualified Data.ByteString.Lazy as LBS
25+import qualified Data.Fixed as Fixed
26+import qualified Data.List as List
27+import qualified Data.Time.Clock as Time
28+import qualified Data.Time.Clock.POSIX as Time
29+import qualified Foreign.ForeignPtr as FPtr
30+import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
31+import qualified System.Directory as Dir
32+import qualified System.FilePath as FP
33+import System.FilePath ((</>))
34+import qualified System.IO as IO
35+import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
36+
37+
38+
39+-- TIME
40+
41+
42+newtype Time = Time Fixed.Pico
43+ deriving (Eq, Ord)
44+
45+
46+getTime :: FilePath -> IO Time
47+getTime path =
48+ fmap
49+ (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)
50+ (Dir.getModificationTime path)
51+
52+
53+zeroTime :: Time
54+zeroTime =
55+ Time 0
56+
57+
58+instance Binary.Binary Time where
59+ put (Time time) = Binary.put time
60+ get = Time <$> Binary.get
61+
62+
63+
64+-- BINARY
65+
66+
67+writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
68+writeBinary path value =
69+ do let dir = FP.dropFileName path
70+ Dir.createDirectoryIfMissing True dir
71+ Binary.encodeFile path value
72+
73+
74+readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
75+readBinary path =
76+ do pathExists <- Dir.doesFileExist path
77+ if pathExists
78+ then
79+ do result <- Binary.decodeFileOrFail path
80+ case result of
81+ Right a ->
82+ return (Just a)
83+
84+ Left (offset, message) ->
85+ do IO.hPutStrLn IO.stderr $ unlines $
86+ [ "+-------------------------------------------------------------------------------"
87+ , "| Corrupt File: " ++ path
88+ , "| Byte Offset: " ++ show offset
89+ , "| Message: " ++ message
90+ , "|"
91+ , "| Please report this to https://github.com/elm/compiler/issues"
92+ , "| Trying to continue anyway."
93+ , "+-------------------------------------------------------------------------------"
94+ ]
95+ return Nothing
96+ else
97+ return Nothing
98+
99+
100+
101+-- WRITE UTF-8
102+
103+
104+writeUtf8 :: FilePath -> BS.ByteString -> IO ()
105+writeUtf8 path content =
106+ withUtf8 path IO.WriteMode $ \handle ->
107+ BS.hPut handle content
108+
109+
110+withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
111+withUtf8 path mode callback =
112+ IO.withFile path mode $ \handle ->
113+ do IO.hSetEncoding handle IO.utf8
114+ callback handle
115+
116+
117+
118+-- READ UTF-8
119+
120+
121+readUtf8 :: FilePath -> IO BS.ByteString
122+readUtf8 path =
123+ withUtf8 path IO.ReadMode $ \handle ->
124+ modifyIOError (encodingError path) $
125+ do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
126+ let readSize = max 0 (fromIntegral fileSize) + 1
127+ hGetContentsSizeHint handle readSize (max 255 readSize)
128+
129+
130+useZeroIfNotRegularFile :: IOException -> IO Integer
131+useZeroIfNotRegularFile _ =
132+ return 0
133+
134+
135+hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
136+hGetContentsSizeHint handle =
137+ readChunks []
138+ where
139+ readChunks chunks readSize incrementSize =
140+ do fp <- BS.mallocByteString readSize
141+ readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
142+ let chunk = BS.PS fp 0 readCount
143+ if readCount < readSize && readSize > 0
144+ then return $! BS.concat (reverse (chunk:chunks))
145+ else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
146+
147+
148+encodingError :: FilePath -> IOError -> IOError
149+encodingError path ioErr =
150+ case ioeGetErrorType ioErr of
151+ InvalidArgument ->
152+ annotateIOError
153+ (userError "Bad encoding; the file must be valid UTF-8")
154+ ""
155+ Nothing
156+ (Just path)
157+
158+ _ ->
159+ ioErr
160+
161+
162+
163+-- WRITE BUILDER
164+
165+
166+writeBuilder :: FilePath -> B.Builder -> IO ()
167+writeBuilder path builder =
168+ IO.withBinaryFile path IO.WriteMode $ \handle ->
169+ do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
170+ B.hPutBuilder handle builder
171+
172+
173+
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
207+
208+
209+exists :: FilePath -> IO Bool
210+exists path =
211+ Dir.doesFileExist path
212+
213+
214+
215+-- REMOVE FILES
216+
217+
218+remove :: FilePath -> IO ()
219+remove path =
220+ do exists_ <- Dir.doesFileExist path
221+ if exists_
222+ then Dir.removeFile path
223+ else return ()
224+
225+
226+removeDir :: FilePath -> IO ()
227+removeDir path =
228+ do exists_ <- Dir.doesDirectoryExist path
229+ if exists_
230+ then Dir.removeDirectoryRecursive path
231+ else return ()
builder/src/File/Args.hsdeleted−40
@@ -1,40 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module File.Args
3− ( Args(..)
4− , fromPaths
5− , fromSummary
6− )
7− where
8−
9−
10−import Data.List.NonEmpty (NonEmpty((:|)))
11−import qualified Elm.Compiler.Module as Module
12−import qualified Elm.Project.Json as Project
13−import qualified Elm.Project.Summary as Summary
14−import qualified Reporting.Error as Error
15−import qualified Reporting.Task as Task
16−
17−
18−data Args roots
19− = Pkg [Module.Raw]
20− | Roots (NonEmpty roots)
21−
22−
23−fromPaths :: Summary.Summary -> [FilePath] -> Task.Task (Args FilePath)
24−fromPaths summary paths =
25− case paths of
26− [] ->
27− fromSummary summary
28−
29− first : rest ->
30− return $ Roots (first :| rest)
31−
32−
33−fromSummary :: Summary.Summary -> Task.Task (Args a)
34−fromSummary (Summary.Summary _ project _ _ _) =
35− case project of
36− Project.Pkg info ->
37− return $ Pkg (Project.getExposed info)
38−
39− Project.App _ ->
40− Task.throw Error.CannotMakeNothing
builder/src/File/Artifacts.hsdeleted−140
@@ -1,140 +0,0 @@
1−module File.Artifacts
2− ( ignore
3− , write
4− , writeDocs
5− )
6− where
7−
8−
9−import Control.Concurrent (forkIO)
10−import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
11−import Control.Monad (foldM, void)
12−import Control.Monad.Except (liftIO)
13−import qualified Data.Binary as Binary
14−import qualified Data.List.NonEmpty as NonEmpty
15−import Data.List.NonEmpty (NonEmpty((:|)))
16−import Data.Map (Map)
17−import qualified Data.Map as Map
18−import qualified Data.Maybe as Maybe
19−import qualified Data.Text.Encoding as Text
20−
21−import qualified Elm.Compiler as Compiler
22−import qualified Elm.Compiler.Module as Module
23−import qualified Elm.Docs as Docs
24−import qualified Json.Encode as Encode
25−
26−import File.Compile (Answer(..))
27−import qualified Reporting.Error.Compile as E
28−import qualified Reporting.Error as Error
29−import qualified Reporting.Task as Task
30−import qualified Stuff.Paths as Path
31−
32−
33−
34−-- IGNORE
35−
36−
37−ignore :: Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts)
38−ignore answers =
39− let
40− ignorer _name result =
41− return result
42− in
43− gather ignorer answers
44−
45−
46−
47−-- WRITE
48−
49−
50−write :: FilePath -> Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts)
51−write root answers =
52− let
53− writer name result@(Compiler.Artifacts elmi elmo _) =
54− do mvar <- newEmptyMVar
55− void $ forkIO $
56− do Binary.encodeFile (Path.elmi root name) elmi
57− Binary.encodeFile (Path.elmo root name) elmo
58− putMVar mvar result
59− return mvar
60− in
61− do mvars <- gather writer answers
62− liftIO $ traverse readMVar mvars
63−
64−
65−writeDocs :: FilePath -> Map Module.Raw Compiler.Artifacts -> Task.Task Docs.Documentation
66−writeDocs path results =
67− let
68− getDocs (Compiler.Artifacts _ _ docs) =
69− docs
70− in
71− case Maybe.mapMaybe getDocs (Map.elems results) of
72− [] ->
73− return Map.empty
74−
75− docs ->
76− do liftIO $ Encode.writeUgly path $ Encode.list Docs.encode docs
77− return $ Docs.toDict docs
78−
79−
80−
81−-- GATHER
82−
83−
84−gather :: OnGood a -> Map Module.Raw Answer -> Task.Task (Map Module.Raw a)
85−gather onGood answers =
86− do summary <- liftIO $
87− foldM (gatherHelp onGood) (Right Map.empty) (Map.toList answers)
88−
89− case summary of
90− Left (err :| errors) ->
91− Task.throw (Error.Compile err errors)
92−
93− Right results ->
94− return results
95−
96−
97−type OnGood a = Module.Raw -> Compiler.Artifacts -> IO a
98−
99−
100−gatherHelp :: OnGood a -> Summary a -> (Module.Raw, Answer) -> IO (Summary a)
101−gatherHelp onGood summary (name, answer) =
102− case answer of
103− Blocked ->
104− return summary
105−
106− Bad path time src errors ->
107− do let err = E.Error name path time (Text.decodeUtf8 src) errors
108− return (addErr err summary)
109−
110− Good result ->
111− do value <- onGood name result
112− return (addOk name value summary)
113−
114−
115−
116−-- DICT RESULT
117−
118−
119−type Summary a =
120− Either (NonEmpty E.Error) (Map Module.Raw a)
121−
122−
123−addOk :: Module.Raw -> a -> Summary a -> Summary a
124−addOk name result acc =
125− case acc of
126− Left _ ->
127− acc
128−
129− Right results ->
130− Right (Map.insert name result results)
131−
132−
133−addErr :: E.Error -> Summary a -> Summary a
134−addErr err acc =
135− case acc of
136− Left errors ->
137− Left (NonEmpty.cons err errors)
138−
139− Right _ ->
140− Left (err :| [])
builder/src/File/Compile.hsdeleted−159
@@ -1,159 +0,0 @@
1−module File.Compile
2− ( compile
3− , Answer(..)
4− )
5− where
6−
7−import Control.Concurrent (forkIO)
8−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
9−import Control.Monad (void)
10−import Control.Monad.Except (liftIO)
11−import qualified Data.ByteString as BS
12−import qualified Data.Map as Map
13−import qualified Data.Time.Clock as Time
14−
15−import qualified Elm.Compiler as Compiler
16−import qualified Elm.Compiler.Module as Module
17−
18−import Elm.Project.Json (Project)
19−import qualified Elm.Project.Json as Project
20−import qualified File.Plan as Plan
21−import qualified Reporting.Progress as Progress
22−import qualified Reporting.Task as Task
23−
24−
25−
26−-- COMPILE
27−
28−
29−compile :: Project -> Module.Interfaces -> Dict Plan.Info -> Task.Task (Dict Answer)
30−compile project ifaces modules =
31− do Task.report (Progress.CompileStart (Map.size modules))
32−
33− tell <- Task.getReporter
34−
35− answers <- liftIO $
36− do mvar <- newEmptyMVar
37− iMVar <- newMVar ifaces
38− answerMVars <- Map.traverseWithKey (compileModule tell project mvar iMVar) modules
39− putMVar mvar answerMVars
40− traverse readMVar answerMVars
41−
42− Task.report Progress.CompileEnd
43−
44− return answers
45−
46−
47−
48−-- ANSWERS
49−
50−
51−data Answer
52− = Blocked
53− | Bad FilePath Time.UTCTime BS.ByteString [Compiler.Error]
54− | Good Compiler.Artifacts
55−
56−
57−type Dict a = Map.Map Module.Raw a
58−
59−
60−
61−-- COMPILE MODULE
62−
63−
64−compileModule
65− :: (Progress.Progress -> IO ())
66− -> Project
67− -> MVar (Dict (MVar Answer))
68− -> MVar Module.Interfaces
69− -> Module.Raw
70− -> Plan.Info
71− -> IO (MVar Answer)
72−compileModule tell project answersMVar ifacesMVar name info =
73− do mvar <- newEmptyMVar
74−
75− void $ forkIO $
76− do answers <- readMVar answersMVar
77− blocked <- isBlocked answers info
78− if blocked
79− then putMVar mvar Blocked
80− else
81− do tell (Progress.CompileFileStart name)
82− let pkg = Project.getName project
83− let isExposed = Project.isPackageRoot name project
84− let imports = makeImports project info
85− ifaces <- readMVar ifacesMVar
86− let context = Compiler.Context pkg isExposed imports ifaces
87− let source = Plan._src info
88− case Compiler.compile context source of
89− (_warnings, Left errors) ->
90− do tell (Progress.CompileFileEnd name Progress.Bad)
91− let path = Plan._path info
92− let time = Plan._time info
93− putMVar mvar (Bad path time source errors)
94−
95− (_warnings, Right result@(Compiler.Artifacts elmi _ _)) ->
96− do tell (Progress.CompileFileEnd name Progress.Good)
97− let canonicalName = Module.Canonical pkg name
98− lock <- takeMVar ifacesMVar
99− putMVar ifacesMVar (Map.insert canonicalName elmi lock)
100− putMVar mvar (Good result)
101−
102− return mvar
103−
104−
105−
106−-- IMPORTS
107−
108−
109−makeImports :: Project -> Plan.Info -> Dict Module.Canonical
110−makeImports project (Plan.Info _ _ _ clean dirty foreign) =
111− let
112− pkgName =
113− Project.getName project
114−
115− mkLocal name =
116− ( name, Module.Canonical pkgName name )
117−
118− mkForeign canonicalName@(Module.Canonical _ name) =
119− ( name, canonicalName )
120− in
121− Map.fromList $
122− map mkLocal clean
123− ++ map mkLocal dirty
124− ++ map mkForeign foreign
125−
126−
127−
128−-- INTERFACES
129−
130−
131−isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
132−isBlocked answers info =
133− anyBlock <$> traverse (get answers) (Plan._dirty info)
134−
135−
136−get :: Dict (MVar Answer) -> Module.Raw -> IO Answer
137−get names name =
138− case Map.lookup name names of
139− Nothing ->
140− error "bug manifesting in File.Complie.get, please report at <TODO>!"
141−
142− Just mvar ->
143− readMVar mvar
144−
145−
146−anyBlock :: [Answer] -> Bool
147−anyBlock answers =
148− case answers of
149− [] ->
150− False
151−
152− Blocked : _ ->
153− True
154−
155− Bad _ _ _ _ : _ ->
156− True
157−
158− Good _ : otherAnswers ->
159− anyBlock otherAnswers
builder/src/File/Crawl.hsdeleted−294
@@ -1,294 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Crawl
4− ( Result
5− , Graph(..)
6− , crawl
7− , crawlFromSource
8− )
9− where
10−
11−import Control.Concurrent.Chan (Chan, newChan, readChan)
12−import Control.Monad (foldM)
13−import Control.Monad.Except (liftIO)
14−import qualified Data.ByteString as BS
15−import qualified Data.Graph as Graph
16−import qualified Data.List.NonEmpty as NonEmpty
17−import Data.List.NonEmpty (NonEmpty((:|)))
18−import qualified Data.Map as Map
19−import qualified Data.Set as Set
20−
21−import qualified Elm.Compiler.Module as Module
22−import qualified Elm.Compiler.Objects as Obj
23−import qualified Elm.Kernel as Kernel
24−import qualified Elm.Package as Pkg
25−
26−import qualified Elm.Project.Json as Project
27−import Elm.Project.Summary (Summary(..))
28−import qualified File.Args as Args
29−import qualified File.Find as Find
30−import qualified File.Header as Header
31−import qualified File.IO as IO
32−import qualified Reporting.Error as Error
33−import qualified Reporting.Error.Crawl as E
34−import qualified Reporting.Task as Task
35−
36−
37−
38−-- GRAPH
39−
40−
41−data Graph kernel problems =
42− Graph
43− { _args :: Args.Args Module.Raw
44− , _locals :: Map.Map Module.Raw Header.Info
45− , _kernels :: Map.Map Module.Raw kernel
46− , _foreigns :: Map.Map Module.Raw Pkg.Package
47− , _problems :: problems
48− }
49−
50−
51−type Result =
52− Graph Obj.Kernel ()
53−
54−
55−type WorkGraph =
56− Graph (FilePath, Maybe FilePath) [E.Problem]
57−
58−
59−initWorkGraph :: Args.Args Module.Raw -> Map.Map Module.Raw Header.Info -> WorkGraph
60−initWorkGraph args locals =
61− Graph args locals Map.empty Map.empty []
62−
63−
64−
65−-- CRAWL
66−
67−
68−crawl :: Summary -> Args.Args FilePath -> Task.Task Result
69−crawl summary args =
70− case args of
71− Args.Pkg names ->
72− do let roots = map (Unvisited E.ElmJson) names
73− let graph = initWorkGraph (Args.Pkg names) Map.empty
74− depthFirstSearch summary roots graph
75−
76− Args.Roots (path :| []) ->
77− crawlHelp summary =<< Header.readOneFile summary path
78−
79− Args.Roots paths ->
80− do headers <- Header.readManyFiles summary paths
81− let names = NonEmpty.map fst headers
82− let unvisited = concatMap toUnvisited (NonEmpty.toList headers)
83− let graph = initWorkGraph (Args.Roots names) (Map.fromList (NonEmpty.toList headers))
84− depthFirstSearch summary unvisited graph
85− where
86− toUnvisited (name, Header.Info path _ _ deps) =
87− map (Unvisited (E.Module path name)) deps
88−
89−
90−crawlFromSource :: Summary -> BS.ByteString -> Task.Task Result
91−crawlFromSource summary@(Summary _ project _ _ _) source =
92− crawlHelp summary =<<
93− Header.readSource project source
94−
95−
96−crawlHelp :: Summary -> ( Maybe Module.Raw, Header.Info ) -> Task.Task Result
97−crawlHelp summary ( maybeName, info@(Header.Info path _ _ deps) ) =
98− do let name = maybe "Main" id maybeName
99− let args = Args.Roots (name :| [])
100− let toUnvisited dep = Unvisited (maybe (E.File path) (E.Module path) maybeName) dep
101− let roots = map toUnvisited deps
102− let graph = initWorkGraph args (Map.singleton name info)
103− depthFirstSearch summary roots graph
104−
105−
106−
107−-- DEPTH FIRST SEARCH
108−
109−
110−depthFirstSearch :: Summary -> [Unvisited] -> WorkGraph -> Task.Task Result
111−depthFirstSearch summary unvisited startGraph =
112− do chan <- liftIO newChan
113−
114− (Graph args locals kernelPaths foreigns problems) <-
115− dfs summary chan 0 Set.empty unvisited startGraph
116−
117− case problems of
118− [] ->
119− do checkForCycles locals
120− kernels <- visitKernels summary locals kernelPaths
121− return $ Graph args locals kernels foreigns ()
122−
123− problem : otherProblems ->
124− Task.throw (Error.Crawl (E.DependencyProblems problem otherProblems))
125−
126−
127−
128−-- CHECK FOR CYCLES
129−
130−
131−checkForCycles :: Map.Map Module.Raw Header.Info -> Task.Task ()
132−checkForCycles locals =
133− let
134− toNode (name, Header.Info _ _ _ imports) =
135− (name, name, imports)
136−
137− components =
138− Graph.stronglyConnComp (map toNode (Map.toList locals))
139− in
140− mapM_ checkComponent components
141−
142−
143−checkComponent :: Graph.SCC Module.Raw -> Task.Task ()
144−checkComponent scc =
145− case scc of
146− Graph.AcyclicSCC _ ->
147− return ()
148−
149− Graph.CyclicSCC names ->
150− Task.throw (Error.Cycle names)
151−
152−
153−
154−-- CONCURRENT DEPTH FIRST SEARCH
155−
156−
157−dfs
158− :: Summary
159− -> Chan (Either E.Problem Asset)
160− -> Int
161− -> Set.Set Module.Raw
162− -> [Unvisited]
163− -> WorkGraph
164− -> Task.Task WorkGraph
165−dfs summary chan oldPending oldSeen unvisited graph =
166− do (seen, pending) <-
167− foldM (spawnVisitor summary chan) (oldSeen, oldPending) unvisited
168−
169− if pending == 0
170− then return graph
171− else
172− do asset <- liftIO $ readChan chan
173− case asset of
174− Right (Local name info@(Header.Info path _ _ imports)) ->
175− do let newGraph = graph { _locals = Map.insert name info (_locals graph) }
176− let deps = map (Unvisited (E.Module path name)) imports
177− dfs summary chan (pending - 1) seen deps newGraph
178−
179− Right (Kernel name info) ->
180− do let kernels = Map.insert name info (_kernels graph)
181− let newGraph = graph { _kernels = kernels }
182− dfs summary chan (pending - 1) seen [] newGraph
183−
184− Right (Foreign name pkg) ->
185− do let foreigns = Map.insert name pkg (_foreigns graph)
186− let newGraph = graph { _foreigns = foreigns }
187− dfs summary chan (pending - 1) seen [] newGraph
188−
189− Left problem ->
190− do let problems = problem : _problems graph
191− let newGraph = graph { _problems = problems }
192− dfs summary chan (pending - 1) seen [] newGraph
193−
194−
195−spawnVisitor
196− :: Summary
197− -> Chan (Either E.Problem Asset)
198− -> (Set.Set Module.Raw, Int)
199− -> Unvisited
200− -> Task.Task (Set.Set Module.Raw, Int)
201−spawnVisitor summary chan (seen, n) unvisited@(Unvisited _ name) =
202− if Set.member name seen then
203− return (seen, n)
204− else
205− do Task.workerChan chan (toVisitor summary unvisited)
206− return (Set.insert name seen, n + 1)
207−
208−
209−
210−-- VISITOR
211−
212−
213−data Unvisited =
214− Unvisited
215− { _origin :: E.Origin
216− , _name :: Module.Raw
217− }
218−
219−
220−data Asset
221− = Local Module.Raw Header.Info
222− | Kernel Module.Raw (FilePath, Maybe FilePath)
223− | Foreign Module.Raw Pkg.Package
224−
225−
226−toVisitor :: Summary -> Unvisited -> Task.Task_ E.Problem Asset
227−toVisitor summary (Unvisited origin name) =
228− do asset <- Find.find summary origin name
229− case asset of
230− Find.Local path ->
231− uncurry Local <$> Header.readModule summary name path
232−
233− Find.Foreign pkg ->
234− return $ Foreign name pkg
235−
236− Find.Kernel clientPath maybeServerPath ->
237− return $ Kernel name (clientPath, maybeServerPath)
238−
239−
240−
241−-- VISIT KERNELS
242−
243−
244−visitKernels
245− :: Summary
246− -> Map.Map Module.Raw Header.Info
247− -> Map.Map Module.Raw (FilePath, Maybe FilePath)
248− -> Task.Task (Map.Map Module.Raw Obj.Kernel)
249−visitKernels summary locals kernelPaths =
250− if Map.null kernelPaths then
251− return Map.empty
252− else
253− -- TODO do this concurrently?
254− -- Need better concurrency primitives in Task
255− traverse (readKernel (toImportDict summary locals)) kernelPaths
256−
257−
258−readKernel :: ImportDict -> (FilePath, Maybe FilePath) -> Task.Task Obj.Kernel
259−readKernel importDict (clientPath, maybeServerPath) =
260− Obj.Kernel
261− <$> readKContent importDict clientPath
262− <*> traverse (readKContent importDict) maybeServerPath
263−
264−
265−readKContent :: ImportDict -> FilePath -> Task.Task Kernel.KContent
266−readKContent importDict path =
267− do source <- liftIO $ IO.readUtf8 path
268− case Kernel.parse importDict source of
269− Right content ->
270− return content
271−
272− Left _ ->
273− Task.throw (Error.Crawl (E.BadKernelHeader path))
274−
275−
276−
277−-- IMPORT DICT
278−
279−
280−type ImportDict =
281− Map.Map Module.Raw [Pkg.Name]
282−
283−
284−toImportDict :: Summary -> Map.Map Module.Raw info -> ImportDict
285−toImportDict (Summary _ project exposed _ _) locals =
286− let
287− localPkg =
288− [Project.getName project]
289−
290− addLocal name _ dict =
291− Map.insertWith (++) name localPkg dict
292− in
293− Map.foldrWithKey addLocal (Map.map (map Pkg._name) exposed) locals
294−
builder/src/File/Find.hsdeleted−99
@@ -1,99 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Find
4− ( Asset(..)
5− , find
6− )
7− where
8−
9−import Control.Monad.Except (liftIO)
10−import qualified Data.Map as Map
11−import qualified Data.Maybe as Maybe
12−import qualified System.Directory as Dir
13−import System.FilePath ((</>), (<.>))
14−
15−import qualified Elm.Compiler.Module as Module
16−import qualified Elm.Name as N
17−import qualified Elm.Package as Pkg
18−
19−import qualified Elm.Project.Json as Project
20−import qualified Elm.Project.Summary as Summary
21−import qualified Reporting.Error.Crawl as E
22−import qualified Reporting.Task as Task
23−
24−
25−
26−-- ASSET
27−
28−
29−data Asset
30− = Local FilePath
31− | Kernel FilePath (Maybe FilePath)
32− | Foreign Pkg.Package
33−
34−
35−
36−-- FIND
37−
38−
39−find :: Summary.Summary -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset
40−find (Summary.Summary root project exposed _ _) origin name =
41− case project of
42− Project.App info ->
43− do let srcDirs = map (root </>) (Project._app_source_dirs info)
44− findElm srcDirs exposed origin name
45−
46− Project.Pkg _ ->
47− if N.startsWith "Elm.Kernel." name then
48− if Project.isPlatformPackage project then
49− findKernel (root </> "src") origin name
50− else
51− Task.throw $ E.ModuleNameReservedForKernel origin name
52−
53− else
54− findElm [ root </> "src" ] exposed origin name
55−
56−
57−
58−-- FIND ELM
59−
60−
61−findElm :: [FilePath] -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset
62−findElm srcDirs exposed origin name =
63− do
64− paths <- liftIO $ Maybe.catMaybes <$> mapM (elmExists name) srcDirs
65−
66− case (paths, Map.lookup name exposed) of
67− ([path], Nothing) ->
68− return (Local path)
69−
70− ([], Just [pkg]) ->
71− return (Foreign pkg)
72−
73− ([], Nothing) ->
74− Task.throw $ E.ModuleNotFound origin name
75−
76− (_, maybePkgs) ->
77− Task.throw $ E.ModuleAmbiguous origin name paths (maybe [] id maybePkgs)
78−
79−
80−elmExists :: Module.Raw -> FilePath -> IO (Maybe FilePath)
81−elmExists name srcDir =
82− do let path = srcDir </> Module.nameToSlashPath name <.> "elm"
83− exists <- Dir.doesFileExist path
84− return $ if exists then Just path else Nothing
85−
86−
87−
88−-- FIND KERNEL
89−
90−
91−findKernel :: FilePath -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset
92−findKernel srcDir origin name =
93− do let clientPath = srcDir </> Module.nameToSlashPath name <.> "js"
94− let serverPath = srcDir </> Module.nameToSlashPath name <.> "server.js"
95− client <- liftIO $ Dir.doesFileExist clientPath
96− server <- liftIO $ Dir.doesFileExist serverPath
97− if client
98− then return $ Kernel clientPath (if server then Just serverPath else Nothing)
99− else Task.throw $ E.ModuleNotFound origin name
builder/src/File/Hash.hsdeleted−110
@@ -1,110 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module File.Hash
3− ( Hasher
4− , put
5− , Digest
6− , toString
7− , putByteString
8− , putBuilder
9− , putFile
10− )
11− where
12−
13−
14−import Prelude hiding (appendFile)
15−import Control.Monad (foldM)
16−import qualified Control.Monad.State as State
17−import qualified Data.Binary.Get as Binary
18−import qualified Data.ByteString as BS
19−import qualified Data.ByteString.Builder as BS
20−import qualified Data.ByteString.Builder.Extra as BS (defaultChunkSize)
21−import qualified Data.ByteString.Lazy as LBS
22−import qualified Data.Digest.Pure.SHA as SHA
23−import qualified System.IO as IO
24−
25−
26−
27−-- HASHER
28−
29−
30−type Hasher = State.StateT State IO ()
31−
32−
33−type Digest = SHA.Digest SHA.SHA1State
34−
35−
36−put :: FilePath -> Hasher -> IO Digest
37−put path hasher =
38− IO.withBinaryFile path IO.WriteMode $ \handle ->
39− do let state = State handle 0 SHA.sha1Incremental
40− (State _ len decoder) <- State.execStateT hasher state
41− return (SHA.completeSha1Incremental decoder len)
42−
43−
44−toString :: Digest -> String
45−toString =
46− SHA.showDigest
47−
48−
49−
50−-- HASH STATE
51−
52−
53−data State =
54− State
55− { _handle :: !IO.Handle
56− , _length :: !Int
57− , _decoder :: !(Binary.Decoder SHA.SHA1State)
58− }
59−
60−
61−
62−-- PUBLIC API
63−
64−
65−putByteString :: BS.ByteString -> Hasher
66−putByteString chunk =
67− do state <- State.get
68− State.put =<< State.liftIO (appendByteString state chunk)
69−
70−
71−putBuilder :: BS.Builder -> Hasher
72−putBuilder builder =
73− do state <- State.get
74− State.put =<< State.liftIO (appendBuilder builder state)
75−
76−
77−putFile :: FilePath -> Hasher
78−putFile path =
79− do state <- State.get
80− State.put =<< State.liftIO (appendFile path state)
81−
82−
83−
84−-- PRIMITIVES
85−
86−
87−appendByteString :: State -> BS.ByteString -> IO State
88−appendByteString (State handle len decoder) chunk =
89− do BS.hPut handle chunk
90− return $ State handle (len + BS.length chunk) (Binary.pushChunk decoder chunk)
91−
92−
93−appendBuilder :: BS.Builder -> State -> IO State
94−appendBuilder builder state =
95− foldM appendByteString state $
96− LBS.toChunks (BS.toLazyByteString builder)
97−
98−
99−appendFile :: FilePath -> State -> IO State
100−appendFile path state =
101− IO.withBinaryFile path IO.ReadMode $ \handle ->
102− appendHelp handle state
103−
104−
105−appendHelp :: IO.Handle -> State -> IO State
106−appendHelp handle state =
107− do chunk <- BS.hGet handle BS.defaultChunkSize
108− if BS.null chunk
109− then return state
110− else appendHelp handle =<< appendByteString state chunk
builder/src/File/Header.hsdeleted−190
@@ -1,190 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Header
4− ( Info(..)
5− , readModule
6− , readOneFile
7− , readManyFiles
8− , readSource
9− )
10− where
11−
12−import Control.Monad.Except (liftIO)
13−import qualified Data.ByteString as BS
14−import Data.List.NonEmpty (NonEmpty((:|)))
15−import qualified Data.Map as Map
16−import Data.Semigroup ((<>))
17−import qualified Data.Time.Calendar as Day
18−import qualified Data.Time.Clock as Time
19−import qualified System.Directory as Dir
20−
21−import qualified Elm.Compiler.Module as Module
22−import qualified Elm.Header as Header
23−
24−import qualified Elm.Project.Json as Project
25−import Elm.Project.Json (Project)
26−import Elm.Project.Summary (Summary(..))
27−import qualified File.IO as IO
28−import qualified Reporting.Error as Error
29−import qualified Reporting.Error.Crawl as E
30−import qualified Reporting.Task as Task
31−
32−
33−
34−-- INFO
35−
36−
37−data Info =
38− Info
39− { _path :: FilePath
40− , _time :: Time.UTCTime
41− , _source :: BS.ByteString
42− , _imports :: [Module.Raw]
43− }
44−
45−
46−atRoot :: Task.Task_ E.Problem a -> Task.Task_ E.Error a
47−atRoot task =
48− Task.mapError (\problem -> E.DependencyProblems problem []) task
49−
50−
51−-- READ MODULE
52−
53−
54−readModule :: Summary -> Module.Raw -> FilePath -> Task.Task_ E.Problem (Module.Raw, Info)
55−readModule summary expectedName path =
56− do time <- liftIO $ Dir.getModificationTime path
57− source <- liftIO $ IO.readUtf8 path
58− (maybeName, info) <- parse (_project summary) path time source
59− name <- checkName path expectedName maybeName
60− return (name, info)
61−
62−
63−checkName :: FilePath -> Module.Raw -> Maybe Module.Raw -> Task.Task_ E.Problem Module.Raw
64−checkName path expectedName maybeName =
65− case maybeName of
66− Nothing ->
67− Task.throw (E.ModuleNameMissing path expectedName)
68−
69− Just actualName ->
70− if expectedName == actualName
71− then return expectedName
72− else Task.throw (E.ModuleNameMismatch path expectedName actualName)
73−
74−
75−
76−-- READ ONE FILE
77−
78−
79−readOneFile :: Summary -> FilePath -> Task.Task (Maybe Module.Raw, Info)
80−readOneFile summary path =
81− Task.mapError Error.Crawl $
82− do (time, source) <- readOneHelp path
83− atRoot $ parse (_project summary) path time source
84−
85−
86−readOneHelp :: FilePath -> Task.Task_ E.Error (Time.UTCTime, BS.ByteString)
87−readOneHelp path =
88− do exists <- IO.exists path
89− if exists
90− then liftIO $ (,) <$> Dir.getModificationTime path <*> IO.readUtf8 path
91− else Task.throw $ E.RootFileNotFound path
92−
93−
94−
95−-- READ MANY FILES
96−
97−
98−readManyFiles :: Summary -> NonEmpty FilePath -> Task.Task (NonEmpty (Module.Raw, Info))
99−readManyFiles summary files =
100− Task.mapError Error.Crawl $
101− do infos <- traverse (readManyFilesHelp summary) files
102− let insert (name, info) dict = Map.insertWith (<>) name (info :| []) dict
103− let nameTable = foldr insert Map.empty infos
104− _ <- Map.traverseWithKey detectDuplicateNames nameTable
105− return infos
106−
107−
108−readManyFilesHelp :: Summary -> FilePath -> Task.Task_ E.Error (Module.Raw, Info)
109−readManyFilesHelp summary path =
110− do (time, source) <- readOneHelp path
111− (maybeName, info) <- atRoot $ parse (_project summary) path time source
112− case maybeName of
113− Nothing ->
114− Task.throw (E.RootNameless path)
115−
116− Just name ->
117− return (name, info)
118−
119−
120−detectDuplicateNames :: Module.Raw -> NonEmpty Info -> Task.Task_ E.Error ()
121−detectDuplicateNames name (info :| otherInfos) =
122− case otherInfos of
123− [] ->
124− return ()
125−
126− _ ->
127− Task.throw (E.RootModuleNameDuplicate name (map _path (info : otherInfos)))
128−
129−
130−
131−
132−-- READ SOURCE
133−
134−
135−readSource :: Project -> BS.ByteString -> Task.Task (Maybe Module.Raw, Info)
136−readSource project source =
137− Task.mapError Error.Crawl $
138− atRoot $ parse project "elm" fakeTime source
139−
140−
141−fakeTime :: Time.UTCTime
142−fakeTime =
143− Time.UTCTime (Day.fromGregorian 3000 1 1) 0
144−
145−
146−
147−-- PARSE HEADER
148−
149−
150−parse :: Project -> FilePath -> Time.UTCTime -> BS.ByteString -> Task.Task_ E.Problem (Maybe Module.Raw, Info)
151−parse project path time source =
152− -- TODO get regions on data extracted here
153− case Header.parse (Project.getName project) source of
154− Right (maybeDecl, deps) ->
155− do maybeName <- checkTag project path maybeDecl
156− return ( maybeName, Info path time source deps )
157−
158− Left msg ->
159− Task.throw (E.BadHeader path source msg)
160−
161−
162−checkTag :: Project -> FilePath -> Maybe (Header.Tag, Module.Raw) -> Task.Task_ E.Problem (Maybe Module.Raw)
163−checkTag project path maybeDecl =
164− case maybeDecl of
165− Nothing ->
166− return Nothing
167−
168− Just (tag, name) ->
169− let
170− success =
171− return (Just name)
172− in
173− case tag of
174− Header.Normal ->
175− success
176−
177− Header.Port ->
178− case project of
179− Project.App _ ->
180− success
181−
182− Project.Pkg _ ->
183− Task.throw (E.PortsInPackage path name)
184−
185− Header.Effect ->
186− if Project.isPlatformPackage project then
187− success
188−
189− else
190− Task.throw (E.EffectsUnexpected path name)
builder/src/File/IO.hsdeleted−249
@@ -1,249 +0,0 @@
1−module File.IO
2− ( writeBinary, readBinary
3− , writeUtf8, readUtf8
4− , writeBuilder
5− , Writer
6− , put
7− , putByteString
8− , putBuilder
9− , putFile
10− , exists
11− , remove, removeDir
12− , find
13− , andM
14− )
15− where
16−
17−
18−import Control.Exception (catch)
19−import Control.Monad.Trans (liftIO)
20−import qualified Data.Binary as Binary
21−import qualified Data.ByteString as BS
22−import qualified Data.ByteString.Internal as BS
23−import qualified Data.ByteString.Builder as B
24−import qualified Data.ByteString.Builder.Extra as B (defaultChunkSize)
25−import qualified Foreign.ForeignPtr as FPtr
26−import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))
27−import qualified System.Directory as Dir
28−import System.FilePath ((</>))
29−import qualified System.FilePath as FP
30−import qualified System.IO as IO
31−import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
32−
33−import qualified Reporting.Error as Error
34−import qualified Reporting.Error.Assets as E
35−import qualified Reporting.Task as Task
36−
37−
38−
39−-- BINARY
40−
41−
42−writeBinary :: (Binary.Binary a) => FilePath -> a -> Task.Task ()
43−writeBinary path value =
44− liftIO $
45− do let dir = FP.dropFileName path
46− Dir.createDirectoryIfMissing True dir
47− Binary.encodeFile path value
48−
49−
50−readBinary :: (Binary.Binary a) => FilePath -> Task.Task a
51−readBinary path =
52− do exists_ <- liftIO (Dir.doesFileExist path)
53− if not exists_
54− then throwCorruptBinary path
55− else
56− do result <- liftIO (Binary.decodeFileOrFail path)
57− case result of
58− Left _ ->
59− throwCorruptBinary path
60−
61− Right value ->
62− return value
63−
64−
65−throwCorruptBinary :: FilePath -> Task.Task a
66−throwCorruptBinary filePath =
67− Task.throw (Error.Assets (E.CorruptBinary filePath))
68−
69−
70−
71−-- WRITE UTF-8
72−
73−
74−writeUtf8 :: FilePath -> BS.ByteString -> IO ()
75−writeUtf8 filePath content =
76− withUtf8 filePath IO.WriteMode $ \handle ->
77− BS.hPut handle content
78−
79−
80−withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
81−withUtf8 filePath mode callback =
82− IO.withFile filePath mode $ \handle ->
83− do IO.hSetEncoding handle IO.utf8
84− callback handle
85−
86−
87−
88−-- READ UTF-8
89−
90−
91−readUtf8 :: FilePath -> IO BS.ByteString
92−readUtf8 filePath =
93− withUtf8 filePath IO.ReadMode $ \handle ->
94− modifyIOError (encodingError filePath) $
95− do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile
96− let readSize = max 0 (fromIntegral fileSize) + 1
97− hGetContentsSizeHint handle readSize (max 255 readSize)
98−
99−
100−useZeroIfNotRegularFile :: IOException -> IO Integer
101−useZeroIfNotRegularFile _ =
102− return 0
103−
104−
105−hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString
106−hGetContentsSizeHint handle =
107− readChunks []
108− where
109− readChunks chunks readSize incrementSize =
110− do fp <- BS.mallocByteString readSize
111− readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize
112− let chunk = BS.PS fp 0 readCount
113− if readCount < readSize && readSize > 0
114− then return $! BS.concat (reverse (chunk:chunks))
115− else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))
116−
117−
118−encodingError :: FilePath -> IOError -> IOError
119−encodingError filePath ioErr =
120− case ioeGetErrorType ioErr of
121− InvalidArgument ->
122− annotateIOError
123− (userError "Bad encoding; the file must be valid UTF-8")
124− ""
125− Nothing
126− (Just filePath)
127−
128− _ ->
129− ioErr
130−
131−
132−
133−-- WRITE BUILDER
134−
135−
136−writeBuilder :: FilePath -> B.Builder -> IO ()
137−writeBuilder path builder =
138− IO.withBinaryFile path IO.WriteMode $ \handle ->
139− do IO.hSetBuffering handle (IO.BlockBuffering Nothing)
140− B.hPutBuilder handle builder
141−
142−
143−
144−-- WRITER
145−
146−
147−newtype Writer =
148− Writer (IO.Handle -> IO ())
149−
150−
151−put :: FilePath -> Writer -> IO ()
152−put path (Writer callback) =
153− IO.withBinaryFile path IO.WriteMode callback
154−
155−
156−putByteString :: BS.ByteString -> Writer
157−putByteString chunk =
158− Writer $ \handle ->
159− BS.hPut handle chunk
160−
161−
162−putBuilder :: B.Builder -> Writer
163−putBuilder builder =
164− Writer $ \handle ->
165− B.hPutBuilder handle builder
166−
167−
168−putFile :: FilePath -> Writer
169−putFile path =
170− Writer $ \sink ->
171− IO.withBinaryFile path IO.ReadMode $ \source ->
172− putHelp source sink
173−
174−
175−putHelp :: IO.Handle -> IO.Handle -> IO ()
176−putHelp source sink =
177− do chunk <- BS.hGet source B.defaultChunkSize
178− if BS.null chunk
179− then return ()
180− else
181− do BS.hPut sink chunk
182− putHelp source sink
183−
184−
185−
186−-- EXISTS
187−
188−
189−exists :: FilePath -> Task.Task_ e Bool
190−exists filePath =
191− liftIO $ Dir.doesFileExist filePath
192−
193−
194−
195−-- REMOVE FILES
196−
197−
198−remove :: FilePath -> Task.Task_ e ()
199−remove filePath =
200− liftIO $
201− do exists_ <- Dir.doesFileExist filePath
202− if exists_
203− then Dir.removeFile filePath
204− else return ()
205−
206−
207−removeDir :: FilePath -> IO ()
208−removeDir path =
209− do exists_ <- Dir.doesDirectoryExist path
210− if exists_
211− then Dir.removeDirectoryRecursive path
212− else return ()
213−
214−
215−
216−-- FIND FILES
217−
218−
219−find :: FilePath -> IO (Maybe FilePath)
220−find name =
221− do subDir <- Dir.getCurrentDirectory
222− findHelp name (FP.splitDirectories subDir)
223−
224−
225−findHelp :: FilePath -> [String] -> IO (Maybe FilePath)
226−findHelp name dirs =
227− if null dirs then
228− return Nothing
229−
230− else
231− do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)
232− if exists_
233− then return (Just (FP.joinPath dirs))
234− else findHelp name (init dirs)
235−
236−
237−
238−-- HELPER
239−
240−
241−andM :: (Monad m) => [m Bool] -> m Bool
242−andM checks =
243− case checks of
244− [] ->
245− return True
246−
247− check : otherChecks ->
248− do bool <- check
249− if bool then andM otherChecks else return False
builder/src/File/Plan.hsdeleted−196
@@ -1,196 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Plan
4− ( plan
5− , Info(..)
6− )
7− where
8−
9−import Control.Concurrent (forkIO)
10−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
11−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
12−import Control.Monad (foldM, void, when)
13−import Control.Monad.Except (liftIO)
14−import qualified Data.Binary as Binary
15−import qualified Data.ByteString as BS
16−import qualified Data.Map as Map
17−import qualified Data.Time.Clock as Time
18−import qualified System.Directory as Dir
19−
20−import qualified Elm.Compiler.Module as Module
21−import qualified Elm.Package as Pkg
22−
23−import qualified Elm.Project.Json as Project
24−import qualified Elm.Project.Summary as Summary
25−import qualified File.Crawl as Crawl
26−import qualified File.Header as Header
27−import qualified Reporting.Task as Task
28−import qualified Stuff.Paths
29−
30−
31−
32−-- PLAN
33−
34−
35−type Dict value = Map.Map Module.Raw value
36−
37−
38−plan :: Summary.Summary -> Crawl.Result -> Task.Task (Dict Info, Module.Interfaces)
39−plan (Summary.Summary root project _ ifaces _) (Crawl.Graph _ locals _ foreigns _) =
40− liftIO $
41− do queue <- newChan
42− let env = Env queue root (Project.getName project)
43−
44− mvar <- newEmptyMVar
45− statusMVars <- Map.traverseWithKey (getStatus env mvar foreigns) locals
46− putMVar mvar statusMVars
47−
48− void $ forkIO $
49− do graph <- Map.traverseMaybeWithKey (\_ -> readMVar) statusMVars
50− writeChan queue (EndLoop graph)
51−
52− ifaceLoader queue ifaces
53−
54−
55−data Env =
56− Env
57− { _queue :: Chan Msg
58− , _root :: FilePath
59− , _pkg :: Pkg.Name
60− }
61−
62−
63−
64−-- STATUS
65−
66−
67−type Status = Maybe Info
68− -- Nothing == clean
69− -- Just info == dirty
70−
71−
72−data Info =
73− Info
74− { _path :: FilePath
75− , _time :: Time.UTCTime
76− , _src :: BS.ByteString
77− , _clean :: [Module.Raw]
78− , _dirty :: [Module.Raw]
79− , _foreign :: [Module.Canonical] -- TODO is this needed?
80− }
81−
82−
83−
84−-- GET STATUS
85−
86−
87−getStatus
88− :: Env
89− -> MVar (Dict (MVar Status))
90− -> Dict Pkg.Package
91− -> Module.Raw
92− -> Header.Info
93− -> IO (MVar Status)
94−getStatus env statusMVars foreigns name (Header.Info path time src deps) =
95− do mvar <- newEmptyMVar
96−
97− void $ forkIO $ putMVar mvar =<<
98− do statuses <- readMVar statusMVars
99− info <- foldM (addDep statuses foreigns) (Info path time src [] [] []) deps
100−
101− let elmi = Stuff.Paths.elmi (_root env) name
102−
103− case _dirty info of
104− _ : _ ->
105− do remove elmi
106− return (Just info)
107−
108− [] ->
109− do fresh <- isFresh time elmi
110− if fresh
111− then
112− do let canonical = Module.Canonical (_pkg env) name
113− writeChan (_queue env) (Get canonical elmi)
114− return Nothing
115− else
116− do remove elmi
117− return (Just info)
118−
119− return mvar
120−
121−
122−addDep :: Dict (MVar Status) -> Dict Pkg.Package -> Info -> Module.Raw -> IO Info
123−addDep locals foreigns info name =
124− case Map.lookup name locals of
125− Just mvar ->
126− do status <- readMVar mvar
127− case status of
128− Nothing ->
129− return $ info { _clean = name : _clean info }
130−
131− Just _ ->
132− return $ info { _dirty = name : _dirty info }
133−
134− Nothing ->
135− case Map.lookup name foreigns of
136− Just (Pkg.Package pkg _vsn) ->
137− return $ info { _foreign = Module.Canonical pkg name : _foreign info }
138−
139− Nothing ->
140− return info -- must be native
141−
142−
143−
144−-- IS FRESH
145−
146−
147−isFresh :: Time.UTCTime -> FilePath -> IO Bool
148−isFresh srcTime elmi =
149− andM
150− [ Dir.doesFileExist elmi
151− , do elmiTime <- Dir.getModificationTime elmi
152− return (elmiTime >= srcTime)
153− ]
154−
155−
156−andM :: [IO Bool] -> IO Bool
157−andM checks =
158− case checks of
159− [] ->
160− return True
161−
162− check : otherChecks ->
163− do bool <- check
164− if bool then andM otherChecks else return False
165−
166−
167−remove :: FilePath -> IO ()
168−remove path =
169− do exists <- Dir.doesFileExist path
170− when exists (Dir.removeFile path)
171−
172−
173−
174−-- INTERFACE LOADER
175−
176−
177−data Msg
178− = EndLoop (Dict Info)
179− | Get Module.Canonical FilePath
180−
181−
182−ifaceLoader :: Chan Msg -> Module.Interfaces -> IO (Dict Info, Module.Interfaces)
183−ifaceLoader queue ifaces =
184− do msg <- readChan queue
185− case msg of
186− EndLoop dirty ->
187− return ( dirty, ifaces )
188−
189− Get canonical elmi ->
190− case Map.lookup canonical ifaces of
191− Just _ ->
192− ifaceLoader queue ifaces
193−
194− Nothing ->
195− do iface <- Binary.decodeFile elmi
196− ifaceLoader queue $ Map.insert canonical iface ifaces
builder/src/File/Watcher.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module File.Watcher where
3−
4−import Control.Concurrent (forkIO, threadDelay)
5−import Control.Concurrent.Chan (newChan, readChan, writeChan)
6−import qualified System.FSNotify as Notify
7−
8−import qualified Elm.Project as Project
9−import Elm.Project (Project)
10−
11−
12−
13−-- GRAPH
14−
15−
16−data Graph =
17− Graph
18− { _elm :: Map.Map Module.Raw Node
19− , _js :: Map.Map Module.Raw FilePath
20− }
21−
22−
23−data Node =
24− Node
25− { _path :: FilePath
26− , _time :: UTCTime
27− , _needs :: Set.Set Module.Raw
28− , _blocks :: Set.Set Module.Raw
29− , _iface :: Maybe (UTCTime, Interface)
30− }
31−
32−
33−
34−-- ABC
35−
36−
37−action :: Notify.Event -> IO ()
38−action event =
39− case event of
40− Notify.Added path time ->
41− return ()
42−
43− Notify.Modified path time ->
44− return ()
45−
46− Notify.Removed path time ->
47− return ()
48−
49−
50−watcher :: Project -> IO ()
51−watcher project =
52− let
53− srcDir =
54− Project.toSourceDir project
55−
56− action event =
57− case event of
58− Notify.Added _ _ ->
59− return ()
60−
61− Notify.Modified path time ->
62−
63− Notify.Removed path time ->
64−
65− in
66− do killer <- newChan
67− mapM_ (watcherHelp killer action) [srcDir]
68−
69−
70−
71−watcherHelp :: Notify.Action -> FilePath -> IO ()
72−watcherHelp killer action dir =
73− void $ forkIO $ Notify.withManager $ \manager ->
74− do stop <- Notify.watchTree manager dir (const True) action
75− _ <- readChan killer
76− stop
builder/src/Generate.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Generate
3+ ( debug
4+ , dev
5+ , prod
6+ , repl
7+ )
8+ where
9+
10+
11+import Prelude hiding (cycle, print)
12+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13+import Control.Monad (liftM2)
14+import qualified Data.ByteString.Builder as B
15+import Data.Map ((!))
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+import qualified Data.Name as N
19+import qualified Data.NonEmptyList as NE
20+
21+import qualified AST.Optimized as Opt
22+import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
26+import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Package as Pkg
28+import qualified File
29+import qualified Generate.JavaScript as JS
30+import qualified Generate.Mode as Mode
31+import qualified Nitpick.Debug as Nitpick
32+import qualified Reporting.Exit as Exit
33+import qualified Reporting.Task as Task
34+import qualified Stuff
35+
36+
37+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38+-- desireable to have Repl and Reactor to keep foreign objects in memory
39+-- to make things a bit faster?
40+
41+
42+
43+-- GENERATORS
44+
45+
46+type Task a =
47+ Task.Task Exit.Generate a
48+
49+
50+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51+debug root details (Build.Artifacts pkg ifaces roots modules) =
52+ do loading <- loadObjects root details modules
53+ types <- loadTypes root ifaces modules
54+ objects <- finalizeObjects loading
55+ let mode = Mode.Dev (Just types)
56+ let graph = objectsToGlobalGraph objects
57+ let mains = gatherMains pkg objects roots
58+ return $ JS.generate mode graph mains
59+
60+
61+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62+dev root details (Build.Artifacts pkg _ roots modules) =
63+ do objects <- finalizeObjects =<< loadObjects root details modules
64+ let mode = Mode.Dev Nothing
65+ let graph = objectsToGlobalGraph objects
66+ let mains = gatherMains pkg objects roots
67+ return $ JS.generate mode graph mains
68+
69+
70+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71+prod root details (Build.Artifacts pkg _ roots modules) =
72+ do objects <- finalizeObjects =<< loadObjects root details modules
73+ checkForDebugUses objects
74+ let graph = objectsToGlobalGraph objects
75+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
76+ let mains = gatherMains pkg objects roots
77+ return $ JS.generate mode graph mains
78+
79+
80+repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81+repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82+ do objects <- finalizeObjects =<< loadObjects root details modules
83+ let graph = objectsToGlobalGraph objects
84+ return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85+
86+
87+
88+-- CHECK FOR DEBUG
89+
90+
91+checkForDebugUses :: Objects -> Task ()
92+checkForDebugUses (Objects _ locals) =
93+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94+ [] -> return ()
95+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96+
97+
98+
99+-- GATHER MAINS
100+
101+
102+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103+gatherMains pkg (Objects _ locals) roots =
104+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105+
106+
107+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108+lookupMain pkg locals root =
109+ let
110+ toPair name (Opt.LocalGraph maybeMain _ _) =
111+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
112+ in
113+ case root of
114+ Build.Inside name -> toPair name =<< Map.lookup name locals
115+ Build.Outside name _ g -> toPair name g
116+
117+
118+
119+-- LOADING OBJECTS
120+
121+
122+data LoadingObjects =
123+ LoadingObjects
124+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126+ }
127+
128+
129+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130+loadObjects root details modules =
131+ Task.io $
132+ do mvar <- Details.loadObjects root details
133+ mvars <- traverse (loadObject root) modules
134+ return $ LoadingObjects mvar (Map.fromList mvars)
135+
136+
137+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138+loadObject root modul =
139+ case modul of
140+ Build.Fresh name _ graph ->
141+ do mvar <- newMVar (Just graph)
142+ return (name, mvar)
143+
144+ Build.Cached name _ _ ->
145+ do mvar <- newEmptyMVar
146+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147+ return (name, mvar)
148+
149+
150+
151+-- FINALIZE OBJECTS
152+
153+
154+data Objects =
155+ Objects
156+ { _foreign :: Opt.GlobalGraph
157+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158+ }
159+
160+
161+finalizeObjects :: LoadingObjects -> Task Objects
162+finalizeObjects (LoadingObjects mvar mvars) =
163+ Task.eio id $
164+ do result <- readMVar mvar
165+ results <- traverse readMVar mvars
166+ case liftM2 Objects result (sequence results) of
167+ Just loaded -> return (Right loaded)
168+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169+
170+
171+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172+objectsToGlobalGraph (Objects globals locals) =
173+ foldr Opt.addLocalGraph globals locals
174+
175+
176+
177+-- LOAD TYPES
178+
179+
180+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181+loadTypes root ifaces modules =
182+ Task.eio id $
183+ do mvars <- traverse (loadTypesHelp root) modules
184+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185+ results <- traverse readMVar mvars
186+ case sequence results of
187+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189+
190+
191+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192+loadTypesHelp root modul =
193+ case modul of
194+ Build.Fresh name iface _ ->
195+ newMVar (Just (Extract.fromInterface name iface))
196+
197+ Build.Cached name _ ciMVar ->
198+ do cachedInterface <- readMVar ciMVar
199+ case cachedInterface of
200+ Build.Unneeded ->
201+ do mvar <- newEmptyMVar
202+ _ <- forkIO $
203+ do maybeIface <- File.readBinary (Stuff.elmi root name)
204+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
205+ return mvar
206+
207+ Build.Loaded iface ->
208+ newMVar (Just (Extract.fromInterface name iface))
209+
210+ Build.Corrupted ->
211+ newMVar Nothing
builder/src/Generate/Output.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Generate.Output
4− ( generate
5− , generateReplFile
6− )
7− where
8−
9−
10−import Control.Monad.Trans (liftIO)
11−import qualified Data.ByteString.Builder as B
12−import qualified Data.List.NonEmpty as NonEmpty
13−import qualified Data.Map as Map
14−import Data.Monoid ((<>))
15−import System.FilePath ((</>))
16−
17−import qualified Elm.Compiler.Module as Module
18−import qualified Elm.Compiler.Objects as Obj
19−import qualified Elm.Name as N
20−import qualified Elm.Package as Pkg
21−
22−import qualified Elm.Project.Flags as Flags
23−import qualified Elm.Project.Json as Project
24−import qualified Elm.Project.Summary as Summary
25−import qualified File.Args as Args
26−import qualified File.Crawl as Crawl
27−import qualified File.IO as IO
28−import qualified Generate.Functions as Functions
29−import qualified Reporting.Task as Task
30−import qualified Stuff.Paths as Paths
31−
32−
33−
34−-- GENERATE
35−
36−
37−generate :: Flags.Options -> Summary.Summary -> Crawl.Result -> Task.Task ()
38−generate options summary graph@(Crawl.Graph args _ _ _ _) =
39− case args of
40− Args.Pkg _ ->
41− return ()
42−
43− Args.Roots names ->
44− generateMonolith options summary graph (NonEmpty.toList names)
45−
46−
47−
48−-- GENERATE MONOLITH
49−
50−
51−generateMonolith :: Flags.Options -> Summary.Summary -> Crawl.Result -> [Module.Raw] -> Task.Task ()
52−generateMonolith (Flags.Options debug target output) summary@(Summary.Summary _ project _ ifaces _) graph names =
53− do
54− objectGraph <- organize summary graph
55− let pkg = Project.getName project
56− let roots = map (Module.Canonical pkg) names
57− let (Right builder) = Obj.generate debug target ifaces objectGraph roots
58− let monolith =
59− "(function(scope){\n'use strict';" <> Functions.functions <> builder <> "}(this));"
60−
61− liftIO $
62− case output of
63− Nothing ->
64− IO.writeBuilder "elm.js" monolith
65−
66− Just Flags.None ->
67− return ()
68−
69− Just (Flags.Custom maybeDir fileName) ->
70− do path <- Flags.safeCustomPath maybeDir fileName
71− IO.writeBuilder path monolith
72−
73−
74−
75−-- GENERATE REPL MONOLITH
76−
77−
78−generateReplFile :: Summary.Summary -> Crawl.Result -> N.Name -> Task.Task FilePath
79−generateReplFile summary@(Summary.Summary _ project _ ifaces _) graph name =
80− do
81− objectGraph <- organize summary graph
82−
83− let home = Module.Canonical (Project.getName project) "ElmRepl"
84− let builder = Obj.generateForRepl ifaces objectGraph home name
85−
86− liftIO $ IO.writeBuilder Paths.temp $
87− replRecovery <> "(function(){\n'use strict';" <> Functions.functions <> builder <> "}());"
88−
89− return Paths.temp
90−
91−
92−replRecovery :: B.Builder
93−replRecovery =
94− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString()); process.exit(1); });"
95−
96−
97−
98−-- ORGANIZE
99−
100−
101−organize :: Summary.Summary -> Crawl.Result -> Task.Task Obj.Graph
102−organize (Summary.Summary root _ _ _ deps) (Crawl.Graph _ locals _ _ _) =
103− do localObjs <- Obj.unions <$> traverse (loadModuleObj root) (Map.keys locals)
104− foreignObjs <- Obj.unions <$> traverse loadPackageObj (Map.toList deps)
105− return (Obj.union localObjs foreignObjs)
106−
107−
108−loadModuleObj :: FilePath -> Module.Raw -> Task.Task Obj.Graph
109−loadModuleObj root name =
110− IO.readBinary (Paths.elmo root name)
111−
112−
113−loadPackageObj :: ( Pkg.Name, (Pkg.Version, deps) ) -> Task.Task Obj.Graph
114−loadPackageObj ( name, (version,_) ) =
115− do dir <- Task.getPackageCacheDirFor name version
116− IO.readBinary (dir </> "objs.dat")
117−
builder/src/Http.hsnew file+244
@@ -0,0 +1,244 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Http
3+ ( Manager
4+ , getManager
5+ , toUrl
6+ -- fetch
7+ , get
8+ , post
9+ , Header
10+ , accept
11+ , Error(..)
12+ -- archives
13+ , Sha
14+ , shaToChars
15+ , getArchive
16+ -- upload
17+ , upload
18+ , filePart
19+ , jsonPart
20+ , stringPart
21+ )
22+ where
23+
24+
25+import Prelude hiding (zip)
26+import qualified Codec.Archive.Zip as Zip
27+import Control.Exception (SomeException, handle)
28+import qualified Data.Binary as Binary
29+import qualified Data.Binary.Get as Binary
30+import qualified Data.ByteString.Builder as B
31+import qualified Data.ByteString.Char8 as BS
32+import qualified Data.Digest.Pure.SHA as SHA
33+import qualified Data.String as String
34+import Network.HTTP (urlEncodeVars)
35+import Network.HTTP.Client
36+import Network.HTTP.Client.TLS (tlsManagerSettings)
37+import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38+import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39+import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
40+import qualified Network.HTTP.Client.MultipartFormData as Multi
41+
42+import qualified Json.Encode as Encode
43+import qualified Elm.Version as V
44+
45+
46+
47+-- MANAGER
48+
49+
50+getManager :: IO Manager
51+getManager =
52+ newManager tlsManagerSettings
53+
54+
55+
56+-- URL
57+
58+
59+toUrl :: String -> [(String,String)] -> String
60+toUrl url params =
61+ case params of
62+ [] -> url
63+ _:_ -> url ++ "?" ++ urlEncodeVars params
64+
65+
66+
67+-- FETCH
68+
69+
70+get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
71+get =
72+ fetch methodGet
73+
74+
75+post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
76+post =
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 =
82+ handle (handleSomeException url onError) $
83+ handle (handleHttpException url onError) $
84+ do req0 <- parseUrlThrow url
85+ let req1 =
86+ req0
87+ { method = methodVerb
88+ , requestHeaders = addDefaultHeaders headers
89+ }
90+ withResponse req1 manager $ \response ->
91+ do chunks <- brConsume (responseBody response)
92+ onSuccess (BS.concat chunks)
93+
94+
95+addDefaultHeaders :: [Header] -> [Header]
96+addDefaultHeaders headers =
97+ (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
98+
99+
100+{-# NOINLINE userAgent #-}
101+userAgent :: BS.ByteString
102+userAgent =
103+ BS.pack ("elm/" ++ V.toChars V.compiler)
104+
105+
106+accept :: BS.ByteString -> Header
107+accept mime =
108+ (hAccept, mime)
109+
110+
111+
112+-- EXCEPTIONS
113+
114+
115+data Error
116+ = BadUrl String String
117+ | BadHttp String HttpExceptionContent
118+ | BadMystery String SomeException
119+
120+
121+handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
122+handleHttpException url onError httpException =
123+ case httpException of
124+ InvalidUrlException _ reason ->
125+ return (Left (onError (BadUrl url reason)))
126+
127+ HttpExceptionRequest _ content ->
128+ return (Left (onError (BadHttp url content)))
129+
130+
131+handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
132+handleSomeException url onError exception =
133+ return (Left (onError (BadMystery url exception)))
134+
135+
136+
137+-- SHA
138+
139+
140+type Sha = SHA.Digest SHA.SHA1State
141+
142+
143+shaToChars :: Sha -> String
144+shaToChars =
145+ SHA.showDigest
146+
147+
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+
175+readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
176+readArchive body =
177+ readArchiveHelp body $
178+ AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
179+
180+
181+data ArchiveState =
182+ AS
183+ { _len :: !Int
184+ , _sha :: !(Binary.Decoder SHA.SHA1State)
185+ , _zip :: !(Binary.Decoder Zip.Archive)
186+ }
187+
188+
189+readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
190+readArchiveHelp body (AS len sha zip) =
191+ case zip of
192+ Binary.Fail _ _ _ ->
193+ return Nothing
194+
195+ Binary.Partial k ->
196+ do chunk <- brRead body
197+ readArchiveHelp body $
198+ AS
199+ { _len = len + BS.length chunk
200+ , _sha = Binary.pushChunk sha chunk
201+ , _zip = k (if BS.null chunk then Nothing else Just chunk)
202+ }
203+
204+ Binary.Done _ _ archive ->
205+ return $ Just ( SHA.completeSha1Incremental sha len, archive )
206+
207+
208+
209+-- UPLOAD
210+
211+
212+upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
213+upload manager url parts =
214+ handle (handleSomeException url id) $
215+ handle (handleHttpException url id) $
216+ do req0 <- parseUrlThrow url
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+
232+
233+jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
234+jsonPart name filePath value =
235+ let
236+ body =
237+ Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
238+ in
239+ Multi.partFileRequestBody (String.fromString name) filePath body
240+
241+
242+stringPart :: String -> String -> Multi.Part
243+stringPart name string =
244+ Multi.partBS (String.fromString name) (BS.pack string)
builder/src/Reporting.hsnew file+474
@@ -0,0 +1,474 @@
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/Error.hsdeleted−153
@@ -1,153 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error
4− ( Error(..)
5− , toString
6− , toStderr
7− )
8− where
9−
10−
11−import qualified Text.PrettyPrint.ANSI.Leijen as P
12−
13−import qualified Elm.Compiler as Compiler
14−import qualified Elm.Compiler.Module as Module
15−import qualified Elm.Package as Pkg
16−import qualified Elm.Utils as Utils
17−import qualified Reporting.Error.Assets as Asset
18−import qualified Reporting.Error.Bump as Bump
19−import qualified Reporting.Error.Compile as Compile
20−import qualified Reporting.Error.Crawl as Crawl
21−import qualified Reporting.Error.Deps as Deps
22−import qualified Reporting.Error.Diff as Diff
23−import qualified Reporting.Error.Help as Help
24−import qualified Reporting.Error.Http as Http
25−import qualified Reporting.Error.Publish as Publish
26−
27−
28−
29−-- ALL POSSIBLE ERRORS
30−
31−
32−data Error
33− = NoElmJson
34− | Assets Asset.Error
35− | Bump Bump.Error
36− | Compile Compile.Error [Compile.Error]
37− | Crawl Crawl.Error
38− | Cycle [Module.Raw] -- TODO write docs to help with this scenario
39− | Deps Deps.Error
40− | Diff Diff.Error
41− | Publish Publish.Error
42− | BadHttp String Http.Error
43−
44− -- install
45− | NoSolution [Pkg.Name]
46− | CannotMakeNothing
47−
48−
49−
50−-- RENDERERS
51−
52−
53−toString :: Error -> String
54−toString err =
55− Help.toString (Help.reportToDoc (toReport err))
56−
57−
58−toStderr :: Error -> IO ()
59−toStderr err =
60− Help.toStderr (Help.reportToDoc (toReport err))
61−
62−
63−toReport :: Error -> Help.Report
64−toReport err =
65− case err of
66− NoElmJson ->
67− Help.report "WELCOME" Nothing
68− "It looks like you are trying to start a new Elm project. Very exciting! :D"
69− [ P.fillSep
70− ["I","very","highly","recommend","working","through"
71− ,P.green "<https://guide.elm-lang.org>","which","will","teach","you","the"
72− ,"basics","of","Elm,","including","how","to","start","new","projects."
73− ]
74− , P.fillSep
75− ["For","folks","who","have","already","built","stuff","with","Elm,","the"
76− ,"problem","is","just","that","there","is","no",P.dullyellow "elm.json","yet."
77− ,"If","you","want","to","work","from","an","example,","check","out","the"
78− ,"one","at","<https://github.com/evancz/elm-todomvc/blob/master/elm.json>"
79− ]
80− , Help.reflow
81− "Whatever your scenario, I hope you have a lovely time using Elm!"
82− ]
83−
84− Assets assetError ->
85− Asset.toReport assetError
86−
87− Bump bumpError ->
88− Bump.toReport bumpError
89−
90− Compile e es ->
91− Help.compilerReport $ Compile.toDoc e es
92−
93− Crawl crawlError ->
94− Crawl.toReport crawlError
95−
96− Cycle names ->
97− Help.report "IMPORT CYCLE" Nothing
98− "Your module imports form a cycle:"
99− [ P.indent 4 (Utils.drawCycle names)
100− , Help.reflow $
101− "Learn more about why this is disallowed and how to break cycles here:"
102− ++ Help.hintLink "import-cycles"
103− ]
104−
105− Deps depsError ->
106− Deps.toReport depsError
107−
108− Diff commandsError ->
109− Diff.toReport commandsError
110−
111− Publish publishError ->
112− Publish.toReport publishError
113−
114− BadHttp url httpError ->
115− Http.toReport url httpError
116−
117− NoSolution badPackages ->
118− case badPackages of
119− [] ->
120− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json")
121− "This usually happens if you try to modify dependency constraints by\
122− \ hand. I recommend deleting any dependency you added recently (or all\
123− \ of them if things are bad) and then adding them again with:"
124− [ P.indent 4 $ P.green "elm install"
125− , Help.reflow $
126− "And do not be afaid to ask for help on Slack if you get stuck!"
127− ]
128−
129− _:_ ->
130− Help.report "OLD DEPENDENCIES" (Just "elm.json")
131− ( "You are using Elm " ++ Pkg.versionToString Compiler.version
132− ++ ", but the following packages have not been updated for this version yet:"
133− )
134− [ P.vcat $ map (P.red . P.text . Pkg.toString) badPackages
135− , Help.note
136− "Please be kind to the relevant package authors! Having friendly interactions\
137− \ with users is great motivation, and conversely, getting berated by strangers\
138− \ on the internet sucks your soul dry. Furthermore, package authors are humans\
139− \ with families, friends, jobs, vacations, responsibilities, goals, etc. They\
140− \ face obstacles outside of their technical work you will never know about,\
141− \ so please assume the best and try to be patient and supportive!"
142− ]
143−
144− CannotMakeNothing ->
145− Help.report "NO INPUT" Nothing
146− "What should I make though? I need more information, like:"
147− [ P.vcat
148− [ P.indent 4 $ P.green "elm make MyThing.elm"
149− , P.indent 4 $ P.green "elm make This.elm That.elm"
150− ]
151− , Help.reflow
152− "However many files you give, I will create one JS file out of them."
153− ]
builder/src/Reporting/Error/Assets.hsdeleted−226
@@ -1,226 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Assets
4− ( Error(..)
5− , ElmJsonProblem(..)
6− , toReport
7− , BadElmJsonContent(..)
8− , badContentToDocs
9− )
10− where
11−
12−
13−import Data.Monoid ((<>))
14−import qualified Data.Text as Text
15−import qualified Text.PrettyPrint.ANSI.Leijen as P
16−
17−import qualified Elm.Package as Pkg
18−import qualified Reporting.Error.Help as Help
19−
20−
21−
22−-- ERRORS
23−
24−
25−data Error
26− = BadElmJson ElmJsonProblem
27− | CorruptElmJson Pkg.Name Pkg.Version
28− | CorruptDocumentation Pkg.Name Pkg.Version
29− | CorruptBinary FilePath
30−
31−
32−
33−-- ELM JSON PROBLEM
34−
35−
36−data ElmJsonProblem
37− = BadJson P.Doc
38− | BadDepDup String String Pkg.Name [Pkg.Name]
39− | BadSrcDir FilePath
40−
41−
42−
43−-- TO REPORT
44−
45−
46−toReport :: Error -> Help.Report
47−toReport err =
48− case err of
49− CorruptElmJson pkg vsn ->
50− corruptJsonToReport "elm.json" pkg vsn
51−
52− CorruptDocumentation pkg vsn ->
53− corruptJsonToReport "docs.json" pkg vsn
54−
55− CorruptBinary path ->
56− Help.report "CORRUPT BINARY" (Just path)
57− ("The binary data at " ++ path ++ " is corrupt.")
58− [ Help.reflow $
59− "Maybe a program is modifying your elm-stuff/ or ELM_HOME\
60− \ directory in unexpected ways? Both of those are just caches, so\
61− \ you can try deleting them and they will be rebuilt from scratch."
62− ]
63−
64− BadElmJson problem ->
65− elmJsonProblemToReport problem
66−
67−
68−
69−-- CORRUPT JSON
70−
71−
72−corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report
73−corruptJsonToReport path pkg vsn =
74− Help.report "CORRUPT JSON" Nothing
75− ( "The " ++ path ++ " for " ++ Pkg.toString pkg
76− ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."
77− )
78− [ Help.reflow $
79− "I removed it from my file cache, so if it was some transient\
80− \ error it should be fixed if you try the same thing again.\
81− \ Please report this if it seems like an Elm problem though!"
82− ]
83−
84−
85−
86−-- BAD ELM JSON
87−
88−
89−elmJsonProblemToReport :: ElmJsonProblem -> Help.Report
90−elmJsonProblemToReport problem =
91− case problem of
92− BadJson jsonErrorDoc ->
93− Help.compilerReport jsonErrorDoc
94−
95− BadSrcDir dir ->
96− Help.report "BAD JSON" (Just "elm.json")
97− "The \"source-directories\" in your elm.json lists the following directory:"
98− [ P.indent 4 (P.dullyellow (P.text dir))
99− , Help.reflow "I cannot find that directory though! Is it missing? Is there a typo?"
100− ]
101−
102− BadDepDup field1 field2 dup dups ->
103− let
104− packagesAre =
105− if null dups then "package is" else "packages are"
106−
107− advice =
108− if null dups then
109− "Delete one of the entries."
110− else
111− "Delete duplicates until each package lives in ONE category."
112− in
113− Help.report "BAD JSON" (Just "elm.json")
114− (
115− if null dups then
116− "The following package appears twice in your elm.json file:"
117− else
118− "The following packages appear twice in your elm.json file:"
119− )
120− [ P.dullyellow $ P.indent 4 $ P.vcat $
121− map (P.text . Pkg.toString) (dup:dups)
122− , Help.reflow $
123− "The " ++ packagesAre ++ " available in \"" ++ field1
124− ++ "\", so it is redundant to list it again in \"" ++ field2
125− ++ "\". It is already available! " ++ advice
126− , Help.reflow "More help at <https://github.com/elm-lang/elm-package/blob/master/TODO>"
127− ]
128−
129−
130−
131−-- PROBLEM TO DOCS
132−
133−
134−data BadElmJsonContent
135− = BadType Text.Text
136− | BadPkgName String
137− | BadVersion Text.Text
138− | BadConstraint String
139− | BadModuleName Text.Text
140− | BadModuleHeaderTooLong Text.Text
141− | BadDependencyName Text.Text
142− | BadLicense Text.Text [Text.Text]
143− | BadDirectoryNotString
144− | BadSummaryTooLong
145−
146−
147−badContentToDocs :: BadElmJsonContent -> [P.Doc]
148−badContentToDocs badContent =
149− case badContent of
150− BadType _ ->
151− ["The","only","valid","types","of","elm.json","are"
152− ,P.green "\"browser\"","and",P.green "\"package\"" <> "."
153− ]
154−
155− BadPkgName problem ->
156− map P.text (words problem)
157−
158− BadVersion txt ->
159− ["You","provided",P.red (P.text (show txt))
160− ,"which","is","not","a","valid","version.","I","need","something","like"
161− ,P.green "\"1.0.0\"","or",P.green "\"2.0.4\"" <> "."
162− ]
163−
164− BadConstraint problem ->
165− map P.text (words ("It is not a valid constraint. " ++ problem))
166−
167− BadModuleName name ->
168− ["You","provided",P.text (show name),"which","is","not","a","valid","module","name."
169− ,"I","need","something","like",P.green "\"Html.Events\"","or",P.green "\"Browser.Navigation\"" <> "."
170− ]
171−
172− BadModuleHeaderTooLong header ->
173− ["The",P.text (show header),"header","is","too","long."
174− ,"I","need","it","to","be",P.green "under",P.green "20",P.green "characters"
175− ,"to","ensure","that","formatting","is","nice","on","the","package","website."
176− ]
177−
178− BadDependencyName name ->
179− ["The",P.text (show name),"entry","is","not","a","valid","package","name."
180− ,"I","recommend","deleting","it,","finding","the","package","you","want","on"
181− ,"the","package","website,","and","installing","it","with","the"
182− ,P.green "`elm install`","command","instead."
183− ]
184−
185− BadLicense _given suggestions ->
186− case suggestions of
187− [] ->
188− ["I","need","an","OSI","approved","SPDX","license,","like"
189− ,P.green "\"BSD-3-Clause\"","or",P.green "\"MIT\".","See"
190− ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."
191− ]
192−
193− code:codes ->
194− ["I","need","an","OSI","approved","SPDX","license."]
195− ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]
196− ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]
197−
198− BadDirectoryNotString ->
199− ["I","need","a",P.green "STRING","that","points","to","a","directory","of","Elm","code."
200− ]
201−
202− BadSummaryTooLong ->
203− ["Your","summary","is","too","long.","I","need","it","to"
204− ,"be",P.green "under",P.green "80",P.green "characters."
205− ]
206−
207−
208−oneOf :: Text.Text -> [Text.Text] -> [P.Doc]
209−oneOf code codes =
210− let
211− toDoc spdx =
212− P.green (P.text (show spdx))
213− in
214− case codes of
215− [] ->
216− [toDoc code]
217−
218− [code2] ->
219− [toDoc code,"or",toDoc code2]
220−
221− _:_ ->
222− let
223− these = code : init codes
224− final = last codes
225− in
226− map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]
builder/src/Reporting/Error/Bump.hsdeleted−53
@@ -1,53 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Bump
4− ( Error(..)
5− , toReport
6− )
7− where
8−
9−
10−import Data.Monoid ((<>))
11−import qualified Text.PrettyPrint.ANSI.Leijen as P
12−
13−import qualified Elm.Package as Pkg
14−import qualified Reporting.Error.Help as Help
15−
16−
17−
18−-- ERRORS
19−
20−
21−data Error
22− = Application
23− | Unbumpable Pkg.Version [Pkg.Version]
24−
25−
26−
27−-- TO REPORT
28−
29−
30−toReport :: Error -> Help.Report
31−toReport err =
32− case err of
33− Application ->
34− Help.report "UNBUMPABLE" (Just "elm.json")
35− "Your elm.json says this is a browser project. That means it cannot be published\
36− \ on <https://package.elm-lang.org> and therefore has no version to bump!"
37− []
38−
39− Unbumpable vsn versions ->
40− Help.docReport "UNBUMPABLE" (Just "elm.json")
41− ( P.fillSep
42− ["Your","elm.json","says","I","should","bump","relative","to","version"
43− ,P.red (P.text (Pkg.versionToString vsn)) <> ","
44− ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."
45− ,"That","means","there","is","no","API","for","me","to","diff","against","and"
46− ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."
47− ]
48− )
49− [ P.fillSep $
50− ["Try","bumping","again","after","changing","the",P.dullyellow "\"version\"","in","elm.json"]
51− ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]
52− , P.vcat $ map (P.green . P.text . Pkg.versionToString) versions
53− ]
builder/src/Reporting/Error/Compile.hsdeleted−72
@@ -1,72 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Compile
4− ( Error(..)
5− , toDoc
6− )
7− where
8−
9−
10−import Data.List.NonEmpty (NonEmpty((:|)))
11−import qualified Data.List.NonEmpty as NonEmpty
12−import qualified Data.Text as Text
13−import qualified Data.Time.Clock as Time
14−import qualified Text.PrettyPrint.ANSI.Leijen as P
15−
16−import qualified Elm.Compiler as Compiler
17−import qualified Elm.Compiler.Module as Module
18−
19−
20−
21−-- ERRORS
22−
23−
24−data Error =
25− Error
26− { _name :: Module.Raw
27− , _path :: FilePath
28− , _time :: Time.UTCTime
29− , _source :: Text.Text
30− , _errors :: [Compiler.Error]
31− }
32−
33−
34−
35−-- TO DOC
36−
37−
38−toDoc :: Error -> [Error] -> P.Doc
39−toDoc e es =
40− case NonEmpty.sortWith _time (e :| es) of
41− err :| errors ->
42− P.vcat (toDocHelp err errors)
43−
44−
45−toDocHelp :: Error -> [Error] -> [P.Doc]
46−toDocHelp e1 errs =
47− case errs of
48− [] ->
49− [errorToDoc e1]
50−
51− e2 : otherErrors ->
52− errorToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors
53−
54−
55−errorToDoc :: Error -> P.Doc
56−errorToDoc (Error _name path _time source errors) =
57− Compiler.errorsToDoc path source errors
58−
59−
60−separator :: Module.Raw -> Module.Raw -> P.Doc
61−separator beforeName afterName =
62− let
63− before = Module.nameToString beforeName ++ " ↑ "
64− after = " ↓ " ++ Module.nameToString afterName
65− in
66− P.dullred $ P.vcat $
67− [ P.indent (80 - length before) (P.text before)
68− , "====o======================================================================o===="
69− , P.text after
70− , P.empty
71− , P.empty
72− ]
builder/src/Reporting/Error/Crawl.hsdeleted−318
@@ -1,318 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Crawl
4− ( Error(..)
5− , Problem(..)
6− , Origin(..)
7− , toReport
8− )
9− where
10−
11−
12−import qualified Data.ByteString as BS
13−import qualified Data.Char as Char
14−import qualified Data.Map as Map
15−import qualified Data.Text.Encoding as Text
16−import qualified Text.PrettyPrint.ANSI.Leijen as P
17−import Text.PrettyPrint.ANSI.Leijen ((<+>), (<>))
18−
19−import qualified Elm.Compiler as Compiler
20−import qualified Elm.Compiler.Module as Module
21−import qualified Elm.Package as Pkg
22−import qualified Reporting.Error.Help as Help
23−
24−
25−
26−-- ERROR
27−
28−
29−data Error
30− = RootFileNotFound FilePath
31− | RootModuleNameDuplicate Module.Raw [FilePath]
32− | RootNameless FilePath
33− | DependencyProblems Problem [Problem]
34− | BadKernelHeader FilePath
35−
36−
37−data Problem
38− = ModuleNotFound Origin Module.Raw -- TODO suggest other names
39− | ModuleAmbiguous Origin Module.Raw [FilePath] [Pkg.Package]
40− | BadHeader FilePath BS.ByteString Compiler.Error
41− | ModuleNameReservedForKernel Origin Module.Raw
42− | ModuleNameMissing FilePath Module.Raw
43− | ModuleNameMismatch
44− FilePath
45− Module.Raw -- expected
46− Module.Raw -- actual
47− | PortsInPackage FilePath Module.Raw
48− | EffectsUnexpected FilePath Module.Raw
49−
50−
51−data Origin
52− = ElmJson
53− | File FilePath
54− | Module FilePath Module.Raw
55−
56−
57−
58−-- TO REPORT
59−
60−
61−toReport :: Error -> Help.Report
62−toReport err =
63− case err of
64− RootFileNotFound path ->
65− Help.report "FILE NOT FOUND" Nothing
66− "You want me to compile this file:"
67− [ P.indent 4 $ P.dullyellow $ P.text path
68− , "I cannot find it though! Is there a typo?"
69− ]
70−
71− RootModuleNameDuplicate name paths ->
72− Help.report "DUPLICATE NAMES" Nothing
73− "I am trying to compile multiple modules with the same name:"
74− [ P.indent 4 $ P.dullyellow $ P.vcat $
75− map P.text paths
76− , P.fillSep $
77− [ "These", "modules", if length paths == 2 then "both" else "all", "claim"
78− , "to", "be", "named", P.dullyellow (P.text (Module.nameToString name)) <> "."
79− , "Change", "them", "to", "have", "unique", "names", "and", "you"
80− , "should", "be", "all", "set!"
81− ]
82− ]
83−
84− RootNameless path ->
85− namelessToDoc path "Main"
86−
87− DependencyProblems problem otherProblems ->
88− case otherProblems of
89− [] ->
90− problemToReport problem
91−
92− _ ->
93− problemToReport problem
94− -- error "TODO handle multiple dependency errors"
95−
96− BadKernelHeader filePath ->
97− Help.report "BAD KERNEL HEADER" Nothing
98− "I ran into a bad header in this file:"
99− [ P.indent 4 $ P.dullyellow $ P.text filePath
100− , Help.reflow $
101− "NOTE: Kernel code is only available to core Elm libraries to ensure\
102− \ the portability and security of the Elm ecosystem. This restriction\
103− \ also makes it possible to improve code gen (i.e. performance) without\
104− \ disrupting the ecosystem."
105− ]
106−
107−
108−
109−-- PROBLEM TO REPORT
110−
111−
112−problemToReport :: Problem -> Help.Report
113−problemToReport problem =
114− case problem of
115− ModuleNotFound origin name ->
116− notFoundToDoc origin name
117−
118− ModuleAmbiguous origin child paths pkgs ->
119− ambiguousToDoc origin child paths pkgs
120−
121− BadHeader path source compilerError ->
122− Help.compilerReport $
123− Compiler.errorsToDoc path (Text.decodeUtf8 source) [compilerError]
124−
125− ModuleNameMissing path name ->
126− namelessToDoc path name
127−
128− ModuleNameMismatch path expected actual ->
129− Help.report "MODULE NAME MISMATCH" (Just path)
130− ( "The file at " ++ path ++ " has a typo in the module name. It says:"
131− )
132− [ P.indent 4 $ P.dullyellow $ "module" <+> P.red (P.text (Module.nameToString actual)) <+> "exposing (..)"
133− , "Looks like a typo or copy/paste error. Instead it needs to say:"
134− , P.indent 4 $ P.dullyellow $ "module" <+> P.green (P.text (Module.nameToString expected)) <+> "exposing (..)"
135− , "Make the change and you should be all set!"
136− ]
137−
138− ModuleNameReservedForKernel origin name ->
139− kernelNameToDoc origin name
140−
141− PortsInPackage path name ->
142− badTagToDoc path name "port" "port-modules" $
143− "Packages cannot have any `port` modules."
144−
145− EffectsUnexpected path name ->
146− badTagToDoc path name "effect" "effect-modules" $
147− "Creating `effect` modules is relatively experimental. There are a\
148− \ couple in @elm-lang repos right now, but we have decided to be\
149− \ very cautious in expanding its usage."
150−
151−
152−badTagToDoc :: FilePath -> Module.Raw -> String -> String -> String -> Help.Report
153−badTagToDoc path name tag hintName summary =
154− Help.report
155− ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")
156− (Just path)
157− summary
158− [ P.fillSep $
159− [ "Get", "rid", "of", "all", "the"
160− , P.red (P.text tag)
161− , "stuff", "in"
162− , P.dullyellow (P.text (Module.nameToString name))
163− , "to", "proceed."
164− ]
165− , Help.note $
166− "You can learn the reasoning behind this design choice at "
167− ++ Help.hintLink hintName
168− ]
169−
170−
171−
172−-- HELPERS
173−
174−
175−namelessToDoc :: FilePath -> Module.Raw -> Help.Report
176−namelessToDoc path name =
177− Help.report "UNNAMED MODULE" (Just path)
178− ( "The `" ++ Module.nameToString name
179− ++ "` module must start with a line like this:"
180− )
181− [ P.indent 4 $ P.dullyellow $ P.text $
182− "module " ++ Module.nameToString name ++ " exposing (..)"
183− , Help.reflow $
184− "Try adding that as the first line of your file!"
185− , Help.note $
186− "It is best to replace (..) with an explicit list of types and\
187− \ functions you want to expose. If you know a value is only used\
188− \ WITHIN this module, it is extra easy to refactor. This kind of\
189− \ information is great, especially as your project grows!"
190− ]
191−
192−
193−notFoundToDoc :: Origin -> Module.Raw -> Help.Report
194−notFoundToDoc origin child =
195− case origin of
196− ElmJson ->
197− Help.report "MODULE NOT FOUND" Nothing
198− "Your elm.json says your project has the following module:"
199− [ P.indent 4 $ P.dullyellow $ P.text $ Module.nameToString child
200− , Help.reflow $
201− "I cannot find it though! Is there a typo in the module name?"
202− ]
203−
204− File path ->
205− Help.report "UNKNOWN IMPORT" (Just path)
206− ("I cannot find a `" ++ Module.nameToString child ++ "` module to import.")
207− (notFoundDetails child)
208−
209− Module path parent ->
210− Help.report "UNKNOWN IMPORT" (Just path)
211− ("The " ++ Module.nameToString parent ++ " module has a bad import:")
212− (notFoundDetails child)
213−
214−
215−notFoundDetails :: Module.Raw -> [P.Doc]
216−notFoundDetails child =
217− let
218− simulatedCode =
219− P.indent 4 $ P.dullyellow $ P.text $ "import " ++ Module.nameToString child
220− in
221− case Map.lookup child Pkg.suggestions of
222− Just pkg ->
223− [ simulatedCode
224− , Help.reflow $
225− "Do you want the one from the " ++ Pkg.toString pkg
226− ++ " package? If so, run this command to add that dependency to your elm.json file:"
227− , P.indent 4 $ P.green $ P.text $ "elm install " ++ Pkg.toString pkg
228− , Help.reflow $
229− "If you want a local file, make sure the directory that contains the `"
230− ++ Module.nameToString child
231− ++ "` module is listed in your elm.json \"source-directories\" field."
232− ]
233−
234− Nothing ->
235− [ simulatedCode
236− , "I cannot find that module! Is there a typo in the module name?"
237− , P.vcat
238− [ P.fillSep
239− ["Is","it","defined","in","a","package?","Did","you"
240− ,P.green "elm install"
241− ,"that","package","yet?"
242− ]
243− , Help.reflow $
244− "Is it a local file? Maybe it lives in some directory, but I cannot find that\
245− \ directory unless it is listed in the \"source-directories\" field of your elm.json!"
246− ]
247− ]
248−
249−
250−ambiguousToDoc :: Origin -> Module.Raw -> [FilePath] -> [Pkg.Package] -> Help.Report
251−ambiguousToDoc origin child paths pkgs =
252− let
253− pkgToString (Pkg.Package pkg vsn) =
254− "exposed by " ++ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn
255−
256− makeReport maybePath summary yellowString =
257− Help.report "AMBIGUOUS IMPORT" maybePath summary
258− [ P.indent 4 $ P.dullyellow $ P.text yellowString
259− , Help.reflow $
260− "I found multiple module with that name though:"
261− , P.indent 4 $ P.dullyellow $ P.vcat $
262− map P.text $ paths ++ map pkgToString pkgs
263− , Help.reflow $
264− if null paths then
265− "It looks like the name clash is in your dependencies, which is\
266− \ out of your control. Elm does not support this scenario right\
267− \ now, but it may be worthwhile. Please open an issue describing\
268− \ your scenario so we can gather more usage information!"
269− else
270− "Which is the right one? Try renaming your modules to have unique names."
271− ]
272− in
273− case origin of
274− ElmJson ->
275− makeReport
276− Nothing
277− "Your elm.json wants the following module:"
278− (Module.nameToString child)
279−
280− File path ->
281− makeReport
282− (Just path)
283− ("The file at " ++ path ++ " has an ambiguous import:")
284− ("import " ++ Module.nameToString child)
285−
286− Module path parent ->
287− makeReport
288− (Just path)
289− ("The " ++ Module.nameToString parent ++ " module has an ambiguous import:")
290− ("import " ++ Module.nameToString child)
291−
292−
293−kernelNameToDoc :: Origin -> Module.Raw -> Help.Report
294−kernelNameToDoc origin kernelName =
295− let
296− (maybePath, statement) =
297− case origin of
298− ElmJson ->
299− ( Nothing
300− , "Your elm.json says your project has the following module:"
301− )
302−
303− File path ->
304− ( Just path
305− , "This file is trying to import the following module:"
306− )
307−
308− Module path parent ->
309− ( Just path
310− , "Your " ++ Module.nameToString parent ++ " module is trying to import:"
311− )
312− in
313− Help.report "BAD MODULE NAME" maybePath statement
314− [ P.indent 4 $ P.dullyellow $ P.text $ Module.nameToString kernelName
315− , Help.reflow $
316− "But names like that are reserved for internal use.\
317− \ Switch to a name outside of the Elm/Kernel/ namespace."
318− ]
builder/src/Reporting/Error/Deps.hsdeleted−100
@@ -1,100 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Deps
4− ( Error(..)
5− , toReport
6− )
7− where
8−
9−import Text.PrettyPrint.ANSI.Leijen ((<>))
10−import qualified Text.PrettyPrint.ANSI.Leijen as P
11−
12−import qualified Elm.Compiler as Compiler
13−import qualified Elm.Package as Pkg
14−import qualified Elm.Project.Constraint as Con
15−import qualified Reporting.Error.Help as Help
16−
17−
18−
19−-- ERRORS
20−
21−
22−data Error
23− = CorruptVersionCache Pkg.Name
24− | PackageNotFound Pkg.Name [Pkg.Name]
25− -- verify
26− | AppBadElm Pkg.Version
27− | PkgBadElm Con.Constraint
28− | BadDeps
29− | BuildFailure Pkg.Name Pkg.Version
30−
31−
32−
33−-- TO DOC
34−
35−
36−toReport :: Error -> Help.Report
37−toReport err =
38− case err of
39− CorruptVersionCache pkg ->
40− Help.report "CORRUPT CACHE" Nothing
41− ( "I ran into an unknown package while exploring dependencies:"
42− )
43− [ P.indent 4 $ P.dullyellow $ P.text $ Pkg.toString pkg
44− , Help.reflow $
45− "This suggests that your ELM_HOME 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.report "PACKAGE NOT FOUND" Nothing
52− ( "Could not find any packages named " ++ Pkg.toString package
53− )
54− [ P.text $ "Maybe you want one of these instead?"
55− , P.indent 4 $ P.vcat $ map (P.text . Pkg.toString) suggestions
56− ]
57−
58− AppBadElm version ->
59− Help.report "ELM VERSION MISMATCH" Nothing
60− "Your elm.json says this application needs a different version of Elm."
61− [ P.fillSep
62− [ "It", "requires"
63− , P.green (P.text (Pkg.versionToString version)) <> ","
64− , "but", "you", "are", "using"
65− , P.red (P.text (Pkg.versionToString Compiler.version))
66− , "right", "now."
67− ]
68− ]
69−
70− PkgBadElm constraint ->
71− Help.report "ELM VERSION MISMATCH" Nothing
72− "Your elm.json says this package needs a version of Elm in this range:"
73− [ P.indent 4 $ P.dullyellow $ P.text $ Con.toString constraint
74− , P.fillSep
75− [ "But", "you", "are", "using", "Elm"
76− , P.red (P.text (Pkg.versionToString Compiler.version))
77− , "right", "now."
78− ]
79− ]
80−
81− BadDeps ->
82− Help.report "CLASHING PACKAGE DEPENDENCIES" Nothing
83− "The dependencies in your elm.json are not compatible."
84− [ Help.reflow $
85− "Did you change them by hand? Try to change it back! It is much\
86− \ better to add dependencies with commands like this:"
87− , P.indent 4 $ P.dullyellow $ P.text $ "elm install elm-lang/http"
88− , Help.reflow $
89− "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\
90− \ you are running into something that seems trickier than this."
91− ]
92−
93− BuildFailure pkg vsn ->
94− Help.report "CORRUPT DEPENDENCY" Nothing
95− "I ran into a problem while building the following package:"
96− [ P.indent 4 $ P.dullyellow $ P.text $ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn
97− , Help.reflow $
98− "This probably means the downloaded files got corrupted somehow.\
99− \ Maybe try deleting your ELM_HOME and see if that resolves the issue?"
100− ]
builder/src/Reporting/Error/Diff.hsdeleted−78
@@ -1,78 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Diff
4− ( Error(..)
5− , toReport
6− )
7− where
8−
9−import qualified Data.List as List
10−import qualified Text.PrettyPrint.ANSI.Leijen as P
11−
12−import qualified Elm.Package as Pkg
13−import qualified Reporting.Error.Help as Help
14−
15−
16−
17−-- ERRORS
18−
19−
20−data Error
21− = Application
22− | UnknownPackage Pkg.Name [Pkg.Name]
23− | UnknownVersion Pkg.Name Pkg.Version [Pkg.Version]
24−
25−
26−
27−-- TO DOC
28−
29−
30−toReport :: Error -> Help.Report
31−toReport err =
32− case err of
33− Application ->
34− Help.report "CANNOT DIFF APPLICATIONS" Nothing
35− "I cannot perform diffs on applications, only packages! If you are\
36− \ just curious to see a diff, try running this command:"
37− [ P.indent 4 $ P.green $ "elm diff elm-lang/html 5.1.1 6.0.0"
38− ]
39−
40− UnknownPackage pkg suggestions ->
41− Help.report "UNKNOWN PACKAGE" Nothing
42− ( "You are trying to diff against this package:"
43− )
44− [ P.indent 4 $ P.red $ P.text $ Pkg.toString pkg
45− , Help.stack $
46− case suggestions of
47− [] ->
48− [ "I cannot find that package though! Maybe there is a typo?"
49− ]
50−
51− [suggestion] ->
52− [ "I cannot find that package though! Maybe you want this one instead?"
53− , P.indent 4 $ P.dullyellow $ P.text (Pkg.toString suggestion)
54− ]
55−
56− _ ->
57− [ "I cannot find that package though! Maybe you want one of these instead?"
58− , P.indent 4 $ P.dullyellow $ P.vcat $ map (P.text . Pkg.toString) suggestions
59− ]
60− ]
61−
62− UnknownVersion _pkg vsn realVersions ->
63− Help.docReport "UNKNOWN VERSION" Nothing
64− ( P.fillSep $
65− [ "Version", P.red (P.text (Pkg.versionToString vsn))
66− , "has", "never", "been", "published,", "so", "I"
67− , "cannot", "diff", "against", "it."
68− ]
69− )
70− [ "Here are all the versions that HAVE been published:"
71− , P.indent 4 $ P.dullyellow $ P.vcat $
72− let
73− sameMajor v1 v2 = Pkg._major v1 == Pkg._major v2
74− mkRow vsns = P.hsep $ map (P.text . Pkg.versionToString) vsns
75− in
76− map mkRow $ List.groupBy sameMajor (List.sort realVersions)
77− , "Want one of those instead?"
78− ]
builder/src/Reporting/Error/Help.hsdeleted−149
@@ -1,149 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Help
4− ( Report
5− , report
6− , docReport
7− , compilerReport
8− , reportToDoc
9− , hintLink
10− , stack
11− , reflow
12− , note
13− , toString
14− , toStdout
15− , toStderr
16− )
17− where
18−
19−import qualified Data.List as List
20−import GHC.IO.Handle (hIsTerminalDevice)
21−import System.IO (Handle, hPutStr, stderr, stdout)
22−import qualified Text.PrettyPrint.ANSI.Leijen as P
23−import Text.PrettyPrint.ANSI.Leijen ((<>),(<+>))
24−
25−import qualified Elm.Compiler as Compiler
26−import qualified Elm.Package as Pkg
27−
28−
29−
30−-- REPORT
31−
32−
33−data Report
34− = FromCompiler P.Doc
35− | Report
36− { _title :: String
37− , _path :: Maybe FilePath
38− , _start :: P.Doc
39− , _others :: [P.Doc]
40− }
41−
42−
43−report :: String -> Maybe FilePath -> String -> [P.Doc] -> Report
44−report title maybePath startString others =
45− Report title maybePath (P.text startString) others
46−
47−
48−docReport :: String -> Maybe FilePath -> P.Doc -> [P.Doc] -> Report
49−docReport =
50− Report
51−
52−
53−compilerReport :: P.Doc -> Report
54−compilerReport =
55− FromCompiler
56−
57−
58−reportToDoc :: Report -> P.Doc
59−reportToDoc report_ =
60− case report_ of
61− FromCompiler doc ->
62− doc
63−
64− Report title maybePath start others ->
65− let
66− makeDashes n =
67− replicate (max 1 (80 - n)) '-'
68−
69− errorBarEnd =
70− case maybePath of
71− Nothing ->
72− makeDashes (4 + length title)
73−
74− Just path ->
75− makeDashes (5 + length title + length path) ++ " " ++ path
76−
77− errorBar =
78− P.dullcyan $
79− "--" <+> P.text title <+> P.text errorBarEnd
80− in
81− stack (errorBar : start : others ++ [""])
82−
83−
84−
85−-- HINT LINKS
86−
87−
88−hintLink :: String -> String
89−hintLink hintName =
90− "<https://github.com/elm-lang/elm-compiler/blob/"
91− ++ Pkg.versionToString Compiler.version
92− ++ "/hints/" ++ hintName ++ ".md>"
93−
94−
95−
96−-- HELPERS
97−
98−
99−stack :: [P.Doc] -> P.Doc
100−stack allDocs =
101− case allDocs of
102− [] ->
103− error "Do not use `stack` on empty lists."
104−
105− doc : docs ->
106− List.foldl' verticalAppend doc docs
107−
108−
109−verticalAppend :: P.Doc -> P.Doc -> P.Doc
110−verticalAppend a b =
111− a <> P.hardline <> P.hardline <> b
112−
113−
114−reflow :: String -> P.Doc
115−reflow paragraph =
116− P.fillSep (map P.text (words paragraph))
117−
118−
119−note :: String -> P.Doc
120−note details =
121− P.fillSep $
122− (P.underline "Note" <> ":") : map P.text (words details)
123−
124−
125−
126−-- OUTPUT
127−
128−
129−toString :: P.Doc -> String
130−toString doc =
131− P.displayS (P.renderPretty 1 80 (P.plain doc)) ""
132−
133−
134−toStdout :: P.Doc -> IO ()
135−toStdout doc =
136− toHandle stdout doc
137−
138−
139−toStderr :: P.Doc -> IO ()
140−toStderr doc =
141− toHandle stderr doc
142−
143−
144−toHandle :: Handle -> P.Doc -> IO ()
145−toHandle handle doc =
146− do isTerminal <- hIsTerminalDevice handle
147− if isTerminal
148− then P.displayIO handle (P.renderPretty 1 80 doc)
149− else hPutStr handle (toString doc)
builder/src/Reporting/Error/Http.hsdeleted−102
@@ -1,102 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Http
4− ( Error(..)
5− , toReport
6− , BadJson(..)
7− , badJsonToDocs
8− )
9− where
10−
11−
12−import qualified Data.Text as Text
13−import Text.PrettyPrint.ANSI.Leijen ((<>))
14−import qualified Text.PrettyPrint.ANSI.Leijen as P
15−
16−import qualified Reporting.Error.Help as Help
17−
18−
19−
20−-- ERRORS
21−
22−
23−data Error
24− = Unknown String
25− | BadJson P.Doc
26− | BadZipData
27− | BadZipSha String String
28−
29−
30−
31−-- TO REPORT
32−
33−
34−toReport :: String -> Error -> Help.Report
35−toReport url err =
36− let
37− urlDoc =
38− P.indent 4 $ P.dullyellow $ "<" <> P.text url <> ">"
39− in
40− case err of
41− Unknown message ->
42− Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"
43− [ urlDoc
44− , Help.stack
45− [ "Here is the error message I was able to extract:"
46− , P.indent 4 $ Help.reflow message
47− ]
48− ]
49−
50− BadJson jsonErrorDoc ->
51− Help.compilerReport jsonErrorDoc
52−
53− BadZipData ->
54− Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"
55− [ urlDoc
56− , Help.reflow $
57− "If it is a transient issue, it should be fixed if you try this\
58− \ again. If it seems like an Elm problem, please report it though!"
59− ]
60−
61− BadZipSha expectedHash actualHash ->
62− Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"
63− [ urlDoc
64− , Help.reflow $
65− "I was expecting the hash of content to be " ++ expectedHash
66− ++ ", but it is " ++ actualHash
67− , Help.reflow $
68− "Most likely the package author may have moved the version\
69− \ tag, so report it to them and see if that is the issue."
70− ]
71−
72−
73−
74−-- BAD JSON
75−
76−
77−data BadJson
78− = BadNewPkg Text.Text
79− | BadAllPkg Text.Text String
80− | BadAllVsn Text.Text
81−
82−
83−badJsonToDocs :: BadJson -> [P.Doc]
84−badJsonToDocs badJson =
85− case badJson of
86− BadNewPkg txt ->
87− ["I","ran","into",P.red (P.text (show txt)) <> ","
88− ,"but","I","need","entries","like"
89− ,P.green "\"elm-lang/core@6.0.0\"" <> "."
90− ]
91−
92− BadAllPkg txt suggestion ->
93− ["The",P.red (P.text (show txt)),"value","is","not","a","valid","package","name."
94− ]
95− ++ map P.text (words suggestion)
96−
97− BadAllVsn txt ->
98− ["You","provided",P.red (P.text (show txt))
99− ,"which","is","not","a","valid","version.","I","need","something","like"
100− ,P.green "\"1.0.0\"","or",P.green "\"2.0.4\"" <> "."
101− ]
102−
builder/src/Reporting/Error/Publish.hsdeleted−243
@@ -1,243 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Publish
4− ( Error(..)
5− , toReport
6− )
7− where
8−
9−
10−import qualified Text.PrettyPrint.ANSI.Leijen as P
11−import Text.PrettyPrint.ANSI.Leijen ((<>))
12−
13−import Deps.Diff (Magnitude, magnitudeToString)
14−import qualified Elm.Package as Pkg
15−import qualified Reporting.Error.Help as Help
16−
17−
18−
19−-- ERRORS
20−
21−
22−data Error
23− = Application
24− | NotInitialVersion Pkg.Version
25− | AlreadyPublished Pkg.Version
26− | InvalidBump Pkg.Version Pkg.Version
27− | BadBump Pkg.Version Pkg.Version Magnitude Pkg.Version Magnitude
28− | NoSummary
29− | NoExposed
30− | NoReadme
31− | ShortReadme
32− | NoLicense
33− | MissingTag Pkg.Version
34− | NoGit
35− | LocalChanges Pkg.Version
36−
37−
38−
39−-- TO REPORT
40−
41−
42−toReport :: Error -> Help.Report
43−toReport err =
44− case err of
45− Application ->
46− Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []
47−
48− NotInitialVersion vsn ->
49− Help.docReport "INVALID VERSION" Nothing
50− ( P.fillSep
51− ["I","cannot","publish"
52− ,P.red (P.text (Pkg.versionToString vsn))
53− ,"as","the","initial","version."
54− ]
55− )
56− [ P.fillSep
57− ["Change","it","to",P.green "1.0.0","which","is"
58− ,"the","initial","version","for","all","Elm","packages."
59− ]
60− ]
61−
62− AlreadyPublished vsn ->
63− Help.docReport "ALREADY PUBLISHED" Nothing
64− ( P.vcat
65− [ P.fillSep
66− [ "Version", P.green (P.text (Pkg.versionToString vsn))
67− , "has", "already", "been", "published.", "You", "cannot"
68− , "publish", "it", "again!"
69− ]
70− , "Try using the `bump` command:"
71− ]
72− )
73− [ P.dullyellow $ P.indent 4 $ P.text "elm bump"
74− , Help.reflow $
75− "It computes the version number based on API changes, ensuring\
76− \ that no breaking changes end up in PATCH releases!"
77− ]
78−
79− InvalidBump statedVersion latestVersion ->
80− Help.docReport "INVALID VERSION" (Just "elm.json")
81− ( P.fillSep $
82− ["Your","elm.json","says","the","next","version","should","be"
83− ,P.red (P.text (Pkg.versionToString statedVersion)) <> ","
84− ,"but","that","is","not","valid","based","on","the","previously"
85− ,"published","versions."
86− ]
87− )
88− [ P.fillSep $
89− ["Change","the","version","back","to"
90− ,P.green (P.text (Pkg.versionToString latestVersion))
91− ,"which","is","the","most","recently","published","version."
92− ,"From","there,","have","Elm","bump","the","version","by","running:"
93− ]
94− , P.indent 4 $ P.green "elm bump"
95− , Help.reflow $
96− "If you want more insight on the API changes Elm detects, you\
97− \ can run `elm diff` at this point as well."
98− ]
99−
100− BadBump old new magnitude realNew realMagnitude ->
101− Help.docReport "INVALID VERSION" (Just "elm.json")
102− (
103− P.fillSep $
104− ["Your","elm.json","says","the","next","version","should","be"
105− ,P.red (P.text (Pkg.versionToString new)) <> ","
106− ,"indicating","a",P.text (magnitudeToString magnitude)
107− ,"change","to","the","public","API."
108− ,"This","does","not","match","the","API","diff","given","by:"
109− ]
110− )
111− [ P.indent 4 $ P.text $
112− "elm diff " ++ Pkg.versionToString old
113−
114− , P.fillSep $
115− ["This","command","says","this","is","a"
116− ,P.text (magnitudeToString realMagnitude)
117− ,"change,","so","the","next","version","should","be"
118− ,P.green (P.text (Pkg.versionToString realNew)) <> "."
119− ,"Double","check","everything","to","make","sure","you"
120− ,"are","publishing","what","you","want!"
121− ]
122− , Help.reflow $
123− "Also, next time use `elm bump` and I'll figure all this out for you!"
124− ]
125−
126− NoSummary ->
127− Help.docReport "NO SUMMARY" (Just "elm.json")
128− ( P.fillSep $
129− [ "To", "publish", "a", "package,", "your", "elm.json", "must"
130− , "have", "a", P.dullyellow "\"summary\"", "field", "that", "gives"
131− , "a", "consice", "overview", "of", "your", "project."
132− ]
133− )
134− [ Help.reflow $
135− "The summary must be less than 80 characters. It should describe\
136− \ the concrete use of your package as clearly and as plainly as possible."
137− ]
138−
139− NoExposed ->
140− Help.docReport "NO EXPOSED MODULES" (Just "elm.json")
141− ( P.fillSep $
142− [ "To", "publish", "a", "package,", "the"
143− , P.dullyellow "\"exposed-modules\"", "field", "of", "your"
144− , "elm.json", "must", "list", "at", "least", "one", "module."
145− ]
146− )
147− [ Help.reflow $
148− "What is the point of a package that has no modules?!"
149− ]
150−
151− NoReadme ->
152− badReadmeReport "NO README" $
153− "Every published package must have a helpful README.md\
154− \ file, but I do not see one in your project."
155−
156− ShortReadme ->
157− badReadmeReport "SHORT README" $
158− "This README.md is too short. Having more details will help\
159− \ people assess your package quickly and fairly."
160−
161− NoLicense ->
162− Help.report "NO LICENSE FILE" (Just "LICENSE")
163− "By publishing a package you are inviting the Elm community to build\
164− \ upon your work. But without knowing your license, we have no idea if\
165− \ that is legal!"
166− [ Help.reflow $
167− "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\
168− \ you must share that choice in two places. First, the license\
169− \ identifier must appear in your elm.json file. Second, the full\
170− \ license text must appear in the root of your project in a file\
171− \ named LICENSE. Add that file and you will be all set!"
172− ]
173−
174− MissingTag version ->
175− let vsn = Pkg.versionToString version in
176− Help.docReport "NO TAG" Nothing
177− ( P.fillSep $
178− [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"
179− , "cannot", "find", "a", P.green (P.text vsn), "tag."
180− ]
181− )
182− [ P.vcat
183− [ "These tags make it possible to find this specific version on GitHub."
184− , "To tag the most recent commit and push it to GitHub, run this:"
185− ]
186− , P.indent 4 $ P.dullyellow $ P.vcat $ map P.text $
187− [ "git tag -a " ++ vsn ++ " -m \"release version " ++ vsn ++ "\""
188− , "git push origin " ++ vsn
189− ]
190− , "The -m flag is for a helpful message. Try to make it more informative!"
191− ]
192−
193− NoGit ->
194− Help.report "NO GIT" Nothing
195− "I searched your PATH environment variable for `git` and could not\
196− \ find it. Is it available through your PATH?"
197− [ Help.reflow $
198− "Who cares about this? Well, I currently use `git` to check if there\
199− \ are any local changes in your code. Local changes are a good sign\
200− \ that some important improvements have gotten mistagged, so this\
201− \ check can be extremely helpful for package authors!"
202− , Help.note $
203− "We plan to do this without the `git` binary in a future release."
204− ]
205−
206− LocalChanges version ->
207− let vsn = Pkg.versionToString version in
208− Help.docReport "LOCAL CHANGES" Nothing
209− ( P.fillSep $
210− [ "The", "code", "tagged", "as", P.green (P.text vsn), "in"
211− , "git", "does", "not", "match", "the", "code", "in", "your"
212− , "working", "directory.", "This", "means", "you", "have"
213− , "commits", "or", "local", "changes", "that", "are", "not"
214− , "going", "to", "be", "published!"
215− ]
216− )
217− [ Help.note $
218− "If you are sure everything is in order, you can run `git checkout "
219− ++ vsn ++ "` and publish your code from there."
220− ]
221−
222−
223−badReadmeReport :: String -> String -> Help.Report
224−badReadmeReport title summary =
225− Help.report title (Just "README.md") summary
226− [ Help.reflow $
227− "When people look at your README, they are wondering:"
228− , P.vcat
229− [ " - What does this package even do?"
230− , " - Will it help me solve MY problems?"
231− ]
232− , Help.reflow $
233− "So I recommend starting your README with a small example of the\
234− \ most common usage scenario. Show people what they can expect if\
235− \ they learn more!"
236− , Help.note $
237− "By publishing your package, you are inviting people to invest time\
238− \ in understanding your work. Spending an hour to communicate your\
239− \ knowledge more clearly can save the community days or weeks of time\
240− \ in aggregate, and saving time in aggregate is the whole point of\
241− \ publishing packages! People really appreciate it, and it makes the\
242− \ whole ecosystem feel nicer!"
243− ]
builder/src/Reporting/Exit.hsnew file+2069
@@ -0,0 +1,2069 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit
3+ ( Init(..), initToReport
4+ , Diff(..), diffToReport
5+ , Make(..), makeToReport
6+ , Bump(..), bumpToReport
7+ , Repl(..), replToReport
8+ , Publish(..), publishToReport
9+ , Install(..), installToReport
10+ , Reactor(..), reactorToReport
11+ , newPackageOverview
12+ --
13+ , Solver(..)
14+ , Outline(..)
15+ , OutlineProblem(..)
16+ , Details(..)
17+ , DetailsBadDep(..)
18+ , PackageProblem(..)
19+ , RegistryProblem(..)
20+ , BuildProblem(..)
21+ , BuildProjectProblem(..)
22+ , DocsProblem(..)
23+ , Generate(..)
24+ --
25+ , toString
26+ , toStderr
27+ , toJson
28+ )
29+ where
30+
31+
32+import qualified Data.ByteString as BS
33+import qualified Data.ByteString.UTF8 as BS_UTF8
34+import qualified Data.List as List
35+import qualified Data.Map as Map
36+import qualified Data.Name as N
37+import qualified Data.NonEmptyList as NE
38+import qualified Network.HTTP.Client as HTTP
39+import qualified Network.HTTP.Types.Header as HTTP
40+import qualified Network.HTTP.Types.Status as HTTP
41+import qualified System.FilePath as FP
42+import System.FilePath ((</>), (<.>))
43+
44+import qualified Elm.Constraint as C
45+import qualified Elm.Magnitude as M
46+import 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
52+import 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 ((<>))
57+import qualified Reporting.Doc as D
58+import qualified Reporting.Error.Import as Import
59+import qualified Reporting.Error.Json as Json
60+import qualified Reporting.Exit.Help as Help
61+import qualified Reporting.Error as Error
62+import qualified Reporting.Render.Code as Code
63+
64+
65+
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+
592+ PublishCannotDecodeZip url ->
593+ Help.report "PROBLEM DOWNLOADING CODE" Nothing
594+ "I need to check that folks can download and build the source code when they\
595+ \ install this package, so I downloaded the code from:"
596+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
597+ , D.reflow $
598+ "I was unable to unzip the archive though. Maybe there is something weird with\
599+ \ your internet connection. We have gotten reports that schools, businesses,\
600+ \ airports, etc. sometimes intercept requests and add things to the body or\
601+ \ change its contents entirely. Could that be the problem?"
602+ ]
603+
604+ PublishCannotGetDocs old new docsProblem ->
605+ toDocsProblemReport docsProblem $
606+ "I need the docs for " ++ V.toChars old ++ " to verify that "
607+ ++ V.toChars new ++ " really does come next"
608+
609+ PublishCannotRegister httpError ->
610+ toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $
611+ "I need to send information about your package to the package website"
612+
613+ PublishNoGit ->
614+ Help.report "NO GIT" Nothing
615+ "I searched your PATH environment variable for `git` and could not\
616+ \ find it. Is it available through your PATH?"
617+ [ D.reflow $
618+ "Who cares about this? Well, I currently use `git` to check if there\
619+ \ are any local changes in your code. Local changes are a good sign\
620+ \ that some important improvements have gotten mistagged, so this\
621+ \ check can be extremely helpful for package authors!"
622+ , D.toSimpleNote $
623+ "We plan to do this without the `git` binary in a future release."
624+ ]
625+
626+ PublishLocalChanges version ->
627+ let vsn = V.toChars version in
628+ Help.docReport "LOCAL CHANGES" Nothing
629+ ( D.fillSep $
630+ [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"
631+ , "git", "does", "not", "match", "the", "code", "in", "your"
632+ , "working", "directory.", "This", "means", "you", "have"
633+ , "commits", "or", "local", "changes", "that", "are", "not"
634+ , "going", "to", "be", "published!"
635+ ]
636+ )
637+ [ D.toSimpleNote $
638+ "If you are sure everything is in order, you can run `git checkout "
639+ ++ vsn ++ "` and publish your code from there."
640+ ]
641+
642+ PublishZipBadDetails _ ->
643+ badZipReport
644+
645+ PublishZipApplication ->
646+ badZipReport
647+
648+ PublishZipNoExposed ->
649+ badZipReport
650+
651+ PublishZipBuildProblem _ ->
652+ badZipReport
653+
654+
655+toBadReadmeReport :: String -> String -> Help.Report
656+toBadReadmeReport title summary =
657+ Help.report title (Just "README.md") summary
658+ [ D.reflow $
659+ "When people look at your README, they are wondering:"
660+ , D.vcat
661+ [ " - What does this package even do?"
662+ , " - Will it help me solve MY problems?"
663+ ]
664+ , D.reflow $
665+ "So I recommend starting your README with a small example of the\
666+ \ most common usage scenario. Show people what they can expect if\
667+ \ they learn more!"
668+ , D.toSimpleNote $
669+ "By publishing your package, you are inviting people to invest time in\
670+ \ understanding your work. Spending an hour on your README to communicate your\
671+ \ knowledge more clearly can save the community days or weeks of time in\
672+ \ aggregate, and saving time in aggregate is the whole point of publishing\
673+ \ packages! People really appreciate it, and it makes the whole ecosystem feel\
674+ \ nicer!"
675+ ]
676+
677+
678+badZipReport :: Help.Report
679+badZipReport =
680+ Help.report "PROBLEM VERIFYING PACKAGE" Nothing
681+ "Before publishing packages, I download the code from GitHub and try to build it\
682+ \ from scratch. That way I can be more confident that it will work for other\
683+ \ people too. But I am not able to build it!"
684+ [ D.reflow $
685+ "I was just able to build your local copy though. Is there some way the version\
686+ \ on GitHub could be different?"
687+ ]
688+
689+
690+
691+-- DOCS
692+
693+
694+data DocsProblem
695+ = DP_Http Http.Error
696+ | DP_Data String BS.ByteString
697+ | DP_Cache
698+
699+
700+toDocsProblemReport :: DocsProblem -> String -> Help.Report
701+toDocsProblemReport problem context =
702+ case problem of
703+ DP_Http httpError ->
704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context
705+
706+ DP_Data url body ->
707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")
708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
709+ , D.reflow $
710+ "I got the data back, but it was not what I was expecting. The response\
711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "
712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"
713+ , D.indent 4 $ D.dullyellow $ D.fromChars $
714+ if BS.length body <= 76
715+ then BS_UTF8.toString body
716+ else take 73 (BS_UTF8.toString body) ++ "..."
717+ , D.reflow $
718+ "Does this error keep showing up? Maybe there is something weird with your\
719+ \ internet connection. We have gotten reports that schools, businesses,\
720+ \ airports, etc. sometimes intercept requests and add things to the body\
721+ \ or change its contents entirely. Could that be the problem?"
722+ ]
723+
724+ DP_Cache ->
725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")
726+ [ D.reflow $
727+ "I deleted the cached version, so the next run should download a fresh copy of\
728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\
729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\
730+ \ for some reason."
731+ ]
732+
733+
734+
735+-- INSTALL
736+
737+
738+data Install
739+ = InstallNoOutline
740+ | InstallBadOutline Outline
741+ | InstallBadRegistry RegistryProblem
742+ | InstallNoArgs FilePath
743+ | InstallNoOnlineAppSolution Pkg.Name
744+ | InstallNoOfflineAppSolution Pkg.Name
745+ | InstallNoOnlinePkgSolution Pkg.Name
746+ | InstallNoOfflinePkgSolution Pkg.Name
747+ | InstallHadSolverTrouble Solver
748+ | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
749+ | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
750+ | InstallBadDetails Details
751+
752+
753+installToReport :: Install -> Help.Report
754+installToReport exit =
755+ case exit of
756+ InstallNoOutline ->
757+ Help.report "NEW PROJECT?" Nothing
758+ "Are you trying to start a new project? Try this command instead:"
759+ [ D.indent 4 $ D.green "elm init"
760+ , D.reflow "It will help you get started!"
761+ ]
762+
763+ InstallBadOutline outline ->
764+ toOutlineReport outline
765+
766+ InstallBadRegistry problem ->
767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $
768+ "I need the list of published packages to figure out how to install things"
769+
770+ InstallNoArgs elmHome ->
771+ Help.report "INSTALL WHAT?" Nothing
772+ "I am expecting commands like:"
773+ [ D.green $ D.indent 4 $ D.vcat $
774+ [ "elm install elm/http"
775+ , "elm install elm/json"
776+ , "elm install elm/random"
777+ ]
778+ , D.toFancyHint
779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."
780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"
781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"
782+ ,D.dullyellow (D.fromChars elmHome)
783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."
784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."
785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"
786+ ,"easier","to","work","offline.","As","a","result"
787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"
788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"
789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"
790+ ]
791+ ]
792+
793+ InstallNoOnlineAppSolution pkg ->
794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
795+ (
796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
797+ \ with your existing dependencies."
798+ )
799+ [ D.reflow $
800+ "I checked all the published versions. When that failed, I tried to find any\
801+ \ compatible combination of these packages, even if it meant changing all your\
802+ \ existing dependencies! That did not work either!"
803+ , D.reflow $
804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\
805+ \ version of Elm came out recently? Maybe a common package was changed recently?\
806+ \ Maybe a better package came along, so there was no need to upgrade this one?\
807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\
808+ \ with this package."
809+ , D.toSimpleNote $
810+ "Whatever the case, please be kind to the relevant package authors! Having\
811+ \ friendly interactions with users is great motivation, and conversely, getting\
812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\
813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\
814+ \ goals, etc. They face obstacles outside of their technical work you will never\
815+ \ know about, so please assume the best and try to be patient and supportive!"
816+ ]
817+
818+ InstallNoOfflineAppSolution pkg ->
819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
820+ (
821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
822+ \ with your existing dependencies."
823+ )
824+ [ D.reflow $
825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
826+ \ able to look through packages that you have downloaded in the past."
827+ , D.reflow $
828+ "Try again later when you have internet!"
829+ ]
830+
831+ InstallNoOnlinePkgSolution pkg ->
832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")
833+ (
834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
835+ \ with your existing constraints."
836+ )
837+ [ D.reflow $
838+ "With applications, I try to broaden the constraints to see if anything works,\
839+ \ but messing with package constraints is much more delicate business. E.g. making\
840+ \ your constraints stricter may make it harder for applications to find compatible\
841+ \ dependencies. So fixing something here may break it for a lot of other people!"
842+ , D.reflow $
843+ "So I recommend making an application with the same dependencies as your package.\
844+ \ See if there is a solution at all. From there it may be easier to figure out\
845+ \ how to proceed in a way that will disrupt your users as little as possible. And\
846+ \ the solution may be to help other package authors to get their packages updated,\
847+ \ or to drop a dependency entirely."
848+ ]
849+
850+ InstallNoOfflinePkgSolution pkg ->
851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")
852+ (
853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\
854+ \ with your existing constraints."
855+ )
856+ [ D.reflow $
857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\
858+ \ able to look through packages that you have downloaded in the past."
859+ , D.reflow $
860+ "Try again later when you have internet!"
861+ ]
862+
863+ InstallHadSolverTrouble solver ->
864+ toSolverReport solver
865+
866+ InstallUnknownPackageOnline pkg suggestions ->
867+ Help.docReport "UNKNOWN PACKAGE" Nothing
868+ (
869+ D.fillSep
870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
871+ )
872+ [ D.reflow $
873+ "I looked through https://package.elm-lang.org for packages with similar names\
874+ \ and found these:"
875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
876+ , D.reflow $ "Maybe you want one of these instead?"
877+ ]
878+
879+ InstallUnknownPackageOffline pkg suggestions ->
880+ Help.docReport "UNKNOWN PACKAGE" Nothing
881+ (
882+ D.fillSep
883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]
884+ )
885+ [ D.reflow $
886+ "I could not connect to https://package.elm-lang.org though, so new packages may\
887+ \ have been published since I last updated my local cache of package names."
888+ , D.reflow $
889+ "Looking through the locally cached names, the closest ones are:"
890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions
891+ , D.reflow $ "Maybe you want one of these instead?"
892+ ]
893+
894+ InstallBadDetails details ->
895+ toDetailsReport details
896+
897+
898+
899+-- SOLVER
900+
901+
902+data Solver
903+ = SolverBadCacheData Pkg.Name V.Version
904+ | SolverBadHttpData Pkg.Name V.Version String
905+ | SolverBadHttp Pkg.Name V.Version Http.Error
906+
907+
908+toSolverReport :: Solver -> Help.Report
909+toSolverReport problem =
910+ case problem of
911+ SolverBadCacheData pkg vsn ->
912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
913+ (
914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
915+ \ help me search for a set of compatible packages. I had it cached locally, but\
916+ \ it looks like the file was corrupted!"
917+ )
918+ [ D.reflow $
919+ "I deleted the cached version, so the next run should download a fresh copy.\
920+ \ Hopefully that will get you unstuck, but it will not resolve the root\
921+ \ problem if a 3rd party tool is modifing cached files for some reason."
922+ ]
923+
924+ SolverBadHttpData pkg vsn url ->
925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing
926+ (
927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\
928+ \ help me search for a set of compatible packages, but I ran into corrupted\
929+ \ information from:"
930+ )
931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url
932+ , D.reflow $
933+ "Is something weird with your internet connection. We have gotten reports that\
934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\
935+ \ to the body or change its contents entirely. Could that be the problem?"
936+ ]
937+
938+ SolverBadHttp pkg vsn httpError ->
939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $
940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
941+ ++ " to help me search for a set of compatible packages"
942+
943+
944+
945+-- OUTLINE
946+
947+
948+data Outline
949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)
950+ | OutlineHasMissingSrcDirs FilePath [FilePath]
951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
952+ | OutlineNoPkgCore
953+ | OutlineNoAppCore
954+ | OutlineNoAppJson
955+
956+
957+data OutlineProblem
958+ = OP_BadType
959+ | OP_BadPkgName Row Col
960+ | OP_BadVersion Row Col
961+ | OP_BadConstraint C.Error
962+ | OP_BadModuleName Row Col
963+ | OP_BadModuleHeaderTooLong
964+ | OP_BadDependencyName Row Col
965+ | OP_BadLicense Json.String [Json.String]
966+ | OP_BadSummaryTooLong
967+ | OP_NoSrcDirs
968+
969+
970+toOutlineReport :: Outline -> Help.Report
971+toOutlineReport problem =
972+ case problem of
973+ OutlineHasBadStructure decodeError ->
974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $
975+ Json.ExplicitReason "I ran into a problem with your elm.json file."
976+
977+ OutlineHasMissingSrcDirs dir dirs ->
978+ case dirs of
979+ [] ->
980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")
981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"
982+ [ D.indent 4 $ D.red $ D.fromChars dir
983+ , D.reflow $
984+ "I cannot find it though. Is it missing? Is there a typo?"
985+ ]
986+
987+ _:_ ->
988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")
989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"
990+ [ D.indent 4 $ D.vcat $
991+ map (D.red . D.fromChars) (dir:dirs)
992+ , D.reflow $
993+ "I cannot find them though. Are they missing? Are there typos?"
994+ ]
995+
996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->
997+ if dir1 == dir2 then
998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"
1000+ [ D.indent 4 $ D.vcat $
1001+ map (D.red . D.fromChars) [dir1,dir2]
1002+ , D.reflow $
1003+ "Remove one of the entries!"
1004+ ]
1005+ else
1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")
1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"
1008+ [ D.indent 4 $ D.vcat $
1009+ map (D.red . D.fromChars) [dir1,dir2]
1010+ , D.reflow $
1011+ "These are two different ways of refering to the same directory:"
1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir
1013+ , D.reflow $
1014+ "Remove one of the redundant entries from your \"source-directories\" field."
1015+ ]
1016+
1017+ OutlineNoPkgCore ->
1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1020+ \ of `List` and `Maybe` do not work without it."
1021+ [ D.reflow $
1022+ "If you modified your elm.json by hand, try to change it back! And if you are\
1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\
1024+ \ working package and start fresh with their elm.json file."
1025+ ]
1026+
1027+ OutlineNoAppCore ->
1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\
1030+ \ of `List` and `Maybe` do not work without it."
1031+ [ D.reflow $
1032+ "If you modified your elm.json by hand, try to change it back! And if you are\
1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1034+ \ and use `elm init` to start fresh."
1035+ ]
1036+
1037+ OutlineNoAppJson ->
1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")
1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\
1040+ \ flags and ports."
1041+ [ D.reflow $
1042+ "If you modified your elm.json by hand, try to change it back! And if you are\
1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\
1044+ \ and use `elm init` to start fresh."
1045+ ]
1046+
1047+
1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
1049+toOutlineProblemReport path source _ region problem =
1050+ let
1051+ toHighlight row col =
1052+ Just $ A.Region (A.Position row col) (A.Position row col)
1053+
1054+ toSnippet title highlight pair =
1055+ Help.jsonReport title (Just path) $
1056+ Code.toSnippet source region highlight pair
1057+ in
1058+ case problem of
1059+ OP_BadType ->
1060+ toSnippet "UNEXPECTED TYPE" Nothing
1061+ ( D.reflow $
1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"
1063+ , D.fillSep
1064+ ["Try","changing","the","\"type\"","to"
1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."
1066+ ]
1067+ )
1068+
1069+ OP_BadPkgName row col ->
1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)
1071+ ( D.reflow $
1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"
1073+ , D.stack
1074+ [ D.fillSep
1075+ ["Package","names","are","always","written","as"
1076+ ,D.green "\"author/project\""
1077+ ,"so","I","am","expecting","to","see","something","like:"
1078+ ]
1079+ , D.dullyellow $ D.indent 4 $ D.vcat $
1080+ [ "\"mdgriffith/elm-ui\""
1081+ , "\"w0rm/elm-physics\""
1082+ , "\"Microsoft/elm-json-tree-view\""
1083+ , "\"FordLabs/elm-star-rating\""
1084+ , "\"1602/json-schema\""
1085+ ]
1086+ , D.reflow
1087+ "The author name should match your GitHub name exactly, and the project name\
1088+ \ needs to follow these rules:"
1089+ , D.indent 4 $ D.vcat $
1090+ [ "+--------------------------------------+-----------+-----------+"
1091+ , "| RULE | BAD | GOOD |"
1092+ , "+--------------------------------------+-----------+-----------+"
1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"
1094+ , "| no leading digits | 3D | elm-3d |"
1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"
1096+ , "| no underscores | elm_ui | elm-ui |"
1097+ , "| no double hyphens | elm--hash | elm-hash |"
1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"
1099+ , "+--------------------------------------+-----------+-----------+"
1100+ ]
1101+ , D.toSimpleNote $
1102+ "These rules only apply to the project name, so you should never need\
1103+ \ to change your GitHub name!"
1104+ ]
1105+ )
1106+
1107+ OP_BadVersion row col ->
1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)
1109+ ( D.reflow $
1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"
1111+ , D.fillSep
1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""
1113+ ,"that","explicitly","states","all","three","numbers!"
1114+ ]
1115+ )
1116+
1117+ OP_BadConstraint constraintError ->
1118+ case constraintError of
1119+ C.BadFormat row col ->
1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)
1121+ ( D.reflow $
1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"
1123+ , D.stack
1124+ [ D.fillSep
1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""
1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."
1127+ ]
1128+ , D.toSimpleNote $
1129+ "The spaces in there are required! Taking them out will confuse me. Adding\
1130+ \ extra spaces confuses me too. I recommend starting with a valid example\
1131+ \ and just changing the version numbers."
1132+ ]
1133+ )
1134+
1135+ C.InvalidRange before after ->
1136+ if before == after then
1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1138+ ( D.reflow $
1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1140+ , D.fillSep
1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"
1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"
1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""
1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"
1145+ ,"happen","in","any","of","the","versions","in","that","range."
1146+ ]
1147+ )
1148+
1149+ else
1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing
1151+ ( D.reflow $
1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"
1153+ , D.fillSep
1154+ ["Maybe","you","want","something","like"
1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""
1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"
1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"
1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."
1159+ ]
1160+ )
1161+
1162+ OP_BadModuleName row col ->
1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)
1164+ ( D.reflow $
1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"
1166+ , D.fillSep
1167+ ["I","need","something","like",D.green "\"Html.Events\""
1168+ ,"or",D.green "\"Browser.Navigation\""
1169+ ,"where","each","segment","starts","with","a","capital"
1170+ ,"letter","and","the","segments","are","separated","by","dots."
1171+ ]
1172+ )
1173+
1174+ OP_BadModuleHeaderTooLong ->
1175+ toSnippet "HEADER TOO LONG" Nothing
1176+ ( D.reflow $
1177+ "I got stuck while reading your elm.json file. This section header is too long:"
1178+ , D.stack
1179+ [ D.fillSep
1180+ ["I","need","it","to","be"
1181+ ,D.green "under",D.green "20",D.green "bytes"
1182+ ,"so","it","renders","nicely","on","the","package","website!"
1183+ ]
1184+ , D.toSimpleNote
1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1187+ \ overly restrictive for your needs."
1188+ ]
1189+ )
1190+
1191+ OP_BadDependencyName row col ->
1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)
1193+ ( D.reflow $
1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"
1195+ , D.stack
1196+ [ D.fillSep
1197+ ["Package","names","always","include","the","name","of","the","author,"
1198+ ,"so","I","am","expecting","to","see","dependencies","like"
1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"
1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."
1201+ ]
1202+ , D.fillSep $
1203+ ["I","generally","recommend","finding","the","package","you","want","on"
1204+ ,"the","package","website,","and","installing","it","with","the"
1205+ ,D.green "elm install","command!"
1206+ ]
1207+ ]
1208+ )
1209+
1210+ OP_BadLicense _ suggestions ->
1211+ toSnippet "UNKNOWN LICENSE" Nothing
1212+ ( D.reflow $
1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"
1214+ ,
1215+ D.stack
1216+ [ D.fillSep
1217+ ["Elm","packages","generally","use"
1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","
1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."
1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"
1221+ ]
1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions
1223+ , D.reflow $
1224+ "Check out https://spdx.org/licenses/ for the full list of options."
1225+ ]
1226+ )
1227+
1228+ OP_BadSummaryTooLong ->
1229+ toSnippet "SUMMARY TOO LONG" Nothing
1230+ ( D.reflow $
1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"
1232+ , D.stack
1233+ [ D.fillSep
1234+ ["I","need","it","to","be"
1235+ ,D.green "under",D.green "80",D.green "bytes"
1236+ ,"so","it","renders","nicely","on","the","package","website!"
1237+ ]
1238+ , D.toSimpleNote
1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\
1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\
1241+ \ overly restrictive for your needs."
1242+ ]
1243+ )
1244+
1245+ OP_NoSrcDirs ->
1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing
1247+ ( D.reflow $
1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"
1249+ , D.fillSep
1250+ ["I","need","something","like",D.green "[\"src\"]"
1251+ ,"so","I","know","where","to","look","for","your","modules!"
1252+ ]
1253+ )
1254+
1255+
1256+
1257+-- DETAILS
1258+
1259+
1260+data Details
1261+ = DetailsNoSolution
1262+ | DetailsNoOfflineSolution
1263+ | DetailsSolverProblem Solver
1264+ | DetailsBadElmInPkg C.Constraint
1265+ | DetailsBadElmInAppOutline V.Version
1266+ | DetailsHandEditedDependencies
1267+ | DetailsBadOutline Outline
1268+ | DetailsCannotGetRegistry RegistryProblem
1269+ | DetailsBadDeps FilePath [DetailsBadDep]
1270+
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
1606+ "It looks like you are starting a new Elm project. Very exciting! Try running:"
1607+ [ D.indent 4 $ D.green $ "elm init"
1608+ , D.reflow $
1609+ "It will help you get set up. It is really simple!"
1610+ ]
1611+
1612+ MakeCannotOptimizeAndDebug ->
1613+ Help.docReport "CLASHING FLAGS" Nothing
1614+ ( D.fillSep
1615+ ["I","cannot","compile","with",D.red "--optimize","and"
1616+ ,D.red "--debug","at","the","same","time."
1617+ ]
1618+ )
1619+ [ D.reflow
1620+ "I need to take away information to optimize things, and I need to\
1621+ \ add information to add the debugger. It is impossible to do both\
1622+ \ at once though! Pick just one of those flags and it should work!"
1623+ ]
1624+
1625+ MakeBadDetails detailsProblem ->
1626+ toDetailsReport detailsProblem
1627+
1628+ MakeAppNeedsFileNames ->
1629+ Help.report "NO INPUT" Nothing
1630+ "What should I make though? I need specific files like:"
1631+ [ D.vcat
1632+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1633+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1634+ ]
1635+ , D.reflow $
1636+ "I recommend reading through https://guide.elm-lang.org for guidance on what to\
1637+ \ actually put in those files!"
1638+ ]
1639+
1640+ MakePkgNeedsExposing ->
1641+ Help.report "NO INPUT" Nothing
1642+ "What should I make though? I need specific files like:"
1643+ [ D.vcat
1644+ [ D.indent 4 $ D.green "elm make src/Main.elm"
1645+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"
1646+ ]
1647+ , D.reflow $
1648+ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\
1649+ \ I will try to compile the relevant files."
1650+ ]
1651+
1652+ MakeMultipleFilesIntoHtml ->
1653+ Help.report "TOO MANY FILES" Nothing
1654+ (
1655+ "When producing an HTML file, I can only handle one file."
1656+ )
1657+ [ D.fillSep
1658+ ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"
1659+ ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"
1660+ ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."
1661+ ]
1662+ , D.fillSep
1663+ ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"
1664+ ,"`main`","values","available","in","a","single","JavaScript","file.","Then"
1665+ ,"you","can","make","your","own","customized","HTML","file","that","embeds"
1666+ ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"
1667+ ,"dependencies","between","modules,","so","it","should","be","smaller","than"
1668+ ,"compiling","each","module","separately."
1669+ ]
1670+ ]
1671+
1672+ MakeNoMain ->
1673+ Help.report "NO MAIN" Nothing
1674+ (
1675+ "When producing an HTML file, I require that the given file has a `main` value.\
1676+ \ That way I have something to show on screen!"
1677+ )
1678+ [ D.reflow $
1679+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1680+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1681+ \ altogether."
1682+ , D.toSimpleNote $
1683+ "Adding a `main` value can be as brief as adding something like this:"
1684+ , D.vcat
1685+ [ D.fillSep [D.cyan "import","Html"]
1686+ , ""
1687+ , D.fillSep [D.green "main","="]
1688+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1689+ ]
1690+ , D.reflow $
1691+ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\
1692+ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\
1693+ \ the `main` value."
1694+ ]
1695+
1696+ MakeNonMainFilesIntoJavaScript m ms ->
1697+ case ms of
1698+ [] ->
1699+ Help.report "NO MAIN" Nothing
1700+ (
1701+ "When producing a JS file, I require that the given file has a `main` value. That\
1702+ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\
1703+ \ resulting file!"
1704+ )
1705+ [ D.reflow $
1706+ "Try adding a `main` value to your file? Or if you just want to verify that this\
1707+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\
1708+ \ altogether."
1709+ , D.toSimpleNote $
1710+ "Adding a `main` value can be as brief as adding something like this:"
1711+ , D.vcat
1712+ [ D.fillSep [D.cyan "import","Html"]
1713+ , ""
1714+ , D.fillSep [D.green "main","="]
1715+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1716+ ]
1717+ , D.reflow $
1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1719+ \ make a `main` with no user interface."
1720+ ]
1721+
1722+ _:_ ->
1723+ Help.report "NO MAIN" Nothing
1724+ (
1725+ "When producing a JS file, I require that given files all have `main` values.\
1726+ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\
1727+ \ definitely defined in the resulting file. I am missing `main` values in:"
1728+ )
1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)
1730+ , D.reflow $
1731+ "Try adding a `main` value to them? Or if you just want to verify that these\
1732+ \ modules compile, switch to --output=/dev/null to skip the code gen phase\
1733+ \ altogether."
1734+ , D.toSimpleNote $
1735+ "Adding a `main` value can be as brief as adding something like this:"
1736+ , D.vcat
1737+ [ D.fillSep [D.cyan "import","Html"]
1738+ , ""
1739+ , D.fillSep [D.green "main","="]
1740+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]
1741+ ]
1742+ , D.reflow $
1743+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\
1744+ \ make a `main` with no user interface."
1745+ ]
1746+
1747+ MakeCannotBuild buildProblem ->
1748+ toBuildProblemReport buildProblem
1749+
1750+ MakeBadGenerate generateProblem ->
1751+ toGenerateReport generateProblem
1752+
1753+
1754+
1755+-- BUILD PROBLEM
1756+
1757+
1758+data BuildProblem
1759+ = BuildBadModules FilePath Error.Module [Error.Module]
1760+ | BuildProjectProblem BuildProjectProblem
1761+
1762+
1763+data BuildProjectProblem
1764+ = BP_PathUnknown FilePath
1765+ | BP_WithBadExtension FilePath
1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath
1767+ | BP_MainPathDuplicate FilePath FilePath
1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath
1769+ | BP_RootNameInvalid FilePath FilePath [String]
1770+ | BP_CannotLoadDependencies
1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]
1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))
1773+
1774+
1775+toBuildProblemReport :: BuildProblem -> Help.Report
1776+toBuildProblemReport problem =
1777+ case problem of
1778+ BuildBadModules root e es ->
1779+ Help.compilerReport root e es
1780+
1781+ BuildProjectProblem projectProblem ->
1782+ toProjectProblemReport projectProblem
1783+
1784+
1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report
1786+toProjectProblemReport projectProblem =
1787+ case projectProblem of
1788+ BP_PathUnknown path ->
1789+ Help.report "FILE NOT FOUND" Nothing
1790+ "I cannot find this file:"
1791+ [ D.indent 4 $ D.red $ D.fromChars path
1792+ , D.reflow $ "Is there a typo?"
1793+ , D.toSimpleNote $
1794+ "If you are just getting started, try working through the examples in the\
1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\
1796+ \ that typically go in a src/Main.elm file."
1797+ ]
1798+
1799+ BP_WithBadExtension path ->
1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing
1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"
1802+ [ D.indent 4 $ D.red $ D.fromChars path
1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"
1804+ ]
1805+
1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->
1807+ Help.report "CONFUSING FILE" Nothing
1808+ "I am getting confused when I try to compile this file:"
1809+ [ D.indent 4 $ D.red $ D.fromChars path
1810+ , D.reflow $
1811+ "I always check if files appear in any of the \"source-directories\" listed in\
1812+ \ your elm.json to see if there might be some cached information about them. That\
1813+ \ can help me compile faster! But in this case, it looks like this file may be in\
1814+ \ either of these directories:"
1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]
1816+ , D.reflow $
1817+ "Try to make it so no source directory contains another source directory!"
1818+ ]
1819+
1820+ BP_MainPathDuplicate path1 path2 ->
1821+ Help.report "CONFUSING FILES" Nothing
1822+ "You are telling me to compile these two files:"
1823+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]
1824+ , D.reflow $
1825+ if path1 == path2 then
1826+ "Why are you telling me twice? Is something weird going on with a script?\
1827+ \ I figured I would let you know about it just in case something is wrong.\
1828+ \ Only list it once and you should be all set!"
1829+ else
1830+ "But seem to be the same file though... It makes me think something tricky is\
1831+ \ going on with symlinks in your project, so I figured I would let you know\
1832+ \ about it just in case. Remove one of these files from your command to get\
1833+ \ unstuck!"
1834+ ]
1835+
1836+ BP_RootNameDuplicate name outsidePath otherPath ->
1837+ Help.report "MODULE NAME CLASH" Nothing
1838+ "These two files are causing a module name clash:"
1839+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]
1840+ , D.reflow $
1841+ "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\
1842+ \ at the top, but they cannot have the same name!"
1843+ , D.reflow $
1844+ "Try changing to a different module name in one of them!"
1845+ ]
1846+
1847+ BP_RootNameInvalid givenPath srcDir _ ->
1848+ Help.report "UNEXPECTED FILE NAME" Nothing
1849+ "I am having trouble with this file name:"
1850+ [ D.indent 4 $ D.red $ D.fromChars givenPath
1851+ , D.reflow $
1852+ "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\
1853+ \ which is good, but I expect all of the files in there to use the following\
1854+ \ module naming convention:"
1855+ , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]
1856+ , D.reflow $
1857+ "Notice that the names always start with capital letters! Can you make your file\
1858+ \ use this naming convention?"
1859+ , D.toSimpleNote $
1860+ "Having a strict naming convention like this makes it a lot easier to find\
1861+ \ things in large projects. If you see a module imported, you know where to look\
1862+ \ for the corresponding file every time!"
1863+ ]
1864+
1865+ BP_CannotLoadDependencies ->
1866+ corruptCacheReport
1867+
1868+ BP_Cycle name names ->
1869+ Help.report "IMPORT CYCLE" Nothing
1870+ "Your module imports form a cycle:"
1871+ [ D.cycle 4 name names
1872+ , D.reflow $
1873+ "Learn more about why this is disallowed and how to break cycles here:"
1874+ ++ D.makeLink "import-cycles"
1875+ ]
1876+
1877+ BP_MissingExposed (NE.List (name, problem) _) ->
1878+ case problem of
1879+ Import.NotFound ->
1880+ Help.report "MISSING MODULE" (Just "elm.json")
1881+ "The \"exposed-modules\" of your elm.json lists the following module:"
1882+ [ D.indent 4 $ D.red $ D.fromName name
1883+ , D.reflow $
1884+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1885+ ]
1886+
1887+ Import.Ambiguous _ _ pkg _ ->
1888+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1889+ "The \"exposed-modules\" of your elm.json lists the following module:"
1890+ [ D.indent 4 $ D.red $ D.fromName name
1891+ , D.reflow $
1892+ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\
1893+ \ choosing a different name for your local file."
1894+ ]
1895+
1896+ Import.AmbiguousLocal path1 path2 paths ->
1897+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")
1898+ "The \"exposed-modules\" of your elm.json lists the following module:"
1899+ [ D.indent 4 $ D.red $ D.fromName name
1900+ , D.reflow $
1901+ "But I found multiple files with that name:"
1902+ , D.dullyellow $ D.indent 4 $ D.vcat $
1903+ map D.fromChars (path1:path2:paths)
1904+ , D.reflow $
1905+ "Change the module names to be distinct!"
1906+ ]
1907+
1908+ Import.AmbiguousForeign _ _ _ ->
1909+ Help.report "MISSING MODULE" (Just "elm.json")
1910+ "The \"exposed-modules\" of your elm.json lists the following module:"
1911+ [ D.indent 4 $ D.red $ D.fromName name
1912+ , D.reflow $
1913+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"
1914+ , D.toSimpleNote $
1915+ "It is not possible to \"re-export\" modules from other packages. You can only\
1916+ \ expose modules that you define in your own code."
1917+ ]
1918+
1919+
1920+toModuleNameConventionTable :: FilePath -> [String] -> D.Doc
1921+toModuleNameConventionTable srcDir names =
1922+ let
1923+ toPair name =
1924+ ( name
1925+ , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"
1926+ )
1927+
1928+ namePairs = map toPair names
1929+ nameWidth = maximum (11 : map (length . fst) namePairs)
1930+ pathWidth = maximum ( 9 : map (length . snd) namePairs)
1931+
1932+ padded width str =
1933+ str ++ replicate (width - length str) ' '
1934+
1935+ toRow (name, path) =
1936+ D.fromChars $
1937+ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"
1938+
1939+ bar =
1940+ D.fromChars $
1941+ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"
1942+ in
1943+ D.indent 4 $ D.vcat $
1944+ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]
1945+
1946+
1947+
1948+-- GENERATE
1949+
1950+
1951+data Generate
1952+ = GenerateCannotLoadArtifacts
1953+ | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]
1954+
1955+
1956+toGenerateReport :: Generate -> Help.Report
1957+toGenerateReport problem =
1958+ case problem of
1959+ GenerateCannotLoadArtifacts ->
1960+ corruptCacheReport
1961+
1962+ GenerateCannotOptimizeDebugValues m ms ->
1963+ Help.report "DEBUG REMNANTS" Nothing
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+
2053+ ReplBadInput source err ->
2054+ Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []
2055+
2056+ ReplBadLocalDeps root e es ->
2057+ Help.compilerReport root e es
2058+
2059+ ReplProjectProblem projectProblem ->
2060+ toProjectProblemReport projectProblem
2061+
2062+ ReplBadGenerate generate ->
2063+ toGenerateReport generate
2064+
2065+ ReplBadCache ->
2066+ corruptCacheReport
2067+
2068+ ReplBlocked ->
2069+ corruptCacheReport
builder/src/Reporting/Exit/Help.hsnew file+136
@@ -0,0 +1,136 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Reporting.Exit.Help
3+ ( Report
4+ , report
5+ , docReport
6+ , jsonReport
7+ , compilerReport
8+ , reportToDoc
9+ , reportToJson
10+ , toString
11+ , toStdout
12+ , toStderr
13+ )
14+ where
15+
16+
17+import GHC.IO.Handle (hIsTerminalDevice)
18+import System.IO (Handle, hPutStr, stderr, stdout)
19+
20+import qualified Json.Encode as E
21+import Json.Encode ((==>))
22+import Reporting.Doc ((<+>))
23+import qualified Reporting.Doc as D
24+import qualified Reporting.Error as Error
25+
26+
27+
28+-- REPORT
29+
30+
31+data Report
32+ = CompilerReport FilePath Error.Module [Error.Module]
33+ | Report
34+ { _title :: String
35+ , _path :: Maybe FilePath
36+ , _message :: D.Doc
37+ }
38+
39+
40+report :: String -> Maybe FilePath -> String -> [D.Doc] -> Report
41+report title path startString others =
42+ Report title path $ D.stack (D.reflow startString:others)
43+
44+
45+docReport :: String -> Maybe FilePath -> D.Doc -> [D.Doc] -> Report
46+docReport title path startDoc others =
47+ Report title path $ D.stack (startDoc:others)
48+
49+
50+jsonReport :: String -> Maybe FilePath -> D.Doc -> Report
51+jsonReport =
52+ Report
53+
54+
55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report
56+compilerReport =
57+ CompilerReport
58+
59+
60+
61+-- TO DOC
62+
63+
64+reportToDoc :: Report -> D.Doc
65+reportToDoc report_ =
66+ case report_ of
67+ CompilerReport root e es ->
68+ Error.toDoc root e es
69+
70+ Report title maybePath message ->
71+ let
72+ makeDashes n =
73+ replicate (max 1 (80 - n)) '-'
74+
75+ errorBarEnd =
76+ case maybePath of
77+ Nothing ->
78+ makeDashes (4 + length title)
79+
80+ Just path ->
81+ makeDashes (5 + length title + length path) ++ " " ++ path
82+
83+ errorBar =
84+ D.dullcyan $
85+ "--" <+> D.fromChars title <+> D.fromChars errorBarEnd
86+ in
87+ D.stack [errorBar, message, ""]
88+
89+
90+
91+-- TO JSON
92+
93+
94+reportToJson :: Report -> E.Value
95+reportToJson report_ =
96+ case report_ of
97+ CompilerReport _ e es ->
98+ E.object
99+ [ "type" ==> E.chars "compile-errors"
100+ , "errors" ==> E.list Error.toJson (e:es)
101+ ]
102+
103+ Report title maybePath message ->
104+ E.object
105+ [ "type" ==> E.chars "error"
106+ , "path" ==> maybe E.null E.chars maybePath
107+ , "title" ==> E.chars title
108+ , "message" ==> D.encode message
109+ ]
110+
111+
112+
113+-- OUTPUT
114+
115+
116+toString :: D.Doc -> String
117+toString =
118+ D.toString
119+
120+
121+toStdout :: D.Doc -> IO ()
122+toStdout doc =
123+ toHandle stdout doc
124+
125+
126+toStderr :: D.Doc -> IO ()
127+toStderr doc =
128+ toHandle stderr doc
129+
130+
131+toHandle :: Handle -> D.Doc -> IO ()
132+toHandle handle doc =
133+ do isTerminal <- hIsTerminalDevice handle
134+ if isTerminal
135+ then D.toAnsi handle doc
136+ else hPutStr handle (toString doc)
builder/src/Reporting/Progress.hsdeleted−98
@@ -1,98 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Reporting.Progress
3− ( Reporter(..)
4− , makeReporter
5− , Msg(..)
6− , Progress(..)
7− , Outcome(..)
8− , PublishPhase(..)
9− , BumpPhase(..)
10− )
11− where
12−
13−
14−import Control.Concurrent.Chan (Chan, writeChan)
15−import Control.Concurrent.MVar (MVar, readMVar)
16−import qualified Elm.Compiler.Module as Module
17−import Deps.Diff (Magnitude)
18−import Elm.Package (Name, Version)
19−import Reporting.Error (Error)
20−
21−
22−
23−-- REPORTER
24−
25−
26−data Reporter =
27− Reporter
28− { _tell :: Progress -> IO ()
29− , _end :: Maybe Error -> IO ()
30− }
31−
32−
33−makeReporter :: Chan Msg -> MVar () -> Reporter
34−makeReporter chan mvar =
35− let
36− tell progress =
37− writeChan chan (Progress progress)
38−
39− end maybeError =
40− do writeChan chan (End maybeError)
41− readMVar mvar
42− in
43− Reporter tell end
44−
45−
46−
47−-- MESSAGES
48−
49−
50−data Msg = Progress Progress | End (Maybe Error)
51−
52−
53−data Progress
54− -- download packages
55− = DownloadSkip
56− | DownloadStart [(Name, Version)]
57− | DownloadPkgStart Name Version
58− | DownloadPkgEnd Name Version Outcome
59− | DownloadEnd Outcome
60−
61− -- build dependencies
62− | BuildDepsStart Int
63− | BuildDepsProgress
64− | BuildDepsEnd
65−
66− -- compile files
67− | CompileStart Int
68− | CompileFileStart Module.Raw
69− | CompileFileEnd Module.Raw Outcome
70− | CompileEnd
71−
72− -- publish
73− | PublishStart Name Version (Maybe [Version])
74− | PublishCheckBump Version BumpPhase
75− | PublishProgress PublishPhase (Maybe Outcome)
76− | PublishEnd
77−
78− -- solver
79− | UnableToLoadLatestPackages
80−
81−
82−data Outcome = Good | Bad
83−
84−
85−data PublishPhase
86− = CheckReadme
87− | CheckLicense
88− | CheckTag Version
89− | CheckDownload
90− | CheckBuild
91− | CheckChanges
92−
93−
94−data BumpPhase
95− = StatedVersion
96− | GoodStart
97− | GoodBump Version Magnitude
98− | BadBump
builder/src/Reporting/Progress/Bar.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Reporting.Progress.Bar
3− ( render
4− , clear
5− )
6− where
7−
8−
9−
10−-- PROGRESS BAR
11−
12−
13−width :: Float
14−width =
15− 50.0
16−
17−
18−render :: Int -> Int -> Int -> String
19−render successes failures total =
20− let
21− numDone =
22− successes + failures
23−
24− fraction =
25− fromIntegral numDone / fromIntegral total
26−
27− unitsDone =
28− truncate (fraction * width)
29−
30− unitsLeft =
31− truncate width - unitsDone
32− in
33− "\r["
34− ++ replicate unitsDone '='
35− ++ replicate unitsLeft ' '
36− ++ "] - "
37− ++ show numDone ++ " / " ++ show total
38−
39−
40−clear :: String
41−clear =
42− '\r' : replicate (length (render 49999 50000 99999)) ' ' ++ "\r"
43−
builder/src/Reporting/Progress/Repl.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Reporting.Progress.Repl
3− ( create
4− )
5− where
6−
7−
8−import Control.Concurrent (forkIO)
9−import Control.Concurrent.Chan (Chan, newChan, readChan)
10−import Control.Concurrent.MVar (newEmptyMVar, putMVar)
11−
12−import qualified Reporting.Error as Error
13−import qualified Reporting.Progress as Progress
14−
15−
16−
17−-- CREATE
18−
19−
20−create :: IO Progress.Reporter
21−create =
22− do chan <- newChan
23− mvar <- newEmptyMVar
24− _ <- forkIO (loop chan >>= putMVar mvar)
25− return (Progress.makeReporter chan mvar)
26−
27−
28−
29−-- LOOP
30−
31−
32−loop :: Chan Progress.Msg -> IO ()
33−loop chan =
34− do msg <- readChan chan
35− case msg of
36− Progress.Progress _ ->
37− loop chan
38−
39− Progress.End maybeError ->
40− case maybeError of
41− Just err ->
42− Error.toStderr err
43−
44− Nothing ->
45− return ()
builder/src/Reporting/Progress/Terminal.hsdeleted−363
@@ -1,363 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
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 System
13−import System.IO (hFlush, hPutStr, stdout)
14−import Text.PrettyPrint.ANSI.Leijen ((<>), (<+>))
15−import qualified Text.PrettyPrint.ANSI.Leijen as P
16−import qualified Elm.Package as Pkg
17−import Elm.Package (Name, Version)
18−
19−import qualified Deps.Diff as Diff
20−import qualified Reporting.Error as Error
21−import qualified Reporting.Error.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 err) ->
60− Error.toStderr err
61−
62− End Nothing ->
63− return ()
64−
65− Progress progress ->
66− loopHelp chan progress state
67−
68−
69−loopHelp :: Chan Msg -> Progress -> State -> IO ()
70−loopHelp chan progress state@(State total good bad) =
71− case progress of
72−
73−
74− -- DOWNLOADS
75−
76− DownloadSkip ->
77− do putStrLn "Dependencies loaded from local cache."
78− loop chan state
79−
80− DownloadStart [] ->
81− loop chan state
82−
83− DownloadStart _ ->
84− do putStrLn "Starting downloads...\n"
85− loop chan state
86−
87− DownloadPkgStart _name _version ->
88− loop chan state
89−
90− DownloadPkgEnd name version outcome ->
91− do Help.toStdout (makeBullet name version outcome)
92− loop chan state
93−
94− DownloadEnd Bad ->
95− do putStrLn ""
96− loop chan state
97−
98− DownloadEnd Good ->
99− do putStrLn ""
100− loop chan state
101−
102−
103− -- BUILD DEPS
104−
105− BuildDepsStart size ->
106− do hPutStr stdout "Verifying dependencies..."
107− hFlush stdout
108− loop chan (State size 0 0)
109−
110− BuildDepsProgress ->
111− do let n = good + 1
112− let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"
113− hPutStr stdout msg
114− hFlush stdout
115− loop chan (State total n 0)
116−
117− BuildDepsEnd ->
118− do putStrLn "\rDependencies ready! "
119− loop chan (State 0 0 0)
120−
121−
122− -- COMPILE
123−
124− CompileStart size ->
125− loop chan (State size 0 0)
126−
127− CompileFileStart _ ->
128− loop chan state
129−
130− CompileFileEnd _ Good ->
131− do hPutStr stdout $ Bar.render (good + 1) bad total
132− hFlush stdout
133− loop chan (State total (good + 1) bad)
134−
135− CompileFileEnd _ Bad ->
136− do hPutStr stdout $ Bar.render good (bad + 1) total
137− hFlush stdout
138− loop chan (State total good (bad + 1))
139−
140− CompileEnd ->
141− let
142− message =
143− case (bad, total) of
144− (0, 0) -> "Success!"
145− (0, 1) -> "Success! Compiled 1 module."
146− (0, n) -> "Success! Compiled " ++ show n ++ " modules."
147− (1, _) -> "Detected errors in 1 module."
148− (n, _) -> "Detected errors in " ++ show n ++ " modules."
149− in
150− do hPutStr stdout $ Bar.clear
151− putStrLn message
152− loop chan (State 0 0 0)
153−
154−
155− -- PUBLISH
156−
157− PublishStart name version maybePublishedVersions ->
158− case maybePublishedVersions of
159− Nothing ->
160− do putStrLn newPackageOverview
161− putStrLn "I will now verify that everything is in order..."
162− putStrLn ""
163− loop chan state
164−
165− Just _ ->
166− do putStrLn $ unwords [ "Verifying", Pkg.toString name, Pkg.versionToString version, "..." ]
167− putStrLn ""
168− loop chan state
169−
170− PublishCheckBump version bumpPhase ->
171− do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase
172− hFlush stdout
173− loop chan state
174−
175− PublishProgress phase status ->
176− do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)
177− hFlush stdout
178− loop chan state
179−
180− PublishEnd ->
181− do putStrLn "Success!"
182− loop chan state
183−
184−
185− -- SOLVER
186−
187− UnableToLoadLatestPackages ->
188− do putStrLn ""
189− Help.toStdout $ P.dullyellow (P.text "WARNING:") <+> P.text "I normally check <https://package.elm-lang.org> for new packages\n"
190− putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"
191− loop chan state
192−
193−
194−
195−-- BULLETS
196−
197−
198−makeBullet :: Name -> Version -> Outcome -> P.Doc
199−makeBullet name version outcome =
200− let
201− nm =
202− P.text (Pkg.toString name)
203−
204− vsn =
205− P.text (Pkg.versionToString version)
206−
207− bullet =
208− case outcome of
209− Good -> goodMark
210− Bad -> badMark
211− in
212− P.indent 2 $ bullet <+> nm <+> vsn <> P.text "\n"
213−
214−
215−goodMark :: P.Doc
216−goodMark =
217− P.green $ P.text $
218− if System.os == "windows" then "+" else "●"
219−
220−
221−badMark :: P.Doc
222−badMark =
223− P.red $ P.text $
224− if System.os == "windows" then "X" else "✗"
225−
226−
227−waitingMark :: P.Doc
228−waitingMark =
229− P.dullyellow $ P.text $
230− if System.os == "windows" then "-" else "→"
231−
232−
233−
234−-- OVERVIEW OF VERSIONING
235−
236−
237−newPackageOverview :: String
238−newPackageOverview =
239− unlines
240− [ "This package has never been published before. Here's how things work:"
241− , ""
242− , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
243− , ""
244− , " - All packages start with initial version " ++ Pkg.versionToString Pkg.initialVersion
245− , ""
246− , " - Versions are incremented based on how the API changes:"
247− , ""
248− , " PATCH = the API is the same, no risk of breaking code"
249− , " MINOR = values have been added, existing values are unchanged"
250− , " MAJOR = existing values have been changed or removed"
251− , ""
252− , " - I will bump versions for you, automatically enforcing these rules"
253− , ""
254− ]
255−
256−
257−
258−-- CHECKLIST
259−
260−
261−toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> P.Doc
262−toChecklistDoc status (ChecklistMessages waiting success failure) =
263− let
264− padded message =
265− message ++ replicate (length waiting - length message) ' '
266− in
267− case status of
268− Nothing ->
269− P.text " " <> waitingMark <+> P.text waiting
270−
271− Just Good ->
272− P.text "\r " <> goodMark <+> P.text (padded success ++ "\n")
273−
274− Just Bad ->
275− P.text "\r " <> badMark <+> P.text (padded failure ++ "\n\n")
276−
277−
278−data ChecklistMessages =
279− ChecklistMessages
280− { _waiting :: String
281− , _success :: String
282− , _failure :: String
283− }
284−
285−
286−toChecklistMessages :: PublishPhase -> ChecklistMessages
287−toChecklistMessages phase =
288− case phase of
289− CheckReadme ->
290− ChecklistMessages
291− "Looking for README.md"
292− "Found README.md"
293− "Problem with your README.md"
294−
295− CheckLicense ->
296− ChecklistMessages
297− "Looking for LICENSE"
298− "Found LICENSE"
299− "Problem with your LICENSE"
300−
301− CheckTag version ->
302− ChecklistMessages
303− ("Is version " ++ Pkg.versionToString version ++ " tagged on GitHub?")
304− ("Version " ++ Pkg.versionToString version ++ " is tagged on GitHub")
305− ("Version " ++ Pkg.versionToString version ++ " is not tagged on GitHub!")
306−
307− CheckDownload ->
308− ChecklistMessages
309− "Downloading code from GitHub..."
310− "Code downloaded successfully from GitHub"
311− "Could not download code from GitHub!"
312−
313− CheckBuild ->
314− ChecklistMessages
315− "Building downloaded code and generated docs..."
316− "Downloaded code compiles successfully / docs generated\n"
317− "Cannot compile downloaded code!"
318−
319− CheckChanges ->
320− ChecklistMessages
321− "Checking for uncommitted changes..."
322− "No uncommitted changes in local code"
323− "Your local code is different than the code tagged on GitHub"
324−
325−
326−
327−-- BUMP PHASE
328−
329−
330−bumpPhaseToChecklistDoc :: Pkg.Version -> BumpPhase -> P.Doc
331−bumpPhaseToChecklistDoc version bumpPhase =
332− let
333− mkMsgs success =
334− ChecklistMessages
335− ("Checking semantic versioning rules. Is " ++ Pkg.versionToString version ++ " correct?")
336− success
337− ("Version " ++ Pkg.versionToString version ++ " is not correct!")
338− in
339−
340− case bumpPhase of
341− StatedVersion ->
342− toChecklistDoc Nothing $ mkMsgs ""
343−
344− GoodStart ->
345− toChecklistDoc (Just Good) $ mkMsgs $
346− "All packages start at version " ++ Pkg.versionToString Pkg.initialVersion
347−
348− GoodBump old magnitude ->
349− toChecklistDoc (Just Good) $ mkMsgs $
350− toCheckVersionSuccessMessage old version magnitude
351−
352− BadBump ->
353− toChecklistDoc (Just Bad) $ mkMsgs ""
354−
355−
356−toCheckVersionSuccessMessage :: Pkg.Version -> Pkg.Version -> Diff.Magnitude -> String
357−toCheckVersionSuccessMessage oldVersion newVersion magnitude =
358− let
359− old = Pkg.versionToString oldVersion
360− new = Pkg.versionToString newVersion
361− mag = Diff.magnitudeToString magnitude
362− in
363− "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"
builder/src/Reporting/Task.hs+79−156
@@ -1,191 +1,114 @@
1−{-# OPTIONS_GHC -Wall #-}
1+{-# LANGUAGE Rank2Types #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Task
2module Reporting.Task
3+ ( Task
4+ , run
5+ , throw
4− ( Task, Task_, run, throw, mapError
6+ , mapError
5− , Env
7+ --
6− , getPackageCacheDir
8+ , io
7− , getPackageCacheDirFor
9+ , mio
8− , report
10+ , eio
9− , getReporter
10− , withApproval
11− , getApproval
12− , silently
13− , getSilentRunner
14− , workerChan
15− , runHttp
16 )
11 )
17 where
12 where
18
13
19−import Control.Concurrent (forkIO)
20−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
21−import Control.Monad (forever, join, replicateM_)
22−import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
23−import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
24−import Control.Monad.Trans (liftIO)
25−import qualified Network.HTTP.Client as Http
26−import qualified Network.HTTP.Client.TLS as Http
27−import System.Directory (createDirectoryIfMissing)
28−import System.FilePath ((</>))
29−import qualified System.IO as IO
30−
31−import Elm.Package (Name, Version)
32−import qualified Elm.Package as Pkg
33−import qualified Elm.PerUserCache as PerUserCache
34−import qualified Reporting.Error as Error
35−import qualified Reporting.Progress as Progress
36−
37
14
38
15
39-- TASKS
16-- TASKS
40
17
41
18
42−type Task =
19+newtype Task x a =
43− Task_ Error.Error
20+ Task
44−
21+ (
45−
22+ forall result. (a -> IO result) -> (x -> IO result) -> IO result
46−type Task_ e =
23+ )
47− ExceptT e (ReaderT Env IO)
48−
49−
50−data Env =
51− Env
52− { _cacheDir :: FilePath
53− , _worker :: IO () -> IO ()
54− , _httpManager :: Http.Manager
55− , _tell :: Progress.Progress -> IO ()
56− }
57−
58−
59−run :: Progress.Reporter -> Task a -> IO (Maybe a)
60−run (Progress.Reporter tell end) task =
61− do root <- PerUserCache.getPackageRoot
62− pool <- initPool 4
63− httpManager <- Http.newManager Http.tlsManagerSettings
64− let env = Env root pool httpManager tell
65− result <- runReaderT (runExceptT task) env
66− case result of
67− Left err ->
68− do end (Just err)
69− return Nothing
70−
71− Right answer ->
72− do end Nothing
73− return (Just answer)
74−
75−
76−throw :: e -> Task_ e a
77−throw =
78− throwError
79−
80−
81−mapError :: (x -> y) -> Task_ x a -> Task_ y a
82−mapError =
83− withExceptT
84−
85−
86−
87−-- CACHING
88−
89−
90−getPackageCacheDir :: Task_ e FilePath
91−getPackageCacheDir =
92− asks _cacheDir
93−
94−
95−getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
96−getPackageCacheDirFor name version =
97− do cacheDir <- getPackageCacheDir
98− let dir = cacheDir </> Pkg.toFilePath name </> Pkg.versionToString version
99− liftIO (createDirectoryIfMissing True dir)
100− return dir
101−
102−
103−
104−-- REPORTER
105−
106−
107−report :: Progress.Progress -> Task_ e ()
108−report progress =
109− do tell <- asks _tell
110− liftIO (tell progress)
111−
112−
113−getReporter :: Task (Progress.Progress -> IO ())
114−getReporter =
115− asks _tell
116−
117−
118−
119−-- APPROVAL
120
24
121
25
122−withApproval :: Task_ e () -> Task_ e ()
26+run :: Task x a -> IO (Either x a)
123−withApproval task =
27+run (Task task) =
124− do approval <- getApproval
28+ task (return . Right) (return . Left)
125− if approval then task else return ()
126
29
127
30
128−getApproval :: Task_ e Bool
31+throw :: x -> Task x a
129−getApproval =
32+throw x =
130− do liftIO $ IO.hFlush IO.stdout
33+ Task $ \_ err -> err x
131− input <- liftIO getLine
132− case input of
133− "" -> return True
134− "Y" -> return True
135− "y" -> return True
136− "n" -> return False
137− _ ->
138− do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "
139− getApproval
140
34
141
35
36+mapError :: (x -> y) -> Task x a -> Task y a
37+mapError func (Task task) =
38+ Task $ \ok err ->
39+ task ok (err . func)
142
40
143−-- RUNNER
144
41
145
42
146−silently :: Task_ e a -> Task_ e a
43+-- IO
147−silently task =
148− do runner <- getSilentRunner
149− result <- liftIO (runner task)
150− either throw return result
151
44
152
45
153−getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
46+{-# INLINE io #-}
154−getSilentRunner =
47+io :: IO a -> Task x a
155− do env <- ask
48+io work =
156− let silentEnv = env { _tell = \_ -> return () }
49+ Task $ \ok _ -> work >>= ok
157− return $ \task -> runReaderT (runExceptT task) silentEnv
158
50
159
51
52+mio :: x -> IO (Maybe a) -> Task x a
53+mio x work =
54+ Task $ \ok err ->
55+ do result <- work
56+ case result of
57+ Just a -> ok a
58+ Nothing -> err x
160
59
161−-- THREAD POOL
162
60
61+eio :: (x -> y) -> IO (Either x a) -> Task y a
62+eio func work =
63+ Task $ \ok err ->
64+ do result <- work
65+ case result of
66+ Right a -> ok a
67+ Left x -> err (func x)
163
68
164−workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
165−workerChan chan task =
166− do env <- ask
167
69
168− liftIO $ _worker env $
169− do result <- runReaderT (runExceptT task) env
170− writeChan chan result
171
70
71+-- INSTANCES
172
72
173−initPool :: Int -> IO (IO () -> IO ())
174−initPool size =
175− do chan <- newChan
176
73
177− replicateM_ size $ forkIO $ forever $
74+instance Functor (Task x) where
178− join (readChan chan)
75+ {-# INLINE fmap #-}
76+ fmap func (Task taskA) =
77+ Task $ \ok err ->
78+ let
79+ okA arg = ok (func arg)
80+ in
81+ taskA okA err
179
82
180− return $ writeChan chan
181
83
84+instance Applicative (Task x) where
85+ {-# INLINE pure #-}
86+ pure a =
87+ Task $ \ok _ -> ok a
182
88
89+ {-# INLINE (<*>) #-}
90+ (<*>) (Task taskFunc) (Task taskArg) =
91+ Task $ \ok err ->
92+ let
93+ okFunc func =
94+ let
95+ okArg arg = ok (func arg)
96+ in
97+ taskArg okArg err
98+ in
99+ taskFunc okFunc err
183
100
184−-- HTTP
185
101
102+instance Monad (Task x) where
103+ {-# INLINE return #-}
104+ return = pure
186
105
187−runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Error.Error a)) -> Task a
106+ {-# INLINE (>>=) #-}
188−runHttp fetcher =
107+ (>>=) (Task taskA) callback =
189− do (Env _ _ manager tell) <- ask
108+ Task $ \ok err ->
190− result <- liftIO $ fetcher manager tell
109+ let
191− either throwError return result
110+ okA a =
111+ case callback a of
112+ Task taskB -> taskB ok err
113+ in
114+ taskA okA err
builder/src/Reporting/Task/Http.hsdeleted−185
@@ -1,185 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−module Reporting.Task.Http
5− ( Fetch
6− , Handler
7− , run
8− , package
9− , anything
10− , andThen
11− , parallel
12− , report
13− )
14− where
15−
16−
17−import Control.Concurrent (forkIO)
18−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
19−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
20−import Control.Exception (Exception, SomeException, catch)
21−import Control.Monad (forever, join, replicateM_, void)
22−import qualified Network.HTTP as Http (urlEncodeVars)
23−import qualified Network.HTTP.Client as Http
24−
25−import qualified Elm.Compiler as Compiler
26−import qualified Elm.Package as Pkg
27−import qualified Reporting.Error as Error
28−import qualified Reporting.Error.Http as E
29−import qualified Reporting.Progress as Progress
30−import qualified Reporting.Task as Task
31−
32−
33−
34−-- FETCH
35−
36−
37−data Fetch a where
38− Package :: String -> [(String,String)] -> Handler a -> Fetch a
39− Anything :: String -> Handler a -> Fetch a
40− AndThen :: Fetch a -> (a -> Fetch b) -> Fetch b
41− Parallel :: [Fetch a] -> Fetch [a]
42− Report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
43−
44−
45−type Handler a =
46− Http.Request -> Http.Manager -> IO (Either E.Error a)
47−
48−
49−package :: String -> [(String,String)] -> Handler a -> Fetch a
50−package =
51− Package
52−
53−
54−anything :: String -> Handler a -> Fetch a
55−anything =
56− Anything
57−
58−
59−andThen :: Fetch a -> (a -> Fetch b) -> Fetch b
60−andThen =
61− AndThen
62−
63−
64−parallel :: [Fetch a] -> Fetch [a]
65−parallel =
66− Parallel
67−
68−
69−report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
70−report =
71− Report
72−
73−
74−
75−-- RUN
76−
77−
78−run :: Fetch a -> Task.Task a
79−run fetch =
80− Task.runHttp $ \manager tell ->
81− do chan <- newChan
82− replicateM_ 4 $ forkIO $ forever $ join (readChan chan)
83− readMVar =<< runHelp chan manager tell fetch
84−
85−
86−runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Error.Error a))
87−runHelp chan manager tell fetch =
88− case fetch of
89− Package path params handler ->
90− do mvar <- newEmptyMVar
91− let url = makePackageUrl path params
92− writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
93− return mvar
94−
95− Anything url handler ->
96− do mvar <- newEmptyMVar
97− writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
98− return mvar
99−
100− AndThen subFetch callback ->
101− do subMVar <- runHelp chan manager tell subFetch
102− mvar <- newEmptyMVar
103− void $ forkIO $
104− do result <- readMVar subMVar
105− putMVar mvar =<<
106− case result of
107− Left err ->
108− return (Left err)
109− Right value ->
110− readMVar =<< runHelp chan manager tell (callback value)
111− return mvar
112−
113− Parallel fetches ->
114− do mvars <- mapM (runHelp chan manager tell) fetches
115− mvar <- newEmptyMVar
116− void $ forkIO $
117− do results <- mapM readMVar mvars
118− putMVar mvar (sequence results)
119− return mvar
120−
121− Report start toEnd subFetch ->
122− do tell start
123− subMVar <- runHelp chan manager tell subFetch
124− mvar <- newEmptyMVar
125− void $ forkIO $
126− do result <- readMVar subMVar
127− tell $ toEnd $
128− either (\_ -> Progress.Bad) (\_ -> Progress.Good) result
129− putMVar mvar result
130− return mvar
131−
132−
133−
134−-- PACKAGE URLS
135−
136−
137−packageDomain :: String
138−packageDomain =
139− "http://localhost:8000"
140−
141−
142−makePackageUrl :: String -> [(String,String)] -> String
143−makePackageUrl path params =
144− let
145− query =
146− if null params then
147− ""
148− else
149− "?" ++ Http.urlEncodeVars (versionParam : params)
150− in
151− packageDomain ++ "/" ++ path ++ query
152−
153−
154−versionParam :: (String, String)
155−versionParam =
156− ( "elm-package-version"
157− , Pkg.versionToString Compiler.version
158− )
159−
160−
161−
162−-- HTTP HELP
163−
164−
165−fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Error.Error a)
166−fetchSafe url manager handler =
167− fetchUnsafe url manager handler
168− `catch` \e -> handleAnyError url (e :: SomeException)
169−
170−
171−fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Error.Error a)
172−fetchUnsafe url manager handler =
173− do request <- Http.parseUrlThrow url
174− result <- handler request manager
175− case result of
176− Right value ->
177− return (Right value)
178−
179− Left problem ->
180− return (Left (Error.BadHttp url problem))
181−
182−
183−handleAnyError :: (Exception e) => String -> e -> IO (Either Error.Error a)
184−handleAnyError url exception =
185− return $ Left $ Error.BadHttp url $ E.Unknown $ show exception
builder/src/Stuff.hsnew file+179
@@ -0,0 +1,179 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Stuff
3+ ( details
4+ , interfaces
5+ , objects
6+ , prepublishDir
7+ , elmi
8+ , elmo
9+ , temp
10+ , findRoot
11+ , withRootLock
12+ , withRegistryLock
13+ , PackageCache
14+ , getPackageCache
15+ , registry
16+ , package
17+ , getReplCache
18+ , getElmHome
19+ )
20+ where
21+
22+
23+import qualified System.Directory as Dir
24+import qualified System.Environment as Env
25+import qualified System.FileLock as Lock
26+import qualified System.FilePath as FP
27+import System.FilePath ((</>), (<.>))
28+
29+import qualified Elm.ModuleName as ModuleName
30+import qualified Elm.Package as Pkg
31+import qualified Elm.Version as V
32+
33+
34+
35+-- PATHS
36+
37+
38+stuff :: FilePath -> FilePath
39+stuff root =
40+ root </> "elm-stuff" </> compilerVersion
41+
42+
43+details :: FilePath -> FilePath
44+details root =
45+ stuff root </> "d.dat"
46+
47+
48+interfaces :: FilePath -> FilePath
49+interfaces root =
50+ stuff root </> "i.dat"
51+
52+
53+objects :: FilePath -> FilePath
54+objects root =
55+ stuff root </> "o.dat"
56+
57+
58+prepublishDir :: FilePath -> FilePath
59+prepublishDir root =
60+ stuff root </> "prepublish"
61+
62+
63+compilerVersion :: FilePath
64+compilerVersion =
65+ V.toChars V.compiler
66+
67+
68+
69+-- ELMI and ELMO
70+
71+
72+elmi :: FilePath -> ModuleName.Raw -> FilePath
73+elmi root name =
74+ toArtifactPath root name "elmi"
75+
76+
77+elmo :: FilePath -> ModuleName.Raw -> FilePath
78+elmo root name =
79+ toArtifactPath root name "elmo"
80+
81+
82+toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath
83+toArtifactPath root name ext =
84+ stuff root </> ModuleName.toHyphenPath name <.> ext
85+
86+
87+
88+-- TEMP
89+
90+
91+temp :: FilePath -> String -> FilePath
92+temp root ext =
93+ stuff root </> "temp" <.> ext
94+
95+
96+
97+-- ROOT
98+
99+
100+findRoot :: IO (Maybe FilePath)
101+findRoot =
102+ do dir <- Dir.getCurrentDirectory
103+ findRootHelp (FP.splitDirectories dir)
104+
105+
106+findRootHelp :: [String] -> IO (Maybe FilePath)
107+findRootHelp dirs =
108+ case dirs of
109+ [] ->
110+ return Nothing
111+
112+ _:_ ->
113+ do exists <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")
114+ if exists
115+ then return (Just (FP.joinPath dirs))
116+ else findRootHelp (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+
134+
135+
136+-- PACKAGE CACHES
137+
138+
139+newtype PackageCache = PackageCache FilePath
140+
141+
142+getPackageCache :: IO PackageCache
143+getPackageCache =
144+ PackageCache <$> getCacheDir "packages"
145+
146+
147+registry :: PackageCache -> FilePath
148+registry (PackageCache dir) =
149+ dir </> "registry.dat"
150+
151+
152+package :: PackageCache -> Pkg.Name -> V.Version -> FilePath
153+package (PackageCache dir) name version =
154+ dir </> Pkg.toFilePath name </> V.toChars version
155+
156+
157+
158+-- CACHE
159+
160+
161+getReplCache :: IO FilePath
162+getReplCache =
163+ getCacheDir "repl"
164+
165+
166+getCacheDir :: FilePath -> IO FilePath
167+getCacheDir projectName =
168+ do home <- getElmHome
169+ let root = home </> compilerVersion </> projectName
170+ Dir.createDirectoryIfMissing True root
171+ return root
172+
173+
174+getElmHome :: IO FilePath
175+getElmHome =
176+ do maybeCustomHome <- Env.lookupEnv "ELM_HOME"
177+ case maybeCustomHome of
178+ Just customHome -> return customHome
179+ Nothing -> Dir.getAppUserDataDirectory "elm"
builder/src/Stuff/Paths.hsdeleted−93
@@ -1,93 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Stuff.Paths
3− ( docs
4− , solution
5− , summary
6− , prepublishDir
7− , removeStuff
8− , elmi
9− , elmo
10− , temp
11− )
12− where
13−
14−
15−import Control.Monad.Trans (liftIO)
16−import qualified System.Directory as Dir
17−import System.FilePath ((</>), (<.>))
18−
19−import qualified Elm.Compiler as Compiler
20−import qualified Elm.Compiler.Module as Module
21−import qualified Elm.Package as Pkg
22−import qualified Reporting.Task as Task
23−
24−
25−
26−-- PATHS
27−
28−
29−stuff :: FilePath
30−stuff =
31− "elm-stuff" </> Pkg.versionToString Compiler.version
32−
33−
34−docs :: FilePath
35−docs =
36− stuff </> "docs.json"
37−
38−
39−solution :: FilePath
40−solution =
41− stuff </> "solution.dat"
42−
43−
44−summary :: FilePath
45−summary =
46− stuff </> "summary.dat"
47−
48−
49−prepublishDir :: FilePath
50−prepublishDir =
51− stuff </> "prepublish"
52−
53−
54−
55−-- REMOVE STUFF
56−
57−
58−removeStuff :: FilePath -> Task.Task_ e ()
59−removeStuff root =
60− liftIO $
61− do let dir = root </> "elm-stuff"
62− exists <- Dir.doesDirectoryExist dir
63− if exists
64− then Dir.removeDirectoryRecursive dir
65− else return ()
66−
67−
68−
69−-- ELMI and ELMO
70−
71−
72−elmi :: FilePath -> Module.Raw -> FilePath
73−elmi root name =
74− toArtifactPath root name "elmi"
75−
76−
77−elmo :: FilePath -> Module.Raw -> FilePath
78−elmo root name =
79− toArtifactPath root name "elmo"
80−
81−
82−toArtifactPath :: FilePath -> Module.Raw -> String -> FilePath
83−toArtifactPath root name ext =
84− root </> stuff </> Module.nameToHyphenPath name <.> ext
85−
86−
87−
88−-- TEMP
89−
90−
91−temp :: FilePath
92−temp =
93− stuff </> "temp.js"
builder/src/Stuff/Verify.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Stuff.Verify
3− ( verify
4− )
5− where
6−
7−
8−import Prelude hiding (read)
9−import qualified Data.Map as Map
10−import Data.Map (Map)
11−
12−import Elm.Package (Name, Version)
13−
14−import qualified Deps.Verify as Verify
15−import Elm.Project.Json (Project(..), PkgInfo(..))
16−import qualified Elm.Project.Json as Project
17−import qualified Elm.Project.Constraint as Con
18−import qualified Elm.Project.Summary as Summary
19−import qualified File.IO as IO
20−import qualified Reporting.Task as Task
21−import qualified Stuff.Paths as Path
22−
23−
24−
25−-- VERIFY
26−
27−
28−verify :: FilePath -> Project -> Task.Task Summary.Summary
29−verify root project =
30− do fresh <-
31− IO.andM
32− [ IO.exists Path.solution
33− , IO.exists Path.summary
34− , checkSolution project
35− ]
36−
37− if fresh
38− then read root project
39− else rebuildCache root project
40−
41−
42−rebuildCache :: FilePath -> Project -> Task.Task Summary.Summary
43−rebuildCache root project =
44− do IO.remove Path.solution
45− IO.remove Path.summary
46−
47− (solution, summary) <- Verify.verify root project
48−
49− IO.writeBinary Path.solution solution
50− write summary
51− return summary
52−
53−
54−
55−-- READ / WRITE
56−
57−
58−read :: FilePath -> Project -> Task.Task Summary.Summary
59−read root project =
60− do (exposed, ifaces, graph) <- IO.readBinary Path.summary
61− return (Summary.Summary root project exposed ifaces graph)
62−
63−
64−write :: Summary.Summary -> Task.Task ()
65−write (Summary.Summary _ _ exposed ifaces graph) =
66− IO.writeBinary Path.summary ( exposed, ifaces, graph )
67−
68−
69−
70−-- CHECK SOLUTION
71−
72−
73−checkSolution :: Project -> Task.Task Bool
74−checkSolution project =
75− checkSolutionHelp project <$> IO.readBinary Path.solution
76−
77−
78−checkSolutionHelp :: Project -> Map Name Version -> Bool
79−checkSolutionHelp project solution =
80− case project of
81− App info ->
82− solution == Project.appSolution info
83−
84− Pkg info ->
85− allGood (_pkg_test_deps info) solution
86− && allGood (_pkg_deps info) solution
87−
88−
89−allGood :: Map Name Con.Constraint -> Map Name Version -> Bool
90−allGood cons vsns =
91− let
92− bools =
93− Map.intersectionWith Con.satisfies cons vsns
94− in
95− Map.size cons == Map.size bools
96− && Map.foldr (&&) True bools
cabal.confignew file+2
@@ -0,0 +1,2 @@
1+profiling: False
2+library-profiling: True
src/AST/Canonical.hs → compiler/src/AST/Canonical.hsrenamed+99−71
@@ -3,6 +3,7 @@
3module AST.Canonical
3module AST.Canonical
4 ( Expr, Expr_(..)
4 ( Expr, Expr_(..)
5 , CaseBranch(..)
5 , CaseBranch(..)
6+ , FieldUpdate(..)
6 , CtorOpts(..)
7 , CtorOpts(..)
7 -- definitions
8 -- definitions
8 , Def(..)
9 , Def(..)
@@ -14,13 +15,14 @@ module AST.Canonical
14 , Annotation(..)
15 , Annotation(..)
15 , Type(..)
16 , Type(..)
16 , AliasType(..)
17 , AliasType(..)
18+ , FieldType(..)
19+ , fieldsToList
17 -- modules
20 -- modules
18 , Module(..)
21 , Module(..)
19 , Alias(..)
22 , Alias(..)
20 , Binop(..)
23 , Binop(..)
21 , Union(..)
24 , Union(..)
22 , Ctor(..)
25 , Ctor(..)
23− , Docs(..)
24 , Exports(..)
26 , Exports(..)
25 , Export(..)
27 , Export(..)
26 , Effects(..)
28 , Effects(..)
@@ -30,7 +32,7 @@ module AST.Canonical
30 where
32 where
31
33
32{- Creating a canonical AST means finding the home module for all variables.
34{- Creating a canonical AST means finding the home module for all variables.
33−So if you have L.map, you need to figure out that it is from the elm-lang/core
35+So if you have L.map, you need to figure out that it is from the elm/core
34package in the List module.
36package in the List module.
35
37
36In later phases (e.g. type inference, exhaustiveness checking, optimization)
38In later phases (e.g. type inference, exhaustiveness checking, optimization)
@@ -51,17 +53,18 @@ So it is clear why the data is kept around.
51
53
52import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
54import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
53import Data.Binary
55import Data.Binary
54−import qualified Data.ByteString as B
56+import qualified Data.List as List
55import qualified Data.Map as Map
57import qualified Data.Map as Map
56−import Data.Text (Text)
58+import Data.Name (Name)
57
59
60+import qualified AST.Source as Src
58import qualified AST.Utils.Binop as Binop
61import qualified AST.Utils.Binop as Binop
59−import qualified AST.Module.Name as ModuleName
60import qualified AST.Utils.Shader as Shader
62import qualified AST.Utils.Shader as Shader
61import qualified Data.Index as Index
63import qualified Data.Index as Index
62−import qualified Elm.Name as N
64+import qualified Elm.Float as EF
65+import qualified Elm.ModuleName as ModuleName
66+import qualified Elm.String as ES
63import qualified Reporting.Annotation as A
67import qualified Reporting.Annotation as A
64−import qualified Reporting.Region as R
65
68
66
69
67
70
@@ -74,20 +77,20 @@ type Expr =
74
77
75-- CACHE Annotations for type inference
78-- CACHE Annotations for type inference
76data Expr_
79data Expr_
77− = VarLocal N.Name
80+ = VarLocal Name
78− | VarTopLevel ModuleName.Canonical N.Name
81+ | VarTopLevel ModuleName.Canonical Name
79− | VarKernel N.Name N.Name
82+ | VarKernel Name Name
80− | VarForeign ModuleName.Canonical N.Name Annotation
83+ | VarForeign ModuleName.Canonical Name Annotation
81− | VarCtor CtorOpts ModuleName.Canonical N.Name Index.ZeroBased Annotation
84+ | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
82− | VarDebug ModuleName.Canonical N.Name Annotation
85+ | VarDebug ModuleName.Canonical Name Annotation
83− | VarOperator N.Name ModuleName.Canonical N.Name Annotation -- CACHE real name for optimization
86+ | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
84− | Chr Text
87+ | Chr ES.String
85− | Str Text
88+ | Str ES.String
86 | Int Int
89 | Int Int
87− | Float Double
90+ | Float EF.Float
88 | List [Expr]
91 | List [Expr]
89 | Negate Expr
92 | Negate Expr
90− | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr -- CACHE real name for optimization
93+ | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
91 | Lambda [Pattern] Expr
94 | Lambda [Pattern] Expr
92 | Call Expr [Expr]
95 | Call Expr [Expr]
93 | If [(Expr, Expr)] Expr
96 | If [(Expr, Expr)] Expr
@@ -95,26 +98,30 @@ data Expr_
95 | LetRec [Def] Expr
98 | LetRec [Def] Expr
96 | LetDestruct Pattern Expr Expr
99 | LetDestruct Pattern Expr Expr
97 | Case Expr [CaseBranch]
100 | Case Expr [CaseBranch]
98− | Accessor N.Name
101+ | Accessor Name
99− | Access Expr N.Name
102+ | Access Expr (A.Located Name)
100− | Update Expr (Map.Map N.Name Expr)
103+ | Update Name Expr (Map.Map Name FieldUpdate)
101− | Record (Map.Map N.Name Expr)
104+ | Record (Map.Map Name Expr)
102 | Unit
105 | Unit
103 | Tuple Expr Expr (Maybe Expr)
106 | Tuple Expr Expr (Maybe Expr)
104− | Shader Text Text Shader.Shader
107+ | Shader Shader.Source Shader.Types
105
108
106
109
107data CaseBranch =
110data CaseBranch =
108 CaseBranch Pattern Expr
111 CaseBranch Pattern Expr
109
112
110
113
114+data FieldUpdate =
115+ FieldUpdate A.Region Expr
116+
117+
111
118
112-- DEFS
119-- DEFS
113
120
114
121
115data Def
122data Def
116− = Def (A.Located N.Name) [Pattern] Expr
123+ = Def (A.Located Name) [Pattern] Expr
117− | TypedDef (A.Located N.Name) FreeVars [(Pattern, Type)] Expr Type
124+ | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type
118
125
119
126
120
127
@@ -123,7 +130,7 @@ data Def
123
130
124data Decls
131data Decls
125 = Declare Def Decls
132 = Declare Def Decls
126− | DeclareRec [Def] Decls
133+ | DeclareRec Def [Def] Decls
127 | SaveTheEnvironment
134 | SaveTheEnvironment
128
135
129
136
@@ -137,21 +144,22 @@ type Pattern =
137
144
138data Pattern_
145data Pattern_
139 = PAnything
146 = PAnything
140− | PVar N.Name
147+ | PVar Name
141− | PRecord [N.Name]
148+ | PRecord [Name]
142− | PAlias Pattern N.Name
149+ | PAlias Pattern Name
143 | PUnit
150 | PUnit
144 | PTuple Pattern Pattern (Maybe Pattern)
151 | PTuple Pattern Pattern (Maybe Pattern)
145 | PList [Pattern]
152 | PList [Pattern]
146 | PCons Pattern Pattern
153 | PCons Pattern Pattern
154+ | PBool Union Bool
147− | PChr Text
155+ | PChr ES.String
148− | PStr Text
156+ | PStr ES.String
149 | PInt Int
157 | PInt Int
150 | PCtor
158 | PCtor
151 { _p_home :: ModuleName.Canonical
159 { _p_home :: ModuleName.Canonical
152− , _p_type :: N.Name
160+ , _p_type :: Name
153 , _p_union :: Union
161 , _p_union :: Union
154− , _p_name :: N.Name
162+ , _p_name :: Name
155 , _p_index :: Index.ZeroBased
163 , _p_index :: Index.ZeroBased
156 , _p_args :: [PatternCtorArg]
164 , _p_args :: [PatternCtorArg]
157 }
165 }
@@ -174,24 +182,47 @@ data PatternCtorArg =
174
182
175
183
176data Annotation = Forall FreeVars Type
184data Annotation = Forall FreeVars Type
185+ deriving (Eq)
177
186
178
187
179−type FreeVars = Map.Map N.Name ()
188+type FreeVars = Map.Map Name ()
180
189
181
190
182data Type
191data Type
183 = TLambda Type Type
192 = TLambda Type Type
184− | TVar N.Name
193+ | TVar Name
185− | TType ModuleName.Canonical N.Name [Type]
194+ | TType ModuleName.Canonical Name [Type]
186− | TRecord (Map.Map N.Name Type) (Maybe N.Name)
195+ | TRecord (Map.Map Name FieldType) (Maybe Name)
187 | TUnit
196 | TUnit
188 | TTuple Type Type (Maybe Type)
197 | TTuple Type Type (Maybe Type)
189− | TAlias ModuleName.Canonical N.Name [(N.Name, Type)] AliasType
198+ | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
199+ deriving (Eq)
190
200
191
201
192data AliasType
202data AliasType
193 = Holey Type
203 = Holey Type
194 | Filled Type
204 | Filled Type
205+ deriving (Eq)
206+
207+
208+data FieldType = FieldType {-# UNPACK #-} !Word16 Type
209+ deriving (Eq)
210+
211+
212+-- NOTE: The Word16 marks the source order, but it may not be available
213+-- for every canonical type. For example, if the canonical type is inferred
214+-- the orders will all be zeros.
215+--
216+fieldsToList :: Map.Map Name FieldType -> [(Name, Type)]
217+fieldsToList fields =
218+ let
219+ getIndex (_, FieldType index _) =
220+ index
221+
222+ dropIndex (name, FieldType _ tipe) =
223+ (name, tipe)
224+ in
225+ map dropIndex (List.sortOn getIndex (Map.toList fields))
195
226
196
227
197
228
@@ -201,27 +232,32 @@ data AliasType
201data Module =
232data Module =
202 Module
233 Module
203 { _name :: ModuleName.Canonical
234 { _name :: ModuleName.Canonical
204− , _docs :: Docs
205 , _exports :: Exports
235 , _exports :: Exports
236+ , _docs :: Src.Docs
206 , _decls :: Decls
237 , _decls :: Decls
207− , _unions :: Map.Map N.Name Union
238+ , _unions :: Map.Map Name Union
208− , _aliases :: Map.Map N.Name Alias
239+ , _aliases :: Map.Map Name Alias
209− , _binops :: Map.Map N.Name Binop
240+ , _binops :: Map.Map Name Binop
210 , _effects :: Effects
241 , _effects :: Effects
211 }
242 }
212
243
213
244
214−data Alias = Alias [N.Name] Type (Maybe [(N.Name,Type)])
245+data Alias = Alias [Name] Type
246+ deriving (Eq)
247+
248+
215−data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name
249+data Binop = Binop_ Binop.Associativity Binop.Precedence Name
250+ deriving (Eq)
216
251
217
252
218data Union =
253data Union =
219 Union
254 Union
220− { _u_vars :: [N.Name]
255+ { _u_vars :: [Name]
221 , _u_alts :: [Ctor]
256 , _u_alts :: [Ctor]
222 , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking
257 , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking
223 , _u_opts :: CtorOpts -- CACHE which optimizations are available
258 , _u_opts :: CtorOpts -- CACHE which optimizations are available
224 }
259 }
260+ deriving (Eq)
225
261
226
262
227data CtorOpts
263data CtorOpts
@@ -231,21 +267,8 @@ data CtorOpts
231 deriving (Eq, Ord)
267 deriving (Eq, Ord)
232
268
233
269
234−data Ctor =
235− Ctor N.Name Index.ZeroBased Int [Type] -- CACHE length args
270+data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
236−
271+ deriving (Eq)
237−
238−
239−-- DOCS
240−
241−
242−data Docs
243− = NoDocs R.Region
244− | YesDocs
245− { _region :: R.Region
246− , _overview :: B.ByteString
247− , _comments :: Map.Map N.Name Text
248− }
249
272
250
273
251
274
@@ -253,8 +276,8 @@ data Docs
253
276
254
277
255data Exports
278data Exports
256− = ExportEverything R.Region
279+ = ExportEverything A.Region
257− | Export (Map.Map N.Name (A.Located Export))
280+ | Export (Map.Map Name (A.Located Export))
258
281
259
282
260data Export
283data Export
@@ -272,8 +295,8 @@ data Export
272
295
273data Effects
296data Effects
274 = NoEffects
297 = NoEffects
275− | Ports (Map.Map N.Name Port)
298+ | Ports (Map.Map Name Port)
276− | Manager R.Region R.Region R.Region Manager
299+ | Manager A.Region A.Region A.Region Manager
277
300
278
301
279data Port
302data Port
@@ -282,9 +305,9 @@ data Port
282
305
283
306
284data Manager
307data Manager
285− = Cmd N.Name
308+ = Cmd Name
286− | Sub N.Name
309+ | Sub Name
287− | Fx N.Name N.Name
310+ | Fx Name Name
288
311
289
312
290
313
@@ -292,8 +315,8 @@ data Manager
292
315
293
316
294instance Binary Alias where
317instance Binary Alias where
295− get = liftM3 Alias get get get
318+ get = liftM2 Alias get get
296− put (Alias a b c) = put a >> put b >> put c
319+ put (Alias a b) = put a >> put b
297
320
298
321
299instance Binary Union where
322instance Binary Union where
@@ -319,7 +342,7 @@ instance Binary CtorOpts where
319 0 -> return Normal
342 0 -> return Normal
320 1 -> return Enum
343 1 -> return Enum
321 2 -> return Unbox
344 2 -> return Unbox
322− _ -> error "binary encoding of CtorOpts was corrupted"
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
323
346
324
347
325instance Binary Annotation where
348instance Binary Annotation where
@@ -370,4 +393,9 @@ instance Binary AliasType where
370 case n of
393 case n of
371 0 -> liftM Holey get
394 0 -> liftM Holey get
372 1 -> liftM Filled get
395 1 -> liftM Filled get
373− _ -> error "binary encoding of AliasType was corrupted"
396+ _ -> fail "binary encoding of AliasType was corrupted"
397+
398+
399+instance Binary FieldType where
400+ get = liftM2 FieldType get get
401+ put (FieldType a b) = put a >> put b
src/AST/Optimized.hs → compiler/src/AST/Optimized.hsrenamed+150−113
@@ -3,35 +3,41 @@ module AST.Optimized
3 ( Def(..)
3 ( Def(..)
4 , Expr(..)
4 , Expr(..)
5 , Global(..)
5 , Global(..)
6− , kernel
7 , Path(..)
6 , Path(..)
8 , Destructor(..)
7 , Destructor(..)
9 , Decider(..)
8 , Decider(..)
10 , Choice(..)
9 , Choice(..)
11− , Graph(..)
10+ , GlobalGraph(..)
11+ , LocalGraph(..)
12 , Main(..)
12 , Main(..)
13 , Node(..)
13 , Node(..)
14 , EffectsType(..)
14 , EffectsType(..)
15− , KContent(..)
15+ , empty
16− , KChunk(..)
16+ , addGlobalGraph
17+ , addLocalGraph
18+ , addKernel
19+ , toKernelGlobal
17 )
20 )
18 where
21 where
19
22
20
23
21import Control.Monad (liftM, liftM2, liftM3, liftM4)
24import Control.Monad (liftM, liftM2, liftM3, liftM4)
22−import Data.Binary
25+import Data.Binary (Binary, get, put, getWord8, putWord8)
23−import qualified Data.ByteString as BS
24import qualified Data.Map as Map
26import qualified Data.Map as Map
27+import qualified Data.Name as Name
28+import Data.Name (Name)
25import qualified Data.Set as Set
29import qualified Data.Set as Set
26−import Data.Text (Text)
27
30
28import qualified AST.Canonical as Can
31import qualified AST.Canonical as Can
29−import qualified AST.Module.Name as ModuleName
32+import qualified AST.Utils.Shader as Shader
30import qualified Data.Index as Index
33import qualified Data.Index as Index
31−import qualified Elm.Name as N
34+import qualified Elm.Float as EF
35+import qualified Elm.Kernel as K
36+import qualified Elm.ModuleName as ModuleName
32import qualified Elm.Package as Pkg
37import qualified Elm.Package as Pkg
38+import qualified Elm.String as ES
33import qualified Optimize.DecisionTree as DT
39import qualified Optimize.DecisionTree as DT
34−import qualified Reporting.Region as R
40+import qualified Reporting.Annotation as A
35
41
36
42
37
43
@@ -40,43 +46,35 @@ import qualified Reporting.Region as R
40
46
41data Expr
47data Expr
42 = Bool Bool
48 = Bool Bool
43− | Chr Text
49+ | Chr ES.String
44− | Str Text
50+ | Str ES.String
45 | Int Int
51 | Int Int
46− | Float Double
52+ | Float EF.Float
47− | VarLocal N.Name
53+ | VarLocal Name
48 | VarGlobal Global
54 | VarGlobal Global
49 | VarEnum Global Index.ZeroBased
55 | VarEnum Global Index.ZeroBased
50 | VarBox Global
56 | VarBox Global
51− | VarCycle ModuleName.Canonical N.Name
57+ | VarCycle ModuleName.Canonical Name
52− | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)
58+ | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
53− | VarKernel N.Name N.Name
59+ | VarKernel Name Name
54 | List [Expr]
60 | List [Expr]
55− | Function [N.Name] Expr
61+ | Function [Name] Expr
56 | Call Expr [Expr]
62 | Call Expr [Expr]
57− | TailCall N.Name [(N.Name, Expr)]
63+ | TailCall Name [(Name, Expr)]
58 | If [(Expr, Expr)] Expr
64 | If [(Expr, Expr)] Expr
59 | Let Def Expr
65 | Let Def Expr
60 | Destruct Destructor Expr
66 | Destruct Destructor Expr
61− | Case N.Name N.Name (Decider Choice) [(Int, Expr)]
67+ | Case Name Name (Decider Choice) [(Int, Expr)]
62− | Accessor N.Name
68+ | Accessor Name
63− | Access Expr N.Name
69+ | Access Expr Name
64− | Update Expr (Map.Map N.Name Expr)
70+ | Update Expr (Map.Map Name Expr)
65− | Record (Map.Map N.Name Expr)
71+ | Record (Map.Map Name Expr)
66 | Unit
72 | Unit
67 | Tuple Expr Expr (Maybe Expr)
73 | Tuple Expr Expr (Maybe Expr)
68− | Shader Text
74+ | Shader Shader.Source (Set.Set Name) (Set.Set Name)
69
75
70
76
71−data Global = Global ModuleName.Canonical N.Name
77+data Global = Global ModuleName.Canonical Name
72− deriving (Eq, Ord)
73−
74−
75−-- Provide "List" not "Elm.Kernel.List"
76−--
77−kernel :: N.Name -> Global
78−kernel home =
79− Global (ModuleName.Canonical Pkg.kernel home) N.dollar
80
78
81
79
82
80
@@ -84,19 +82,19 @@ kernel home =
84
82
85
83
86data Def
84data Def
87− = Def N.Name Expr
85+ = Def Name Expr
88− | TailDef N.Name [N.Name] Expr
86+ | TailDef Name [Name] Expr
89
87
90
88
91data Destructor =
89data Destructor =
92− Destructor N.Name Path
90+ Destructor Name Path
93
91
94
92
95data Path
93data Path
96 = Index Index.ZeroBased Path
94 = Index Index.ZeroBased Path
97− | Field N.Name Path
95+ | Field Name Path
98 | Unbox Path
96 | Unbox Path
99− | Root N.Name
97+ | Root Name
100
98
101
99
102
100
@@ -127,11 +125,18 @@ data Choice
127-- OBJECT GRAPH
125-- OBJECT GRAPH
128
126
129
127
130−data Graph =
128+data GlobalGraph =
131− Graph
129+ GlobalGraph
132− { _mains :: Map.Map ModuleName.Canonical Main
130+ { _g_nodes :: Map.Map Global Node
131+ , _g_fields :: Map.Map Name Int
132+ }
133+
134+
135+data LocalGraph =
136+ LocalGraph
137+ { _l_main :: Maybe Main
133− , _nodes :: Map.Map Global Node
138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
134− , _fields :: Map.Map N.Name Int
139+ , _l_fields :: Map.Map Name Int
135 }
140 }
136
141
137
142
@@ -145,14 +150,14 @@ data Main
145
150
146data Node
151data Node
147 = Define Expr (Set.Set Global)
152 = Define Expr (Set.Set Global)
148− | DefineTailFunc [N.Name] Expr (Set.Set Global)
153+ | DefineTailFunc [Name] Expr (Set.Set Global)
149− | Ctor N.Name Index.ZeroBased Int
154+ | Ctor Index.ZeroBased Int
150− | Enum N.Name Index.ZeroBased
155+ | Enum Index.ZeroBased
151− | Box N.Name
156+ | Box
152 | Link Global
157 | Link Global
153− | Cycle [(N.Name, Expr)] (Set.Set Global)
158+ | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
154 | Manager EffectsType
159 | Manager EffectsType
155− | Kernel KContent (Maybe KContent)
160+ | Kernel [K.Chunk] (Set.Set Global)
156 | PortIncoming Expr (Set.Set Global)
161 | PortIncoming Expr (Set.Set Global)
157 | PortOutgoing Expr (Set.Set Global)
162 | PortOutgoing Expr (Set.Set Global)
158
163
@@ -160,19 +165,77 @@ data Node
160data EffectsType = Cmd | Sub | Fx
165data EffectsType = Cmd | Sub | Fx
161
166
162
167
163−data KContent =
164− KContent [KChunk] (Set.Set Global)
165
168
169+-- GRAPHS
170+
171+
172+{-# NOINLINE empty #-}
173+empty :: GlobalGraph
174+empty =
175+ GlobalGraph Map.empty Map.empty
176+
177+
178+addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph
179+addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) =
180+ GlobalGraph
181+ { _g_nodes = Map.union nodes1 nodes2
182+ , _g_fields = Map.union fields1 fields2
183+ }
184+
185+
186+addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph
187+addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) =
188+ GlobalGraph
189+ { _g_nodes = Map.union nodes1 nodes2
190+ , _g_fields = Map.union fields1 fields2
191+ }
192+
193+
194+addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph
195+addKernel shortName chunks (GlobalGraph nodes fields) =
196+ let
197+ global = toKernelGlobal shortName
198+ node = Kernel chunks (foldr addKernelDep Set.empty chunks)
199+ in
200+ GlobalGraph
201+ { _g_nodes = Map.insert global node nodes
202+ , _g_fields = Map.union (K.countFields chunks) fields
203+ }
204+
205+
206+addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global
207+addKernelDep chunk deps =
208+ case chunk of
209+ K.JS _ -> deps
210+ K.ElmVar home name -> Set.insert (Global home name) deps
211+ K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps
212+ K.ElmField _ -> deps
213+ K.JsField _ -> deps
214+ K.JsEnum _ -> deps
215+ K.Debug -> deps
216+ K.Prod -> deps
217+
218+
219+toKernelGlobal :: Name.Name -> Global
220+toKernelGlobal shortName =
221+ Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar
222+
223+
224+
225+-- INSTANCES
166
226
167−data KChunk
227+
168− = JS BS.ByteString
228+instance Eq Global where
169− | ElmVar ModuleName.Canonical N.Name
229+ (==) (Global home1 name1) (Global home2 name2) =
170− | JsVar N.Name N.Name
230+ name1 == name2 && home1 == home2
171− | ElmField N.Name
231+
172− | JsField Int
232+
173− | JsEnum Int
233+instance Ord Global where
174− | Debug
234+ compare (Global home1 name1) (Global home2 name2) =
175− | Prod
235+ case compare name1 name2 of
236+ LT -> LT
237+ EQ -> compare home1 home2
238+ GT -> GT
176
239
177
240
178
241
@@ -213,7 +276,7 @@ instance Binary Expr where
213 Record a -> putWord8 23 >> put a
276 Record a -> putWord8 23 >> put a
214 Unit -> putWord8 24
277 Unit -> putWord8 24
215 Tuple a b c -> putWord8 25 >> put a >> put b >> put c
278 Tuple a b c -> putWord8 25 >> put a >> put b >> put c
216− Shader a -> putWord8 26 >> put a
279+ Shader a b c -> putWord8 26 >> put a >> put b >> put c
217
280
218 get =
281 get =
219 do word <- getWord8
282 do word <- getWord8
@@ -244,8 +307,8 @@ instance Binary Expr where
244 23 -> liftM Record get
307 23 -> liftM Record get
245 24 -> pure Unit
308 24 -> pure Unit
246 25 -> liftM3 Tuple get get get
309 25 -> liftM3 Tuple get get get
247− 26 -> liftM Shader get
310+ 26 -> liftM3 Shader get get get
248− _ -> error "problem getting Opt.Expr binary"
311+ _ -> fail "problem getting Opt.Expr binary"
249
312
250
313
251instance Binary Def where
314instance Binary Def where
@@ -259,7 +322,7 @@ instance Binary Def where
259 case word of
322 case word of
260 0 -> liftM2 Def get get
323 0 -> liftM2 Def get get
261 1 -> liftM3 TailDef get get get
324 1 -> liftM3 TailDef get get get
262− _ -> error "problem getting Opt.Def binary"
325+ _ -> fail "problem getting Opt.Def binary"
263
326
264
327
265instance Binary Destructor where
328instance Binary Destructor where
@@ -282,7 +345,7 @@ instance Binary Path where
282 1 -> liftM2 Field get get
345 1 -> liftM2 Field get get
283 2 -> liftM Unbox get
346 2 -> liftM Unbox get
284 3 -> liftM Root get
347 3 -> liftM Root get
285− _ -> error "problem getting Opt.Path binary"
348+ _ -> fail "problem getting Opt.Path binary"
286
349
287
350
288instance (Binary a) => Binary (Decider a) where
351instance (Binary a) => Binary (Decider a) where
@@ -298,7 +361,7 @@ instance (Binary a) => Binary (Decider a) where
298 0 -> liftM Leaf get
361 0 -> liftM Leaf get
299 1 -> liftM3 Chain get get get
362 1 -> liftM3 Chain get get get
300 2 -> liftM3 FanOut get get get
363 2 -> liftM3 FanOut get get get
301− _ -> error "problem getting Opt.Decider binary"
364+ _ -> fail "problem getting Opt.Decider binary"
302
365
303
366
304instance Binary Choice where
367instance Binary Choice where
@@ -312,13 +375,18 @@ instance Binary Choice where
312 case word of
375 case word of
313 0 -> liftM Inline get
376 0 -> liftM Inline get
314 1 -> liftM Jump get
377 1 -> liftM Jump get
315− _ -> error "problem getting Opt.Choice binary"
378+ _ -> fail "problem getting Opt.Choice binary"
379+
316
380
317
381
382+instance Binary GlobalGraph where
383+ get = liftM2 GlobalGraph get get
384+ put (GlobalGraph a b) = put a >> put b
318
385
386+
319−instance Binary Graph where
387+instance Binary LocalGraph where
320− get = liftM3 Graph get get get
388+ get = liftM3 LocalGraph get get get
321− put (Graph a b c) = put a >> put b >> put c
389+ put (LocalGraph a b c) = put a >> put b >> put c
322
390
323
391
324instance Binary Main where
392instance Binary Main where
@@ -332,7 +400,7 @@ instance Binary Main where
332 case word of
400 case word of
333 0 -> return Static
401 0 -> return Static
334 1 -> liftM2 Dynamic get get
402 1 -> liftM2 Dynamic get get
335− _ -> error "problem getting Opt.Main binary"
403+ _ -> fail "problem getting Opt.Main binary"
336
404
337
405
338instance Binary Node where
406instance Binary Node where
@@ -340,11 +408,11 @@ instance Binary Node where
340 case node of
408 case node of
341 Define a b -> putWord8 0 >> put a >> put b
409 Define a b -> putWord8 0 >> put a >> put b
342 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
410 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
343− Ctor a b c -> putWord8 2 >> put a >> put b >> put c
411+ Ctor a b -> putWord8 2 >> put a >> put b
344− Enum a b -> putWord8 3 >> put a >> put b
412+ Enum a -> putWord8 3 >> put a
345− Box a -> putWord8 4 >> put a
413+ Box -> putWord8 4
346 Link a -> putWord8 5 >> put a
414 Link a -> putWord8 5 >> put a
347− Cycle a b -> putWord8 6 >> put a >> put b
415+ Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d
348 Manager a -> putWord8 7 >> put a
416 Manager a -> putWord8 7 >> put a
349 Kernel a b -> putWord8 8 >> put a >> put b
417 Kernel a b -> putWord8 8 >> put a >> put b
350 PortIncoming a b -> putWord8 9 >> put a >> put b
418 PortIncoming a b -> putWord8 9 >> put a >> put b
@@ -355,16 +423,16 @@ instance Binary Node where
355 case word of
423 case word of
356 0 -> liftM2 Define get get
424 0 -> liftM2 Define get get
357 1 -> liftM3 DefineTailFunc get get get
425 1 -> liftM3 DefineTailFunc get get get
358− 2 -> liftM3 Ctor get get get
426+ 2 -> liftM2 Ctor get get
359− 3 -> liftM2 Enum get get
427+ 3 -> liftM Enum get
360− 4 -> liftM Box get
428+ 4 -> return Box
361 5 -> liftM Link get
429 5 -> liftM Link get
362− 6 -> liftM2 Cycle get get
430+ 6 -> liftM4 Cycle get get get get
363 7 -> liftM Manager get
431 7 -> liftM Manager get
364 8 -> liftM2 Kernel get get
432 8 -> liftM2 Kernel get get
365 9 -> liftM2 PortIncoming get get
433 9 -> liftM2 PortIncoming get get
366 10 -> liftM2 PortOutgoing get get
434 10 -> liftM2 PortOutgoing get get
367− _ -> error "problem getting Opt.Node binary"
435+ _ -> fail "problem getting Opt.Node binary"
368
436
369
437
370instance Binary EffectsType where
438instance Binary EffectsType where
@@ -380,35 +448,4 @@ instance Binary EffectsType where
380 0 -> return Cmd
448 0 -> return Cmd
381 1 -> return Sub
449 1 -> return Sub
382 2 -> return Fx
450 2 -> return Fx
383− _ -> error "problem getting Opt.EffectsType binary"
451+ _ -> fail "problem getting Opt.EffectsType binary"
384−
385−
386−instance Binary KContent where
387− get = liftM2 KContent get get
388− put (KContent a b) = put a >> put b
389−
390−
391−instance Binary KChunk where
392− put chunk =
393− case chunk of
394− JS a -> putWord8 0 >> put a
395− ElmVar a b -> putWord8 1 >> put a >> put b
396− JsVar a b -> putWord8 2 >> put a >> put b
397− ElmField a -> putWord8 3 >> put a
398− JsField a -> putWord8 4 >> put a
399− JsEnum a -> putWord8 5 >> put a
400− Debug -> putWord8 6
401− Prod -> putWord8 7
402−
403− get =
404− do word <- getWord8
405− case word of
406− 0 -> liftM JS get
407− 1 -> liftM2 ElmVar get get
408− 2 -> liftM2 JsVar get get
409− 3 -> liftM ElmField get
410− 4 -> liftM JsField get
411− 5 -> liftM JsEnum get
412− 6 -> return Debug
413− 7 -> return Prod
414− _ -> error "problem deserializing AST.Optimized.KChunk"
compiler/src/AST/Source.hsnew file+209
@@ -0,0 +1,209 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Source
3+ ( Expr, Expr_(..), VarType(..)
4+ , Def(..)
5+ , Pattern, Pattern_(..)
6+ , Type, Type_(..)
7+ , Module(..)
8+ , getName
9+ , getImportName
10+ , Import(..)
11+ , Value(..)
12+ , Union(..)
13+ , Alias(..)
14+ , Infix(..)
15+ , Port(..)
16+ , Effects(..)
17+ , Manager(..)
18+ , Docs(..)
19+ , Comment(..)
20+ , Exposing(..)
21+ , Exposed(..)
22+ , Privacy(..)
23+ )
24+ where
25+
26+
27+import Data.Name (Name)
28+import qualified Data.Name as Name
29+
30+import qualified AST.Utils.Binop as Binop
31+import 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
35+import qualified Reporting.Annotation as A
36+
37+
38+
39+-- EXPRESSIONS
40+
41+
42+type Expr = A.Located Expr_
43+
44+
45+data Expr_
46+ = Chr ES.String
47+ | Str ES.String
48+ | Int Int
49+ | Float EF.Float
50+ | Var VarType Name
51+ | VarQual VarType Name Name
52+ | List [Expr]
53+ | Op Name
54+ | Negate Expr
55+ | Binops [(Expr, A.Located Name)] Expr
56+ | Lambda [Pattern] Expr
57+ | Call Expr [Expr]
58+ | If [(Expr, Expr)] Expr
59+ | Let [A.Located Def] Expr
60+ | Case Expr [(Pattern, Expr)]
61+ | Accessor Name
62+ | Access Expr (A.Located Name)
63+ | Update (A.Located Name) [(A.Located Name, Expr)]
64+ | Record [(A.Located Name, Expr)]
65+ | Unit
66+ | Tuple Expr Expr [Expr]
67+ | Shader Shader.Source Shader.Types
68+
69+
70+data VarType = LowVar | CapVar
71+
72+
73+
74+-- DEFINITIONS
75+
76+
77+data Def
78+ = Define (A.Located Name) [Pattern] Expr (Maybe Type)
79+ | Destruct Pattern Expr
80+
81+
82+
83+-- PATTERN
84+
85+
86+type Pattern = A.Located Pattern_
87+
88+
89+data Pattern_
90+ = PAnything
91+ | PVar Name
92+ | PRecord [A.Located Name]
93+ | PAlias Pattern (A.Located Name)
94+ | PUnit
95+ | PTuple Pattern Pattern [Pattern]
96+ | PCtor A.Region Name [Pattern]
97+ | PCtorQual A.Region Name Name [Pattern]
98+ | PList [Pattern]
99+ | PCons Pattern Pattern
100+ | PChr ES.String
101+ | PStr ES.String
102+ | PInt Int
103+
104+
105+
106+-- TYPE
107+
108+
109+type Type =
110+ A.Located Type_
111+
112+
113+data Type_
114+ = TLambda Type Type
115+ | TVar Name
116+ | TType A.Region Name [Type]
117+ | TTypeQual A.Region Name Name [Type]
118+ | TRecord [(A.Located Name, Type)] (Maybe (A.Located Name))
119+ | TUnit
120+ | TTuple Type Type [Type]
121+
122+
123+
124+-- MODULE
125+
126+
127+data Module =
128+ Module
129+ { _name :: Maybe (A.Located Name)
130+ , _exports :: A.Located Exposing
131+ , _docs :: Docs
132+ , _imports :: [Import]
133+ , _values :: [A.Located Value]
134+ , _unions :: [A.Located Union]
135+ , _aliases :: [A.Located Alias]
136+ , _binops :: [A.Located Infix]
137+ , _effects :: Effects
138+ }
139+
140+
141+getName :: Module -> Name
142+getName (Module maybeName _ _ _ _ _ _ _ _) =
143+ case maybeName of
144+ Just (A.At _ name) ->
145+ name
146+
147+ Nothing ->
148+ Name._Main
149+
150+
151+getImportName :: Import -> Name
152+getImportName (Import (A.At _ name) _ _) =
153+ name
154+
155+
156+data Import =
157+ Import
158+ { _import :: A.Located Name
159+ , _alias :: Maybe Name
160+ , _exposing :: Exposing
161+ }
162+
163+
164+data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
165+data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
166+data Alias = Alias (A.Located Name) [A.Located Name] Type
167+data Infix = Infix Name Binop.Associativity Binop.Precedence Name
168+data Port = Port (A.Located Name) Type
169+
170+
171+data Effects
172+ = NoEffects
173+ | Ports [Port]
174+ | Manager A.Region Manager
175+
176+
177+data Manager
178+ = Cmd (A.Located Name)
179+ | Sub (A.Located Name)
180+ | Fx (A.Located Name) (A.Located Name)
181+
182+
183+data Docs
184+ = NoDocs A.Region
185+ | YesDocs Comment [(Name, Comment)]
186+
187+
188+newtype Comment =
189+ Comment P.Snippet
190+
191+
192+
193+-- EXPOSING
194+
195+
196+data Exposing
197+ = Open
198+ | Explicit [Exposed]
199+
200+
201+data Exposed
202+ = Lower (A.Located Name)
203+ | Upper (A.Located Name) Privacy
204+ | Operator A.Region Name
205+
206+
207+data Privacy
208+ = Public A.Region
209+ | Private
src/AST/Utils/Binop.hs → compiler/src/AST/Utils/Binop.hsrenamed+5−6
@@ -41,12 +41,11 @@ instance Binary Precedence where
41instance Binary Associativity where
41instance Binary Associativity where
42 get =
42 get =
43 do n <- getWord8
43 do n <- getWord8
44− return $
45− case n of
44+ case n of
46− 0 -> Left
45+ 0 -> return Left
47− 1 -> Non
46+ 1 -> return Non
48− 2 -> Right
47+ 2 -> return Right
49− _ -> error "Error reading valid associativity from serialized string"
48+ _ -> fail "Error reading valid associativity from serialized string"
50
49
51 put assoc =
50 put assoc =
52 putWord8 $
51 putWord8 $
compiler/src/AST/Utils/Shader.hsnew file+91
@@ -0,0 +1,91 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+module AST.Utils.Shader
4+ ( Source
5+ , Types(..)
6+ , Type(..)
7+ , fromChars
8+ , toJsStringBuilder
9+ )
10+ where
11+
12+
13+import Control.Monad (liftM)
14+import Data.Binary (Binary, get, put)
15+import qualified Data.ByteString as BS
16+import qualified Data.ByteString.Builder as B
17+import qualified Data.ByteString.UTF8 as BS_UTF8
18+import qualified Data.Map as Map
19+import qualified Data.Name as Name
20+
21+
22+
23+-- SOURCE
24+
25+
26+newtype Source =
27+ Source BS.ByteString
28+
29+
30+
31+-- TYPES
32+
33+
34+data Types =
35+ Types
36+ { _attribute :: Map.Map Name.Name Type
37+ , _uniform :: Map.Map Name.Name Type
38+ , _varying :: Map.Map Name.Name Type
39+ }
40+
41+
42+data Type
43+ = Int
44+ | Float
45+ | V2
46+ | V3
47+ | V4
48+ | M4
49+ | Texture
50+
51+
52+
53+-- TO BUILDER
54+
55+
56+toJsStringBuilder :: Source -> B.Builder
57+toJsStringBuilder (Source src) =
58+ B.byteString src
59+
60+
61+
62+-- FROM CHARS
63+
64+
65+fromChars :: [Char] -> Source
66+fromChars chars =
67+ Source (BS_UTF8.fromString (escape chars))
68+
69+
70+escape :: [Char] -> [Char]
71+escape chars =
72+ case chars of
73+ [] ->
74+ []
75+
76+ c:cs
77+ | c == '\r' -> escape cs
78+ | c == '\n' -> '\\' : 'n' : escape cs
79+ | c == '\"' -> '\\' : '"' : escape cs
80+ | c == '\'' -> '\\' : '\'' : escape cs
81+ | c == '\\' -> '\\' : '\\' : escape cs
82+ | otherwise -> c : escape cs
83+
84+
85+
86+-- BINARY
87+
88+
89+instance Binary Source where
90+ get = liftM Source get
91+ put (Source a) = put a
src/AST/Utils/Type.hs → compiler/src/AST/Utils/Type.hsrenamed+16−7
@@ -1,5 +1,4 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3module AST.Utils.Type
2module AST.Utils.Type
4 ( delambda
3 ( delambda
5 , dealias
4 , dealias
@@ -10,9 +9,9 @@ module AST.Utils.Type
10
9
11
10
12import qualified Data.Map as Map
11import qualified Data.Map as Map
12+import qualified Data.Name as Name
13
13
14−import AST.Canonical (Type(..), AliasType(..))
14+import AST.Canonical (Type(..), AliasType(..), FieldType(..))
15−import qualified Elm.Name as N
16
15
17
16
18
17
@@ -33,7 +32,7 @@ delambda tipe =
33-- DEALIAS
32-- DEALIAS
34
33
35
34
36−dealias :: [(N.Name, Type)] -> AliasType -> Type
35+dealias :: [(Name.Name, Type)] -> AliasType -> Type
37dealias args aliasType =
36dealias args aliasType =
38 case aliasType of
37 case aliasType of
39 Holey tipe ->
38 Holey tipe ->
@@ -43,7 +42,7 @@ dealias args aliasType =
43 tipe
42 tipe
44
43
45
44
46−dealiasHelp :: Map.Map N.Name Type -> Type -> Type
45+dealiasHelp :: Map.Map Name.Name Type -> Type -> Type
47dealiasHelp typeTable tipe =
46dealiasHelp typeTable tipe =
48 case tipe of
47 case tipe of
49 TLambda a b ->
48 TLambda a b ->
@@ -55,7 +54,7 @@ dealiasHelp typeTable tipe =
55 Map.findWithDefault tipe x typeTable
54 Map.findWithDefault tipe x typeTable
56
55
57 TRecord fields ext ->
56 TRecord fields ext ->
58− TRecord (Map.map (dealiasHelp typeTable) fields) ext
57+ TRecord (Map.map (dealiasField typeTable) fields) ext
59
58
60 TAlias home name args t' ->
59 TAlias home name args t' ->
61 TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'
60 TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'
@@ -73,6 +72,11 @@ dealiasHelp typeTable tipe =
73 (fmap (dealiasHelp typeTable) maybeC)
72 (fmap (dealiasHelp typeTable) maybeC)
74
73
75
74
75+dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType
76+dealiasField typeTable (FieldType index tipe) =
77+ FieldType index (dealiasHelp typeTable tipe)
78+
79+
76
80
77-- DEEP DEALIAS
81-- DEEP DEALIAS
78
82
@@ -87,7 +91,7 @@ deepDealias tipe =
87 tipe
91 tipe
88
92
89 TRecord fields ext ->
93 TRecord fields ext ->
90− TRecord (Map.map deepDealias fields) ext
94+ TRecord (Map.map deepDealiasField fields) ext
91
95
92 TAlias _ _ args tipe' ->
96 TAlias _ _ args tipe' ->
93 deepDealias (dealias args tipe')
97 deepDealias (dealias args tipe')
@@ -102,6 +106,11 @@ deepDealias tipe =
102 TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)
106 TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)
103
107
104
108
109+deepDealiasField :: FieldType -> FieldType
110+deepDealiasField (FieldType index tipe) =
111+ FieldType index (deepDealias tipe)
112+
113+
105
114
106-- ITERATED DEALIAS
115-- ITERATED DEALIAS
107
116
src/Canonicalize/Effects.hs → compiler/src/Canonicalize/Effects.hsrenamed+42−38
@@ -8,17 +8,16 @@ module Canonicalize.Effects
8
8
9import qualified Data.Foldable as F
9import qualified Data.Foldable as F
10import qualified Data.Map as Map
10import qualified Data.Map as Map
11+import qualified Data.Name as Name
11
12
12import qualified AST.Canonical as Can
13import qualified AST.Canonical as Can
13−import qualified AST.Valid as Valid
14+import qualified AST.Source as Src
14−import qualified AST.Module.Name as ModuleName
15import qualified AST.Utils.Type as Type
15import qualified AST.Utils.Type as Type
16import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Type as Type
17import qualified Canonicalize.Type as Type
18−import qualified Elm.Name as N
18+import qualified Elm.ModuleName as ModuleName
19import qualified Reporting.Annotation as A
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Canonicalize as Error
20import qualified Reporting.Error.Canonicalize as Error
21−import qualified Reporting.Region as R
22import qualified Reporting.Result as Result
21import qualified Reporting.Result as Result
23
22
24
23
@@ -36,38 +35,38 @@ type Result i w a =
36
35
37canonicalize
36canonicalize
38 :: Env.Env
37 :: Env.Env
39− -> [A.Located Valid.Decl]
38+ -> [A.Located Src.Value]
40− -> Map.Map N.Name union
39+ -> Map.Map Name.Name union
41− -> Valid.Effects
40+ -> Src.Effects
42 -> Result i w Can.Effects
41 -> Result i w Can.Effects
43−canonicalize env decls unions effects =
42+canonicalize env values unions effects =
44 case effects of
43 case effects of
45− Valid.NoEffects ->
44+ Src.NoEffects ->
46 Result.ok Can.NoEffects
45 Result.ok Can.NoEffects
47
46
48− Valid.Ports ports ->
47+ Src.Ports ports ->
49 do pairs <- traverse (canonicalizePort env) ports
48 do pairs <- traverse (canonicalizePort env) ports
50 return $ Can.Ports (Map.fromList pairs)
49 return $ Can.Ports (Map.fromList pairs)
51
50
52− Valid.Manager region manager ->
51+ Src.Manager region manager ->
53− let dict = Map.fromList (map toNameRegion decls) in
52+ let dict = Map.fromList (map toNameRegion values) in
54 Can.Manager
53 Can.Manager
55 <$> verifyManager region dict "init"
54 <$> verifyManager region dict "init"
56 <*> verifyManager region dict "onEffects"
55 <*> verifyManager region dict "onEffects"
57 <*> verifyManager region dict "onSelfMsg"
56 <*> verifyManager region dict "onSelfMsg"
58 <*>
57 <*>
59 case manager of
58 case manager of
60− Valid.Cmd cmdType ->
59+ Src.Cmd cmdType ->
61 Can.Cmd
60 Can.Cmd
62 <$> verifyEffectType cmdType unions
61 <$> verifyEffectType cmdType unions
63 <* verifyManager region dict "cmdMap"
62 <* verifyManager region dict "cmdMap"
64
63
65− Valid.Sub subType ->
64+ Src.Sub subType ->
66 Can.Sub
65 Can.Sub
67 <$> verifyEffectType subType unions
66 <$> verifyEffectType subType unions
68 <* verifyManager region dict "subMap"
67 <* verifyManager region dict "subMap"
69
68
70− Valid.Fx cmdType subType ->
69+ Src.Fx cmdType subType ->
71 Can.Fx
70 Can.Fx
72 <$> verifyEffectType cmdType unions
71 <$> verifyEffectType cmdType unions
73 <*> verifyEffectType subType unions
72 <*> verifyEffectType subType unions
@@ -79,12 +78,12 @@ canonicalize env decls unions effects =
79-- CANONICALIZE PORT
78-- CANONICALIZE PORT
80
79
81
80
82−canonicalizePort :: Env.Env -> Valid.Port -> Result i w (N.Name, Can.Port)
81+canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port)
83−canonicalizePort env (Valid.Port (A.At region portName) tipe) =
82+canonicalizePort env (Src.Port (A.At region portName) tipe) =
84 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
83 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
85 case reverse (Type.delambda (Type.deepDealias ctipe)) of
84 case reverse (Type.delambda (Type.deepDealias ctipe)) of
86 Can.TType home name [msg] : revArgs
85 Can.TType home name [msg] : revArgs
87− | home == ModuleName.cmd && name == N.cmd ->
86+ | home == ModuleName.cmd && name == Name.cmd ->
88 case revArgs of
87 case revArgs of
89 [] ->
88 [] ->
90 Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg)
89 Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg)
@@ -105,7 +104,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =
105 _ ->
104 _ ->
106 Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs)))
105 Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs)))
107
106
108− | home == ModuleName.sub && name == N.sub ->
107+ | home == ModuleName.sub && name == Name.sub ->
109 case revArgs of
108 case revArgs of
110 [Can.TLambda incomingType (Can.TVar msg1)] ->
109 [Can.TLambda incomingType (Can.TVar msg1)] ->
111 case msg of
110 case msg of
@@ -131,7 +130,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =
131-- VERIFY MANAGER
130-- VERIFY MANAGER
132
131
133
132
134−verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result i w N.Name
133+verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name
135verifyEffectType (A.At region name) unions =
134verifyEffectType (A.At region name) unions =
136 if Map.member name unions then
135 if Map.member name unions then
137 Result.ok name
136 Result.ok name
@@ -139,14 +138,14 @@ verifyEffectType (A.At region name) unions =
139 Result.throw (Error.EffectNotFound region name)
138 Result.throw (Error.EffectNotFound region name)
140
139
141
140
142−toNameRegion :: A.Located Valid.Decl -> (N.Name, R.Region)
141+toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region)
143−toNameRegion (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
142+toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) =
144 (name, region)
143 (name, region)
145
144
146
145
147−verifyManager :: R.Region -> Map.Map N.Name R.Region -> N.Name -> Result i w R.Region
146+verifyManager :: A.Region -> Map.Map Name.Name A.Region -> Name.Name -> Result i w A.Region
148−verifyManager tagRegion decls name =
147+verifyManager tagRegion values name =
149− case Map.lookup name decls of
148+ case Map.lookup name values of
150 Just region ->
149 Just region ->
151 Result.ok region
150 Result.ok region
152
151
@@ -202,46 +201,51 @@ checkPayload tipe =
202 Left (tipe, Error.ExtendedRecord)
201 Left (tipe, Error.ExtendedRecord)
203
202
204 Can.TRecord fields Nothing ->
203 Can.TRecord fields Nothing ->
205− F.traverse_ checkPayload fields
204+ F.traverse_ checkFieldPayload fields
206
205
207
206
207+checkFieldPayload :: Can.FieldType -> Either (Can.Type, Error.InvalidPayload) ()
208+checkFieldPayload (Can.FieldType _ tipe) =
209+ checkPayload tipe
210+
211+
208−isIntFloatBool :: ModuleName.Canonical -> N.Name -> Bool
212+isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool
209isIntFloatBool home name =
213isIntFloatBool home name =
210 home == ModuleName.basics
214 home == ModuleName.basics
211 &&
215 &&
212− (name == N.int || name == N.float || name == N.bool)
216+ (name == Name.int || name == Name.float || name == Name.bool)
213
217
214
218
215−isString :: ModuleName.Canonical -> N.Name -> Bool
219+isString :: ModuleName.Canonical -> Name.Name -> Bool
216isString home name =
220isString home name =
217 home == ModuleName.string
221 home == ModuleName.string
218 &&
222 &&
219− name == N.string
223+ name == Name.string
220
224
221
225
222−isJson :: ModuleName.Canonical -> N.Name -> Bool
226+isJson :: ModuleName.Canonical -> Name.Name -> Bool
223isJson home name =
227isJson home name =
224 home == ModuleName.jsonEncode
228 home == ModuleName.jsonEncode
225 &&
229 &&
226− name == N.value
230+ name == Name.value
227
231
228
232
229−isList :: ModuleName.Canonical -> N.Name -> Bool
233+isList :: ModuleName.Canonical -> Name.Name -> Bool
230isList home name =
234isList home name =
231 home == ModuleName.list
235 home == ModuleName.list
232 &&
236 &&
233− name == N.list
237+ name == Name.list
234
238
235
239
236−isMaybe :: ModuleName.Canonical -> N.Name -> Bool
240+isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
237isMaybe home name =
241isMaybe home name =
238 home == ModuleName.maybe
242 home == ModuleName.maybe
239 &&
243 &&
240− name == N.maybe
244+ name == Name.maybe
241
245
242
246
243−isArray :: ModuleName.Canonical -> N.Name -> Bool
247+isArray :: ModuleName.Canonical -> Name.Name -> Bool
244isArray home name =
248isArray home name =
245 home == ModuleName.array
249 home == ModuleName.array
246 &&
250 &&
247− name == N.array
251+ name == Name.array
src/Canonicalize/Environment.hs → compiler/src/Canonicalize/Environment.hsrenamed+72−42
@@ -4,6 +4,8 @@ module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5 , Exposed
5 , Exposed
6 , Qualified
6 , Qualified
7+ , Info(..)
8+ , mergeInfo
7 , Var(..)
9 , Var(..)
8 , Type(..)
10 , Type(..)
9 , Ctor(..)
11 , Ctor(..)
@@ -20,15 +22,15 @@ module Canonicalize.Environment
20
22
21import qualified Data.Map.Merge.Strict as Map
23import qualified Data.Map.Merge.Strict as Map
22import qualified Data.Map.Strict as Map
24import qualified Data.Map.Strict as Map
23−import qualified Data.Map.Strict.Internal as I
25+import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
24
27
25import qualified AST.Utils.Binop as Binop
28import qualified AST.Utils.Binop as Binop
26import qualified AST.Canonical as Can
29import qualified AST.Canonical as Can
27−import qualified AST.Module.Name as ModuleName
28import qualified Data.Index as Index
30import qualified Data.Index as Index
29−import qualified Elm.Name as N
31+import qualified Elm.ModuleName as ModuleName
32+import qualified Reporting.Annotation as A
30import qualified Reporting.Error.Canonicalize as Error
33import qualified Reporting.Error.Canonicalize as Error
31−import qualified Reporting.Region as R
32import qualified Reporting.Result as Result
34import qualified Reporting.Result as Result
33
35
34
36
@@ -47,7 +49,7 @@ type Result i w a =
47data Env =
49data Env =
48 Env
50 Env
49 { _home :: ModuleName.Canonical
51 { _home :: ModuleName.Canonical
50− , _vars :: Map.Map N.Name Var
52+ , _vars :: Map.Map Name.Name Var
51 , _types :: Exposed Type
53 , _types :: Exposed Type
52 , _ctors :: Exposed Ctor
54 , _ctors :: Exposed Ctor
53 , _binops :: Exposed Binop
55 , _binops :: Exposed Binop
@@ -58,11 +60,34 @@ data Env =
58
60
59
61
60type Exposed a =
62type Exposed a =
61− Map.Map N.Name (Map.Map ModuleName.Canonical a)
63+ Map.Map Name.Name (Info a)
62
64
63
65
64type Qualified a =
66type Qualified a =
65− Map.Map N.Name (Map.Map N.Name (Map.Map ModuleName.Canonical a))
67+ Map.Map Name.Name (Map.Map Name.Name (Info a))
68+
69+
70+
71+-- INFO
72+
73+
74+data Info a
75+ = Specific ModuleName.Canonical a
76+ | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
77+
78+
79+mergeInfo :: Info a -> Info a -> Info a
80+mergeInfo info1 info2 =
81+ case info1 of
82+ Specific h1 _ ->
83+ case info2 of
84+ Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)
85+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)
86+
87+ Ambiguous h1 hs1 ->
88+ case info2 of
89+ Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))
90+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))
66
91
67
92
68
93
@@ -70,9 +95,10 @@ type Qualified a =
70
95
71
96
72data Var
97data Var
73− = Local R.Region
98+ = Local A.Region
74− | TopLevel R.Region
99+ | TopLevel A.Region
75− | Foreign (Map.Map ModuleName.Canonical Can.Annotation)
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
76
102
77
103
78
104
@@ -80,7 +106,7 @@ data Var
80
106
81
107
82data Type
108data Type
83− = Alias Int ModuleName.Canonical [N.Name] Can.Type
109+ = Alias Int ModuleName.Canonical [Name.Name] Can.Type
84 | Union Int ModuleName.Canonical
110 | Union Int ModuleName.Canonical
85
111
86
112
@@ -89,10 +115,10 @@ data Type
89
115
90
116
91data Ctor
117data Ctor
92− = RecordCtor ModuleName.Canonical [N.Name] Can.Type
118+ = RecordCtor ModuleName.Canonical [Name.Name] Can.Type
93 | Ctor
119 | Ctor
94 { _c_home :: ModuleName.Canonical
120 { _c_home :: ModuleName.Canonical
95− , _c_type :: N.Name
121+ , _c_type :: Name.Name
96 , _c_union :: Can.Union
122 , _c_union :: Can.Union
97 , _c_index :: Index.ZeroBased
123 , _c_index :: Index.ZeroBased
98 , _c_args :: [Can.Type]
124 , _c_args :: [Can.Type]
@@ -105,9 +131,9 @@ data Ctor
105
131
106data Binop =
132data Binop =
107 Binop
133 Binop
108− { _op :: N.Name
134+ { _op :: Name.Name
109 , _op_home :: ModuleName.Canonical
135 , _op_home :: ModuleName.Canonical
110− , _op_name :: N.Name
136+ , _op_name :: Name.Name
111 , _op_annotation :: Can.Annotation
137 , _op_annotation :: Can.Annotation
112 , _op_associativity :: Binop.Associativity
138 , _op_associativity :: Binop.Associativity
113 , _op_precedence :: Binop.Precedence
139 , _op_precedence :: Binop.Precedence
@@ -118,7 +144,7 @@ data Binop =
118-- VARIABLE -- ADD LOCALS
144-- VARIABLE -- ADD LOCALS
119
145
120
146
121−addLocals :: Map.Map N.Name R.Region -> Env -> Result i w Env
147+addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env
122addLocals names (Env home vars ts cs bs qvs qts qcs) =
148addLocals names (Env home vars ts cs bs qvs qts qcs) =
123 do newVars <-
149 do newVars <-
124 Map.mergeA
150 Map.mergeA
@@ -131,15 +157,18 @@ addLocals names (Env home vars ts cs bs qvs qts qcs) =
131 Result.ok (Env home newVars ts cs bs qvs qts qcs)
157 Result.ok (Env home newVars ts cs bs qvs qts qcs)
132
158
133
159
134−addLocalLeft :: N.Name -> R.Region -> Var
160+addLocalLeft :: Name.Name -> A.Region -> Var
135addLocalLeft _ region =
161addLocalLeft _ region =
136 Local region
162 Local region
137
163
138
164
139−addLocalBoth :: N.Name -> R.Region -> Var -> Result i w Var
165+addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
140addLocalBoth name region var =
166addLocalBoth name region var =
141 case var of
167 case var of
142− Foreign _ ->
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
143 Result.ok (Local region)
172 Result.ok (Local region)
144
173
145 Local parentRegion ->
174 Local parentRegion ->
@@ -150,32 +179,33 @@ addLocalBoth name region var =
150
179
151
180
152
181
182+
153-- FIND TYPE
183-- FIND TYPE
154
184
155
185
156−findType :: R.Region -> Env -> N.Name -> Result i w Type
186+findType :: A.Region -> Env -> Name.Name -> Result i w Type
157findType region (Env _ _ ts _ _ _ qts _) name =
187findType region (Env _ _ ts _ _ _ qts _) name =
158 case Map.lookup name ts of
188 case Map.lookup name ts of
159− Just (I.Bin 1 _ tipe _ _) ->
189+ Just (Specific _ tipe) ->
160 Result.ok tipe
190 Result.ok tipe
161
191
162− Just homes ->
192+ Just (Ambiguous h hs) ->
163− Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
164
194
165 Nothing ->
195 Nothing ->
166 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
167
197
168
198
169−findTypeQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Type
199+findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type
170findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
200findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
171 case Map.lookup prefix qts of
201 case Map.lookup prefix qts of
172 Just qualified ->
202 Just qualified ->
173 case Map.lookup name qualified of
203 case Map.lookup name qualified of
174− Just (I.Bin 1 _ tipe _ _) ->
204+ Just (Specific _ tipe) ->
175 Result.ok tipe
205 Result.ok tipe
176
206
177− Just homes ->
207+ Just (Ambiguous h hs) ->
178− Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
179
209
180 Nothing ->
210 Nothing ->
181 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
@@ -188,49 +218,49 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
188-- FIND CTOR
218-- FIND CTOR
189
219
190
220
191−findCtor :: R.Region -> Env -> N.Name -> Result i w Ctor
221+findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
192findCtor region (Env _ _ _ cs _ _ _ qcs) name =
222findCtor region (Env _ _ _ cs _ _ _ qcs) name =
193 case Map.lookup name cs of
223 case Map.lookup name cs of
194− Just (I.Bin 1 _ ctor _ _) ->
224+ Just (Specific _ ctor) ->
195 Result.ok ctor
225 Result.ok ctor
196
226
197− Just homes ->
227+ Just (Ambiguous h hs) ->
198− Result.throw (Error.AmbiguousCtor region Nothing name (Map.keys homes))
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
199
229
200 Nothing ->
230 Nothing ->
201− Result.throw (Error.NotFoundCtor region Nothing name (toPossibleNames cs qcs))
231+ Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
202
232
203
233
204−findCtorQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Ctor
234+findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor
205findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
235findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
206 case Map.lookup prefix qcs of
236 case Map.lookup prefix qcs of
207 Just qualified ->
237 Just qualified ->
208 case Map.lookup name qualified of
238 case Map.lookup name qualified of
209− Just (I.Bin 1 _ pattern _ _) ->
239+ Just (Specific _ pattern) ->
210 Result.ok pattern
240 Result.ok pattern
211
241
212− Just homes ->
242+ Just (Ambiguous h hs) ->
213− Result.throw (Error.AmbiguousCtor region (Just prefix) name (Map.keys homes))
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
214
244
215 Nothing ->
245 Nothing ->
216− Result.throw (Error.NotFoundCtor region (Just prefix) name (toPossibleNames cs qcs))
246+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
217
247
218 Nothing ->
248 Nothing ->
219− Result.throw (Error.NotFoundCtor region (Just prefix) name (toPossibleNames cs qcs))
249+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
220
250
221
251
222
252
223-- FIND BINOP
253-- FIND BINOP
224
254
225
255
226−findBinop :: R.Region -> Env -> N.Name -> Result i w Binop
256+findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
227findBinop region (Env _ _ _ _ binops _ _ _) name =
257findBinop region (Env _ _ _ _ binops _ _ _) name =
228 case Map.lookup name binops of
258 case Map.lookup name binops of
229− Just (I.Bin 1 _ binop _ _) ->
259+ Just (Specific _ binop) ->
230 Result.ok binop
260 Result.ok binop
231
261
232− Just homes ->
262+ Just (Ambiguous h hs) ->
233− Result.throw (Error.AmbiguousBinop region name (Map.keys homes))
263+ Result.throw (Error.AmbiguousBinop region name h hs)
234
264
235 Nothing ->
265 Nothing ->
236 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
src/Canonicalize/Environment/Dups.hs → compiler/src/Canonicalize/Environment/Dups.hsrenamed+27−14
@@ -3,6 +3,7 @@
3module Canonicalize.Environment.Dups
3module Canonicalize.Environment.Dups
4 ( detect
4 ( detect
5 , checkFields
5 , checkFields
6+ , checkFields'
6 , Dict
7 , Dict
7 , none
8 , none
8 , one
9 , one
@@ -14,12 +15,11 @@ module Canonicalize.Environment.Dups
14
15
15
16
16import qualified Data.Map as Map
17import qualified Data.Map as Map
18+import qualified Data.Name as Name
17
19
18import qualified Data.OneOrMore as OneOrMore
20import qualified Data.OneOrMore as OneOrMore
19−import qualified Elm.Name as N
20import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
22−import qualified Reporting.Region as R
23import qualified Reporting.Result as Result
23import qualified Reporting.Result as Result
24
24
25
25
@@ -28,12 +28,12 @@ import qualified Reporting.Result as Result
28
28
29
29
30type Dict value =
30type Dict value =
31− Map.Map N.Name (OneOrMore.OneOrMore (Info value))
31+ Map.Map Name.Name (OneOrMore.OneOrMore (Info value))
32
32
33
33
34data Info value =
34data Info value =
35 Info
35 Info
36− { _region :: R.Region
36+ { _region :: A.Region
37 , _value :: value
37 , _value :: value
38 }
38 }
39
39
@@ -43,22 +43,25 @@ data Info value =
43
43
44
44
45type ToError =
45type ToError =
46− N.Name -> R.Region -> R.Region -> Error.Error
46+ Name.Name -> A.Region -> A.Region -> Error.Error
47
47
48
48
49−detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map N.Name a)
49+detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a)
50detect toError dict =
50detect toError dict =
51 Map.traverseWithKey (detectHelp toError) dict
51 Map.traverseWithKey (detectHelp toError) dict
52
52
53
53
54−detectHelp :: ToError -> N.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
54+detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
55detectHelp toError name values =
55detectHelp toError name values =
56 case values of
56 case values of
57 OneOrMore.One (Info _ value) ->
57 OneOrMore.One (Info _ value) ->
58 return value
58 return value
59
59
60− OneOrMore.More _ _ ->
60+ OneOrMore.More left right ->
61+ let
61− let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in
62+ (Info r1 _, Info r2 _) =
63+ OneOrMore.getFirstTwo left right
64+ in
62 Result.throw (toError name r1 r2)
65 Result.throw (toError name r1 r2)
63
66
64
67
@@ -66,16 +69,26 @@ detectHelp toError name values =
66-- CHECK FIELDS
69-- CHECK FIELDS
67
70
68
71
69−checkFields :: [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name a)
72+checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a)
70checkFields fields =
73checkFields fields =
71 detect Error.DuplicateField (foldr addField none fields)
74 detect Error.DuplicateField (foldr addField none fields)
72
75
73
76
74−addField :: (A.Located N.Name, a) -> Dict a -> Dict a
77+addField :: (A.Located Name.Name, a) -> Dict a -> Dict a
75addField (A.At region name, value) dups =
78addField (A.At region name, value) dups =
76 Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups
79 Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups
77
80
78
81
82+checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name b)
83+checkFields' toValue fields =
84+ detect Error.DuplicateField (foldr (addField' toValue) none fields)
85+
86+
87+addField' :: (A.Region -> a -> b) -> (A.Located Name.Name, a) -> Dict b -> Dict b
88+addField' toValue (A.At region name, value) dups =
89+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region (toValue region value))) dups
90+
91+
79
92
80-- BUILDING DICTIONARIES
93-- BUILDING DICTIONARIES
81
94
@@ -85,14 +98,14 @@ none =
85 Map.empty
98 Map.empty
86
99
87
100
88−one :: N.Name -> R.Region -> value -> Dict value
101+one :: Name.Name -> A.Region -> value -> Dict value
89one name region value =
102one name region value =
90 Map.singleton name (OneOrMore.one (Info region value))
103 Map.singleton name (OneOrMore.one (Info region value))
91
104
92
105
93−insert :: N.Name -> R.Region -> a -> Dict a -> Dict a
106+insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
94insert name region value dict =
107insert name region value dict =
95− Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict
108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
96
109
97
110
98union :: Dict a -> Dict a -> Dict a
111union :: Dict a -> Dict a -> Dict a
compiler/src/Canonicalize/Environment/Foreign.hsnew file+304
@@ -0,0 +1,304 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Canonicalize.Environment.Foreign
5+ ( createInitialEnv
6+ )
7+ where
8+
9+
10+import Control.Monad (foldM)
11+import qualified Data.List as List
12+import qualified Data.Map.Strict as Map
13+import Data.Map.Strict ((!))
14+import qualified Data.Name as Name
15+
16+import qualified AST.Canonical as Can
17+import qualified AST.Source as Src
18+import qualified Canonicalize.Environment as Env
19+import qualified Elm.Interface as I
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Elm.Package as Pkg
22+import qualified Reporting.Annotation as A
23+import qualified Reporting.Error.Canonicalize as Error
24+import qualified Reporting.Result as Result
25+
26+
27+
28+-- RESULT
29+
30+
31+type Result i w a =
32+ Result.Result i w Error.Error a
33+
34+
35+createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env
36+createInitialEnv home ifaces imports =
37+ do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)
38+ Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)
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+
47+
48+
49+-- STATE
50+
51+
52+data State =
53+ State
54+ { _vars :: Env.Exposed Can.Annotation
55+ , _types :: Env.Exposed Env.Type
56+ , _ctors :: Env.Exposed Env.Ctor
57+ , _binops :: Env.Exposed Env.Binop
58+ , _q_vars :: Env.Qualified Can.Annotation
59+ , _q_types :: Env.Qualified Env.Type
60+ , _q_ctors :: Env.Qualified Env.Ctor
61+ }
62+
63+
64+emptyState :: State
65+emptyState =
66+ State Map.empty emptyTypes Map.empty Map.empty Map.empty Map.empty Map.empty
67+
68+
69+emptyTypes :: Env.Exposed Env.Type
70+emptyTypes =
71+ Map.singleton "List" (Env.Specific 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+
95+
96+
97+-- ADD IMPORTS
98+
99+
100+addImport :: Map.Map ModuleName.Raw I.Interface -> State -> Src.Import -> Result i w State
101+addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybeAlias exposing) =
102+ let
103+ (I.Interface pkg defs unions aliases binops) = ifaces ! name
104+ !prefix = maybe name id maybeAlias
105+ !home = ModuleName.Canonical pkg name
106+
107+ !rawTypeInfo =
108+ Map.union
109+ (Map.mapMaybeWithKey (unionToType home) unions)
110+ (Map.mapMaybeWithKey (aliasToType home) aliases)
111+
112+ !vars = Map.map (Env.Specific home) defs
113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo
114+ !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
115+
116+ !qvs2 = addQualified prefix vars qvs
117+ !qts2 = addQualified prefix types qts
118+ !qcs2 = addQualified prefix ctors qcs
119+ in
120+ case exposing of
121+ Src.Open ->
122+ let
123+ !vs2 = addExposed vs vars
124+ !ts2 = addExposed ts types
125+ !cs2 = addExposed cs ctors
126+ !bs2 = addExposed bs (Map.mapWithKey (binopToBinop home) binops)
127+ in
128+ Result.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2)
129+
130+ Src.Explicit exposedList ->
131+ foldM
132+ (addExposedValue home vars rawTypeInfo binops)
133+ (State vs ts cs bs qvs2 qts2 qcs2)
134+ exposedList
135+
136+
137+addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
138+addExposed =
139+ Map.unionWith Env.mergeInfo
140+
141+
142+addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
143+addQualified prefix exposed qualified =
144+ Map.insertWith addExposed prefix exposed qualified
145+
146+
147+
148+-- UNION
149+
150+
151+unionToType :: ModuleName.Canonical -> Name.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)
152+unionToType home name union =
153+ unionToTypeHelp home name <$> I.toPublicUnion union
154+
155+
156+unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
157+unionToTypeHelp home name union@(Can.Union vars ctors _ _) =
158+ let
159+ addCtor dict (Can.Ctor ctor index _ args) =
160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict
161+ in
162+ ( Env.Union (length vars) home
163+ , List.foldl' addCtor Map.empty ctors
164+ )
165+
166+
167+
168+-- ALIAS
169+
170+
171+aliasToType :: ModuleName.Canonical -> Name.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)
172+aliasToType home name alias =
173+ aliasToTypeHelp home name <$> I.toPublicAlias alias
174+
175+
176+aliasToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
177+aliasToTypeHelp home name (Can.Alias vars tipe) =
178+ (
179+ Env.Alias (length vars) home vars tipe
180+ ,
181+ case tipe of
182+ Can.TRecord fields Nothing ->
183+ let
184+ avars = map (\var -> (var, Can.TVar var)) vars
185+ alias =
186+ foldr
187+ (\(_,t1) t2 -> Can.TLambda t1 t2)
188+ (Can.TAlias home name avars (Can.Filled tipe))
189+ (Can.fieldsToList fields)
190+ in
191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))
192+
193+ _ ->
194+ Map.empty
195+ )
196+
197+
198+
199+-- BINOP
200+
201+
202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop
203+binopToBinop home op (I.Binop name annotation associativity precedence) =
204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)
205+
206+
207+
208+-- ADD EXPOSED VALUE
209+
210+
211+addExposedValue
212+ :: ModuleName.Canonical
213+ -> Env.Exposed Can.Annotation
214+ -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)
215+ -> Map.Map Name.Name I.Binop
216+ -> State
217+ -> Src.Exposed
218+ -> Result i w State
219+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =
220+ case exposed of
221+ Src.Lower (A.At region name) ->
222+ case Map.lookup name vars of
223+ Just info ->
224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)
225+
226+ Nothing ->
227+ Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))
228+
229+ Src.Upper (A.At region name) privacy ->
230+ case privacy of
231+ Src.Private ->
232+ case Map.lookup name types of
233+ Just (tipe, ctors) ->
234+ case tipe of
235+ Env.Union _ _ ->
236+ let
237+ !ts2 = Map.insert name (Env.Specific home tipe) ts
238+ in
239+ Result.ok (State vs ts2 cs bs qvs qts qcs)
240+
241+ Env.Alias _ _ _ _ ->
242+ let
243+ !ts2 = Map.insert name (Env.Specific home tipe) ts
244+ !cs2 = addExposed cs ctors
245+ in
246+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)
247+
248+ Nothing ->
249+ case checkForCtorMistake name types of
250+ tipe:_ ->
251+ Result.throw $ Error.ImportCtorByName region name tipe
252+
253+ [] ->
254+ Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)
255+
256+ Src.Public dotDotRegion ->
257+ case Map.lookup name types of
258+ Just (tipe, ctors) ->
259+ case tipe of
260+ Env.Union _ _ ->
261+ let
262+ !ts2 = Map.insert name (Env.Specific home tipe) ts
263+ !cs2 = addExposed cs ctors
264+ in
265+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)
266+
267+ Env.Alias _ _ _ _ ->
268+ Result.throw (Error.ImportOpenAlias dotDotRegion name)
269+
270+ Nothing ->
271+ Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))
272+
273+ Src.Operator region op ->
274+ case Map.lookup op binops of
275+ Just binop ->
276+ let
277+ !bs2 = Map.insert op (binopToBinop home op binop) bs
278+ in
279+ Result.ok (State vs ts cs bs2 qvs qts qcs)
280+
281+ Nothing ->
282+ Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))
283+
284+
285+checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]
286+checkForCtorMistake givenName types =
287+ Map.foldr addMatches [] types
288+ where
289+ addMatches (_, exposedCtors) matches =
290+ Map.foldrWithKey addMatch matches exposedCtors
291+
292+ addMatch ctorName info matches =
293+ if ctorName /= givenName
294+ then matches
295+ else
296+ case info of
297+ Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->
298+ tipeName : matches
299+
300+ Env.Specific _ (Env.RecordCtor _ _ _) ->
301+ matches
302+
303+ Env.Ambiguous _ _ ->
304+ matches
src/Canonicalize/Environment/Local.hs → compiler/src/Canonicalize/Environment/Local.hsrenamed+73−74
@@ -6,24 +6,21 @@ module Canonicalize.Environment.Local
6 where
6 where
7
7
8
8
9−import Control.Arrow (first)
10import Control.Monad (foldM)
9import Control.Monad (foldM)
11import qualified Data.Graph as Graph
10import qualified Data.Graph as Graph
12import qualified Data.List as List
11import qualified Data.List as List
13import qualified Data.Map.Strict as Map
12import qualified Data.Map.Strict as Map
13+import qualified Data.Name as Name
14
14
15import qualified AST.Canonical as Can
15import qualified AST.Canonical as Can
16import qualified AST.Source as Src
16import qualified AST.Source as Src
17−import qualified AST.Valid as Valid
18−import qualified AST.Module.Name as ModuleName
19import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Environment as Env
20import qualified Canonicalize.Environment.Dups as Dups
18import qualified Canonicalize.Environment.Dups as Dups
21import qualified Canonicalize.Type as Type
19import qualified Canonicalize.Type as Type
22import qualified Data.Index as Index
20import qualified Data.Index as Index
23−import qualified Elm.Name as N
21+import qualified Elm.ModuleName as ModuleName
24import qualified Reporting.Annotation as A
22import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Canonicalize as Error
23import qualified Reporting.Error.Canonicalize as Error
26−import qualified Reporting.Region as R
27import qualified Reporting.Result as Result
24import qualified Reporting.Result as Result
28
25
29
26
@@ -35,11 +32,11 @@ type Result i w a =
35 Result.Result i w Error.Error a
32 Result.Result i w Error.Error a
36
33
37
34
38−type Unions = Map.Map N.Name Can.Union
35+type Unions = Map.Map Name.Name Can.Union
39−type Aliases = Map.Map N.Name Can.Alias
36+type Aliases = Map.Map Name.Name Can.Alias
40
37
41
38
42−add :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
39+add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
43add module_ env =
40add module_ env =
44 addCtors module_ =<< addVars module_ =<< addTypes module_ env
41 addCtors module_ =<< addVars module_ =<< addTypes module_ env
45
42
@@ -48,7 +45,7 @@ add module_ env =
48-- ADD VARS
45-- ADD VARS
49
46
50
47
51−addVars :: Valid.Module -> Env.Env -> Result i w Env.Env
48+addVars :: Src.Module -> Env.Env -> Result i w Env.Env
52addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
49addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
53 do topLevelVars <- collectVars module_
50 do topLevelVars <- collectVars module_
54 let vs2 = Map.union topLevelVars vs
51 let vs2 = Map.union topLevelVars vs
@@ -56,38 +53,38 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
56 Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
53 Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
57
54
58
55
59−collectVars :: Valid.Module -> Result i w (Map.Map N.Name Env.Var)
56+collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
60−collectVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
61 let
58 let
62− addDecl dict (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
59+ addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
63 Dups.insert name region (Env.TopLevel region) dict
60 Dups.insert name region (Env.TopLevel region) dict
64 in
61 in
65 Dups.detect Error.DuplicateDecl $
62 Dups.detect Error.DuplicateDecl $
66− List.foldl' addDecl (toEffectDups effects) decls
63+ List.foldl' addDecl (toEffectDups effects) values
67
64
68
65
69−toEffectDups :: Valid.Effects -> Dups.Dict Env.Var
66+toEffectDups :: Src.Effects -> Dups.Dict Env.Var
70toEffectDups effects =
67toEffectDups effects =
71 case effects of
68 case effects of
72− Valid.NoEffects ->
69+ Src.NoEffects ->
73 Dups.none
70 Dups.none
74
71
75− Valid.Ports ports ->
72+ Src.Ports ports ->
76 let
73 let
77− addPort dict (Valid.Port (A.At region name) _) =
74+ addPort dict (Src.Port (A.At region name) _) =
78 Dups.insert name region (Env.TopLevel region) dict
75 Dups.insert name region (Env.TopLevel region) dict
79 in
76 in
80 List.foldl' addPort Dups.none ports
77 List.foldl' addPort Dups.none ports
81
78
82− Valid.Manager _ manager ->
79+ Src.Manager _ manager ->
83 case manager of
80 case manager of
84− Valid.Cmd (A.At region _) ->
81+ Src.Cmd (A.At region _) ->
85 Dups.one "command" region (Env.TopLevel region)
82 Dups.one "command" region (Env.TopLevel region)
86
83
87− Valid.Sub (A.At region _) ->
84+ Src.Sub (A.At region _) ->
88 Dups.one "subscription" region (Env.TopLevel region)
85 Dups.one "subscription" region (Env.TopLevel region)
89
86
90− Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
87+ Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
91 Dups.union
88 Dups.union
92 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
89 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
93 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
90 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
@@ -97,11 +94,11 @@ toEffectDups effects =
97-- ADD TYPES
94-- ADD TYPES
98
95
99
96
100−addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env
97+addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
101−addTypes (Valid.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) =
102 let
99 let
103− addAliasDups dups (Valid.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
104− addUnionDups dups (Valid.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
105 typeNameDups =
102 typeNameDups =
106 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
103 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
107 in
104 in
@@ -110,10 +107,10 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs
110 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
107 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
111
108
112
109
113−addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)
110+addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
114−addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =
111+addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
115 do arity <- checkUnionFreeVars union
112 do arity <- checkUnionFreeVars union
116− let one = Map.singleton home (Env.Union arity home)
113+ let one = Env.Specific home (Env.Union arity home)
117 Result.ok $ Map.insert name one types
114 Result.ok $ Map.insert name one types
118
115
119
116
@@ -121,7 +118,7 @@ addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =
121-- ADD TYPE ALIASES
118-- ADD TYPE ALIASES
122
119
123
120
124−addAliases :: [Valid.Alias] -> Env.Env -> Result i w Env.Env
121+addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env
125addAliases aliases env =
122addAliases aliases env =
126 let
123 let
127 nodes = map toNode aliases
124 nodes = map toNode aliases
@@ -130,22 +127,22 @@ addAliases aliases env =
130 foldM addAlias env sccs
127 foldM addAlias env sccs
131
128
132
129
133−addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env
130+addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env
134addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
131addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
135 case scc of
132 case scc of
136− Graph.AcyclicSCC alias@(Valid.Alias _ (A.At _ name) _ tipe) ->
133+ Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
137 do args <- checkAliasFreeVars alias
134 do args <- checkAliasFreeVars alias
138 ctype <- Type.canonicalize env tipe
135 ctype <- Type.canonicalize env tipe
139− let one = Map.singleton home (Env.Alias (length args) home args ctype)
136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)
140 let ts1 = Map.insert name one ts
137 let ts1 = Map.insert name one ts
141 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
142
139
143 Graph.CyclicSCC [] ->
140 Graph.CyclicSCC [] ->
144 Result.ok env
141 Result.ok env
145
142
146− Graph.CyclicSCC (alias@(Valid.Alias _ (A.At region name1) _ tipe) : others) ->
143+ Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->
147 do args <- checkAliasFreeVars alias
144 do args <- checkAliasFreeVars alias
148− let toName (Valid.Alias _ (A.At _ name) _ _) = name
145+ let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name
149 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
146 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
150
147
151
148
@@ -153,12 +150,12 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
153-- DETECT TYPE ALIAS CYCLES
150-- DETECT TYPE ALIAS CYCLES
154
151
155
152
156−toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])
153+toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name])
157−toNode alias@(Valid.Alias _ (A.At _ name) _ tipe) =
154+toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) =
158 ( alias, name, getEdges [] tipe )
155 ( alias, name, getEdges [] tipe )
159
156
160
157
161−getEdges :: [N.Name] -> Src.Type -> [N.Name]
158+getEdges :: [Name.Name] -> Src.Type -> [Name.Name]
162getEdges edges (A.At _ tipe) =
159getEdges edges (A.At _ tipe) =
163 case tipe of
160 case tipe of
164 Src.TLambda arg result ->
161 Src.TLambda arg result ->
@@ -187,8 +184,8 @@ getEdges edges (A.At _ tipe) =
187-- CHECK FREE VARIABLES
184-- CHECK FREE VARIABLES
188
185
189
186
190−checkUnionFreeVars :: Valid.Union -> Result i w Int
187+checkUnionFreeVars :: A.Located Src.Union -> Result i w Int
191−checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =
188+checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =
192 let
189 let
193 addArg (A.At region arg) dict =
190 addArg (A.At region arg) dict =
194 Dups.insert arg region region dict
191 Dups.insert arg region region dict
@@ -207,8 +204,8 @@ checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =
207 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
204 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
208
205
209
206
210−checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
207+checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]
211−checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =
208+checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =
212 let
209 let
213 addArg (A.At region arg) dict =
210 addArg (A.At region arg) dict =
214 Dups.insert arg region region dict
211 Dups.insert arg region region dict
@@ -226,7 +223,7 @@ checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =
226 (Map.toList (Map.difference freeVars boundVars))
223 (Map.toList (Map.difference freeVars boundVars))
227
224
228
225
229−addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region
226+addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region
230addFreeVars freeVars (A.At region tipe) =
227addFreeVars freeVars (A.At region tipe) =
231 case tipe of
228 case tipe of
232 Src.TLambda arg result ->
229 Src.TLambda arg result ->
@@ -264,8 +261,8 @@ addFreeVars freeVars (A.At region tipe) =
264-- ADD CTORS
261-- ADD CTORS
265
262
266
263
267−addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
264+addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
268−addCtors (Valid.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) =
269 do unionInfo <- traverse (canonicalizeUnion env) unions
266 do unionInfo <- traverse (canonicalizeUnion env) unions
270 aliasInfo <- traverse (canonicalizeAlias env) aliases
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
271
268
@@ -284,45 +281,47 @@ addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts c
284 )
281 )
285
282
286
283
287−type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)
288
285
289
286
290
287
291-- CANONICALIZE ALIAS
288-- CANONICALIZE ALIAS
292
289
293
290
294−canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
291+canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups )
295−canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =
292+canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) =
296− case tipe of
293+ do let vars = map A.toValue args
297− A.At _ (Src.TRecord fields Nothing) ->
298− do cfields <- traverse (traverse (Type.canonicalize env)) fields
294+ ctipe <- Type.canonicalize env tipe
299− fieldDict <- Dups.checkFields cfields
300−
301− let recordType = Can.TRecord fieldDict Nothing
302− let ctorType = foldr (Can.TLambda . snd) recordType cfields
303− let vars = map A.toValue args
304− let alias = Can.Alias vars recordType (Just (map (first A.toValue) cfields))
305− let ctor = Env.RecordCtor home vars ctorType
306−
307− Result.ok
295+ Result.ok
308− ( (name, alias)
296+ ( (name, Can.Alias vars ctipe)
297+ ,
298+ case ctipe of
299+ Can.TRecord fields Nothing ->
309− , Dups.one name region (Map.singleton home ctor)
300+ Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
301+
302+ _ ->
303+ Dups.none
310− )
304+ )
311
305
312− _ ->
306+toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor
313− do ctipe <- Type.canonicalize env tipe
307+toRecordCtor home name vars fields =
314− Result.ok
308+ let
315− ( (name, Can.Alias (map A.toValue args) ctipe Nothing)
309+ avars = map (\var -> (var, Can.TVar var)) vars
316− , Dups.none
310+ alias =
317− )
311+ foldr
312+ (\(_,t1) t2 -> Can.TLambda t1 t2)
313+ (Can.TAlias home name avars (Can.Filled (Can.TRecord fields Nothing)))
314+ (Can.fieldsToList fields)
315+ in
316+ Env.RecordCtor home vars alias
318
317
319
318
320
319
321-- CANONICALIZE UNION
320-- CANONICALIZE UNION
322
321
323
322
324−canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
323+canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups )
325−canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name) avars ctors) =
324+canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ name) avars ctors)) =
326 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
325 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
327 let vars = map A.toValue avars
326 let vars = map A.toValue avars
328 let alts = map A.toValue cctors
327 let alts = map A.toValue cctors
@@ -333,14 +332,14 @@ canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name)
333 )
332 )
334
333
335
334
336−canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
335+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
337canonicalizeCtor env index (A.At region ctor, tipes) =
336canonicalizeCtor env index (A.At region ctor, tipes) =
338 do ctipes <- traverse (Type.canonicalize env) tipes
337 do ctipes <- traverse (Type.canonicalize env) tipes
339 Result.ok $ A.At region $
338 Result.ok $ A.At region $
340 Can.Ctor ctor index (length ctipes) ctipes
339 Can.Ctor ctor index (length ctipes) ctipes
341
340
342
341
343−toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts
342+toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts
344toOpts ctors =
343toOpts ctors =
345 case ctors of
344 case ctors of
346 [ (_,[_]) ] ->
345 [ (_,[_]) ] ->
@@ -350,7 +349,7 @@ toOpts ctors =
350 if all (null . snd) ctors then Can.Enum else Can.Normal
349 if all (null . snd) ctors then Can.Enum else Can.Normal
351
350
352
351
353−toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
352+toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
354toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
355− Dups.one name region $ Map.singleton home $
354+ Dups.one name region $ Env.Specific home $
356 Env.Ctor home typeName union index args
355 Env.Ctor home typeName union index args
src/Canonicalize/Expression.hs → compiler/src/Canonicalize/Expression.hsrenamed+78−77
@@ -14,23 +14,21 @@ 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
17+import qualified Data.Name as Name
18
18
19import qualified AST.Canonical as Can
19import qualified AST.Canonical as Can
20import qualified AST.Source as Src
20import qualified AST.Source as Src
21−import qualified AST.Module.Name as ModuleName
22import qualified AST.Utils.Binop as Binop
21import qualified AST.Utils.Binop as Binop
23import qualified AST.Utils.Type as Type
22import qualified AST.Utils.Type as Type
24−import qualified AST.Valid as Valid
25import qualified Canonicalize.Environment as Env
23import qualified Canonicalize.Environment as Env
26import qualified Canonicalize.Environment.Dups as Dups
24import qualified Canonicalize.Environment.Dups as Dups
27import qualified Canonicalize.Pattern as Pattern
25import qualified Canonicalize.Pattern as Pattern
28import qualified Canonicalize.Type as Type
26import qualified Canonicalize.Type as Type
29import qualified Data.Index as Index
27import qualified Data.Index as Index
30−import qualified Elm.Name as N
28+import qualified Elm.ModuleName as ModuleName
29+import qualified Elm.Package as Pkg
31import qualified Reporting.Annotation as A
30import qualified Reporting.Annotation as A
32import qualified Reporting.Error.Canonicalize as Error
31import qualified Reporting.Error.Canonicalize as Error
33−import qualified Reporting.Region as R
34import qualified Reporting.Result as Result
32import qualified Reporting.Result as Result
35import qualified Reporting.Warning as W
33import qualified Reporting.Warning as W
36
34
@@ -44,7 +42,7 @@ type Result i w a =
44
42
45
43
46type FreeLocals =
44type FreeLocals =
47− Map.Map N.Name Uses
45+ Map.Map Name.Name Uses
48
46
49
47
50data Uses =
48data Uses =
@@ -58,46 +56,46 @@ data Uses =
58-- CANONICALIZE
56-- CANONICALIZE
59
57
60
58
61−canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
59+canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
62canonicalize env (A.At region expression) =
60canonicalize env (A.At region expression) =
63 A.At region <$>
61 A.At region <$>
64 case expression of
62 case expression of
65− Valid.Str string ->
63+ Src.Str string ->
66 Result.ok (Can.Str string)
64 Result.ok (Can.Str string)
67
65
68− Valid.Chr char ->
66+ Src.Chr char ->
69 Result.ok (Can.Chr char)
67 Result.ok (Can.Chr char)
70
68
71− Valid.Int int ->
69+ Src.Int int ->
72 Result.ok (Can.Int int)
70 Result.ok (Can.Int int)
73
71
74− Valid.Float float ->
72+ Src.Float float ->
75 Result.ok (Can.Float float)
73 Result.ok (Can.Float float)
76
74
77− Valid.Var varType name ->
75+ Src.Var varType name ->
78 case varType of
76 case varType of
79− Src.Value -> findVar region env name
77+ Src.LowVar -> findVar region env name
80− Src.Ctor -> toVarCtor name <$> Env.findCtor region env name
78+ Src.CapVar -> toVarCtor name <$> Env.findCtor region env name
81
79
82− Valid.VarQual varType prefix name ->
80+ Src.VarQual varType prefix name ->
83 case varType of
81 case varType of
84− Src.Value -> findVarQual region env prefix name
82+ Src.LowVar -> findVarQual region env prefix name
85− Src.Ctor -> toVarCtor name <$> Env.findCtorQual region env prefix name
83+ Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name
86
84
87− Valid.List exprs ->
85+ Src.List exprs ->
88 Can.List <$> traverse (canonicalize env) exprs
86 Can.List <$> traverse (canonicalize env) exprs
89
87
90− Valid.Op op ->
88+ Src.Op op ->
91 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
89 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
92 return (Can.VarOperator op home name annotation)
90 return (Can.VarOperator op home name annotation)
93
91
94− Valid.Negate expr ->
92+ Src.Negate expr ->
95 Can.Negate <$> canonicalize env expr
93 Can.Negate <$> canonicalize env expr
96
94
97− Valid.Binops ops final ->
95+ Src.Binops ops final ->
98 A.toValue <$> canonicalizeBinops region env ops final
96 A.toValue <$> canonicalizeBinops region env ops final
99
97
100− Valid.Lambda srcArgs body ->
98+ Src.Lambda srcArgs body ->
101 delayedUsage $
99 delayedUsage $
102 do (args, bindings) <-
100 do (args, bindings) <-
103 Pattern.verify Error.DPLambdaArgs $
101 Pattern.verify Error.DPLambdaArgs $
@@ -111,60 +109,63 @@ canonicalize env (A.At region expression) =
111
109
112 return (Can.Lambda args cbody, freeLocals)
110 return (Can.Lambda args cbody, freeLocals)
113
111
114− Valid.Call func args ->
112+ Src.Call func args ->
115 Can.Call
113 Can.Call
116 <$> canonicalize env func
114 <$> canonicalize env func
117 <*> traverse (canonicalize env) args
115 <*> traverse (canonicalize env) args
118
116
119− Valid.If branches finally ->
117+ Src.If branches finally ->
120 Can.If
118 Can.If
121 <$> traverse (canonicalizeIfBranch env) branches
119 <$> traverse (canonicalizeIfBranch env) branches
122 <*> canonicalize env finally
120 <*> canonicalize env finally
123
121
124− Valid.Let defs expr ->
122+ Src.Let defs expr ->
125 A.toValue <$> canonicalizeLet region env defs expr
123 A.toValue <$> canonicalizeLet region env defs expr
126
124
127− Valid.Case expr branches ->
125+ Src.Case expr branches ->
128 Can.Case
126 Can.Case
129 <$> canonicalize env expr
127 <$> canonicalize env expr
130 <*> traverse (canonicalizeCaseBranch env) branches
128 <*> traverse (canonicalizeCaseBranch env) branches
131
129
132− Valid.Accessor field ->
130+ Src.Accessor field ->
133 Result.ok $ Can.Accessor field
131 Result.ok $ Can.Accessor field
134
132
135− Valid.Access record field ->
133+ Src.Access record field ->
136 Can.Access
134 Can.Access
137 <$> canonicalize env record
135 <$> canonicalize env record
138 <*> Result.ok field
136 <*> Result.ok field
139
137
140− Valid.Update (A.At reg name) fields ->
138+ Src.Update (A.At reg name) fields ->
139+ let
140+ makeCanFields =
141− do fieldDict <- Dups.checkFields fields
141+ Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields
142+ in
143+ Can.Update name
142− name_ <- findVar reg env name
144+ <$> (A.At reg <$> findVar reg env name)
143− Can.Update (A.At reg name_)
145+ <*> (sequenceA =<< makeCanFields)
144− <$> traverse (canonicalize env) fieldDict
145
146
146− Valid.Record fields ->
147+ Src.Record fields ->
147 do fieldDict <- Dups.checkFields fields
148 do fieldDict <- Dups.checkFields fields
148 Can.Record <$> traverse (canonicalize env) fieldDict
149 Can.Record <$> traverse (canonicalize env) fieldDict
149
150
150− Valid.Unit ->
151+ Src.Unit ->
151 Result.ok Can.Unit
152 Result.ok Can.Unit
152
153
153− Valid.Tuple a b cs ->
154+ Src.Tuple a b cs ->
154 Can.Tuple
155 Can.Tuple
155 <$> canonicalize env a
156 <$> canonicalize env a
156 <*> canonicalize env b
157 <*> canonicalize env b
157 <*> canonicalizeTupleExtras region env cs
158 <*> canonicalizeTupleExtras region env cs
158
159
159− Valid.Shader uid src tipe ->
160+ Src.Shader src tipe ->
160− Result.ok (Can.Shader uid src tipe)
161+ Result.ok (Can.Shader src tipe)
161
162
162
163
163
164
164-- CANONICALIZE TUPLE EXTRAS
165-- CANONICALIZE TUPLE EXTRAS
165
166
166
167
167−canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
168+canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
168canonicalizeTupleExtras region env extras =
169canonicalizeTupleExtras region env extras =
169 case extras of
170 case extras of
170 [] ->
171 [] ->
@@ -181,7 +182,7 @@ canonicalizeTupleExtras region env extras =
181-- CANONICALIZE IF BRANCH
182-- CANONICALIZE IF BRANCH
182
183
183
184
184−canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
185+canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
185canonicalizeIfBranch env (condition, branch) =
186canonicalizeIfBranch env (condition, branch) =
186 (,)
187 (,)
187 <$> canonicalize env condition
188 <$> canonicalize env condition
@@ -192,7 +193,7 @@ canonicalizeIfBranch env (condition, branch) =
192-- CANONICALIZE CASE BRANCH
193-- CANONICALIZE CASE BRANCH
193
194
194
195
195−canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
196+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
196canonicalizeCaseBranch env (pattern, expr) =
197canonicalizeCaseBranch env (pattern, expr) =
197 directUsage $
198 directUsage $
198 do (cpattern, bindings) <-
199 do (cpattern, bindings) <-
@@ -210,7 +211,7 @@ canonicalizeCaseBranch env (pattern, expr) =
210-- CANONICALIZE BINOPS
211-- CANONICALIZE BINOPS
211
212
212
213
213−canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
214+canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
214canonicalizeBinops overallRegion env ops final =
215canonicalizeBinops overallRegion env ops final =
215 let
216 let
216 canonicalizeHelp (expr, A.At region op) =
217 canonicalizeHelp (expr, A.At region op) =
@@ -231,7 +232,7 @@ data Step
231 | Error Env.Binop Env.Binop
232 | Error Env.Binop Env.Binop
232
233
233
234
234−runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr
235+runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr
235runBinopStepper overallRegion step =
236runBinopStepper overallRegion step =
236 case step of
237 case step of
237 Done expr ->
238 Done expr ->
@@ -293,7 +294,7 @@ toBinop (Env.Binop op home name annotation _ _) left right =
293-- CANONICALIZE LET
294-- CANONICALIZE LET
294
295
295
296
296−canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
297+canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
297canonicalizeLet letRegion env defs body =
298canonicalizeLet letRegion env defs body =
298 directUsage $
299 directUsage $
299 do bindings <-
300 do bindings <-
@@ -312,17 +313,17 @@ canonicalizeLet letRegion env defs body =
312-- ADD BINDINGS
313-- ADD BINDINGS
313
314
314
315
315−addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region
316+addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region
316−addBindings bindings def =
317+addBindings bindings (A.At _ def) =
317 case def of
318 case def of
318− Valid.Define _ (A.At region name) _ _ _ ->
319+ Src.Define (A.At region name) _ _ _ ->
319 Dups.insert name region region bindings
320 Dups.insert name region region bindings
320
321
321− Valid.Destruct _ pattern _ ->
322+ Src.Destruct pattern _ ->
322 addBindingsHelp bindings pattern
323 addBindingsHelp bindings pattern
323
324
324
325
325−addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region
326+addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region
326addBindingsHelp bindings (A.At region pattern) =
327addBindingsHelp bindings (A.At region pattern) =
327 case pattern of
328 case pattern of
328 Src.PAnything ->
329 Src.PAnything ->
@@ -375,19 +376,19 @@ addBindingsHelp bindings (A.At region pattern) =
375
376
376
377
377type Node =
378type Node =
378− (Binding, N.Name, [N.Name])
379+ (Binding, Name.Name, [Name.Name])
379
380
380
381
381data Binding
382data Binding
382 = Define Can.Def
383 = Define Can.Def
383− | Edge (A.Located N.Name)
384+ | Edge (A.Located Name.Name)
384 | Destruct Can.Pattern Can.Expr
385 | Destruct Can.Pattern Can.Expr
385
386
386
387
387−addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]
388+addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node]
388−addDefNodes env nodes def =
389+addDefNodes env nodes (A.At _ def) =
389 case def of
390 case def of
390− Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->
391+ Src.Define aname@(A.At _ name) srcArgs body maybeType ->
391 case maybeType of
392 case maybeType of
392 Nothing ->
393 Nothing ->
393 do (args, argBindings) <-
394 do (args, argBindings) <-
@@ -420,7 +421,7 @@ addDefNodes env nodes def =
420 let node = ( Define cdef, name, Map.keys freeLocals )
421 let node = ( Define cdef, name, Map.keys freeLocals )
421 logLetLocals args freeLocals (node:nodes)
422 logLetLocals args freeLocals (node:nodes)
422
423
423− Valid.Destruct _ pattern body ->
424+ Src.Destruct pattern body ->
424 do (cpattern, _bindings) <-
425 do (cpattern, _bindings) <-
425 Pattern.verify Error.DPDestruct $
426 Pattern.verify Error.DPDestruct $
426 Pattern.canonicalize env pattern
427 Pattern.canonicalize env pattern
@@ -435,7 +436,7 @@ addDefNodes env nodes def =
435 (\freeLocals warnings cbody ->
436 (\freeLocals warnings cbody ->
436 let
437 let
437 names = getPatternNames [] pattern
438 names = getPatternNames [] pattern
438− name = N.toCompositeName (map A.toValue names)
439+ name = Name.fromManyNames (map A.toValue names)
439 node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
440 node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
440 in
441 in
441 good
442 good
@@ -458,12 +459,12 @@ logLetLocals args letLocals value =
458 value
459 value
459
460
460
461
461−addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]
462+addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node]
462addEdge edges nodes aname@(A.At _ name) =
463addEdge edges nodes aname@(A.At _ name) =
463 (Edge aname, name, edges) : nodes
464 (Edge aname, name, edges) : nodes
464
465
465
466
466−getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]
467+getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]
467getPatternNames names (A.At region pattern) =
468getPatternNames names (A.At region pattern) =
468 case pattern of
469 case pattern of
469 Src.PAnything -> names
470 Src.PAnything -> names
@@ -487,7 +488,7 @@ getPatternNames names (A.At region pattern) =
487
488
488gatherTypedArgs
489gatherTypedArgs
489 :: Env.Env
490 :: Env.Env
490− -> N.Name
491+ -> Name.Name
491 -> [Src.Pattern]
492 -> [Src.Pattern]
492 -> Can.Type
493 -> Can.Type
493 -> Index.ZeroBased
494 -> Index.ZeroBased
@@ -508,14 +509,14 @@ gatherTypedArgs env name srcArgs tipe index revTypedArgs =
508 _ ->
509 _ ->
509 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
510 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
510 Result.throw $
511 Result.throw $
511− Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)
512+ Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs)
512
513
513
514
514
515
515-- DETECT CYCLES
516-- DETECT CYCLES
516
517
517
518
518−detectCycles :: R.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
519+detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
519detectCycles letRegion sccs body =
520detectCycles letRegion sccs body =
520 case sccs of
521 case sccs of
521 [] ->
522 [] ->
@@ -571,7 +572,7 @@ checkCycle bindings defs =
571 checkCycle otherBindings defs
572 checkCycle otherBindings defs
572
573
573
574
574−toNames :: [Binding] -> [Can.Def] -> [N.Name]
575+toNames :: [Binding] -> [Can.Def] -> [Name.Name]
575toNames bindings revDefs =
576toNames bindings revDefs =
576 case bindings of
577 case bindings of
577 [] ->
578 [] ->
@@ -584,7 +585,7 @@ toNames bindings revDefs =
584 Destruct _ _ -> toNames otherBindings revDefs
585 Destruct _ _ -> toNames otherBindings revDefs
585
586
586
587
587−getDefName :: Can.Def -> N.Name
588+getDefName :: Can.Def -> Name.Name
588getDefName def =
589getDefName def =
589 case def of
590 case def of
590 Can.Def (A.At _ name) _ _ ->
591 Can.Def (A.At _ name) _ _ ->
@@ -598,7 +599,7 @@ getDefName def =
598-- LOG VARIABLE USES
599-- LOG VARIABLE USES
599
600
600
601
601−logVar :: N.Name -> a -> Result FreeLocals w a
602+logVar :: Name.Name -> a -> Result FreeLocals w a
602logVar name value =
603logVar name value =
603 Result.Result $ \freeLocals warnings _ good ->
604 Result.Result $ \freeLocals warnings _ good ->
604 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
605 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
@@ -653,7 +654,7 @@ verifyBindings context bindings (Result.Result k) =
653 )
654 )
654
655
655
656
656−addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> R.Region -> [W.Warning]
657+addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning]
657addUnusedWarning context warnings name region =
658addUnusedWarning context warnings name region =
658 W.UnusedVariable region context name : warnings
659 W.UnusedVariable region context name : warnings
659
660
@@ -683,7 +684,7 @@ delayedUsage (Result.Result k) =
683-- FIND VARIABLE
684-- FIND VARIABLE
684
685
685
686
686−findVar :: R.Region -> Env.Env -> N.Name -> Result FreeLocals w Can.Expr_
687+findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_
687findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
688findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
688 case Map.lookup name vs of
689 case Map.lookup name vs of
689 Just var ->
690 Just var ->
@@ -694,46 +695,46 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
694 Env.TopLevel _ ->
695 Env.TopLevel _ ->
695 logVar name (Can.VarTopLevel localHome name)
696 logVar name (Can.VarTopLevel localHome name)
696
697
697− Env.Foreign (I.Bin 1 home annotation _ _) ->
698+ Env.Foreign home annotation ->
698 Result.ok $
699 Result.ok $
699 if home == ModuleName.debug then
700 if home == ModuleName.debug then
700 Can.VarDebug localHome name annotation
701 Can.VarDebug localHome name annotation
701 else
702 else
702 Can.VarForeign home name annotation
703 Can.VarForeign home name annotation
703
704
704− Env.Foreign homes ->
705+ Env.Foreigns h hs ->
705− Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
706
707
707 Nothing ->
708 Nothing ->
708 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
709
710
710
711
711−findVarQual :: R.Region -> Env.Env -> N.Name -> N.Name -> Result FreeLocals w Can.Expr_
712+findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_
712findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
713findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
713 case Map.lookup prefix qvs of
714 case Map.lookup prefix qvs of
714 Just qualified ->
715 Just qualified ->
715 case Map.lookup name qualified of
716 case Map.lookup name qualified of
716− Just (I.Bin 1 home annotation _ _) ->
717+ Just (Env.Specific home annotation) ->
717 Result.ok $
718 Result.ok $
718 if home == ModuleName.debug then
719 if home == ModuleName.debug then
719 Can.VarDebug localHome name annotation
720 Can.VarDebug localHome name annotation
720 else
721 else
721 Can.VarForeign home name annotation
722 Can.VarForeign home name annotation
722
723
723− Just homes ->
724+ Just (Env.Ambiguous h hs) ->
724− Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
725
726
726 Nothing ->
727 Nothing ->
727 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
728
729
729 Nothing ->
730 Nothing ->
730− if ModuleName.isKernel prefix then
731+ if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then
731− Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name
732+ Result.ok $ Can.VarKernel (Name.getKernel prefix) name
732 else
733 else
733 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
734 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
734
735
735
736
736−toPossibleNames :: Map.Map N.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames
737+toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames
737toPossibleNames exposed qualified =
738toPossibleNames exposed qualified =
738 Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
739 Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
739
740
@@ -742,7 +743,7 @@ toPossibleNames exposed qualified =
742-- FIND CTOR
743-- FIND CTOR
743
744
744
745
745−toVarCtor :: N.Name -> Env.Ctor -> Can.Expr_
746+toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_
746toVarCtor name ctor =
747toVarCtor name ctor =
747 case ctor of
748 case ctor of
748 Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->
749 Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->
src/Canonicalize/Module.hs → compiler/src/Canonicalize/Module.hsrenamed+65−74
@@ -7,11 +7,10 @@ module Canonicalize.Module
7
7
8import qualified Data.Graph as Graph
8import qualified Data.Graph as Graph
9import qualified Data.Map as Map
9import qualified Data.Map as Map
10+import qualified Data.Name as Name
10
11
11import qualified AST.Canonical as Can
12import qualified AST.Canonical as Can
12import qualified AST.Source as Src
13import qualified AST.Source as Src
13−import qualified AST.Valid as Valid
14−import qualified AST.Module.Name as ModuleName
15import qualified Canonicalize.Effects as Effects
14import qualified Canonicalize.Effects as Effects
16import qualified Canonicalize.Environment as Env
15import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Environment.Dups as Dups
16import qualified Canonicalize.Environment.Dups as Dups
@@ -22,11 +21,10 @@ import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Type as Type
21import qualified Canonicalize.Type as Type
23import qualified Data.Index as Index
22import qualified Data.Index as Index
24import qualified Elm.Interface as I
23import qualified Elm.Interface as I
25−import qualified Elm.Name as N
24+import qualified Elm.ModuleName as ModuleName
26import qualified Elm.Package as Pkg
25import qualified Elm.Package as Pkg
27import qualified Reporting.Annotation as A
26import qualified Reporting.Annotation as A
28import qualified Reporting.Error.Canonicalize as Error
27import qualified Reporting.Error.Canonicalize as Error
29−import qualified Reporting.Region as R
30import qualified Reporting.Result as Result
28import qualified Reporting.Result as Result
31import qualified Reporting.Warning as W
29import qualified Reporting.Warning as W
32
30
@@ -43,47 +41,28 @@ type Result i w a =
43-- MODULES
41-- MODULES
44
42
45
43
46−canonicalize
47− :: Pkg.Name
48− -> Map.Map N.Name ModuleName.Canonical
49− -> I.Interfaces
50− -> Valid.Module
51− -> Result i [W.Warning] Can.Module
44+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
52−canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls _ _ binops effects) =
45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
53− do let home = ModuleName.Canonical pkg name
46+ do let home = ModuleName.Canonical pkg (Src.getName modul)
54 let cbinops = Map.fromList (map canonicalizeBinop binops)
47 let cbinops = Map.fromList (map canonicalizeBinop binops)
55
48
56 (env, cunions, caliases) <-
49 (env, cunions, caliases) <-
57− Local.add module_ =<<
50+ Local.add modul =<<
58− Foreign.createInitialEnv home importDict interfaces imports
51+ Foreign.createInitialEnv home ifaces imports
59
52
60− cdecls <- canonicalizeDecls env decls
53+ cvalues <- canonicalizeValues env values
61− ceffects <- Effects.canonicalize env decls cunions effects
54+ ceffects <- Effects.canonicalize env values cunions effects
62− cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
55+ cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
63
56
64− return $ Can.Module home (toDocs module_) cexports cdecls cunions caliases cbinops ceffects
57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
65−
66−
67−
68−-- DOCUMENTATION
69−
70−
71−toDocs :: Valid.Module -> Can.Docs
72−toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =
73− case docs of
74− Src.NoDocs region ->
75− Can.NoDocs region
76−
77− Src.YesDocs region overview ->
78− Can.YesDocs region overview comments
79
58
80
59
81
60
82-- CANONICALIZE BINOP
61-- CANONICALIZE BINOP
83
62
84
63
85−canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
86−canonicalizeBinop (Valid.Binop op associativity precedence func) =
65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
87 ( op, Can.Binop_ associativity precedence func )
66 ( op, Can.Binop_ associativity precedence func )
88
67
89
68
@@ -97,9 +76,9 @@ canonicalizeBinop (Valid.Binop op associativity precedence func) =
97--
76--
98
77
99
78
100−canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls
79+canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls
101−canonicalizeDecls env decls =
80+canonicalizeValues env values =
102− do nodes <- traverse (toNodeOne env) decls
81+ do nodes <- traverse (toNodeOne env) values
103 detectCycles (Graph.stronglyConnComp nodes)
82 detectCycles (Graph.stronglyConnComp nodes)
104
83
105
84
@@ -114,13 +93,11 @@ detectCycles sccs =
114 Graph.AcyclicSCC (def, _, _) ->
93 Graph.AcyclicSCC (def, _, _) ->
115 Can.Declare def <$> detectCycles otherSccs
94 Can.Declare def <$> detectCycles otherSccs
116
95
117− Graph.CyclicSCC [] ->
118− detectCycles otherSccs
119−
120 Graph.CyclicSCC subNodes ->
96 Graph.CyclicSCC subNodes ->
121− Can.DeclareRec
122− <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
97+ do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)
98+ case defs of
99+ [] -> detectCycles otherSccs
123− <*> detectCycles otherSccs
100+ d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs
124
101
125
102
126detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
@@ -129,8 +106,22 @@ detectBadCycles scc =
129 Graph.AcyclicSCC def ->
106 Graph.AcyclicSCC def ->
130 Result.ok def
107 Result.ok def
131
108
132− Graph.CyclicSCC cyclicValueDefs ->
109+ Graph.CyclicSCC [] ->
110+ error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"
111+
112+ Graph.CyclicSCC (def:defs) ->
113+ let
114+ (A.At region name) = extractDefName def
115+ names = map (A.toValue . extractDefName) defs
116+ in
133− Result.throw (Error.RecursiveDecl cyclicValueDefs)
117+ Result.throw (Error.RecursiveDecl region name names)
118+
119+
120+extractDefName :: Can.Def -> A.Located Name.Name
121+extractDefName def =
122+ case def of
123+ Can.Def name _ _ -> name
124+ Can.TypedDef name _ _ _ _ -> name
134
125
135
126
136
127
@@ -142,17 +133,17 @@ detectBadCycles scc =
142-- Phase one nodes track ALL dependencies.
133-- Phase one nodes track ALL dependencies.
143-- This allows us to find cyclic values for type inference.
134-- This allows us to find cyclic values for type inference.
144type NodeOne =
135type NodeOne =
145− (NodeTwo, N.Name, [N.Name])
136+ (NodeTwo, Name.Name, [Name.Name])
146
137
147
138
148-- Phase two nodes track DIRECT dependencies.
139-- Phase two nodes track DIRECT dependencies.
149-- This allows us to detect cycles that definitely do not terminate.
140-- This allows us to detect cycles that definitely do not terminate.
150type NodeTwo =
141type NodeTwo =
151− (Can.Def, N.Name, [N.Name])
142+ (Can.Def, Name.Name, [Name.Name])
152
143
153
144
154−toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne
145+toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne
155−toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
146+toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =
156 case maybeType of
147 case maybeType of
157 Nothing ->
148 Nothing ->
158 do (args, argBindings) <-
149 do (args, argBindings) <-
@@ -193,7 +184,7 @@ toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
193 )
184 )
194
185
195
186
196−toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
187+toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
197toNodeTwo name args def freeLocals =
188toNodeTwo name args def freeLocals =
198 case args of
189 case args of
199 [] ->
190 [] ->
@@ -203,7 +194,7 @@ toNodeTwo name args def freeLocals =
203 (def, name, [])
194 (def, name, [])
204
195
205
196
206−addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]
197+addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]
207addDirects name (Expr.Uses directUses _) directDeps =
198addDirects name (Expr.Uses directUses _) directDeps =
208 if directUses > 0 then
199 if directUses > 0 then
209 name:directDeps
200 name:directDeps
@@ -216,41 +207,41 @@ addDirects name (Expr.Uses directUses _) directDeps =
216
207
217
208
218canonicalizeExports
209canonicalizeExports
219− :: [A.Located Valid.Decl]
210+ :: [A.Located Src.Value]
220− -> Map.Map N.Name union
211+ -> Map.Map Name.Name union
221− -> Map.Map N.Name alias
212+ -> Map.Map Name.Name alias
222− -> Map.Map N.Name binop
213+ -> Map.Map Name.Name binop
223 -> Can.Effects
214 -> Can.Effects
224 -> A.Located Src.Exposing
215 -> A.Located Src.Exposing
225 -> Result i w Can.Exports
216 -> Result i w Can.Exports
226−canonicalizeExports decls unions aliases binops effects (A.At region exposing) =
217+canonicalizeExports values unions aliases binops effects (A.At region exposing) =
227 case exposing of
218 case exposing of
228 Src.Open ->
219 Src.Open ->
229 Result.ok (Can.ExportEverything region)
220 Result.ok (Can.ExportEverything region)
230
221
231 Src.Explicit exposeds ->
222 Src.Explicit exposeds ->
232− do let names = Map.fromList (map declToName decls)
223+ do let names = Map.fromList (map valueToName values)
233 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
224 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
234 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
225 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
235
226
236
227
237−declToName :: A.Located Valid.Decl -> ( N.Name, () )
228+valueToName :: A.Located Src.Value -> ( Name.Name, () )
238−declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =
229+valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =
239 ( name, () )
230 ( name, () )
240
231
241
232
242checkExposed
233checkExposed
243− :: Map.Map N.Name decl
234+ :: Map.Map Name.Name value
244− -> Map.Map N.Name union
235+ -> Map.Map Name.Name union
245− -> Map.Map N.Name alias
236+ -> Map.Map Name.Name alias
246− -> Map.Map N.Name binop
237+ -> Map.Map Name.Name binop
247 -> Can.Effects
238 -> Can.Effects
248− -> A.Located Src.Exposed
239+ -> Src.Exposed
249 -> Result i w (Dups.Dict (A.Located Can.Export))
240 -> Result i w (Dups.Dict (A.Located Can.Export))
250−checkExposed decls unions aliases binops effects (A.At region exposed) =
241+checkExposed values unions aliases binops effects exposed =
251 case exposed of
242 case exposed of
252− Src.Lower name ->
243+ Src.Lower (A.At region name) ->
253− if Map.member name decls then
244+ if Map.member name values then
254 ok name region Can.ExportValue
245 ok name region Can.ExportValue
255 else
246 else
256 case checkPorts effects name of
247 case checkPorts effects name of
@@ -259,25 +250,25 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =
259
250
260 Just ports ->
251 Just ports ->
261 Result.throw $ Error.ExportNotFound region Error.BadVar name $
252 Result.throw $ Error.ExportNotFound region Error.BadVar name $
262− ports ++ Map.keys decls
253+ ports ++ Map.keys values
263
254
264− Src.Operator name ->
255+ Src.Operator region name ->
265 if Map.member name binops then
256 if Map.member name binops then
266 ok name region Can.ExportBinop
257 ok name region Can.ExportBinop
267 else
258 else
268 Result.throw $ Error.ExportNotFound region Error.BadOp name $
259 Result.throw $ Error.ExportNotFound region Error.BadOp name $
269 Map.keys binops
260 Map.keys binops
270
261
271− Src.Upper name Src.Public ->
262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
272 if Map.member name unions then
263 if Map.member name unions then
273 ok name region Can.ExportUnionOpen
264 ok name region Can.ExportUnionOpen
274 else if Map.member name aliases then
265 else if Map.member name aliases then
275− Result.throw $ Error.ExportOpenAlias region name
266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name
276 else
267 else
277 Result.throw $ Error.ExportNotFound region Error.BadType name $
268 Result.throw $ Error.ExportNotFound region Error.BadType name $
278 Map.keys unions ++ Map.keys aliases
269 Map.keys unions ++ Map.keys aliases
279
270
280− Src.Upper name Src.Private ->
271+ Src.Upper (A.At region name) Src.Private ->
281 if Map.member name unions then
272 if Map.member name unions then
282 ok name region Can.ExportUnionClosed
273 ok name region Can.ExportUnionClosed
283 else if Map.member name aliases then
274 else if Map.member name aliases then
@@ -287,7 +278,7 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =
287 Map.keys unions ++ Map.keys aliases
278 Map.keys unions ++ Map.keys aliases
288
279
289
280
290−checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
281+checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]
291checkPorts effects name =
282checkPorts effects name =
292 case effects of
283 case effects of
293 Can.NoEffects ->
284 Can.NoEffects ->
@@ -300,6 +291,6 @@ checkPorts effects name =
300 Just []
291 Just []
301
292
302
293
303−ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
294+ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
304ok name region export =
295ok name region export =
305 Result.ok $ Dups.one name region (A.At region export)
296 Result.ok $ Dups.one name region (A.At region export)
src/Canonicalize/Pattern.hs → compiler/src/Canonicalize/Pattern.hsrenamed+16−12
@@ -8,17 +8,18 @@ module Canonicalize.Pattern
8 where
8 where
9
9
10
10
11+import qualified Data.List as List
11import qualified Data.Map.Strict as Map
12import qualified Data.Map.Strict as Map
13+import qualified Data.Name as Name
12
14
13import qualified AST.Canonical as Can
15import qualified AST.Canonical as Can
14import qualified AST.Source as Src
16import qualified AST.Source as Src
15import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment.Dups as Dups
18import qualified Canonicalize.Environment.Dups as Dups
17import qualified Data.Index as Index
19import qualified Data.Index as Index
18−import qualified Elm.Name as N
20+import qualified Elm.ModuleName as ModuleName
19import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
21−import qualified Reporting.Region as R
22import qualified Reporting.Result as Result
23import qualified Reporting.Result as Result
23
24
24
25
@@ -31,7 +32,7 @@ type Result i w a =
31
32
32
33
33type Bindings =
34type Bindings =
34− Map.Map N.Name R.Region
35+ Map.Map Name.Name A.Region
35
36
36
37
37
38
@@ -59,7 +60,7 @@ verify context (Result.Result k) =
59
60
60
61
61type DupsDict =
62type DupsDict =
62− Dups.Dict R.Region
63+ Dups.Dict A.Region
63
64
64
65
65canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
66canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
@@ -112,7 +113,7 @@ canonicalize env (A.At region pattern) =
112 Result.ok (Can.PInt int)
113 Result.ok (Can.PInt int)
113
114
114
115
115−canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
116+canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
116canonicalizeCtor env region name patterns ctor =
117canonicalizeCtor env region name patterns ctor =
117 case ctor of
118 case ctor of
118 Env.Ctor home tipe union index args ->
119 Env.Ctor home tipe union index args ->
@@ -123,16 +124,19 @@ canonicalizeCtor env region name patterns ctor =
123 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
124 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
124 case verifiedList of
125 case verifiedList of
125 Index.LengthMatch cargs ->
126 Index.LengthMatch cargs ->
127+ if tipe == Name.bool && home == ModuleName.basics then
128+ Result.ok (Can.PBool union (name == Name.true))
129+ else
126− Result.ok (Can.PCtor home tipe union name index cargs)
130+ Result.ok (Can.PCtor home tipe union name index cargs)
127
131
128 Index.LengthMismatch actualLength expectedLength ->
132 Index.LengthMismatch actualLength expectedLength ->
129− Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)
133+ Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)
130
134
131 Env.RecordCtor _ _ _ ->
135 Env.RecordCtor _ _ _ ->
132 Result.throw (Error.PatternHasRecordCtor region name)
136 Result.throw (Error.PatternHasRecordCtor region name)
133
137
134
138
135−canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
139+canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
136canonicalizeTuple tupleRegion env extras =
140canonicalizeTuple tupleRegion env extras =
137 case extras of
141 case extras of
138 [] ->
142 [] ->
@@ -161,17 +165,17 @@ canonicalizeList env list =
161-- LOG BINDINGS
165-- LOG BINDINGS
162
166
163
167
164−logVar :: N.Name -> R.Region -> a -> Result DupsDict w a
168+logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a
165logVar name region value =
169logVar name region value =
166 Result.Result $ \bindings warnings _ ok ->
170 Result.Result $ \bindings warnings _ ok ->
167 ok (Dups.insert name region region bindings) warnings value
171 ok (Dups.insert name region region bindings) warnings value
168
172
169
173
170−logFields :: [A.Located N.Name] -> a -> Result DupsDict w a
174+logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
171logFields fields value =
175logFields fields value =
172 let
176 let
173− addField (A.At region name) dict =
177+ addField dict (A.At region name) =
174 Dups.insert name region region dict
178 Dups.insert name region region dict
175 in
179 in
176 Result.Result $ \bindings warnings _ ok ->
180 Result.Result $ \bindings warnings _ ok ->
177− ok (foldr addField bindings fields) warnings value
181+ ok (List.foldl' addField bindings fields) warnings value
src/Canonicalize/Type.hs → compiler/src/Canonicalize/Type.hsrenamed+22−9
@@ -9,15 +9,14 @@ module Canonicalize.Type
9
9
10import qualified Data.List as List
10import qualified Data.List as List
11import qualified Data.Map as Map
11import qualified Data.Map as Map
12+import qualified Data.Name as Name
12
13
13import qualified AST.Canonical as Can
14import qualified AST.Canonical as Can
14import qualified AST.Source as Src
15import qualified AST.Source as Src
15import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment.Dups as Dups
17import qualified Canonicalize.Environment.Dups as Dups
17−import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Canonicalize as Error
19import qualified Reporting.Error.Canonicalize as Error
20−import qualified Reporting.Region as R
21import qualified Reporting.Result as Result
20import qualified Reporting.Result as Result
22
21
23
22
@@ -63,8 +62,7 @@ canonicalize env (A.At typeRegion tipe) =
63 <*> canonicalize env b
62 <*> canonicalize env b
64
63
65 Src.TRecord fields ext ->
64 Src.TRecord fields ext ->
66− do fieldDict <- Dups.checkFields fields
65+ do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields)
67− cfields <- traverse (canonicalize env) fieldDict
68 return $ Can.TRecord cfields (fmap A.toValue ext)
66 return $ Can.TRecord cfields (fmap A.toValue ext)
69
67
70 Src.TUnit ->
68 Src.TUnit ->
@@ -86,11 +84,21 @@ canonicalize env (A.At typeRegion tipe) =
86 Result.throw $ Error.TupleLargerThanThree typeRegion
84 Result.throw $ Error.TupleLargerThanThree typeRegion
87
85
88
86
87+canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)]
88+canonicalizeFields env fields =
89+ let
90+ len = fromIntegral (length fields)
91+ canonicalizeField index (name, srcType) =
92+ (name, Can.FieldType index <$> canonicalize env srcType)
93+ in
94+ zipWith canonicalizeField [0..len] fields
95+
96+
89
97
90-- CANONICALIZE TYPE
98-- CANONICALIZE TYPE
91
99
92
100
93−canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
101+canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
94canonicalizeType env region name args info =
102canonicalizeType env region name args info =
95 do cargs <- traverse (canonicalize env) args
103 do cargs <- traverse (canonicalize env) args
96 case info of
104 case info of
@@ -103,7 +111,7 @@ canonicalizeType env region name args info =
103 Can.TType home name cargs
111 Can.TType home name cargs
104
112
105
113
106−checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer
114+checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer
107checkArity expected region name args answer =
115checkArity expected region name args answer =
108 let actual = length args in
116 let actual = length args in
109 if expected == actual then
117 if expected == actual then
@@ -116,7 +124,7 @@ checkArity expected region name args answer =
116-- ADD FREE VARS
124-- ADD FREE VARS
117
125
118
126
119−addFreeVars :: Map.Map N.Name () -> Can.Type -> Map.Map N.Name ()
127+addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name ()
120addFreeVars freeVars tipe =
128addFreeVars freeVars tipe =
121 case tipe of
129 case tipe of
122 Can.TLambda arg result ->
130 Can.TLambda arg result ->
@@ -129,10 +137,10 @@ addFreeVars freeVars tipe =
129 List.foldl' addFreeVars freeVars args
137 List.foldl' addFreeVars freeVars args
130
138
131 Can.TRecord fields Nothing ->
139 Can.TRecord fields Nothing ->
132− Map.foldl addFreeVars freeVars fields
140+ Map.foldl addFieldFreeVars freeVars fields
133
141
134 Can.TRecord fields (Just ext) ->
142 Can.TRecord fields (Just ext) ->
135− Map.foldl addFreeVars (Map.insert ext () freeVars) fields
143+ Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields
136
144
137 Can.TUnit ->
145 Can.TUnit ->
138 freeVars
146 freeVars
@@ -147,3 +155,8 @@ addFreeVars freeVars tipe =
147
155
148 Can.TAlias _ _ args _ ->
156 Can.TAlias _ _ args _ ->
149 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args
157 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args
158+
159+
160+addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name ()
161+addFieldFreeVars freeVars (Can.FieldType _ tipe) =
162+ addFreeVars freeVars tipe
compiler/src/Compile.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+module Compile
3+ ( Artifacts(..)
4+ , compile
5+ )
6+ where
7+
8+
9+import qualified Data.Map as Map
10+import qualified Data.Name as Name
11+
12+import qualified AST.Source as Src
13+import qualified AST.Canonical as Can
14+import qualified AST.Optimized as Opt
15+import qualified Canonicalize.Module as Canonicalize
16+import qualified Elm.Interface as I
17+import qualified Elm.ModuleName as ModuleName
18+import qualified Elm.Package as Pkg
19+import qualified Nitpick.PatternMatches as PatternMatches
20+import qualified Optimize.Module as Optimize
21+import qualified Reporting.Error as E
22+import qualified Reporting.Result as R
23+import qualified Reporting.Render.Type.Localizer as Localizer
24+import qualified Type.Constrain.Module as Type
25+import qualified Type.Solve as Type
26+
27+import System.IO.Unsafe (unsafePerformIO)
28+
29+
30+
31+-- COMPILE
32+
33+
34+data Artifacts =
35+ Artifacts
36+ { _modul :: Can.Module
37+ , _types :: Map.Map Name.Name Can.Annotation
38+ , _graph :: Opt.LocalGraph
39+ }
40+
41+
42+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
43+compile pkg ifaces modul =
44+ do canonical <- canonicalize pkg ifaces modul
45+ annotations <- typeCheck modul canonical
46+ () <- nitpick canonical
47+ objects <- optimize modul annotations canonical
48+ return (Artifacts canonical annotations objects)
49+
50+
51+
52+-- PHASES
53+
54+
55+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module
56+canonicalize pkg ifaces modul =
57+ case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of
58+ Right canonical ->
59+ Right canonical
60+
61+ Left errors ->
62+ Left $ E.BadNames errors
63+
64+
65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)
66+typeCheck modul canonical =
67+ case unsafePerformIO (Type.run =<< Type.constrain canonical) of
68+ Right annotations ->
69+ Right annotations
70+
71+ Left errors ->
72+ Left (E.BadTypes (Localizer.fromModule modul) errors)
73+
74+
75+nitpick :: Can.Module -> Either E.Error ()
76+nitpick canonical =
77+ case PatternMatches.check canonical of
78+ Right () ->
79+ Right ()
80+
81+ Left errors ->
82+ Left (E.BadPatterns errors)
83+
84+
85+optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
86+optimize modul annotations canonical =
87+ case snd $ R.run $ Optimize.optimize annotations canonical of
88+ Right localGraph ->
89+ Right localGraph
90+
91+ Left errors ->
92+ Left (E.BadMains (Localizer.fromModule modul) errors)
src/Data/Bag.hs → compiler/src/Data/Bag.hsrenamed−11
@@ -108,14 +108,3 @@ fromList func list =
108add :: (a -> b) -> Bag b -> a -> Bag b
108add :: (a -> b) -> Bag b -> a -> Bag b
109add func bag value =
109add func bag value =
110 Two (One (func value)) bag
110 Two (One (func value)) bag
111−
112−
113−
114−-- MONOID
115−
116−
117−instance Monoid (Bag a) where
118− {-# INLINE mempty #-}
119− mempty = Empty
120− {-# INLINE mappend #-}
121− mappend = Two
src/Data/Index.hs → compiler/src/Data/Index.hsrenamed

The content is the same.

compiler/src/Data/Map/Utils.hsnew file+43
@@ -0,0 +1,43 @@
1+module Data.Map.Utils
2+ ( fromKeys
3+ , fromKeysA
4+ , fromValues
5+ , any
6+ )
7+ where
8+
9+
10+import Prelude hiding (any)
11+import qualified Data.Map as Map
12+import Data.Map.Internal (Map(..))
13+
14+
15+
16+-- FROM KEYS
17+
18+
19+fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v
20+fromKeys toValue keys =
21+ Map.fromList $ map (\k -> (k, toValue k)) keys
22+
23+
24+fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v)
25+fromKeysA toValue keys =
26+ Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys
27+
28+
29+fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v
30+fromValues toKey values =
31+ Map.fromList $ map (\v -> (toKey v, v)) values
32+
33+
34+
35+-- ANY
36+
37+
38+{-# INLINE any #-}
39+any :: (v -> Bool) -> Map.Map k v -> Bool
40+any isGood = go
41+ where
42+ go Tip = False
43+ go (Bin _ _ v l r) = isGood v || go l || go r
compiler/src/Data/Name.hsnew file+610
@@ -0,0 +1,610 @@
1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
3+module Data.Name
4+ ( Name
5+ --
6+ , toChars
7+ , toElmString
8+ , toBuilder
9+ --
10+ , fromPtr
11+ , fromChars
12+ --
13+ , getKernel
14+ , hasDot
15+ , splitDots
16+ , isKernel
17+ , isNumberType
18+ , isComparableType
19+ , isAppendableType
20+ , isCompappendType
21+ , fromVarIndex
22+ , fromWords
23+ , fromManyNames
24+ , fromTypeVariable
25+ , fromTypeVariableScheme
26+ , sepBy
27+ --
28+ , int, float, bool, char, string
29+ , maybe, result, list, array, dict, tuple, jsArray
30+ , task, router, cmd, sub, platform, virtualDom
31+ , shader, debug, debugger, bitwise, basics
32+ , utils, negate, true, false, value
33+ , node, program, _main, _Main, dollar, identity
34+ , replModule, replValueToPrint
35+ )
36+ where
37+
38+
39+import Prelude hiding (length, maybe, negate)
40+import Control.Exception (assert)
41+import qualified Data.Binary as Binary
42+import qualified Data.ByteString.Builder.Internal as B
43+import qualified Data.Coerce as Coerce
44+import qualified Data.List as List
45+import qualified Data.String as Chars
46+import qualified Data.Utf8 as Utf8
47+import GHC.Exts
48+ ( Int(I#), Ptr
49+ , MutableByteArray#
50+ , isTrue#
51+ , newByteArray#
52+ , sizeofByteArray#
53+ , unsafeFreezeByteArray#
54+ )
55+import GHC.ST (ST(ST), runST)
56+import GHC.Prim
57+import GHC.Word (Word8(W8#))
58+
59+import qualified Elm.String as ES
60+
61+
62+
63+-- NAME
64+
65+
66+type Name =
67+ Utf8.Utf8 ELM_NAME
68+
69+
70+data ELM_NAME
71+
72+
73+
74+-- INSTANCES
75+
76+
77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
78+ fromString = Utf8.fromChars
79+
80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
81+ get = Utf8.getUnder256
82+ put = Utf8.putUnder256
83+
84+
85+
86+-- TO
87+
88+
89+toChars :: Name -> [Char]
90+toChars =
91+ Utf8.toChars
92+
93+
94+toElmString :: Name -> ES.String
95+toElmString =
96+ Coerce.coerce
97+
98+
99+{-# INLINE toBuilder #-}
100+toBuilder :: Name -> B.Builder
101+toBuilder =
102+ Utf8.toBuilder
103+
104+
105+
106+-- FROM
107+
108+
109+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
110+fromPtr =
111+ Utf8.fromPtr
112+
113+
114+fromChars :: [Char] -> Name
115+fromChars =
116+ Utf8.fromChars
117+
118+
119+
120+-- HAS DOT
121+
122+
123+hasDot :: Name -> Bool
124+hasDot name =
125+ Utf8.contains 0x2E {- . -} name
126+
127+
128+splitDots :: Name -> [Name]
129+splitDots name =
130+ Utf8.split 0x2E {- . -} name
131+
132+
133+
134+-- GET KERNEL
135+
136+
137+getKernel :: Name -> Name
138+getKernel name@(Utf8.Utf8 ba#) =
139+ assert (isKernel name)
140+ (
141+ runST
142+ (
143+ let
144+ !size# = sizeofByteArray# ba# -# 11#
145+ in
146+ ST $ \s ->
147+ case newByteArray# size# s of
148+ (# s, mba# #) ->
149+ case copyByteArray# ba# 11# mba# 0# size# s of
150+ s ->
151+ case unsafeFreezeByteArray# mba# s of
152+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
153+ )
154+ )
155+
156+
157+
158+-- STARTS WITH
159+
160+
161+isKernel :: Name -> Bool
162+isKernel = Utf8.startsWith prefix_kernel
163+
164+isNumberType :: Name -> Bool
165+isNumberType = Utf8.startsWith prefix_number
166+
167+isComparableType :: Name -> Bool
168+isComparableType = Utf8.startsWith prefix_comparable
169+
170+isAppendableType :: Name -> Bool
171+isAppendableType = Utf8.startsWith prefix_appendable
172+
173+isCompappendType :: Name -> Bool
174+isCompappendType = Utf8.startsWith prefix_compappend
175+
176+{-# NOINLINE prefix_kernel #-}
177+prefix_kernel :: Name
178+prefix_kernel = fromChars "Elm.Kernel."
179+
180+{-# NOINLINE prefix_number #-}
181+prefix_number :: Name
182+prefix_number = fromChars "number"
183+
184+{-# NOINLINE prefix_comparable #-}
185+prefix_comparable :: Name
186+prefix_comparable = fromChars "comparable"
187+
188+{-# NOINLINE prefix_appendable #-}
189+prefix_appendable :: Name
190+prefix_appendable = fromChars "appendable"
191+
192+{-# NOINLINE prefix_compappend #-}
193+prefix_compappend :: Name
194+prefix_compappend = fromChars "compappend"
195+
196+
197+
198+-- FROM VAR INDEX
199+
200+
201+fromVarIndex :: Int -> Name
202+fromVarIndex n =
203+ runST
204+ (
205+ do let !size = 2 + getIndexSize n
206+ mba <- newByteArray size
207+ writeWord8 mba 0 0x5F {- _ -}
208+ writeWord8 mba 1 0x76 {- v -}
209+ writeDigitsAtEnd mba size n
210+ freeze mba
211+ )
212+
213+
214+{-# INLINE getIndexSize #-}
215+getIndexSize :: Int -> Int
216+getIndexSize n
217+ | n < 10 = 1
218+ | n < 100 = 2
219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)
220+
221+
222+
223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()
224+writeDigitsAtEnd !mba !oldOffset !n =
225+ do let (q,r) = quotRem n 10
226+ let !newOffset = oldOffset - 1
227+ writeWord8 mba newOffset (0x30 + fromIntegral r)
228+ if q <= 0
229+ then return ()
230+ else writeDigitsAtEnd mba newOffset q
231+
232+
233+
234+-- FROM TYPE VARIABLE
235+
236+
237+fromTypeVariable :: Name -> Int -> Name
238+fromTypeVariable name@(Utf8.Utf8 ba#) index =
239+ if index <= 0 then
240+ name
241+ else
242+ let
243+ len# = sizeofByteArray# ba#
244+ end# = indexWord8Array# ba# (len# -# 1#)
245+ in
246+ if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
247+ runST
248+ (
249+ do let !size = I# len# + 1 + getIndexSize index
250+ mba <- newByteArray size
251+ copyToMBA name mba
252+ writeWord8 mba (I# len#) 0x5F {- _ -}
253+ writeDigitsAtEnd mba size index
254+ freeze mba
255+ )
256+ else
257+ runST
258+ (
259+ do let !size = I# len# + getIndexSize index
260+ mba <- newByteArray size
261+ copyToMBA name mba
262+ writeDigitsAtEnd mba size index
263+ freeze mba
264+ )
265+
266+
267+
268+-- FROM TYPE VARIABLE SCHEME
269+
270+
271+fromTypeVariableScheme :: Int -> Name
272+fromTypeVariableScheme scheme =
273+ runST
274+ (
275+ if scheme < 26 then
276+ do mba <- newByteArray 1
277+ writeWord8 mba 0 (0x61 + fromIntegral scheme)
278+ freeze mba
279+ else
280+ do let (extra, letter) = quotRem scheme 26
281+ let !size = 1 + getIndexSize extra
282+ mba <- newByteArray size
283+ writeWord8 mba 0 (0x61 + fromIntegral letter)
284+ writeDigitsAtEnd mba size extra
285+ freeze mba
286+ )
287+
288+
289+
290+-- FROM MANY NAMES
291+--
292+-- Creating a unique name by combining all the subnames can create names
293+-- longer than 256 bytes relatively easily. So instead, the first given name
294+-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)
295+--
296+-- This should be a unique name since 0.19 disallows shadowing. It would not
297+-- be possible for multiple top-level cycles to include values with the same
298+-- name, so the important thing is to make the cycle name distinct from the
299+-- normal name. Same logic for destructuring patterns like (x,y)
300+
301+
302+fromManyNames :: [Name] -> Name
303+fromManyNames names =
304+ case names of
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#
313+ in
314+ runST
315+ (
316+ ST $ \s ->
317+ case newByteArray# (len# +# 3#) s of
318+ (# s, mba# #) ->
319+ case writeWord8Array# mba# 0# 0x5F## {-_-} s of
320+ s ->
321+ case writeWord8Array# mba# 1# 0x4D## {-M-} s of
322+ s ->
323+ case writeWord8Array# mba# 2# 0x24## {-$-} s of
324+ s ->
325+ case copyByteArray# ba# 0# mba# 3# len# s of
326+ s ->
327+ case unsafeFreezeByteArray# mba# s of
328+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
329+ )
330+
331+
332+{-# NOINLINE blank #-}
333+blank :: Name
334+blank =
335+ fromWords [0x5F,0x4D,0x24] {-_M$-}
336+
337+
338+
339+-- FROM WORDS
340+
341+
342+fromWords :: [Word8] -> Name
343+fromWords words =
344+ runST
345+ (
346+ do mba <- newByteArray (List.length words)
347+ writeWords mba 0 words
348+ freeze mba
349+ )
350+
351+
352+writeWords :: MBA s -> Int -> [Word8] -> ST s ()
353+writeWords !mba !i words =
354+ case words of
355+ [] ->
356+ return ()
357+
358+ w:ws ->
359+ do writeWord8 mba i w
360+ writeWords mba (i+1) ws
361+
362+
363+
364+-- SEP BY
365+
366+
367+sepBy :: Word8 -> Name -> Name -> Name
368+sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =
369+ let
370+ !len1# = sizeofByteArray# ba1#
371+ !len2# = sizeofByteArray# ba2#
372+ in
373+ runST
374+ (
375+ ST $ \s ->
376+ case newByteArray# (len1# +# len2# +# 1#) s of
377+ (# s, mba# #) ->
378+ case copyByteArray# ba1# 0# mba# 0# len1# s of
379+ s ->
380+ case writeWord8Array# mba# len1# sep# s of
381+ s ->
382+ case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
383+ s ->
384+ case unsafeFreezeByteArray# mba# s of
385+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
386+ )
387+
388+
389+
390+-- PRIMITIVES
391+
392+
393+data MBA s =
394+ MBA# (MutableByteArray# s)
395+
396+
397+{-# INLINE newByteArray #-}
398+newByteArray :: Int -> ST s (MBA s)
399+newByteArray (I# len#) =
400+ ST $ \s ->
401+ case newByteArray# len# s of
402+ (# s, mba# #) -> (# s, MBA# mba# #)
403+
404+
405+{-# INLINE freeze #-}
406+freeze :: MBA s -> ST s Name
407+freeze (MBA# mba#) =
408+ ST $ \s ->
409+ case unsafeFreezeByteArray# mba# s of
410+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
411+
412+
413+{-# INLINE writeWord8 #-}
414+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
415+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
416+ ST $ \s ->
417+ case writeWord8Array# mba# offset# w# s of
418+ s -> (# s, () #)
419+
420+
421+{-# INLINE copyToMBA #-}
422+copyToMBA :: Name -> MBA s -> ST s ()
423+copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
424+ ST $ \s ->
425+ case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
426+ s -> (# s, () #)
427+
428+
429+
430+-- COMMON NAMES
431+
432+
433+{-# NOINLINE int #-}
434+int :: Name
435+int = fromChars "Int"
436+
437+
438+{-# NOINLINE float #-}
439+float :: Name
440+float = fromChars "Float"
441+
442+
443+{-# NOINLINE bool #-}
444+bool :: Name
445+bool = fromChars "Bool"
446+
447+
448+{-# NOINLINE char #-}
449+char :: Name
450+char = fromChars "Char"
451+
452+
453+{-# NOINLINE string #-}
454+string :: Name
455+string = fromChars "String"
456+
457+
458+{-# NOINLINE maybe #-}
459+maybe :: Name
460+maybe = fromChars "Maybe"
461+
462+
463+{-# NOINLINE result #-}
464+result :: Name
465+result = fromChars "Result"
466+
467+
468+{-# NOINLINE list #-}
469+list :: Name
470+list = fromChars "List"
471+
472+
473+{-# NOINLINE array #-}
474+array :: Name
475+array = fromChars "Array"
476+
477+
478+{-# NOINLINE dict #-}
479+dict :: Name
480+dict = fromChars "Dict"
481+
482+
483+{-# NOINLINE tuple #-}
484+tuple :: Name
485+tuple = fromChars "Tuple"
486+
487+
488+{-# NOINLINE jsArray #-}
489+jsArray :: Name
490+jsArray = fromChars "JsArray"
491+
492+
493+{-# NOINLINE task #-}
494+task :: Name
495+task = fromChars "Task"
496+
497+
498+{-# NOINLINE router #-}
499+router :: Name
500+router = fromChars "Router"
501+
502+
503+{-# NOINLINE cmd #-}
504+cmd :: Name
505+cmd = fromChars "Cmd"
506+
507+
508+{-# NOINLINE sub #-}
509+sub :: Name
510+sub = fromChars "Sub"
511+
512+
513+{-# NOINLINE platform #-}
514+platform :: Name
515+platform = fromChars "Platform"
516+
517+
518+{-# NOINLINE virtualDom #-}
519+virtualDom :: Name
520+virtualDom = fromChars "VirtualDom"
521+
522+
523+{-# NOINLINE shader #-}
524+shader :: Name
525+shader = fromChars "Shader"
526+
527+
528+{-# NOINLINE debug #-}
529+debug :: Name
530+debug = fromChars "Debug"
531+
532+
533+{-# NOINLINE debugger #-}
534+debugger :: Name
535+debugger = fromChars "Debugger"
536+
537+
538+{-# NOINLINE bitwise #-}
539+bitwise :: Name
540+bitwise = fromChars "Bitwise"
541+
542+
543+{-# NOINLINE basics #-}
544+basics :: Name
545+basics = fromChars "Basics"
546+
547+
548+{-# NOINLINE utils #-}
549+utils :: Name
550+utils = fromChars "Utils"
551+
552+
553+{-# NOINLINE negate #-}
554+negate :: Name
555+negate = fromChars "negate"
556+
557+
558+{-# NOINLINE true #-}
559+true :: Name
560+true = fromChars "True"
561+
562+
563+{-# NOINLINE false #-}
564+false :: Name
565+false = fromChars "False"
566+
567+
568+{-# NOINLINE value #-}
569+value :: Name
570+value = fromChars "Value"
571+
572+
573+{-# NOINLINE node #-}
574+node :: Name
575+node = fromChars "Node"
576+
577+
578+{-# NOINLINE program #-}
579+program :: Name
580+program = fromChars "Program"
581+
582+
583+{-# NOINLINE _main #-}
584+_main :: Name
585+_main = fromChars "main"
586+
587+
588+{-# NOINLINE _Main #-}
589+_Main :: Name
590+_Main = fromChars "Main"
591+
592+
593+{-# NOINLINE dollar #-}
594+dollar :: Name
595+dollar = fromChars "$"
596+
597+
598+{-# NOINLINE identity #-}
599+identity :: Name
600+identity = fromChars "identity"
601+
602+
603+{-# NOINLINE replModule #-}
604+replModule :: Name
605+replModule = fromChars "Elm_Repl"
606+
607+
608+{-# NOINLINE replValueToPrint #-}
609+replValueToPrint :: Name
610+replValueToPrint = fromChars "repl_input_value_"
compiler/src/Data/NonEmptyList.hsnew file+78
@@ -0,0 +1,78 @@
1+module Data.NonEmptyList
2+ ( List(..)
3+ , singleton
4+ , toList
5+ , sortBy
6+ )
7+ where
8+
9+
10+import Control.Monad (liftM2)
11+import Data.Binary (Binary, get, put)
12+import qualified Data.List as List
13+
14+
15+
16+-- LIST
17+
18+
19+data List a =
20+ List a [a]
21+
22+
23+singleton :: a -> List a
24+singleton a =
25+ List a []
26+
27+
28+toList :: List a -> [a]
29+toList (List x xs) =
30+ x:xs
31+
32+
33+
34+-- INSTANCES
35+
36+
37+instance Functor List where
38+ fmap func (List x xs) = List (func x) (map func xs)
39+
40+
41+instance Traversable List where
42+ traverse func (List x xs) = List <$> func x <*> traverse func xs
43+
44+
45+instance Foldable List where
46+ foldr step state (List x xs) = step x (foldr step state xs)
47+ foldl step state (List x xs) = foldl step (step state x) xs
48+ foldl1 step (List x xs) = foldl step x xs
49+
50+
51+
52+-- SORT BY
53+
54+
55+sortBy :: (Ord b) => (a -> b) -> List a -> List a
56+sortBy toRank (List x xs) =
57+ let
58+ comparison a b =
59+ compare (toRank a) (toRank b)
60+ in
61+ case List.sortBy comparison xs of
62+ [] ->
63+ List x []
64+
65+ y:ys ->
66+ case comparison x y of
67+ LT -> List x (y:ys)
68+ EQ -> List x (y:ys)
69+ GT -> List y (List.insertBy comparison x ys)
70+
71+
72+
73+-- BINARY
74+
75+
76+instance (Binary a) => Binary (List a) where
77+ put (List x xs) = put x >> put xs
78+ get = liftM2 List get get
compiler/src/Data/OneOrMore.hsnew file+99
@@ -0,0 +1,99 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Data.OneOrMore
3+ ( OneOrMore(..)
4+ , one
5+ , more
6+ , map
7+ , destruct
8+ , getFirstTwo
9+ )
10+ where
11+
12+
13+import Prelude hiding (map)
14+
15+
16+
17+-- ONE OR MORE
18+
19+
20+data OneOrMore a
21+ = One a
22+ | More (OneOrMore a) (OneOrMore a)
23+
24+
25+one :: a -> OneOrMore a
26+one =
27+ One
28+
29+
30+more :: OneOrMore a -> OneOrMore a -> OneOrMore a
31+more =
32+ More
33+
34+
35+
36+-- MAP
37+
38+
39+map :: (a -> b) -> OneOrMore a -> OneOrMore b
40+map func oneOrMore =
41+ case oneOrMore of
42+ One value ->
43+ One (func value)
44+
45+ More left right ->
46+ More (map func left) (map func right)
47+
48+
49+
50+-- DESTRUCT
51+
52+
53+destruct :: (a -> [a] -> b) -> OneOrMore a -> b
54+destruct func oneOrMore =
55+ destructLeft func oneOrMore []
56+
57+
58+destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b
59+destructLeft func oneOrMore xs =
60+ case oneOrMore of
61+ One x ->
62+ func x xs
63+
64+ More a b ->
65+ destructLeft func a (destructRight b xs)
66+
67+
68+destructRight :: OneOrMore a -> [a] -> [a]
69+destructRight oneOrMore xs =
70+ case oneOrMore of
71+ One x ->
72+ x : xs
73+
74+ More a b ->
75+ destructRight a (destructRight b xs)
76+
77+
78+
79+-- GET FIRST TWO
80+
81+
82+getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)
83+getFirstTwo left right =
84+ case left of
85+ One x ->
86+ (x, getFirstOne right)
87+
88+ More lleft lright ->
89+ getFirstTwo lleft lright
90+
91+
92+getFirstOne :: OneOrMore a -> a
93+getFirstOne oneOrMore =
94+ case oneOrMore of
95+ One x ->
96+ x
97+
98+ More left _ ->
99+ getFirstOne left
compiler/src/Data/Utf8.hsnew file+618
@@ -0,0 +1,618 @@
1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}
3+module Data.Utf8
4+ ( Utf8(..)
5+ , isEmpty
6+ , empty
7+ , size
8+ , contains
9+ , startsWith
10+ , startsWithChar
11+ , endsWithWord8
12+ , split
13+ , join
14+ --
15+ , getUnder256
16+ , putUnder256
17+ --
18+ , getVeryLong
19+ , putVeryLong
20+ --
21+ , toChars
22+ , toBuilder
23+ , toEscapedBuilder
24+ --
25+ , fromPtr
26+ , fromSnippet
27+ , fromChars
28+ --
29+ , MBA
30+ , newByteArray
31+ , copyFromPtr
32+ , writeWord8
33+ , freeze
34+ )
35+ where
36+
37+
38+import Prelude hiding (String, all, any, concat)
39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)
40+import Data.Binary.Put (putBuilder)
41+import Data.Binary.Get.Internal (readN)
42+import Data.Bits ((.&.), shiftR)
43+import qualified Data.ByteString.Internal as B
44+import qualified Data.ByteString.Builder.Internal as B
45+import qualified Data.Char as Char
46+import qualified Data.List as List
47+import Foreign.ForeignPtr (touchForeignPtr)
48+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
49+import Foreign.Ptr (minusPtr, plusPtr)
50+import GHC.Exts
51+ ( Int(I#), Ptr(Ptr), Char(C#)
52+ , RealWorld
53+ , ByteArray#, MutableByteArray#
54+ , isTrue#
55+ , newByteArray#
56+ , unsafeFreezeByteArray#
57+ , sizeofByteArray#
58+ , copyByteArray#
59+ , copyAddrToByteArray#
60+ , copyByteArrayToAddr#
61+ , writeWord8Array#
62+ )
63+import GHC.IO
64+import GHC.ST (ST(ST), runST)
65+import GHC.Prim
66+import GHC.Word (Word8(W8#))
67+
68+import qualified Parse.Primitives as P
69+
70+
71+
72+-- UTF-8
73+
74+
75+data Utf8 tipe =
76+ Utf8 ByteArray#
77+
78+
79+
80+-- EMPTY
81+
82+
83+{-# NOINLINE empty #-}
84+empty :: Utf8 t
85+empty =
86+ runST (freeze =<< newByteArray 0)
87+
88+
89+isEmpty :: Utf8 t -> Bool
90+isEmpty (Utf8 ba#) =
91+ isTrue# (sizeofByteArray# ba# ==# 0#)
92+
93+
94+
95+-- SIZE
96+
97+
98+size :: Utf8 t -> Int
99+size (Utf8 ba#) =
100+ I# (sizeofByteArray# ba#)
101+
102+
103+
104+-- CONTAINS
105+
106+
107+contains :: Word8 -> Utf8 t -> Bool
108+contains (W8# word#) (Utf8 ba#) =
109+ containsHelp word# ba# 0# (sizeofByteArray# ba#)
110+
111+
112+containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool
113+containsHelp word# ba# !offset# len# =
114+ if isTrue# (offset# <# len#) then
115+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset#))
116+ then True
117+ else containsHelp word# ba# (offset# +# 1#) len#
118+ else
119+ False
120+
121+
122+
123+-- STARTS WITH
124+
125+
126+{-# INLINE startsWith #-}
127+startsWith :: Utf8 t -> Utf8 t -> Bool
128+startsWith (Utf8 ba1#) (Utf8 ba2#) =
129+ let
130+ !len1# = sizeofByteArray# ba1#
131+ !len2# = sizeofByteArray# ba2#
132+ in
133+ isTrue# (len1# <=# len2#)
134+ &&
135+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
136+
137+
138+
139+-- STARTS WITH CHAR
140+
141+
142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool
143+startsWithChar isGood bytes@(Utf8 ba#) =
144+ if isEmpty bytes then
145+ False
146+ else
147+ let
148+ !w# = indexWord8Array# ba# 0#
149+ !char
150+ | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#))
151+ | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w#
152+ | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w#
153+ | True = chr4 ba# 0# w#
154+ in
155+ isGood char
156+
157+
158+
159+-- ENDS WITH WORD
160+
161+
162+endsWithWord8 :: Word8 -> Utf8 t -> Bool
163+endsWithWord8 (W8# w#) (Utf8 ba#) =
164+ let len# = sizeofByteArray# ba# in
165+ isTrue# (len# ># 0#)
166+ &&
167+ isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#)))
168+
169+
170+
171+-- SPLIT
172+
173+
174+split :: Word8 -> Utf8 t -> [Utf8 t]
175+split (W8# divider#) str@(Utf8 ba#) =
176+ splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])
177+
178+
179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]
180+splitHelp str start offsets =
181+ case offsets of
182+ [] ->
183+ [ unsafeSlice str start (size str) ]
184+
185+ offset : offsets ->
186+ unsafeSlice str start offset : splitHelp str (offset + 1) offsets
187+
188+
189+findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int]
190+findDividers divider# ba# !offset# len# revOffsets =
191+ if isTrue# (offset# <# len#) then
192+ findDividers divider# ba# (offset# +# 1#) len# $
193+ if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#))
194+ then I# offset# : revOffsets
195+ else revOffsets
196+ else
197+ reverse revOffsets
198+
199+
200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t
201+unsafeSlice str start end =
202+ let !len = end - start in
203+ if len == 0 then
204+ empty
205+ else
206+ runST $
207+ do mba <- newByteArray len
208+ copy str start mba 0 len
209+ freeze mba
210+
211+
212+
213+-- JOIN
214+
215+
216+join :: Word8 -> [Utf8 t] -> Utf8 t
217+join sep strings =
218+ case strings of
219+ [] ->
220+ empty
221+
222+ str:strs ->
223+ runST $
224+ do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs
225+ mba <- newByteArray len
226+ joinHelp sep mba 0 str strs
227+ freeze mba
228+
229+
230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()
231+joinHelp sep mba offset str strings =
232+ let
233+ !len = size str
234+ in
235+ case strings of
236+ [] ->
237+ copy str 0 mba offset len
238+
239+ s:ss ->
240+ do copy str 0 mba offset len
241+ let !dotOffset = offset + len
242+ writeWord8 mba dotOffset sep
243+ let !newOffset = dotOffset + 1
244+ joinHelp sep mba newOffset s ss
245+
246+
247+
248+-- EQUAL
249+
250+
251+instance Eq (Utf8 t) where
252+ (==) (Utf8 ba1#) (Utf8 ba2#) =
253+ let
254+ !len1# = sizeofByteArray# ba1#
255+ !len2# = sizeofByteArray# ba2#
256+ in
257+ isTrue# (len1# ==# len2#)
258+ &&
259+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)
260+
261+
262+
263+-- COMPARE
264+--
265+-- TODO: is it fine to sort by length and only compare bytes on length ties?
266+--
267+
268+instance Ord (Utf8 t) where
269+ compare (Utf8 ba1#) (Utf8 ba2#) =
270+ let
271+ !len1# = sizeofByteArray# ba1#
272+ !len2# = sizeofByteArray# ba2#
273+ !len# = if isTrue# (len1# <# len2#) then len1# else len2#
274+ !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#
275+ in
276+ case () of
277+ _ | isTrue# (cmp# <# 0#) -> LT
278+ | isTrue# (cmp# ># 0#) -> GT
279+ | isTrue# (len1# <# len2#) -> LT
280+ | isTrue# (len1# ># len2#) -> GT
281+ | True -> EQ
282+
283+
284+
285+-- FROM STRING
286+
287+
288+fromChars :: [Char] -> Utf8 t
289+fromChars chars =
290+ runST
291+ (
292+ do mba <- newByteArray (sum (map getWidth chars))
293+ writeChars mba 0 chars
294+ )
295+
296+
297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)
298+writeChars !mba !offset chars =
299+ case chars of
300+ [] ->
301+ freeze mba
302+
303+ char : chars
304+ | n < 0x80 ->
305+ do writeWord8 mba (offset ) (fromIntegral n)
306+ writeChars mba (offset + 1) chars
307+
308+ | n < 0x800 ->
309+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))
310+ writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))
311+ writeChars mba (offset + 2) chars
312+
313+ | n < 0x10000 ->
314+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))
315+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
316+ writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))
317+ writeChars mba (offset + 3) chars
318+
319+ | otherwise ->
320+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))
321+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))
322+ writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))
323+ writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))
324+ writeChars mba (offset + 4) chars
325+
326+ where
327+ n = Char.ord char
328+
329+
330+{-# INLINE getWidth #-}
331+getWidth :: Char -> Int
332+getWidth char
333+ | code < 0x80 = 1
334+ | code < 0x800 = 2
335+ | code < 0x10000 = 3
336+ | otherwise = 4
337+ where
338+ code = Char.ord char
339+
340+
341+
342+-- TO CHARS
343+
344+
345+toChars :: Utf8 t -> [Char]
346+toChars (Utf8 ba#) =
347+ toCharsHelp ba# 0# (sizeofByteArray# ba#)
348+
349+
350+toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char]
351+toCharsHelp ba# offset# len# =
352+ if isTrue# (offset# >=# len#) then
353+ []
354+ else
355+ let
356+ !w# = indexWord8Array# ba# offset#
357+ !(# char, width# #)
358+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)
359+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)
360+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)
361+ | True = (# chr4 ba# offset# w#, 4# #)
362+
363+ !newOffset# = offset# +# width#
364+ in
365+ char : toCharsHelp ba# newOffset# len#
366+
367+
368+{-# INLINE chr2 #-}
369+chr2 :: ByteArray# -> Int# -> Word# -> Char
370+chr2 ba# offset# firstWord# =
371+ let
372+ !i1# = word2Int# firstWord#
373+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
374+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
375+ !c2# = i2# -# 0x80#
376+ in
377+ C# (chr# (c1# +# c2#))
378+
379+
380+{-# INLINE chr3 #-}
381+chr3 :: ByteArray# -> Int# -> Word# -> Char
382+chr3 ba# offset# firstWord# =
383+ let
384+ !i1# = word2Int# firstWord#
385+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
386+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
387+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
388+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
389+ !c3# = i3# -# 0x80#
390+ in
391+ C# (chr# (c1# +# c2# +# c3#))
392+
393+
394+{-# INLINE chr4 #-}
395+chr4 :: ByteArray# -> Int# -> Word# -> Char
396+chr4 ba# offset# firstWord# =
397+ let
398+ !i1# = word2Int# firstWord#
399+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))
400+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))
401+ !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))
402+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
403+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
404+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
405+ !c4# = i4# -# 0x80#
406+ in
407+ C# (chr# (c1# +# c2# +# c3# +# c4#))
408+
409+
410+
411+-- TO BUILDER
412+
413+
414+{-# INLINE toBuilder #-}
415+toBuilder :: Utf8 t -> B.Builder
416+toBuilder =
417+ \bytes -> B.builder (toBuilderHelp bytes)
418+
419+
420+{-# INLINE toBuilderHelp #-}
421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a
422+toBuilderHelp !bytes@(Utf8 ba#) k =
423+ go 0 (I# (sizeofByteArray# ba#))
424+ where
425+ go !offset !end !(B.BufferRange bOffset bEnd) =
426+ let
427+ !bLen = minusPtr bEnd bOffset
428+ !len = end - offset
429+ in
430+ if len <= bLen then
431+ do copyToPtr bytes offset bOffset len
432+ let !br' = B.BufferRange (plusPtr bOffset len) bEnd
433+ k br'
434+ else
435+ do copyToPtr bytes offset bOffset bLen
436+ let !offset' = offset + bLen
437+ return $ B.bufferFull 1 bEnd (go offset' end)
438+
439+
440+
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
489+
490+
491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t
492+fromPtr pos end =
493+ unsafeDupablePerformIO (stToIO (
494+ do let !len = minusPtr end pos
495+ mba <- newByteArray len
496+ copyFromPtr pos mba 0 len
497+ freeze mba
498+ ))
499+
500+
501+
502+-- FROM SNIPPET
503+
504+
505+fromSnippet :: P.Snippet -> Utf8 t
506+fromSnippet (P.Snippet fptr off len _ _) =
507+ unsafeDupablePerformIO (stToIO (
508+ do mba <- newByteArray len
509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off
510+ copyFromPtr pos mba 0 len
511+ freeze mba
512+ ))
513+
514+
515+
516+-- BINARY
517+
518+
519+putUnder256 :: Utf8 t -> Put
520+putUnder256 bytes =
521+ do putWord8 (fromIntegral (size bytes))
522+ putBuilder (toBuilder bytes)
523+
524+
525+getUnder256 :: Get (Utf8 t)
526+getUnder256 =
527+ do word <- getWord8
528+ let !n = fromIntegral word
529+ readN n (copyFromByteString n)
530+
531+
532+putVeryLong :: Utf8 t -> Put
533+putVeryLong bytes =
534+ do put (size bytes)
535+ putBuilder (toBuilder bytes)
536+
537+
538+getVeryLong :: Get (Utf8 t)
539+getVeryLong =
540+ do n <- get
541+ if n > 0
542+ then readN n (copyFromByteString n)
543+ else return empty
544+
545+
546+
547+-- COPY FROM BYTESTRING
548+
549+
550+{-# INLINE copyFromByteString #-}
551+copyFromByteString :: Int -> B.ByteString -> Utf8 t
552+copyFromByteString len (B.PS fptr offset _) =
553+ unsafeDupablePerformIO
554+ (
555+ do mba <- stToIO (newByteArray len)
556+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)
557+ touchForeignPtr fptr
558+ stToIO (freeze mba)
559+ )
560+
561+
562+
563+-- PRIMITIVES
564+
565+
566+data MBA s =
567+ MBA# (MutableByteArray# s)
568+
569+
570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive
571+newByteArray (I# len#) =
572+ ST $ \s ->
573+ case newByteArray# len# s of
574+ (# s, mba# #) -> (# s, MBA# mba# #)
575+
576+
577+freeze :: MBA s -> ST s (Utf8 t)
578+freeze (MBA# mba#) =
579+ ST $ \s ->
580+ case unsafeFreezeByteArray# mba# s of
581+ (# s, ba# #) -> (# s, Utf8 ba# #)
582+
583+
584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()
585+copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =
586+ ST $ \s ->
587+ case copyByteArray# ba# offset# mba# i# len# s of
588+ s -> (# s, () #)
589+
590+
591+copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()
592+copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =
593+ ST $ \s ->
594+ case copyAddrToByteArray# src# mba# offset# len# s of
595+ s -> (# s, () #)
596+
597+
598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()
599+copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =
600+ IO $ \s ->
601+ case copyByteArrayToAddr# ba# offset# mba# len# s of
602+ s -> (# s, () #)
603+
604+
605+{-# INLINE writeWord8 #-}
606+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
607+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
608+ ST $ \s ->
609+ case writeWord8Array# mba# offset# w# s of
610+ s -> (# s, () #)
611+
612+
613+{-# INLINE writeWordToPtr #-}
614+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()
615+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =
616+ IO $ \s ->
617+ case writeWord8OffAddr# addr# offset# word# s of
618+ s -> (# s, () #)
compiler/src/Elm/Compiler/Imports.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Elm.Compiler.Imports
4+ ( defaults
5+ )
6+ where
7+
8+
9+import qualified Data.Name as Name
10+
11+import qualified AST.Source as Src
12+import qualified Elm.ModuleName as ModuleName
13+import qualified Reporting.Annotation as A
14+
15+
16+
17+-- DEFAULTS
18+
19+
20+defaults :: [Src.Import]
21+defaults =
22+ [ import_ ModuleName.basics Nothing Src.Open
23+ , import_ ModuleName.debug Nothing closed
24+ , import_ ModuleName.list Nothing (operator "::")
25+ , import_ ModuleName.maybe Nothing (typeOpen Name.maybe)
26+ , import_ ModuleName.result Nothing (typeOpen Name.result)
27+ , import_ ModuleName.string Nothing (typeClosed Name.string)
28+ , import_ ModuleName.char Nothing (typeClosed Name.char)
29+ , import_ ModuleName.tuple Nothing closed
30+ , import_ ModuleName.platform Nothing (typeClosed Name.program)
31+ , import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd)
32+ , import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub)
33+ ]
34+
35+
36+import_ :: ModuleName.Canonical -> Maybe Name.Name -> Src.Exposing -> Src.Import
37+import_ (ModuleName.Canonical _ name) maybeAlias exposing =
38+ Src.Import (A.At A.zero name) maybeAlias exposing
39+
40+
41+
42+-- EXPOSING
43+
44+
45+closed :: Src.Exposing
46+closed =
47+ Src.Explicit []
48+
49+
50+typeOpen :: Name.Name -> Src.Exposing
51+typeOpen name =
52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]
53+
54+
55+typeClosed :: Name.Name -> Src.Exposing
56+typeClosed name =
57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]
58+
59+
60+operator :: Name.Name -> Src.Exposing
61+operator op =
62+ Src.Explicit [ Src.Operator A.zero op ]
compiler/src/Elm/Compiler/Type.hsnew file+194

This diff is too big to show here.

src/Elm/Compiler/Type/Extract.hs → compiler/src/Elm/Compiler/Type/Extract.hsrenamed+79−28

This diff is too big to show here.

compiler/src/Elm/Constraint.hsnew file+260

This diff is too big to show here.

compiler/src/Elm/Docs.hsnew file+587

This diff is too big to show here.

compiler/src/Elm/Float.hsnew file+51

This diff is too big to show here.

compiler/src/Elm/Interface.hsnew file+254

This diff is too big to show here.

compiler/src/Elm/Kernel.hsnew file+365

This diff is too big to show here.

builder/src/Elm/Project/Licenses.hs → compiler/src/Elm/Licenses.hsrenamed+65−63

This diff is too big to show here.

compiler/src/Elm/Magnitude.hsnew file+24

This diff is too big to show here.

compiler/src/Elm/ModuleName.hsnew file+283

This diff is too big to show here.

compiler/src/Elm/Package.hsnew file+374

This diff is too big to show here.

compiler/src/Elm/String.hsnew file+133

This diff is too big to show here.

compiler/src/Elm/Version.hsnew file+196

This diff is too big to show here.

compiler/src/Generate/Html.hsnew file+54

This diff is too big to show here.

compiler/src/Generate/JavaScript.hsnew file+590

This diff is too big to show here.

compiler/src/Generate/JavaScript/Builder.hsnew file+530

This diff is too big to show here.

src/Generate/JavaScript/Expression.hs → compiler/src/Generate/JavaScript/Expression.hsrenamed+269−236

This diff is too big to show here.

builder/src/Generate/Functions.hs → compiler/src/Generate/JavaScript/Functions.hsrenamed+8−6

This diff is too big to show here.

src/Generate/JavaScript/Name.hs → compiler/src/Generate/JavaScript/Name.hsrenamed+46−112

This diff is too big to show here.

compiler/src/Generate/Mode.hsnew file+63

This diff is too big to show here.

compiler/src/Json/Decode.hsnew file+799

This diff is too big to show here.

src/Json/Encode.hs → compiler/src/Json/Encode.hsrenamed+46−58

This diff is too big to show here.

compiler/src/Json/String.hsnew file+192

This diff is too big to show here.

compiler/src/Nitpick/Debug.hsnew file+87

This diff is too big to show here.

src/Nitpick/PatternMatches.hs → compiler/src/Nitpick/PatternMatches.hsrenamed+44−32

This diff is too big to show here.

src/Optimize/Case.hs → compiler/src/Optimize/Case.hsrenamed+2−2

This diff is too big to show here.

src/Optimize/DecisionTree.hs → compiler/src/Optimize/DecisionTree.hsrenamed+42−20

This diff is too big to show here.

src/Optimize/Expression.hs → compiler/src/Optimize/Expression.hsrenamed+59−35

This diff is too big to show here.

src/Optimize/Module.hs → compiler/src/Optimize/Module.hsrenamed+97−107

This diff is too big to show here.

src/Optimize/Names.hs → compiler/src/Optimize/Names.hsrenamed+18−24

This diff is too big to show here.

src/Optimize/Port.hs → compiler/src/Optimize/Port.hsrenamed+49−45

This diff is too big to show here.

compiler/src/Parse/Declaration.hsnew file+266

This diff is too big to show here.

compiler/src/Parse/Expression.hsnew file+577

This diff is too big to show here.

compiler/src/Parse/Keyword.hsnew file+265

This diff is too big to show here.

compiler/src/Parse/Module.hsnew file+487

This diff is too big to show here.

compiler/src/Parse/Number.hsnew file+305

This diff is too big to show here.

compiler/src/Parse/Pattern.hsnew file+279

This diff is too big to show here.

compiler/src/Parse/Primitives.hsnew file+404

This diff is too big to show here.

compiler/src/Parse/Shader.hsnew file+181

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Parse/String.hsnew file+343

This diff is too big to show here.

compiler/src/Parse/Symbol.hsnew file+79

This diff is too big to show here.

compiler/src/Parse/Type.hsnew file+203

This diff is too big to show here.

compiler/src/Parse/Variable.hsnew file+387

This diff is too big to show here.

compiler/src/Reporting/Annotation.hsnew file+103

This diff is too big to show here.

compiler/src/Reporting/Doc.hsnew file+431

This diff is too big to show here.

compiler/src/Reporting/Error.hsnew file+210

This diff is too big to show here.

src/Reporting/Error/Canonicalize.hs → compiler/src/Reporting/Error/Canonicalize.hsrenamed+425−417

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hsnew file+250

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Error/Json.hsnew file+344

This diff is too big to show here.

src/Reporting/Error/Main.hs → compiler/src/Reporting/Error/Main.hsrenamed+31−29

This diff is too big to show here.

src/Reporting/Error/Pattern.hs → compiler/src/Reporting/Error/Pattern.hsrenamed+29−28

This diff is too big to show here.

compiler/src/Reporting/Error/Syntax.hsnew file+5848

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hsnew file+1613

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hsnew file+288

This diff is too big to show here.

src/Reporting/Render/Type.hs → compiler/src/Reporting/Render/Type.hsrenamed+71−49

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hsnew file+120

This diff is too big to show here.

compiler/src/Reporting/Report.hsnew file+22

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Suggest.hsnew file+52

This diff is too big to show here.

src/Reporting/Warning.hs → compiler/src/Reporting/Warning.hsrenamed+28−27

This diff is too big to show here.

src/Type/Constrain/Expression.hs → compiler/src/Type/Constrain/Expression.hsrenamed+78−93

This diff is too big to show here.

src/Type/Constrain/Module.hs → compiler/src/Type/Constrain/Module.hsrenamed+24−25

This diff is too big to show here.

src/Type/Constrain/Pattern.hs → compiler/src/Type/Constrain/Pattern.hsrenamed+15−11

This diff is too big to show here.

compiler/src/Type/Error.hsnew file+589

This diff is too big to show here.

src/Type/Instantiate.hs → compiler/src/Type/Instantiate.hsrenamed+9−4

This diff is too big to show here.

src/Type/Occurs.hs → compiler/src/Type/Occurs.hsrenamed

The content is the same.

src/Type/Solve.hs → compiler/src/Type/Solve.hsrenamed+39−33

This diff is too big to show here.

src/Type/Type.hs → compiler/src/Type/Type.hsrenamed+77−85

This diff is too big to show here.

src/Type/Unify.hs → compiler/src/Type/Unify.hsrenamed+46−67

This diff is too big to show here.

src/Type/UnionFind.hs → compiler/src/Type/UnionFind.hsrenamed

The content is the same.

docs/elm.json/application.mdnew file+69

This diff is too big to show here.

docs/elm.json/package.mdnew file+93

This diff is too big to show here.

docs/upgrade-instructions/0.16.mdnew file+174

This diff is too big to show here.

docs/upgrade-instructions/0.17.mdnew file+275

This diff is too big to show here.

docs/upgrade-instructions/0.18.mdnew file+161

This diff is too big to show here.

docs/upgrade-instructions/0.19.0.mdnew file+164

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

elm-compiler.cabaldeleted−216

This diff is too big to show here.

elm.cabalnew file+238

This diff is too big to show here.

hints/bad-recursion.md+25−27

This diff is too big to show here.

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

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/effect-modules.mddeleted−10

This diff is too big to show here.

hints/implicit-casts.md+2−5

This diff is too big to show here.

hints/imports.md+7−6

This diff is too big to show here.

hints/infinite-type.md+20−94

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.md+66−69

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/recursive-alias.md+3−2

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.md+1

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.md+2−8

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.xmlnew file+33

This diff is too big to show here.

installers/mac/README.mdnew file+93

This diff is too big to show here.

installers/mac/Resources/en.lproj/conclusion.rtfnew file+16

This diff is too big to show here.

installers/mac/Resources/en.lproj/welcome.rtfnew file+12

This diff is too big to show here.

installers/mac/helper-scripts/elm-startup.shnew file+3

This diff is too big to show here.

installers/mac/helper-scripts/uninstall.shnew file+21

This diff is too big to show here.

installers/mac/make-installer.shnew file+81

This diff is too big to show here.

installers/mac/postinstallnew file+5

This diff is too big to show here.

installers/mac/preinstallnew file+18

This diff is too big to show here.

installers/npm/.gitignorenew file+1

This diff is too big to show here.

installers/npm/.npmignorenew file+3

This diff is too big to show here.

installers/npm/PUBLISHING.mdnew file+59

This diff is too big to show here.

installers/npm/README.mdnew file+45

This diff is too big to show here.

installers/npm/bin/elmnew file+54

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/install.jsnew file+4

This diff is too big to show here.

installers/npm/package.jsonnew file+42

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+76

This diff is too big to show here.

installers/win/CreateInternetShortcut.nshnew file+5

This diff is too big to show here.

installers/win/Nsisfile.nsinew file+264

This diff is too big to show here.

installers/win/README.mdnew file+24

This diff is too big to show here.

installers/win/inst.datnew file+6

This diff is too big to show here.

installers/win/logo.iconew file

Binary file not shown.

installers/win/make_installer.cmdnew file+18

This diff is too big to show here.

installers/win/removefrompath.vbsnew file+17

This diff is too big to show here.

installers/win/uninst.datnew file+6

This diff is too big to show here.

installers/win/updatepath.vbsnew file+14

This diff is too big to show here.

installers/win/welcome.bmpnew file

Binary file not shown.

profiling/Main.hsdeleted−77

This diff is too big to show here.

profiling/cabal.configdeleted−2

This diff is too big to show here.

profiling/elm-prof.cabaldeleted−18

This diff is too big to show here.

reactor/assets/favicon.iconew file

Binary file not shown.

reactor/assets/source-code-pro.ttfnew file

Binary file not shown.

reactor/assets/source-sans-pro.ttfnew file

Binary file not shown.

reactor/assets/styles.cssnew file+157

This diff is too big to show here.

reactor/check.pynew file+48

This diff is too big to show here.

reactor/elm.jsonnew file+31

This diff is too big to show here.

reactor/src/Deps.elmnew file+1210

This diff is too big to show here.

reactor/src/Errors.elmnew file+207

This diff is too big to show here.

reactor/src/Index.elmnew file+280

This diff is too big to show here.

reactor/src/Index/Icon.elmnew file+111

This diff is too big to show here.

reactor/src/Index/Navigator.elmnew file+63

This diff is too big to show here.

reactor/src/Index/Skeleton.elmnew file+61

This diff is too big to show here.

reactor/src/NotFound.elmnew file+29

This diff is too big to show here.

reactor/src/mock.txtnew file+33

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

src/AST/Module/Name.hsdeleted−198

This diff is too big to show here.

src/AST/Source.hsdeleted−193

This diff is too big to show here.

src/AST/Utils/Shader.hsdeleted−36

This diff is too big to show here.

src/AST/Valid.hsdeleted−124

This diff is too big to show here.

src/Canonicalize/Environment/Foreign.hsdeleted−287

This diff is too big to show here.

src/Compile.hsdeleted−124

This diff is too big to show here.

src/Data/OneOrMore.hsdeleted−64

This diff is too big to show here.

src/Elm/Compiler.hsdeleted−70

This diff is too big to show here.

src/Elm/Compiler/Imports.hsdeleted−74

This diff is too big to show here.

src/Elm/Compiler/Module.hsdeleted−96

This diff is too big to show here.

src/Elm/Compiler/Objects.hsdeleted−110

This diff is too big to show here.

src/Elm/Compiler/Type.hsdeleted−248

This diff is too big to show here.

src/Elm/Compiler/Version.hsdeleted−27

This diff is too big to show here.

src/Elm/Docs.hsdeleted−541

This diff is too big to show here.

src/Elm/Header.hsdeleted−73

This diff is too big to show here.

src/Elm/Interface.hsdeleted−113

This diff is too big to show here.

src/Elm/Kernel.hsdeleted−248

This diff is too big to show here.

src/Elm/Name.hsdeleted−316

This diff is too big to show here.

src/Elm/Package.hsdeleted−390

This diff is too big to show here.

src/Elm/Utils.hsdeleted−13

This diff is too big to show here.

src/Generate/JavaScript.hsdeleted−533

This diff is too big to show here.

src/Generate/JavaScript/Builder.hsdeleted−540

This diff is too big to show here.

src/Json/Decode.hsdeleted−310

This diff is too big to show here.

src/Json/Decode/Internals.hsdeleted−367

This diff is too big to show here.

src/Parse/Declaration.hsdeleted−197

This diff is too big to show here.

src/Parse/Expression.hsdeleted−564

This diff is too big to show here.

src/Parse/Module.hsdeleted−295

This diff is too big to show here.

src/Parse/Parse.hsdeleted−65

This diff is too big to show here.

src/Parse/Pattern.hsdeleted−273

This diff is too big to show here.

src/Parse/Primitives.hsdeleted−228

This diff is too big to show here.

src/Parse/Primitives/Internals.hsdeleted−251

This diff is too big to show here.

src/Parse/Primitives/Kernel.hsdeleted−116

This diff is too big to show here.

src/Parse/Primitives/Keyword.hsdeleted−235

This diff is too big to show here.

src/Parse/Primitives/Number.hsdeleted−297

This diff is too big to show here.

src/Parse/Primitives/Shader.hsdeleted−69

This diff is too big to show here.

src/Parse/Primitives/Symbol.hsdeleted−259

This diff is too big to show here.

src/Parse/Primitives/Utf8.hsdeleted−471

This diff is too big to show here.

src/Parse/Primitives/Variable.hsdeleted−376

This diff is too big to show here.

src/Parse/Primitives/Whitespace.hsdeleted−223

This diff is too big to show here.

src/Parse/Repl.hsdeleted−101

This diff is too big to show here.

src/Parse/Shader.hsdeleted−101

This diff is too big to show here.

src/Parse/Type.hsdeleted−228

This diff is too big to show here.

src/Reporting/Annotation.hsdeleted−60

This diff is too big to show here.

src/Reporting/Error.hsdeleted−57

This diff is too big to show here.

src/Reporting/Error/Docs.hsdeleted−140

This diff is too big to show here.

src/Reporting/Error/Json.hsdeleted−270

This diff is too big to show here.

src/Reporting/Error/Syntax.hsdeleted−787

This diff is too big to show here.

src/Reporting/Error/Type.hsdeleted−1725

This diff is too big to show here.

src/Reporting/Helpers.hsdeleted−250

This diff is too big to show here.

src/Reporting/Region.hsdeleted−93

This diff is too big to show here.

src/Reporting/Render/Code.hsdeleted−153

This diff is too big to show here.

src/Reporting/Report.hsdeleted−83

This diff is too big to show here.

src/Type/Error.hsdeleted−623

This diff is too big to show here.

src/Validate.hsdeleted−334

This diff is too big to show here.

terminal/impl/Terminal.hsnew file+375

This diff is too big to show here.

terminal/impl/Terminal/Chomp.hsnew file+514

This diff is too big to show here.

terminal/impl/Terminal/Error.hsnew file+457

This diff is too big to show here.

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

This diff is too big to show here.

terminal/impl/Terminal/Internal.hsnew file+93

This diff is too big to show here.

terminal/src/Bump.hsnew file+169

This diff is too big to show here.

terminal/src/Develop.hsnew file+256

This diff is too big to show here.

terminal/src/Develop/Generate/Help.hsnew file+65

This diff is too big to show here.

terminal/src/Develop/Generate/Index.hsnew file+213

This diff is too big to show here.

terminal/src/Develop/Socket.hsnew file+43

This diff is too big to show here.

terminal/src/Develop/StaticFiles.hsnew file+123

This diff is too big to show here.

terminal/src/Develop/StaticFiles/Build.hsnew file+73

This diff is too big to show here.

terminal/src/Diff.hsnew file+359

This diff is too big to show here.

terminal/src/Init.hsnew file+104

This diff is too big to show here.

terminal/src/Install.hsnew file+425

This diff is too big to show here.

terminal/src/Main.hsnew file+338

This diff is too big to show here.

terminal/src/Make.hsnew file+319

This diff is too big to show here.

terminal/src/Publish.hsnew file+540

This diff is too big to show here.

terminal/src/Repl.hsnew file+726

This diff is too big to show here.

tests/Test.hsdeleted−14

This diff is too big to show here.

tests/Test/Compiler.hsdeleted−247

This diff is too big to show here.

tests/Test/Property.hsdeleted−68

This diff is too big to show here.

tests/Test/Property/Arbitrary.hsdeleted−193

This diff is too big to show here.

tests/test-files/bad/BBTArgsdeleted−1

This diff is too big to show here.

tests/test-files/bad/IncompletePatternMatch.elmdeleted−17

This diff is too big to show here.

tests/test-files/bad/InfiniteType.elmdeleted−2

This diff is too big to show here.

tests/test-files/bad/NonElementMain.elmdeleted−2

This diff is too big to show here.

tests/test-files/bad/RepeatedArgument.elmdeleted−4

This diff is too big to show here.

tests/test-files/bad/Strings/ExtraClose.elmdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/Cases/CharCase.elm.jsdeleted−8

This diff is too big to show here.

tests/test-files/good-expected-js/Cases/ListZip.elm.jsdeleted−21

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/CommentInterpretedAsInfix.elm.jsdeleted−13

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/NestedPatternMatch.elm.jsdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/Shadowing.elm.jsdeleted−16

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/Shadowing2.elm.jsdeleted−13

This diff is too big to show here.

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_ListAny.elm.jsdeleted−20

This diff is too big to show here.

tests/test-files/good-expected-js/Crash/CrashCase.elm.jsdeleted−14

This diff is too big to show here.

tests/test-files/good-expected-js/Crash/CrashIf.elm.jsdeleted−8

This diff is too big to show here.

tests/test-files/good-expected-js/Declarations/NoDefinitions.elm.jsdeleted

No changes to the content.

tests/test-files/good-expected-js/Lists/EmptyList.elm.jsdeleted−1

This diff is too big to show here.

tests/test-files/good-expected-js/Lists/NonEmptyList.elm.jsdeleted−13

This diff is too big to show here.

tests/test-files/good-expected-js/Literals/Multiline.elm.jsdeleted−1

This diff is too big to show here.

tests/test-files/good-expected-js/Literals/Negatives.elm.jsdeleted−22

This diff is too big to show here.

tests/test-files/good-expected-js/Literals/Numbers.elm.jsdeleted−14

This diff is too big to show here.

tests/test-files/good-expected-js/Literals/QuotesAndComments.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Records/Access.elm.jsdeleted−19

This diff is too big to show here.

tests/test-files/good-expected-js/Records/AliasSubstitution.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Records/NonHomogeneousRecords.elm.jsdeleted−9

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/Apply.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/ApplyAnnotated.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/Id.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/IdAnnotated.elm.jsdeleted−6

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/SpecificAnnotationInt.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/SpecificAnnotationNumber.elm.jsdeleted−3

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/TrickyId.elm.jsdeleted−4

This diff is too big to show here.

tests/test-files/good-expected-js/Soundness/TrickyIdAnnotated.elm.jsdeleted−4

This diff is too big to show here.

tests/test-files/good/Cases/CharCase.elmdeleted−8

This diff is too big to show here.

tests/test-files/good/Cases/ListZip.elmdeleted−17

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/CommentInterpretedAsInfix.elmdeleted−12

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/NestedPatternMatch.elmdeleted−5

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/Shadowing.elmdeleted−22

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/Shadowing2.elmdeleted−25

This diff is too big to show here.

tests/test-files/good/CodeGenBugs/TailRecursion_ListAny.elmdeleted−12

This diff is too big to show here.

tests/test-files/good/Crash/CrashCase.elmdeleted−9

This diff is too big to show here.

tests/test-files/good/Crash/CrashIf.elmdeleted−8

This diff is too big to show here.

tests/test-files/good/Declarations/NoDefinitions.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Lists/EmptyList.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Lists/NonEmptyList.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Literals/Multiline.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Literals/Negatives.elmdeleted−17

This diff is too big to show here.

tests/test-files/good/Literals/Numbers.elmdeleted−18

This diff is too big to show here.

tests/test-files/good/Literals/QuotesAndComments.elmdeleted−10

This diff is too big to show here.

tests/test-files/good/Records/Access.elmdeleted−22

This diff is too big to show here.

tests/test-files/good/Records/AliasSubstitution.elmdeleted−13

This diff is too big to show here.

tests/test-files/good/Records/NonHomogeneousRecords.elmdeleted−14

This diff is too big to show here.

tests/test-files/good/Soundness/Apply.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Soundness/ApplyAnnotated.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/Id.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Soundness/IdAnnotated.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/SpecificAnnotationInt.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/SpecificAnnotationNumber.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/Soundness/TrickyId.elmdeleted−2

This diff is too big to show here.

tests/test-files/good/Soundness/TrickyIdAnnotated.elmdeleted−3

This diff is too big to show here.

worker/elm.cabalnew file+210

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hsnew file+73

This diff is too big to show here.