git.iko.soy/elk
on master help sign in
swap
9f1bbb53841 ahead, 0 behind
.github/CONTRIBUTING.mdnew file+41
since splitsnapshots
unifiedsplit
@@ -0,0 +1,41 @@
1+# Contributing to Elm
2+
3+Thanks helping with the development of Elm! This document describes the basic
4+standards for opening pull requests and making the review process as smooth as
5+possible.
6+
7+
8+## Expectations
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+
16+
17+## Style Guide
18+
19+ * Haskell — conform to [these guidelines][haskell]
20+ * JavaScript — use [Google's JS style guide][js]
21+
22+[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be
23+[js]: https://google.github.io/styleguide/javascriptguide.xml
24+
25+
26+## Branches
27+
28+[The master branch][master] is the home of the next release of the compiler
29+so new features and improvements get merged there. Most pull requests
30+should target this branch!
31+
32+[master]: http://github.com/elm-lang/elm/tree/master
33+
34+
35+## Licensing
36+
37+Nothing extra to do for this. The default on GitHub described [here](https://docs.github.com/en/github/site-policy/github-terms-of-service#6-contributions-under-repository-license) is that:
38+
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+
41+
.github/ISSUE_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/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+4−9
@@ -1,13 +1,8 @@
1+elm-stuff
1dist
2dist
2cabal-dev
3cabal-dev
3−*.o
4+.cabal-sandbox/
4−*.hi
5+cabal.sandbox.config
5−*.chi
6−*.chs.h
7−*.aes
8−*.elmi
9−*.elmo
10−data
11−*/ElmFiles/*
12.DS_Store
6.DS_Store
13*~
7*~
8+travis.log
.travis.ymlnew file+28
@@ -0,0 +1,28 @@
1+language: minimal
2+services: docker
3+
4+env:
5+ global:
6+ - LINUX_ARCHIVE=binary-for-linux-64-bit.gz
7+
8+before_install:
9+ - docker build -t elm -f installers/linux/Dockerfile .
10+ - docker cp $(docker create elm):/usr/local/bin/elm .
11+ - gzip -9 -c elm > $LINUX_ARCHIVE
12+
13+deploy:
14+ provider: releases
15+ api_key:
16+ secure: Yz2Lo4u9rZQ7Ee7ohAsrZpkqsYDUerCSMdSQIH8ryrf7phHhiloPEkTKsM+NupHqU/LEAVsunxbau4QrCEjA2vPavAPVk8cKomRUWK/YjbXHKa24hPkal2c+A2bnMQ6w3qYk/PjL9rW+Goq++/SNLcYZwHBV0Chl2blivMwWCSA=
17+ file: $LINUX_ARCHIVE
18+ skip_cleanup: true
19+ on:
20+ branch: master
21+ tags: true
22+
23+notifications:
24+ email:
25+ recipients:
26+ - rlefevre@dmy.fr
27+ on_success: change
28+ on_failure: change
CONTRIBUTING.mddeleted−35
@@ -1,35 +0,0 @@
1−# Contributing to Elm
2−
3−Thanks helping with the development of Elm! This document
4−describes the basic standards for opening pull requests:
5−
6−## Branches
7−
8− * The master branch of Elm is for tagging previous releases
9− and non-breaking changes, like bug fixes. This branch is
10− handy for folks who want to build the most recent public
11− release from source.
12−
13− * The dev branch is where the most active development occurs.
14− It is the home of the next release of the compiler so new
15− features and improvements get merged there.
16−
17−## Opening a pull request
18−
19−**Please open PRs against the [dev branch of
20−Elm](http://github.com/evancz/elm/tree/dev) whenever possible.** Changes that
21−are compatible with the API of master will be merged to master as soon as
22−possible. Changes that affect Elm's API will be merged to master with a future
23−release of the compiler.
24−
25−Note that changes in the master branch of [Elm](https://github.com/evancz/Elm/)
26−are able to be compiled against the master branch of the [elm-lang.org
27−repo](https://github.com/evancz/elm-lang.org), and the dev branch of
28−[Elm](https://github.com/evancz/Elm/) is able to be built with the dev branch of
29−the [elm-lang.org repo](https://github.com/evancz/elm-lang.org). Please make
30−sure that your changes maintain this compatibility.
31−
32−## Licensing
33−
34−You should sign the [contributor agreement](ContributorAgreement.pdf)
35−and send it to <info@elm-lang.org> before opening your pull request.
ContributorAgreement.pdfdeleted

Binary file not shown.

Elm.cabaldeleted−277
@@ -1,277 +0,0 @@
1−Name: Elm
2−Version: 0.10.1
3−Synopsis: The Elm language module.
4−Description: Elm aims to make client-side web-development more pleasant.
5− It is a statically/strongly typed, functional reactive
6− language to HTML, CSS, and JS. This package provides a
7− library for Elm compilation in Haskell and a compiler
8− executable.
9−
10−Homepage: http://elm-lang.org
11−
12−License: BSD3
13−License-file: LICENSE
14−
15−Author: Evan Czaplicki
16−Maintainer: info@elm-lang.org
17−Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
18−
19−Category: Compiler, Language
20−
21−Build-type: Custom
22−
23−Extra-source-files: changelog.txt
24−Data-dir: data
25−Data-files: elm-runtime.js interfaces.data docs.json
26−Cabal-version: >=1.9
27−
28−source-repository head
29− type: git
30− location: git://github.com/evancz/Elm.git
31−
32−Library
33− exposed-modules: Elm.Internal.Dependencies,
34− Elm.Internal.Documentation,
35− Elm.Internal.Name,
36− Elm.Internal.Paths,
37− Elm.Internal.Utils,
38− Elm.Internal.Version
39− Hs-Source-Dirs: compiler
40− other-modules: SourceSyntax.Declaration,
41− SourceSyntax.Expression,
42− SourceSyntax.Helpers,
43− SourceSyntax.Literal,
44− SourceSyntax.Location,
45− SourceSyntax.Module,
46− SourceSyntax.Pattern,
47− SourceSyntax.PrettyPrint,
48− SourceSyntax.Type,
49− Generate.JavaScript,
50− Generate.JavaScript.Helpers,
51− Generate.JavaScript.Ports,
52− Generate.Noscript,
53− Generate.Markdown,
54− Generate.Html,
55− Generate.Cases,
56− Transform.Canonicalize,
57− Transform.Check,
58− Transform.Expression,
59− Transform.Declaration,
60− Transform.Definition,
61− Transform.SafeNames,
62− Transform.SortDefinitions,
63− Transform.Substitute,
64− Metadata.Prelude,
65− Parse.Binop,
66− Parse.Declaration,
67− Parse.Expression,
68− Parse.Helpers,
69− Parse.Literal,
70− Parse.Module,
71− Parse.Parse,
72− Parse.Pattern,
73− Parse.Type,
74− Type.Alias,
75− Type.Constrain.Declaration,
76− Type.Constrain.Expression,
77− Type.Constrain.Literal,
78− Type.Constrain.Pattern,
79− Type.Environment,
80− Type.ExtraChecks,
81− Type.Fragment,
82− Type.Inference,
83− Type.PrettyPrint,
84− Type.Solve,
85− Type.State,
86− Type.Type,
87− Type.Unify,
88− Build.Dependencies,
89− Build.File,
90− Build.Flags,
91− Build.Interface,
92− Build.Print,
93− Build.Source,
94− Build.Utils,
95− Paths_Elm
96−
97− Build-depends: aeson,
98− base >=4.2 && <5,
99− binary >= 0.6.4.0,
100− blaze-html == 0.5.* || == 0.6.*,
101− blaze-markup,
102− bytestring,
103− cmdargs,
104− containers >= 0.3,
105− directory,
106− filepath,
107− indents,
108− language-ecmascript >=0.15 && < 1.0,
109− mtl >= 2,
110− pandoc >= 1.10,
111− parsec >= 3.1.1,
112− pretty,
113− text,
114− transformers >= 0.2,
115− union-find,
116− unordered-containers
117−
118−Executable elm
119− Main-is: Compiler.hs
120− ghc-options: -threaded -O2
121− Hs-Source-Dirs: compiler
122− other-modules: SourceSyntax.Declaration,
123− SourceSyntax.Expression,
124− SourceSyntax.Helpers,
125− SourceSyntax.Literal,
126− SourceSyntax.Location,
127− SourceSyntax.Module,
128− SourceSyntax.Pattern,
129− SourceSyntax.PrettyPrint,
130− SourceSyntax.Type,
131− Generate.JavaScript,
132− Generate.JavaScript.Helpers,
133− Generate.JavaScript.Ports,
134− Generate.Noscript,
135− Generate.Markdown,
136− Generate.Html,
137− Generate.Cases,
138− Transform.Canonicalize,
139− Transform.Check,
140− Transform.Expression,
141− Transform.Declaration,
142− Transform.Definition,
143− Transform.SafeNames,
144− Transform.SortDefinitions,
145− Transform.Substitute,
146− Metadata.Prelude,
147− Parse.Binop,
148− Parse.Declaration,
149− Parse.Expression,
150− Parse.Helpers,
151− Parse.Literal,
152− Parse.Module,
153− Parse.Parse,
154− Parse.Pattern,
155− Parse.Type,
156− Type.Alias,
157− Type.Constrain.Declaration,
158− Type.Constrain.Expression,
159− Type.Constrain.Literal,
160− Type.Constrain.Pattern,
161− Type.Environment,
162− Type.ExtraChecks,
163− Type.Fragment,
164− Type.Inference,
165− Type.PrettyPrint,
166− Type.Solve,
167− Type.State,
168− Type.Type,
169− Type.Unify,
170− Build.Dependencies,
171− Build.File,
172− Build.Flags,
173− Build.Interface,
174− Build.Print,
175− Build.Source,
176− Build.Utils,
177− Paths_Elm
178−
179− Build-depends: aeson,
180− base >=4.2 && <5,
181− binary >= 0.6.4.0,
182− blaze-html == 0.5.* || == 0.6.*,
183− blaze-markup == 0.5.1.*,
184− bytestring,
185− cmdargs,
186− containers >= 0.3,
187− directory,
188− filepath,
189− indents,
190− language-ecmascript >=0.15 && < 1.0,
191− mtl >= 2,
192− pandoc >= 1.10,
193− parsec >= 3.1.1,
194− pretty,
195− text,
196− transformers >= 0.2,
197− union-find,
198− unordered-containers
199−
200−Executable elm-doc
201− Main-is: Docs.hs
202− Hs-Source-Dirs: compiler
203− other-modules: SourceSyntax.Declaration,
204− SourceSyntax.Expression,
205− SourceSyntax.Helpers,
206− SourceSyntax.Literal,
207− SourceSyntax.Location,
208− SourceSyntax.Module,
209− SourceSyntax.Pattern,
210− SourceSyntax.PrettyPrint,
211− SourceSyntax.Type,
212− Parse.Binop,
213− Parse.Declaration,
214− Parse.Expression,
215− Parse.Helpers,
216− Parse.Literal,
217− Parse.Module,
218− Parse.Pattern,
219− Parse.Type
220−
221− Build-depends: aeson,
222− aeson-pretty,
223− base >=4.2 && <5,
224− binary >= 0.6.4.0,
225− bytestring,
226− cmdargs,
227− containers >= 0.3,
228− directory,
229− filepath,
230− indents,
231− mtl >= 2,
232− pandoc >= 1.10,
233− parsec >= 3.1.1,
234− pretty,
235− text,
236− union-find
237−
238−Test-Suite test-elm
239− Type: exitcode-stdio-1.0
240− Hs-Source-Dirs: tests, compiler
241− Main-is: Main.hs
242− other-modules: Tests.Compiler
243− Tests.Property
244− Tests.Property.Arbitrary
245− SourceSyntax.Helpers
246− SourceSyntax.Literal
247− SourceSyntax.PrettyPrint
248− build-depends: base,
249− directory,
250− Elm,
251− test-framework,
252− test-framework-hunit,
253− test-framework-quickcheck2,
254− HUnit,
255− pretty,
256− QuickCheck >= 2 && < 3,
257− filemanip,
258− aeson,
259− base >=4.2 && <5,
260− binary >= 0.6.4.0,
261− blaze-html == 0.5.* || == 0.6.*,
262− blaze-markup == 0.5.1.*,
263− bytestring,
264− cmdargs,
265− containers >= 0.3,
266− directory,
267− filepath,
268− indents,
269− language-ecmascript >=0.15 && < 1.0,
270− mtl >= 2,
271− pandoc >= 1.10,
272− parsec >= 3.1.1,
273− pretty,
274− text,
275− transformers >= 0.2,
276− union-find,
277− unordered-containers
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-2013, 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+11−48
@@ -1,59 +1,22 @@
1−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
1+# Elm
2
2
3+A delightful language for reliable webapps.
3
4
4−## Install
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/)
5−
6−**Arch Linux** &mdash; follow [these directions](https://github.com/evancz/Elm/wiki/Installing-Elm#arch-linux) and then
7−jump to the [My First Project](#my-first-project) section.
8−<br/>
9−**OS X 10.9** &mdash; follow
10−[these directions](http://justtesting.org/post/64947952690/the-glasgow-haskell-compiler-ghc-on-os-x-10-9)
11−before continuing with the platform agnostic directions below.
12−
13−**Platform Agnostic** &mdash;
14−download the [Haskell Platform 2012.2.0.0 or later](http://hackage.haskell.org/platform/).
15−Once the Haskell Platform is installed:
16
6
17− cabal update
18− cabal install elm
19− cabal install elm-server
20
7
21−## Use
8+<br>
22
9
23−To use `elm` and `elm-server` you may need to add a new directory to your PATH.
10+## Install
24−
25−Cabal should tell you where your executables are located upon
26−successful installation. It'll be something like `/home/evan/.cabal/bin`
27−which you should append to your PATH variable.
28−See this tutorial if you are new to changing your PATH in
29−[Unix/Linux](http://www.cyberciti.biz/faq/unix-linux-adding-path/).
30−
31−## My First Project
32
11
33−Now we will create a simple Elm project.
12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨
34−The following commands will set-up a very basic project and start the Elm server.
35
13
36− mkdir helloElm
14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).
37− cd helloElm
38− printf "import Mouse\n\nmain = lift asText Mouse.position" > Main.elm
39− elm-server
40
15
41−The first two commands create a new directory and navigate into it. The `printf`
16+<br>
42−commands place a simple program into `Main.elm`. Do this manually if you do not
43−have `printf`. The final command starts the Elm server at [localhost:8000](http://localhost:8000/),
44−allowing you to navigate to `Main.elm` and see your first program in action.
45
17
46−#### Final Notes
18+## Help
47
19
48−The `elm` package provides
20+If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!
49−[some utility functions](http://hackage.haskell.org/package/Elm) for
50−working with Elm in Haskell. This can be useful for creating tooling
51−for Elm, and has been useful for projects like
52−[the website](http://elm-lang.org/) and
53−[`elm-get`](https://github.com/evancz/elm-get). Email the list if you
54−want to rely on these functions!
55
21
56−If you are stuck, email
22+[slack]: http://elmlang.herokuapp.com/
57−[the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)
58−or ask a question in the
59−[#Elm IRC channel](http://webchat.freenode.net/?channels=elm).
Setup.hsdeleted−179
@@ -1,179 +0,0 @@
1−import Distribution.Simple
2−import Distribution.Simple.LocalBuildInfo
3−import Distribution.Simple.Setup
4−import Distribution.PackageDescription
5−
6−import System.Cmd
7−import System.Directory
8−import System.FilePath
9−import System.IO
10−import System.Process
11−
12−import Control.Monad
13−import qualified Data.Binary as Binary
14−import qualified Data.ByteString.Lazy as BS
15−import qualified Data.List as List
16−
17−-- Part 1
18−-- ------
19−-- Add a build callout
20−-- We need to build elm-doc and run it because that generates the file "docs.json"
21−-- needs by Libraries.hs which is part of the elm library and executable
22−-- Unfort. there seems to be no way to tell cabal that:
23−-- (a) elm-doc generates docs.json, and
24−-- (b) elm (library) depends on docs.json
25−-- Therefore, we either use make instead (or a script), or hack around in cabal
26−
27−-- Part 2
28−-- ------
29−-- Add a post-build callout.
30−-- We need to build the runtime.js after we've built elm (because we use elm to generate some of the JavaScript),
31−-- but before cabal does the install file copy step
32−
33−-- Assumptions
34−-- Elm.cabal expects the generated files to end up in dist/data
35−-- git won't look in dist + cabal will clean it
36−rtsDir :: LocalBuildInfo -> FilePath
37−rtsDir lbi = "data"
38−
39−tempDir :: LocalBuildInfo -> FilePath
40−tempDir lbi = "temp"
41−
42−-- The runtime is called:
43−rts :: LocalBuildInfo -> FilePath
44−rts lbi = rtsDir lbi </> "elm-runtime.js"
45−
46−-- The runtime is called:
47−docs :: LocalBuildInfo -> FilePath
48−docs lbi = rtsDir lbi </> "docs.json"
49−
50−-- The interfaces for the Standard Libraries live in:
51−interfaces :: LocalBuildInfo -> FilePath
52−interfaces lbi = rtsDir lbi </> "interfaces.data"
53−
54−elm :: LocalBuildInfo -> FilePath
55−elm lbi = buildDir lbi </> "elm" </> "elm"
56−
57−document :: LocalBuildInfo -> FilePath
58−document lbi = buildDir lbi </> "elm-doc" </> "elm-doc"
59−
60−-- Care! This appears to be based on an unstable API
61−-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2
62−
63−
64−main :: IO ()
65−main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }
66−
67−
68−-- Build
69−
70−-- note(1): We use to include docs.json directly into LoadLibraries at compile time
71−-- If docs.json is used in other (template) haskell files, they should be copied
72−-- and compiled in a separate directory (eg, dist/copiedSrc).
73−-- This is to make sure they are re-compiled on docs.json changes.
74−-- Copying is a better solution than 'touch'ing the source files
75−-- (touch is non-portable and confusing wrt RCS).
76−
77−-- In the PackageDescription, the list of stuff to build is held in library
78−-- (in a Maybe) and the executables list. We want a PackageDescription that
79−-- only mentions the executable 'name'
80−filterExe :: String -> PackageDescription -> PackageDescription
81−filterExe name pd = pd {
82− library = Nothing,
83− executables = filter (\x -> (exeName x == name)) (executables pd)
84− }
85−
86−
87−-- Post Build
88−
89−myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
90−myPostBuild as bfs pd lbi = do
91− putStrLn "Custom build step: compiling standard libraries"
92− (elmos, elmis) <- compileLibraries lbi
93− putStrLn "Custom build step: build interfaces.data"
94− buildInterfaces lbi elmis
95− putStrLn "Custom build step: build elm-runtime.js"
96− buildRuntime lbi elmos
97− putStrLn "Custom build step: build docs.json"
98− buildDocs lbi
99− removeDirectoryRecursive (tempDir lbi)
100− removeDirectoryRecursive ("libraries" </> "docs")
101− postBuild simpleUserHooks as bfs pd lbi
102−
103−
104−compileLibraries lbi = do
105− let temp = tempDir lbi -- temp
106− rts = rtsDir lbi -- data
107− createDirectoryIfMissing True temp
108− createDirectoryIfMissing True rts
109− out_c <- canonicalizePath temp -- temp (root folder)
110− elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm
111− doc_c <- canonicalizePath (document lbi) -- dist/build/elm-doc/elm-doc
112− rtd_c <- canonicalizePath rts -- data
113−
114− let make file = do
115− -- replace 'system' call with 'runProcess' which handles args better
116− -- and allows env variable "Elm_datadir" which is used by LoadLibraries
117− -- to find docs.json
118− let args = [ "--only-js", "--make", "--no-prelude"
119− , "--cache-dir="++out_c, "--build-dir="++out_c, file ]
120− arg = Just [("Elm_datadir", rtd_c)]
121− handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing
122− exitCode <- waitForProcess handle
123− return ( out_c </> replaceExtension file "elmo"
124− , out_c </> replaceExtension file "elmi")
125−
126− setCurrentDirectory "libraries"
127− paths <- getFiles ".elm" "."
128− files <- unzip `fmap` mapM make paths
129− mapM_ (\path -> rawSystem doc_c [path]) paths
130− setCurrentDirectory ".."
131− return files
132−
133−buildInterfaces :: LocalBuildInfo -> [FilePath] -> IO ()
134−buildInterfaces lbi elmis = do
135− createDirectoryIfMissing True (rtsDir lbi)
136− let ifaces = interfaces lbi
137− ifaceHandle <- openBinaryFile ifaces WriteMode
138− BS.hPut ifaceHandle (Binary.encode (length elmis))
139− let append file = do
140− handle <- openBinaryFile file ReadMode
141− bits <- hGetContents handle
142− length bits `seq` hPutStr ifaceHandle bits
143− hClose handle
144− mapM_ append elmis
145− hClose ifaceHandle
146−
147−buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
148−buildRuntime lbi elmos = do
149− createDirectoryIfMissing True (rtsDir lbi)
150− let rts' = rts lbi
151− writeFile rts' "var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
152− \var ElmRuntime = {}; ElmRuntime.Render = {};\n"
153− mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
154− mapM_ (appendTo rts') elmos
155− mapM_ (appendTo rts') =<< getFiles ".js" "runtime"
156−
157−buildDocs :: LocalBuildInfo -> IO ()
158−buildDocs lbi = do
159− createDirectoryIfMissing True (rtsDir lbi)
160− let docs' = docs lbi
161− writeFile docs' "[\n"
162− json <- getFiles ".json" ("libraries" </> "docs")
163− let appends = map (appendTo docs') json
164− addCommas = List.intersperse (appendFile docs' ",\n")
165− sequence_ (addCommas appends)
166− appendFile docs' "\n]"
167−
168−getFiles ext dir = do
169− contents <- map (dir </>) `fmap` getDirectoryContents dir
170− let files = filter (\f -> takeExtension f == ext) contents
171− dirs = filter (not . hasExtension) contents
172− filess <- mapM (getFiles ext) dirs
173− return (files ++ concat filess)
174−
175−appendTo :: FilePath -> FilePath -> IO ()
176−appendTo destination source = do
177− str <- readFile source
178− length str `seq` return ()
179− appendFile destination str
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.hsnew file+383
@@ -0,0 +1,383 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Deps.Diff
3+ ( diff
4+ , PackageChanges(..)
5+ , ModuleChanges(..)
6+ , Changes(..)
7+ , moduleChangeMagnitude
8+ , toMagnitude
9+ , bump
10+ , getDocs
11+ )
12+ where
13+
14+
15+import Control.Monad (zipWithM)
16+import Data.Function (on)
17+import qualified Data.List as List
18+import qualified Data.Map as Map
19+import qualified Data.Name as Name
20+import qualified Data.Set as Set
21+import qualified System.Directory as Dir
22+import System.FilePath ((</>))
23+
24+import qualified Deps.Website as Website
25+import qualified Elm.Compiler.Type as Type
26+import qualified Elm.Docs as Docs
27+import qualified Elm.Magnitude as M
28+import qualified Elm.ModuleName as ModuleName
29+import 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
36+
37+
38+
39+-- CHANGES
40+
41+
42+data PackageChanges =
43+ PackageChanges
44+ { _modules_added :: [ModuleName.Raw]
45+ , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges
46+ , _modules_removed :: [ModuleName.Raw]
47+ }
48+
49+
50+data ModuleChanges =
51+ ModuleChanges
52+ { _unions :: Changes Name.Name Docs.Union
53+ , _aliases :: Changes Name.Name Docs.Alias
54+ , _values :: Changes Name.Name Docs.Value
55+ , _binops :: Changes Name.Name Docs.Binop
56+ }
57+
58+
59+data Changes k v =
60+ Changes
61+ { _added :: Map.Map k v
62+ , _changed :: Map.Map k (v,v)
63+ , _removed :: Map.Map k v
64+ }
65+
66+
67+getChanges :: (Ord k) => (v -> v -> Bool) -> Map.Map k v -> Map.Map k v -> Changes k v
68+getChanges isEquivalent old new =
69+ let
70+ overlap = Map.intersectionWith (,) old new
71+ changed = Map.filter (not . uncurry isEquivalent) overlap
72+ in
73+ Changes (Map.difference new old) changed (Map.difference old new)
74+
75+
76+
77+-- DIFF
78+
79+
80+diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges
81+diff oldDocs newDocs =
82+ let
83+ filterOutPatches chngs =
84+ Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs
85+
86+ (Changes added changed removed) =
87+ getChanges (\_ _ -> False) oldDocs newDocs
88+ in
89+ PackageChanges
90+ (Map.keys added)
91+ (filterOutPatches (Map.map diffModule changed))
92+ (Map.keys removed)
93+
94+
95+
96+diffModule :: (Docs.Module, Docs.Module) -> ModuleChanges
97+diffModule (Docs.Module _ _ u1 a1 v1 b1, Docs.Module _ _ u2 a2 v2 b2) =
98+ ModuleChanges
99+ (getChanges isEquivalentUnion u1 u2)
100+ (getChanges isEquivalentAlias a1 a2)
101+ (getChanges isEquivalentValue v1 v2)
102+ (getChanges isEquivalentBinop b1 b2)
103+
104+
105+
106+-- EQUIVALENCE
107+
108+
109+isEquivalentUnion :: Docs.Union -> Docs.Union -> Bool
110+isEquivalentUnion (Docs.Union oldComment oldVars oldCtors) (Docs.Union newComment newVars newCtors) =
111+ length oldCtors == length newCtors
112+ && and (zipWith (==) (map fst oldCtors) (map fst newCtors))
113+ && and (Map.elems (Map.intersectionWith equiv (Map.fromList oldCtors) (Map.fromList newCtors)))
114+ where
115+ equiv :: [Type.Type] -> [Type.Type] -> Bool
116+ equiv oldTypes newTypes =
117+ let
118+ allEquivalent =
119+ zipWith
120+ isEquivalentAlias
121+ (map (Docs.Alias oldComment oldVars) oldTypes)
122+ (map (Docs.Alias newComment newVars) newTypes)
123+ in
124+ length oldTypes == length newTypes
125+ && and allEquivalent
126+
127+
128+isEquivalentAlias :: Docs.Alias -> Docs.Alias -> Bool
129+isEquivalentAlias (Docs.Alias _ oldVars oldType) (Docs.Alias _ newVars newType) =
130+ case diffType oldType newType of
131+ Nothing ->
132+ False
133+
134+ Just renamings ->
135+ length oldVars == length newVars
136+ && isEquivalentRenaming (zip oldVars newVars ++ renamings)
137+
138+
139+isEquivalentValue :: Docs.Value -> Docs.Value -> Bool
140+isEquivalentValue (Docs.Value c1 t1) (Docs.Value c2 t2) =
141+ isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
142+
143+
144+isEquivalentBinop :: Docs.Binop -> Docs.Binop -> Bool
145+isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =
146+ isEquivalentAlias (Docs.Alias c1 [] t1) (Docs.Alias c2 [] t2)
147+ && a1 == a2
148+ && p1 == p2
149+
150+
151+
152+-- DIFF TYPES
153+
154+
155+diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]
156+diffType oldType newType =
157+ case (oldType, newType) of
158+ (Type.Var oldName, Type.Var newName) ->
159+ Just [(oldName, newName)]
160+
161+ (Type.Lambda a b, Type.Lambda a' b') ->
162+ (++)
163+ <$> diffType a a'
164+ <*> diffType b b'
165+
166+ (Type.Type oldName oldArgs, Type.Type newName newArgs) ->
167+ if not (isSameName oldName newName) || length oldArgs /= length newArgs then
168+ Nothing
169+ else
170+ concat <$> zipWithM diffType oldArgs newArgs
171+
172+ (Type.Record fields maybeExt, Type.Record fields' maybeExt') ->
173+ case (maybeExt, maybeExt') of
174+ (Nothing, Just _) ->
175+ Nothing
176+
177+ (Just _, Nothing) ->
178+ Nothing
179+
180+ (Nothing, Nothing) ->
181+ diffFields fields fields'
182+
183+ (Just oldExt, Just newExt) ->
184+ (:) (oldExt, newExt) <$> diffFields fields fields'
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+
198+ (_, _) ->
199+ Nothing
200+
201+
202+-- handle very old docs that do not use qualified names
203+isSameName :: Name.Name -> Name.Name -> Bool
204+isSameName oldFullName newFullName =
205+ let
206+ dedot name =
207+ reverse (Name.splitDots name)
208+ in
209+ case ( dedot oldFullName, dedot newFullName ) of
210+ (oldName:[], newName:_) ->
211+ oldName == newName
212+
213+ (oldName:_, newName:[]) ->
214+ oldName == newName
215+
216+ _ ->
217+ oldFullName == newFullName
218+
219+
220+diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]
221+diffFields oldRawFields newRawFields =
222+ let
223+ sort = List.sortBy (compare `on` fst)
224+ oldFields = sort oldRawFields
225+ newFields = sort newRawFields
226+ in
227+ if length oldRawFields /= length newRawFields then
228+ Nothing
229+
230+ else if or (zipWith ((/=) `on` fst) oldFields newFields) then
231+ Nothing
232+
233+ else
234+ concat <$> zipWithM (diffType `on` snd) oldFields newFields
235+
236+
237+
238+-- TYPE VARIABLES
239+
240+
241+isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool
242+isEquivalentRenaming varPairs =
243+ let
244+ renamings =
245+ Map.toList (foldr insert Map.empty varPairs)
246+
247+ insert (old,new) dict =
248+ Map.insertWith (++) old [new] dict
249+
250+ verify (old, news) =
251+ case news of
252+ [] ->
253+ Nothing
254+
255+ new : rest ->
256+ if all (new ==) rest then
257+ Just (old, new)
258+ else
259+ Nothing
260+
261+ allUnique list =
262+ length list == Set.size (Set.fromList list)
263+ in
264+ case mapM verify renamings of
265+ Nothing ->
266+ False
267+
268+ Just verifiedRenamings ->
269+ all compatibleVars verifiedRenamings
270+ &&
271+ allUnique (map snd verifiedRenamings)
272+
273+
274+compatibleVars :: (Name.Name, Name.Name) -> Bool
275+compatibleVars (old, new) =
276+ case (categorizeVar old, categorizeVar new) of
277+ (CompAppend, CompAppend) -> True
278+ (Comparable, Comparable) -> True
279+ (Appendable, Appendable) -> True
280+ (Number , Number ) -> True
281+ (Number , Comparable) -> True
282+
283+ (_, Var) -> True
284+
285+ (_, _) -> False
286+
287+
288+data TypeVarCategory
289+ = CompAppend
290+ | Comparable
291+ | Appendable
292+ | Number
293+ | Var
294+
295+
296+categorizeVar :: Name.Name -> TypeVarCategory
297+categorizeVar name
298+ | Name.isCompappendType name = CompAppend
299+ | Name.isComparableType name = Comparable
300+ | Name.isAppendableType name = Appendable
301+ | Name.isNumberType name = Number
302+ | otherwise = Var
303+
304+
305+
306+-- MAGNITUDE
307+
308+
309+bump :: PackageChanges -> V.Version -> V.Version
310+bump changes version =
311+ case toMagnitude changes of
312+ M.PATCH ->
313+ V.bumpPatch version
314+
315+ M.MINOR ->
316+ V.bumpMinor version
317+
318+ M.MAJOR ->
319+ V.bumpMajor version
320+
321+
322+toMagnitude :: PackageChanges -> M.Magnitude
323+toMagnitude (PackageChanges added changed removed) =
324+ let
325+ addMag = if null added then M.PATCH else M.MINOR
326+ removeMag = if null removed then M.PATCH else M.MAJOR
327+ changeMags = map moduleChangeMagnitude (Map.elems changed)
328+ in
329+ maximum (addMag : removeMag : changeMags)
330+
331+
332+moduleChangeMagnitude :: ModuleChanges -> M.Magnitude
333+moduleChangeMagnitude (ModuleChanges unions aliases values binops) =
334+ maximum
335+ [ changeMagnitude unions
336+ , changeMagnitude aliases
337+ , changeMagnitude values
338+ , changeMagnitude binops
339+ ]
340+
341+
342+changeMagnitude :: Changes k v -> M.Magnitude
343+changeMagnitude (Changes added changed removed) =
344+ if Map.size removed > 0 || Map.size changed > 0 then
345+ M.MAJOR
346+
347+ else if Map.size added > 0 then
348+ M.MINOR
349+
350+ else
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/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.hsnew file+444
@@ -0,0 +1,444 @@
1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
2+module Deps.Solver
3+ ( Solver
4+ , Result(..)
5+ , Connection(..)
6+ --
7+ , Details(..)
8+ , verify
9+ --
10+ , AppSolution(..)
11+ , addToApp
12+ --
13+ , Env(..)
14+ , initEnv
15+ )
16+ where
17+
18+
19+import Control.Monad (foldM)
20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)
21+import qualified Data.Map as Map
22+import Data.Map ((!))
23+import qualified System.Directory as Dir
24+import System.FilePath ((</>))
25+
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
37+
38+
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+
54+
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+ }
62+
63+
64+data Constraints =
65+ Constraints
66+ { _elm :: C.Constraint
67+ , _deps :: Map.Map Pkg.Name C.Constraint
68+ }
69+
70+
71+data Connection
72+ = Online Http.Manager
73+ | Offline
74+
75+
76+
77+-- RESULT
78+
79+
80+data Result a
81+ = Ok a
82+ | NoSolution
83+ | NoOfflineSolution
84+ | Err Exit.Solver
85+
86+
87+
88+-- VERIFY -- used by Elm.Details
89+
90+
91+data Details =
92+ Details V.Version (Map.Map Pkg.Name C.Constraint)
93+
94+
95+verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
96+verify cache connection registry constraints =
97+ Stuff.withRegistryLock cache $
98+ case try constraints of
99+ Solver solver ->
100+ solver (State cache connection registry Map.empty)
101+ (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
102+ (\_ -> return $ noSolution connection)
103+ (\e -> return $ Err e)
104+
105+
106+addDeps :: State -> Pkg.Name -> V.Version -> Details
107+addDeps (State _ _ _ constraints) name vsn =
108+ case Map.lookup (name, vsn) constraints of
109+ Just (Constraints _ deps) -> Details vsn deps
110+ Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
111+
112+
113+noSolution :: Connection -> Result a
114+noSolution connection =
115+ case connection of
116+ Online _ -> NoSolution
117+ Offline -> NoOfflineSolution
118+
119+
120+
121+-- ADD TO APP - used in Install
122+
123+
124+data AppSolution =
125+ AppSolution
126+ { _old :: Map.Map Pkg.Name V.Version
127+ , _new :: Map.Map Pkg.Name V.Version
128+ , _app :: Outline.AppOutline
129+ }
130+
131+
132+addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
133+addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
134+ Stuff.withRegistryLock cache $
135+ let
136+ allIndirects = Map.union indirect testIndirect
137+ allDirects = Map.union direct testDirect
138+ allDeps = Map.union allDirects allIndirects
139+
140+ attempt toConstraint deps =
141+ try (Map.insert pkg C.anything (Map.map toConstraint deps))
142+ in
143+ case
144+ oneOf
145+ ( attempt C.exactly allDeps )
146+ [ attempt C.exactly allDirects
147+ , attempt C.untilNextMinor allDirects
148+ , attempt C.untilNextMajor allDirects
149+ , attempt (\_ -> C.anything) allDirects
150+ ]
151+ of
152+ Solver solver ->
153+ solver (State cache connection registry Map.empty)
154+ (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
155+ (\_ -> return $ noSolution connection)
156+ (\e -> return $ Err e)
157+
158+
159+toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
160+toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =
161+ let
162+ d = Map.intersection new (Map.insert pkg V.one direct)
163+ i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
164+ td = Map.intersection new (Map.delete pkg testDirect)
165+ ti = Map.difference new (Map.unions [d,i,td])
166+ in
167+ AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)
168+
169+
170+getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
171+getTransitive constraints solution unvisited visited =
172+ case unvisited of
173+ [] ->
174+ visited
175+
176+ info@(pkg,vsn) : infos ->
177+ if Map.member pkg visited
178+ then getTransitive constraints solution infos visited
179+ else
180+ let
181+ newDeps = _deps (constraints ! info)
182+ newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))
183+ newVisited = Map.insert pkg vsn visited
184+ in
185+ getTransitive constraints solution infos $
186+ getTransitive constraints solution newUnvisited newVisited
187+
188+
189+
190+-- TRY
191+
192+
193+try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
194+try constraints =
195+ exploreGoals (Goals constraints Map.empty)
196+
197+
198+
199+-- EXPLORE GOALS
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+
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)
235+addConstraint solved unsolved (name, newConstraint) =
236+ case Map.lookup name solved of
237+ Just version ->
238+ if C.satisfies newConstraint version
239+ then return unsolved
240+ else backtrack
241+
242+ Nothing ->
243+ case Map.lookup name unsolved of
244+ Nothing ->
245+ return $ Map.insert name newConstraint unsolved
246+
247+ Just oldConstraint ->
248+ case C.intersect oldConstraint newConstraint of
249+ Nothing ->
250+ backtrack
251+
252+ Just mergedConstraint ->
253+ if oldConstraint == mergedConstraint
254+ then return 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+
441+
442+backtrack :: Solver a
443+backtrack =
444+ Solver $ \state _ back _ -> back state
builder/src/Deps/Website.hsnew file+26
@@ -0,0 +1,26 @@
1+module Deps.Website
2+ ( domain
3+ , route
4+ , metadata
5+ )
6+ where
7+
8+
9+import qualified Elm.Package as Pkg
10+import qualified Elm.Version as V
11+import qualified Http
12+
13+
14+domain :: String
15+domain =
16+ "https://package.elm-lang.org"
17+
18+
19+route :: String -> [(String,String)] -> String
20+route path params =
21+ Http.toUrl (domain ++ path) params
22+
23+
24+metadata :: Pkg.Name -> V.Version -> String -> String
25+metadata name version file =
26+ domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file
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/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/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/Generate.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE BangPatterns #-}
2+module Generate
3+ ( debug
4+ , dev
5+ , prod
6+ , repl
7+ )
8+ where
9+
10+
11+import Prelude hiding (cycle, print)
12+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
13+import Control.Monad (liftM2)
14+import qualified Data.ByteString.Builder as B
15+import Data.Map ((!))
16+import qualified Data.Map as Map
17+import qualified Data.Maybe as Maybe
18+import qualified Data.Name as N
19+import qualified Data.NonEmptyList as NE
20+
21+import qualified AST.Optimized as Opt
22+import qualified Build
23+import qualified Elm.Compiler.Type.Extract as Extract
24+import qualified Elm.Details as Details
25+import qualified Elm.Interface as I
26+import qualified Elm.ModuleName as ModuleName
27+import qualified Elm.Package as Pkg
28+import qualified File
29+import qualified Generate.JavaScript as JS
30+import qualified Generate.Mode as Mode
31+import qualified Nitpick.Debug as Nitpick
32+import qualified Reporting.Exit as Exit
33+import qualified Reporting.Task as Task
34+import qualified Stuff
35+
36+
37+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
38+-- desireable to have Repl and Reactor to keep foreign objects in memory
39+-- to make things a bit faster?
40+
41+
42+
43+-- GENERATORS
44+
45+
46+type Task a =
47+ Task.Task Exit.Generate a
48+
49+
50+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
51+debug root details (Build.Artifacts pkg ifaces roots modules) =
52+ do loading <- loadObjects root details modules
53+ types <- loadTypes root ifaces modules
54+ objects <- finalizeObjects loading
55+ let mode = Mode.Dev (Just types)
56+ let graph = objectsToGlobalGraph objects
57+ let mains = gatherMains pkg objects roots
58+ return $ JS.generate mode graph mains
59+
60+
61+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
62+dev root details (Build.Artifacts pkg _ roots modules) =
63+ do objects <- finalizeObjects =<< loadObjects root details modules
64+ let mode = Mode.Dev Nothing
65+ let graph = objectsToGlobalGraph objects
66+ let mains = gatherMains pkg objects roots
67+ return $ JS.generate mode graph mains
68+
69+
70+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
71+prod root details (Build.Artifacts pkg _ roots modules) =
72+ do objects <- finalizeObjects =<< loadObjects root details modules
73+ checkForDebugUses objects
74+ let graph = objectsToGlobalGraph objects
75+ let mode = Mode.Prod (Mode.shortenFieldNames graph)
76+ let mains = gatherMains pkg objects roots
77+ return $ JS.generate mode graph mains
78+
79+
80+repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder
81+repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =
82+ do objects <- finalizeObjects =<< loadObjects root details modules
83+ let graph = objectsToGlobalGraph objects
84+ return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)
85+
86+
87+
88+-- CHECK FOR DEBUG
89+
90+
91+checkForDebugUses :: Objects -> Task ()
92+checkForDebugUses (Objects _ locals) =
93+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of
94+ [] -> return ()
95+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)
96+
97+
98+
99+-- GATHER MAINS
100+
101+
102+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main
103+gatherMains pkg (Objects _ locals) roots =
104+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)
105+
106+
107+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)
108+lookupMain pkg locals root =
109+ let
110+ toPair name (Opt.LocalGraph maybeMain _ _) =
111+ (,) (ModuleName.Canonical pkg name) <$> maybeMain
112+ in
113+ case root of
114+ Build.Inside name -> toPair name =<< Map.lookup name locals
115+ Build.Outside name _ g -> toPair name g
116+
117+
118+
119+-- LOADING OBJECTS
120+
121+
122+data LoadingObjects =
123+ LoadingObjects
124+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)
125+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))
126+ }
127+
128+
129+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects
130+loadObjects root details modules =
131+ Task.io $
132+ do mvar <- Details.loadObjects root details
133+ mvars <- traverse (loadObject root) modules
134+ return $ LoadingObjects mvar (Map.fromList mvars)
135+
136+
137+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))
138+loadObject root modul =
139+ case modul of
140+ Build.Fresh name _ graph ->
141+ do mvar <- newMVar (Just graph)
142+ return (name, mvar)
143+
144+ Build.Cached name _ _ ->
145+ do mvar <- newEmptyMVar
146+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)
147+ return (name, mvar)
148+
149+
150+
151+-- FINALIZE OBJECTS
152+
153+
154+data Objects =
155+ Objects
156+ { _foreign :: Opt.GlobalGraph
157+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph
158+ }
159+
160+
161+finalizeObjects :: LoadingObjects -> Task Objects
162+finalizeObjects (LoadingObjects mvar mvars) =
163+ Task.eio id $
164+ do result <- readMVar mvar
165+ results <- traverse readMVar mvars
166+ case liftM2 Objects result (sequence results) of
167+ Just loaded -> return (Right loaded)
168+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
169+
170+
171+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph
172+objectsToGlobalGraph (Objects globals locals) =
173+ foldr Opt.addLocalGraph globals locals
174+
175+
176+
177+-- LOAD TYPES
178+
179+
180+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types
181+loadTypes root ifaces modules =
182+ Task.eio id $
183+ do mvars <- traverse (loadTypesHelp root) modules
184+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))
185+ results <- traverse readMVar mvars
186+ case sequence results of
187+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))
188+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)
189+
190+
191+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))
192+loadTypesHelp root modul =
193+ case modul of
194+ Build.Fresh name iface _ ->
195+ newMVar (Just (Extract.fromInterface name iface))
196+
197+ Build.Cached name _ ciMVar ->
198+ do cachedInterface <- readMVar ciMVar
199+ case cachedInterface of
200+ Build.Unneeded ->
201+ do mvar <- newEmptyMVar
202+ _ <- forkIO $
203+ do maybeIface <- File.readBinary (Stuff.elmi root name)
204+ putMVar mvar (Extract.fromInterface name <$> maybeIface)
205+ return mvar
206+
207+ Build.Loaded iface ->
208+ newMVar (Just (Extract.fromInterface name iface))
209+
210+ Build.Corrupted ->
211+ newMVar Nothing
builder/src/Http.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/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/Task.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE Rank2Types #-}
2+module Reporting.Task
3+ ( Task
4+ , run
5+ , throw
6+ , mapError
7+ --
8+ , io
9+ , mio
10+ , eio
11+ )
12+ where
13+
14+
15+
16+-- TASKS
17+
18+
19+newtype Task x a =
20+ Task
21+ (
22+ forall result. (a -> IO result) -> (x -> IO result) -> IO result
23+ )
24+
25+
26+run :: Task x a -> IO (Either x a)
27+run (Task task) =
28+ task (return . Right) (return . Left)
29+
30+
31+throw :: x -> Task x a
32+throw x =
33+ Task $ \_ err -> err x
34+
35+
36+mapError :: (x -> y) -> Task x a -> Task y a
37+mapError func (Task task) =
38+ Task $ \ok err ->
39+ task ok (err . func)
40+
41+
42+
43+-- IO
44+
45+
46+{-# INLINE io #-}
47+io :: IO a -> Task x a
48+io work =
49+ Task $ \ok _ -> work >>= ok
50+
51+
52+mio :: x -> IO (Maybe a) -> Task x a
53+mio x work =
54+ Task $ \ok err ->
55+ do result <- work
56+ case result of
57+ Just a -> ok a
58+ Nothing -> err x
59+
60+
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)
68+
69+
70+
71+-- INSTANCES
72+
73+
74+instance Functor (Task x) where
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
82+
83+
84+instance Applicative (Task x) where
85+ {-# INLINE pure #-}
86+ pure a =
87+ Task $ \ok _ -> ok a
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
100+
101+
102+instance Monad (Task x) where
103+ {-# INLINE return #-}
104+ return = pure
105+
106+ {-# INLINE (>>=) #-}
107+ (>>=) (Task taskA) callback =
108+ Task $ \ok err ->
109+ let
110+ okA a =
111+ case callback a of
112+ Task taskB -> taskB ok err
113+ in
114+ taskA okA err
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"
cabal.confignew file+2
@@ -0,0 +1,2 @@
1+profiling: False
2+library-profiling: True
compiler/Build/Dependencies.hsdeleted−125
@@ -1,125 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Build.Dependencies (getSortedDependencies, readDeps) where
3−
4−import Control.Applicative
5−import Control.Monad.Error
6−import qualified Control.Monad.State as State
7−import qualified Data.Aeson as Json
8−import qualified Data.ByteString.Lazy.Char8 as BSC
9−import qualified Data.Graph as Graph
10−import qualified Data.List as List
11−import qualified Data.Map as Map
12−import qualified Data.Maybe as Maybe
13−import qualified Data.Set as Set
14−import System.Directory
15−import System.FilePath as FP
16−
17−import Build.Print (failure)
18−
19−import qualified SourceSyntax.Module as Module
20−import qualified Parse.Parse as Parse
21−import qualified Elm.Internal.Paths as Path
22−import qualified Elm.Internal.Name as N
23−import qualified Elm.Internal.Dependencies as Deps
24−
25−getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]
26−getSortedDependencies srcDirs builtIns root =
27− do extras <- extraDependencies
28− let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
29− result <- runErrorT $ readAllDeps allSrcDirs builtIns root
30− case result of
31− Right deps -> sortDeps deps
32− Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
33− where msg = "\nYou may need to create a " ++
34− Path.dependencyFile ++
35− " file if you\nare trying to use a 3rd party library."
36−
37−extraDependencies :: IO (Maybe [FilePath])
38−extraDependencies =
39− do exists <- doesFileExist Path.dependencyFile
40− if not exists then return Nothing else Just <$> getPaths
41− where
42− getPaths = do
43− raw <- BSC.readFile Path.dependencyFile
44− case Json.eitherDecode raw of
45− Right (Deps.Mini deps) -> mapM validate deps
46− Left err ->
47− failure $ "Error reading the " ++ Path.dependencyFile ++ " file:\n" ++ err
48−
49− validate (name,version) = do
50− let path = Path.dependencyDirectory </> toPath name version
51− exists <- doesDirectoryExist path
52− if exists then return path else failure (notFound name version)
53−
54− toPath name version = N.toFilePath name </> show version
55−
56− notFound name version =
57− unlines
58− [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"
59− , show name ++ " " ++ show version ++ " but it was not found."
60− , "You may need to install it with:"
61− , ""
62− , " elm-get install " ++ show name ++ " " ++ show version ]
63−
64−type Deps = (FilePath, String, [String])
65−
66−sortDeps :: [Deps] -> IO [String]
67−sortDeps depends =
68− if null mistakes
69− then return (concat sccs)
70− else failure $ msg ++ unlines (map show mistakes)
71− where
72− sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
73−
74− mistakes = filter (\scc -> length scc > 1) sccs
75− msg = "A cyclical module dependency or was detected in:\n"
76−
77−readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
78−readAllDeps srcDirs builtIns root =
79− do let ifaces = (Set.fromList . Map.keys) builtIns
80− State.evalStateT (go ifaces root) Set.empty
81− where
82− go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
83− go builtIns root = do
84− root' <- lift $ findSrcFile srcDirs root
85− (name, deps) <- lift $ readDeps root'
86− seen <- State.get
87− let realDeps = Set.difference (Set.fromList deps) builtIns
88− newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
89− State.put (Set.insert name (Set.union newDeps seen))
90− rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
91− return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
92−
93−readDeps :: FilePath -> ErrorT String IO (String, [String])
94−readDeps path = do
95− txt <- lift $ readFile path
96− case Parse.dependencies txt of
97− Left err -> throwError $ msg ++ show err
98− where msg = "Error resolving dependencies in " ++ path ++ ":\n"
99− Right o -> return o
100−
101−findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
102−findSrcFile dirs path = foldr tryDir notFound dirs
103− where
104− notFound = throwError $ unlines
105− [ "Could not find file: " ++ path
106− , " If it is not in the root directory of your project, use"
107− , " --src-dir to declare additional locations for source files."
108− , " If it is part of a 3rd party library, it needs to be declared"
109− , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
110− tryDir dir next = do
111− let path' = dir </> path
112− exists <- liftIO $ doesFileExist path'
113− if exists
114− then return path'
115− else next
116−
117−isNative :: String -> Bool
118−isNative name = List.isPrefixOf "Native." name
119−
120−toFilePath :: String -> FilePath
121−toFilePath name = map swapDots name ++ ext
122− where
123− swapDots '.' = '/'
124− swapDots c = c
125− ext = if isNative name then ".js" else ".elm"
compiler/Build/File.hsdeleted−156
@@ -1,156 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Build.File (build) where
3−
4−import Control.Applicative ((<$>))
5−import Control.Monad.Error (runErrorT)
6−import Control.Monad.RWS.Strict
7−import System.Directory
8−import System.Exit
9−import System.FilePath
10−import System.IO
11−
12−import qualified Data.Binary as Binary
13−import qualified Data.Maybe as Maybe
14−import qualified Data.Map as Map
15−import qualified Data.ByteString.Lazy as L
16−
17−import qualified Build.Dependencies as Deps
18−import qualified Build.Flags as Flag
19−import qualified Build.Interface as Interface
20−import qualified Build.Print as Print
21−import qualified Build.Source as Source
22−import qualified Build.Utils as Utils
23−import qualified Generate.JavaScript as JS
24−import qualified Parse.Module as Parser
25−import qualified SourceSyntax.Module as M
26−import qualified Transform.Canonicalize as Canonical
27−
28−-- Reader: Runtime flags, always accessible
29−-- Writer: Remember the last module to be accessed
30−-- State: Build up a map of the module interfaces
31−type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
32−type Build a = BuildT IO a
33−
34−-- Interfaces, remembering if something was recompiled
35−type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
36−
37−evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
38−evalBuild flags interfaces b = do
39− (_, s) <- evalRWST b flags (fmap notUpdated interfaces)
40− return . getLast $ s
41− where
42− notUpdated i = (False, i)
43−
44−-- | Builds a list of files, returning the moduleName of the last one.
45−-- Returns \"\" if the list is empty
46−build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
47−build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
48−
49−buildAll :: [FilePath] -> Build ()
50−buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
51− where build1 :: Integer -> FilePath -> Build ()
52− build1 num fname = do
53− shouldCompile <- shouldBeCompiled fname
54− if shouldCompile
55− then compile number fname
56− else retrieve fname
57−
58− where number = join ["[", show num, " of ", show total, "]"]
59−
60− total = length fs
61−
62−shouldBeCompiled :: FilePath -> Build Bool
63−shouldBeCompiled filePath = do
64− flags <- ask
65− let alreadyCompiled = liftIO $ do
66− existsi <- doesFileExist (Utils.elmi flags filePath)
67− existso <- doesFileExist (Utils.elmo flags filePath)
68− return $ existsi && existso
69−
70− outDated = liftIO $ do
71− tsrc <- getModificationTime filePath
72− tint <- getModificationTime (Utils.elmo flags filePath)
73− return (tsrc > tint)
74−
75− dependenciesUpdated = do
76− eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
77− case eDeps of
78− -- Should never actually reach here
79− Left err -> liftIO $ Print.failure err
80− Right (_, deps) -> anyM wasCompiled deps
81−
82−
83− in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
84−
85−wasCompiled :: String -> Build Bool
86−wasCompiled modul = maybe False fst . Map.lookup modul <$> get
87−
88−-- Short-circuiting monadic (||)
89−infixr 2 `orM`
90−orM :: (Monad m) => m Bool -> m Bool -> m Bool
91−orM m1 m2 = do b1 <- m1
92− if b1
93− then return b1
94− else m2
95−
96−anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
97−anyM f = foldr (orM . f) (return False)
98−
99−retrieve :: FilePath -> Build ()
100−retrieve filePath = do
101− flags <- ask
102− iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
103− case Interface.isValid filePath iface of
104− Right (name, interface) ->
105− do binterfaces <- get
106− let interfaces = snd <$> binterfaces
107− liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
108− update name interface False
109−
110− Left err -> liftIO $ Print.failure err
111−
112−compile :: String -> FilePath -> Build ()
113−compile number filePath =
114− do flags <- ask
115− binterfaces <- get
116− source <- liftIO $ readFile filePath
117− let interfaces = snd <$> binterfaces
118− name = getName source
119− liftIO $ do
120− printStatus name
121− createDirectoryIfMissing True (Flag.cache_dir flags)
122− createDirectoryIfMissing True (Flag.build_dir flags)
123−
124− metaModule <-
125− liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
126− Right modul -> return modul
127− Left errors -> do Print.errors errors
128− exitFailure
129−
130− liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
131−
132− let newInters = Canonical.interface name $ M.metaToInterface metaModule
133− generateCache name newInters metaModule
134− update name newInters True
135−
136− where
137− getName source = case Parser.getModuleName source of
138− Just n -> n
139− Nothing -> "Main"
140−
141− printStatus name =
142− hPutStrLn stdout $ concat [ number, " Compiling ", name
143− , replicate (max 1 (20 - length name)) ' '
144− , "( " ++ filePath ++ " )" ]
145−
146− generateCache name interfs metaModule = do
147− flags <- ask
148− liftIO $ do
149− createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
150− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
151− withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
152− L.hPut handle (Binary.encode (name, interfs))
153−
154−update :: String -> M.ModuleInterface -> Bool -> Build ()
155−update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
156− >> tell (Last . Just $ name)
compiler/Build/Flags.hsdeleted−44
@@ -1,44 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Build.Flags where
3−
4−import qualified Elm.Internal.Version as Version
5−import System.Console.CmdArgs
6−
7−data Flags = Flags
8− { make :: Bool
9− , files :: [FilePath]
10− , runtime :: Maybe FilePath
11− , only_js :: Bool
12− , print_types :: Bool
13− , scripts :: [FilePath]
14− , no_prelude :: Bool
15− , cache_dir :: FilePath
16− , build_dir :: FilePath
17− , src_dir :: [FilePath]
18− }
19− deriving (Data,Typeable,Show,Eq)
20−
21−flags = Flags
22− { files = def &= args &= typ "FILES"
23− , make = False
24− &= help "automatically compile dependencies."
25− , only_js = False
26− &= help "Compile only to JavaScript."
27− , no_prelude = False
28− &= help "Do not import Prelude by default, used only when compiling standard libraries."
29− , scripts = [] &= typFile
30− &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
31− , runtime = Nothing &= typFile
32− &= help "Specify a custom location for Elm's runtime system."
33− , cache_dir = "cache" &= typFile
34− &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
35− , build_dir = "build" &= typFile
36− &= help "Directory for generated HTML and JS files. Defaults to build/ directory."
37− , src_dir = ["."] &= typFile
38− &= help "Additional source directories besides project root. Searched when using --make"
39− , print_types = False
40− &= help "Print out infered types of top-level definitions."
41− } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
42− &= helpArg [explicit, name "help", name "h"]
43− &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]
44− &= summary ("The Elm Compiler " ++ show Version.elmVersion ++ ", (c) Evan Czaplicki 2011-2013")
compiler/Build/Interface.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Build.Interface (load,isValid) where
3−
4−import qualified Data.ByteString.Lazy as L
5−import qualified Data.Binary as Binary
6−
7−import qualified Elm.Internal.Version as Version
8−import System.Directory (doesFileExist)
9−import System.Exit
10−import System.IO
11−
12−import SourceSyntax.Module
13−
14−load :: Binary.Binary a => FilePath -> IO a
15−load filePath =
16− do exists <- doesFileExist filePath
17− case exists of
18− False -> failure $ "Unable to find file " ++ filePath ++ " for deserialization!"
19− True -> do
20− bytes <- L.readFile filePath
21− case Binary.decodeOrFail bytes of
22− Right (_, _, binaryInfo) -> return binaryInfo
23− Left (_, offset, err) -> failure $ msg offset err
24−
25− where
26− failure err = do hPutStrLn stderr err
27− exitFailure
28−
29− msg offset err = concat
30− [ "Error reading build artifact: ", filePath, "\n"
31− , " '", err, "' at offset ", show offset, "\n"
32− , " The file was generated by a previous build and may be outdated or corrupt.\n"
33− , " Please remove the file and try again."
34− ]
35−
36−isValid :: FilePath -> (String, ModuleInterface) -> Either String (String, ModuleInterface)
37−isValid filePath (name, interface) =
38− let version = iVersion interface in
39− if version == Version.elmVersion
40− then Right (name, interface)
41− else Left $ concat
42− [ "Error reading build artifact: ", filePath, "\n"
43− , " It was generated by version ", show version, " of the compiler,\n"
44− , " but you are using version ", show Version.elmVersion, "\n"
45− , " Please remove the file and try again.\n"
46− ]
compiler/Build/Print.hsdeleted−38
@@ -1,38 +0,0 @@
1−module Build.Print where
2−
3−import System.IO (hPutStrLn, stderr)
4−import System.Exit (exitFailure)
5−
6−import qualified Data.Map as Map
7−import qualified Data.List as List
8−import qualified SourceSyntax.Module as M
9−import qualified SourceSyntax.PrettyPrint as Pretty
10−import qualified Type.Alias as Alias
11−import qualified Text.PrettyPrint as P
12−
13−metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule -> IO ()
14−metaTypes interfaces meta =
15− types interfaces (M.types meta) (M.aliases meta) (M.imports meta)
16−
17−interfaceTypes :: Map.Map String M.ModuleInterface -> M.ModuleInterface -> IO ()
18−interfaceTypes interfaces iface =
19− types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)
20−
21−types interfaces types' aliases imports =
22− do putStrLn ""
23− mapM_ printType (Map.toList types')
24− putStrLn ""
25− where
26− rules = Alias.rules interfaces aliases imports
27−
28− printType (n,t) = do
29− print $ P.hsep [ Pretty.variable n
30− , P.text ":"
31− , Pretty.pretty (Alias.realias rules t) ]
32−
33−errors :: [P.Doc] -> IO ()
34−errors errs =
35− mapM_ print (List.intersperse (P.text " ") errs)
36−
37−failure :: String -> IO a
38−failure msg = hPutStrLn stderr msg >> exitFailure
compiler/Build/Source.hsdeleted−58
@@ -1,58 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Build.Source (build) where
3−
4−import qualified Data.Map as Map
5−import qualified Data.Set as Set
6−import System.FilePath as FP
7−import Text.PrettyPrint (Doc)
8−
9−import SourceSyntax.Declaration
10−import SourceSyntax.Module
11−import qualified SourceSyntax.Expression as Expr
12−import qualified SourceSyntax.Pattern as Pattern
13−import qualified SourceSyntax.Type as Type
14−import qualified Parse.Parse as Parse
15−import qualified Metadata.Prelude as Prelude
16−import qualified Transform.Check as Check
17−import qualified Transform.SortDefinitions as SD
18−import qualified Type.Inference as TI
19−import qualified Type.Constrain.Declaration as TcDecl
20−import qualified Transform.Canonicalize as Canonical
21−
22−build :: Bool -> Interfaces -> String -> Either [Doc] MetadataModule
23−build noPrelude interfaces source =
24− do let add = Prelude.add noPrelude
25− infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
26− . concatMap iFixities $ Map.elems interfaces
27−
28− Module names exs ims decls <- do
29− modul@(Module _ _ _ decls) <- add `fmap` Parse.program infixes source
30− case Check.mistakes decls of
31− [] -> return modul
32− ms -> Left ms
33−
34− let exports'
35− | null exs =
36− let get = Set.toList . Pattern.boundVars in
37− concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
38− concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++
39− [ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]
40− | otherwise = exs
41−
42− metaModule <- Canonical.metadataModule interfaces $
43− MetadataModule
44− { names = names
45− , path = FP.joinPath names
46− , exports = exports'
47− , imports = ims
48− -- reorder AST into strongly connected components
49− , program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls
50− , types = Map.empty
51− , datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ]
52− , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
53− , aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ]
54− }
55−
56− types <- TI.infer interfaces metaModule
57−
58− return $ metaModule { types = types }
compiler/Build/Utils.hsdeleted−21
@@ -1,21 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Build.Utils where
3−
4−import System.FilePath ((</>), replaceExtension)
5−import qualified Build.Flags as Flag
6−
7−buildPath :: Flag.Flags -> FilePath -> String -> FilePath
8−buildPath flags filePath ext =
9− Flag.build_dir flags </> replaceExtension filePath ext
10−
11−cachePath :: Flag.Flags -> FilePath -> String -> FilePath
12−cachePath flags filePath ext =
13− Flag.cache_dir flags </> replaceExtension filePath ext
14−
15−elmo :: Flag.Flags -> FilePath -> FilePath
16−elmo flags filePath =
17− cachePath flags filePath "elmo"
18−
19−elmi :: Flag.Flags -> FilePath -> FilePath
20−elmi flags filePath =
21− cachePath flags filePath "elmi"
compiler/Compiler.hsdeleted−67
@@ -1,67 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Main where
3−
4−import Control.Monad (foldM)
5−import qualified Data.Maybe as Maybe
6−import Text.Blaze.Html.Renderer.String (renderHtml)
7−import qualified Data.ByteString.Lazy.Char8 as BS
8−import qualified System.Console.CmdArgs as CmdArgs
9−import System.Directory
10−import System.FilePath
11−import GHC.Conc
12−
13−import Build.Dependencies (getSortedDependencies)
14−import qualified Generate.Html as Html
15−import qualified Metadata.Prelude as Prelude
16−import qualified Build.Utils as Utils
17−import qualified Build.Flags as Flag
18−import qualified Build.File as File
19−import qualified Elm.Internal.Paths as Path
20−
21−main :: IO ()
22−main = do setNumCapabilities =<< getNumProcessors
23− compileArgs =<< CmdArgs.cmdArgs Flag.flags
24−
25−compileArgs :: Flag.Flags -> IO ()
26−compileArgs flags =
27− case Flag.files flags of
28− [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
29− fs -> mapM_ (build flags) fs
30−
31−build :: Flag.Flags -> FilePath -> IO ()
32−build flags rootFile =
33− do let noPrelude = Flag.no_prelude flags
34− builtIns <- Prelude.interfaces noPrelude
35−
36− files <- if Flag.make flags
37− then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
38− else return [rootFile]
39−
40− moduleName <- File.build flags builtIns files
41−
42− js <- foldM appendToOutput BS.empty files
43−
44− (extension, code) <-
45− if Flag.only_js flags
46− then do putStr "Generating JavaScript ... "
47− return ("js", js)
48− else do putStr "Generating HTML ... "
49− return (makeHtml js moduleName)
50−
51− let targetFile = Utils.buildPath flags rootFile extension
52− createDirectoryIfMissing True (takeDirectory targetFile)
53− BS.writeFile targetFile code
54− putStrLn "Done"
55−
56− where
57− appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
58− appendToOutput js filePath = do
59− src <- BS.readFile (Utils.elmo flags filePath)
60− return (BS.append src js)
61−
62− sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
63−
64− makeHtml js moduleName = ("html", BS.pack $ renderHtml html)
65− where
66− rtsPath = Maybe.fromMaybe Path.runtime (Flag.runtime flags)
67− html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""
compiler/Docs.hsdeleted−167
@@ -1,167 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
2−module Main where
3−
4−import System.Console.CmdArgs
5−import System.Directory
6−import System.FilePath
7−import System.Exit
8−import System.IO
9−
10−import Control.Applicative ((<$>))
11−import Data.Aeson
12−import Data.Aeson.Encode.Pretty
13−import qualified Data.List as List
14−import qualified Data.Map as Map
15−import qualified Data.ByteString.Lazy as BS
16−import qualified Data.Text as Text
17−
18−import SourceSyntax.Helpers (isSymbol)
19−import SourceSyntax.Type (Type(..))
20−import qualified SourceSyntax.Expression as E
21−import qualified SourceSyntax.Declaration as D
22−
23−import Text.Parsec hiding (newline,spaces)
24−import Parse.Declaration (alias,datatype,infixDecl)
25−import Parse.Expression (typeAnnotation)
26−import Parse.Helpers
27−import Parse.Module (moduleDef)
28−
29−data Flags = Flags
30− { files :: [FilePath] }
31− deriving (Data,Typeable,Show,Eq)
32−
33−defaultFlags = Flags
34− { files = def &= args &= typ "FILES"
35− } &= help "Generate documentation for Elm"
36− &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
37−
38−main = do
39− flags <- cmdArgs defaultFlags
40− mapM parseFile (files flags)
41−
42−config = Config { confIndent = 2, confCompare = keyOrder keys }
43− where
44− keys = ["name","document","comment","raw","aliases","datatypes"
45− ,"values","typeVariables","type","constructors"]
46−
47−parseFile path = do
48− source <- readFile path
49− case iParse docs source of
50− Right json -> do
51− putStrLn $ "Documenting " ++ path
52− let docPath = "docs" </> replaceExtension path ".json"
53− createDirectoryIfMissing True (dropFileName docPath)
54− BS.writeFile docPath (encodePretty' config json)
55− Left err -> do
56− hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err
57− exitFailure
58−
59−docs :: IParser Value
60−docs = do
61− (name, exports, structure) <- moduleDocs
62− things <- document
63− return $ documentToJson name exports structure things
64−
65−docComment :: IParser String
66−docComment = do
67− try (string "{-|")
68− contents <- closeComment
69− let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
70− return $ dropWhile (==' ') (reverse reversed)
71−
72−moduleDocs = do
73− optional freshLine
74− (names,exports) <- moduleDef
75− manyTill (string " " <|> newline <?> "more whitespace")
76− (lookAhead (string "{-|") <?> "module documentation comment")
77− structure <- docComment
78− return (List.intercalate "." names, exports, structure)
79−
80−document :: IParser [(String, D.ParseDeclaration, String)]
81−document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
82−
83−docThing :: IParser (String, D.ParseDeclaration, String)
84−docThing = uncommentable <|> commented <|> uncommented ""
85− where
86− uncommentable = do
87− ifx <- infixDecl
88− return ("", ifx, "")
89−
90− commented = do
91− comment <- docComment
92− freshLine
93− uncommented comment
94−
95− uncommented comment = do
96− (src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]
97− return (comment, def, src)
98−
99−
100−documentToJson name exports structure things =
101− object $ [ "name" .= name
102− , "document" .= structure
103− , "values" .= toList values
104− , "aliases" .= toList aliases
105− , "datatypes" .= toList adts
106− ]
107− where
108− (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things
109−
110− toList dict = map object . Map.elems $ filterPublics dict
111−
112− exportMap = Map.fromList (zip exports exports)
113− filterPublics dict =
114− case Map.null exportMap of
115− True -> dict
116− False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict
117−
118−collect infixes types aliases adts things =
119− case things of
120− [] -> (Map.union customOps nonCustomOps, aliases, adts)
121− where
122− nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
123− addDefaultInfix name pairs
124− | all isSymbol name = addInfix (D.L, 9 :: Int) pairs
125− | otherwise = pairs
126−
127− customOps = Map.intersectionWith addInfix infixes types
128− addInfix (assoc,prec) pairs =
129− [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs
130−
131− (comment, decl, source) : rest ->
132− case decl of
133− D.Fixity assoc prec name ->
134− collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
135− D.Definition (E.TypeAnnotation name tipe) ->
136− collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
137− D.TypeAlias name vars tipe derivations ->
138− let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]
139− in collect infixes types (insert name fields aliases) adts rest
140− D.Datatype name vars ctors derivations ->
141− let tipe = Data name (map Var vars)
142− fields = ["typeVariables" .= vars
143− , "constructors" .= map (ctorToJson tipe) ctors
144− , "deriving" .= derivations ]
145− in collect infixes types aliases (insert name fields adts) rest
146− where
147− insert name fields dict = Map.insert name (obj name fields) dict
148− obj name fields =
149− [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
150−
151−instance ToJSON Type where
152− toJSON tipe =
153− case tipe of
154− Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
155− Var x -> toJSON x
156− Data name ts -> toJSON (toJSON name : map toJSON ts)
157− Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
158− where fields' = case ext of
159− Nothing -> fields
160− Just x -> ("_", Var x) : fields
161−
162−ctorToJson tipe (ctor, tipes) =
163− object [ "name" .= ctor
164− , "type" .= foldr Lambda tipe tipes ]
165−
166−instance ToJSON D.Derivation where
167− toJSON = toJSON . show
compiler/Dummy.cabaldeleted−170
@@ -1,170 +0,0 @@
1−-- This is a dummy .cabal file that makes it possible to build the
2−-- compiler with GHCi from within emacs. Do not actually use this
3−-- file to install things.
4−
5−Name: Elm
6−Version: 0.8.0.3
7−Synopsis: The Elm language module.
8−Description: Elm aims to make client-side web-development more pleasant.
9− It is a statically/strongly typed, functional reactive
10− language to HTML, CSS, and JS. This package provides a
11− library for Elm compilation in Haskell and a compiler
12− executable.
13−
14−Homepage: http://elm-lang.org
15−
16−License: BSD3
17−License-file: LICENSE
18−
19−Author: Evan Czaplicki
20−Maintainer: info@elm-lang.org
21−Copyright: Copyright: (c) 2011-2012 Evan Czaplicki
22−
23−Category: Compiler, Language
24−
25−Build-type: Custom
26−
27−Extra-source-files: changelog.txt
28−Data-dir: dist/data
29−Data-files: elm-runtime.js docs.json
30−Cabal-version: >=1.8
31−
32−source-repository head
33− type: git
34− location: git://github.com/evancz/Elm.git
35−
36−Library
37− exposed-modules: Language.Elm,
38− Language.Elm.Quasi
39− Hs-Source-Dirs: compiler
40− other-modules: Unique,
41− SourceSyntax.Helpers,
42− SourceSyntax.Location,
43− SourceSyntax.Literal,
44− SourceSyntax.Pattern,
45− SourceSyntax.Expression,
46− SourceSyntax.Declaration,
47− SourceSyntax.Module,
48− Generate.JavaScript,
49− Generate.Noscript,
50− Generate.Html,
51− Generate.Cases,
52− Transform.Substitute,
53− Transform.Optimize,
54− Metadata.Libraries,
55− Metadata.LoadLibraries,
56− Initialize,
57− Parse.Binop,
58− Parse.Expression,
59− Parse.Foreign,
60− Parse.Helpers,
61− Parse.Module,
62− Parse.Parser,
63− Parse.Pattern,
64− Parse.Type,
65− Types.Alias,
66− Types.Types,
67− Types.Constrain,
68− Types.Hints,
69− Types.Solver,
70− Types.Substitutions,
71− Types.Unify,
72− Paths_Elm
73−
74− Build-depends: base >=4.2 && <5,
75− containers >= 0.3,
76− transformers >= 0.2,
77− mtl >= 2,
78− deepseq,
79− parsec >= 3.1.1,
80− blaze-html == 0.5.* || == 0.6.*,
81− blaze-markup == 0.5.1.*,
82− text,
83− shakespeare >= 1,
84− template-haskell,
85− pandoc >= 1.10,
86− bytestring,
87− uniplate,
88− hjsmin,
89− indents,
90− filepath,
91− json,
92− directory
93−
94−Executable elm
95− Main-is: Compiler.hs
96− Hs-Source-Dirs: compiler
97− other-modules: Unique,
98− SourceSyntax.Helpers,
99− SourceSyntax.Location,
100− SourceSyntax.Literal,
101− SourceSyntax.Pattern,
102− SourceSyntax.Expression,
103− SourceSyntax.Declaration,
104− SourceSyntax.Module,
105− Generate.JavaScript,
106− Generate.Noscript,
107− Generate.Html,
108− Generate.Cases,
109− Transform.Substitute,
110− Transform.Optimize,
111− Metadata.Libraries,
112− Metadata.LoadLibraries,
113− Initialize,
114− Parse.Binop,
115− Parse.Expression,
116− Parse.Foreign,
117− Parse.Helpers,
118− Parse.Module,
119− Parse.Parser,
120− Parse.Pattern,
121− Parse.Type,
122− Types.Alias,
123− Types.Types,
124− Types.Constrain,
125− Types.Hints,
126− Types.Solver,
127− Types.Substitutions,
128− Types.Unify,
129− Paths_Elm
130−
131− Build-depends: base >=4.2 && <5,
132− containers >= 0.3,
133− transformers >= 0.2,
134− mtl >= 2,
135− deepseq,
136− parsec >= 3.1.1,
137− blaze-html == 0.5.* || == 0.6.*,
138− blaze-markup == 0.5.1.*,
139− cmdargs,
140− pandoc >= 1.10,
141− bytestring,
142− uniplate,
143− hjsmin,
144− indents,
145− filepath,
146− json,
147− directory
148−
149−Executable elm-doc
150− Main-is: Docs.hs
151− Hs-Source-Dirs: compiler
152− other-modules: SourceSyntax.Helpers,
153− SourceSyntax.Location,
154− SourceSyntax.Literal,
155− SourceSyntax.Pattern,
156− SourceSyntax.Expression,
157− SourceSyntax.Declaration,
158− SourceSyntax.Module,
159− Parse.Helpers,
160− Parse.Module
161−
162− Build-depends: base >=4.2 && <5,
163− containers >= 0.3,
164− transformers >= 0.2,
165− mtl >= 2,
166− parsec >= 3.1.1,
167− pandoc >= 1.10,
168− cmdargs,
169− filepath,
170− indents
compiler/Elm/Internal/Dependencies.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Internal.Dependencies where
3−
4−import Control.Applicative
5−import Control.Monad.Error
6−import qualified Control.Exception as E
7−import Data.Aeson
8−import qualified Data.List as List
9−import qualified Data.ByteString.Lazy as BS
10−import qualified Data.HashMap.Strict as Map
11−import qualified Elm.Internal.Name as N
12−import qualified Elm.Internal.Version as V
13−import qualified Elm.Internal.Paths as Path
14−
15−data Deps = Deps
16− { name :: N.Name
17− , version :: V.Version
18− , summary :: String
19− , description :: String
20− , license :: String
21− , repo :: String
22− , exposed :: [String]
23− , elmVersion :: V.Version
24− , dependencies :: [(N.Name,V.Version)]
25− } deriving Show
26−
27−data MiniDeps = Mini [(N.Name,V.Version)]
28−
29−instance FromJSON MiniDeps where
30− parseJSON (Object obj) = Mini <$> getDependencies obj
31− parseJSON _ = mzero
32−
33−instance FromJSON Deps where
34− parseJSON (Object obj) =
35− do version <- get obj "version" "your projects version number"
36−
37− summary <- get obj "summary" "a short summary of your project"
38− when (length summary >= 80) $
39− fail "'summary' must be less than 80 characters"
40−
41− desc <- get obj "description" "an extended description of your project \
42− \and how to get started with it."
43− license <- get obj "license" "license information (BSD3 is recommended)"
44−
45− repo <- get obj "repository" "a link to the project's GitHub repo"
46− name <- case repoToName repo of
47− Left err -> fail err
48− Right nm -> return nm
49−
50− exposed <- get obj "exposed-modules" "a list of modules exposed to users"
51−
52− elmVersion <- get obj "elm-version" "the version of the Elm compiler you are using"
53−
54− deps <- getDependencies obj
55−
56− return $ Deps name version summary desc license repo exposed elmVersion deps
57−
58− parseJSON _ = mzero
59−
60−getDependencies obj =
61− toDeps =<< get obj "dependencies" "a listing of your project's dependencies"
62− where
63− toDeps deps =
64− forM (Map.toList deps) $ \(f,v) ->
65− case (N.fromString f, V.fromString v) of
66− (Just name, Just version) -> return (name,version)
67− (Nothing, _) -> fail $ N.errorMsg f
68− (_, Nothing) -> fail $ "invalid version number " ++ v
69−
70−
71−get obj field desc =
72− do maybe <- obj .:? field
73− case maybe of
74− Just value -> return value
75− Nothing -> fail $ "Missing field " ++ show field ++ ", " ++ desc ++ ".\n" ++
76− " Check out an example " ++ Path.dependencyFile ++ " file here:" ++
77− " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"
78−
79−repoToName :: String -> Either String N.Name
80−repoToName repo
81− | not (end `List.isSuffixOf` repo) = Left msg
82− | otherwise =
83− do path <- getPath
84− let raw = take (length path - length end) path
85− case N.fromString raw of
86− Nothing -> Left msg
87− Just name -> Right name
88− where
89− getPath | http `List.isPrefixOf` repo = Right $ drop (length http ) repo
90− | https `List.isPrefixOf` repo = Right $ drop (length https) repo
91− | otherwise = Left msg
92− http = "http://github.com/"
93− https = "https://github.com/"
94− end = ".git"
95− msg = "the 'repository' field must point to a GitHub project for now, something\n\
96− \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
97− \and PROJECT is the repo you want to upload."
98−
99−withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a
100−withDeps handle path =
101− do json <- readPath
102− case eitherDecode json of
103− Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
104− Right ds -> return (handle ds)
105− where
106− readPath :: ErrorT String IO BS.ByteString
107− readPath = do
108− result <- liftIO $ E.catch (Right <$> BS.readFile path)
109− (\err -> return $ Left (err :: IOError))
110− case result of
111− Right bytes -> return bytes
112− Left _ -> throwError $
113− "could not find file " ++ path ++
114− "\n You may need to create a dependency file for your project."
115−
116−depsAt :: FilePath -> ErrorT String IO Deps
117−depsAt = withDeps id
compiler/Elm/Internal/Documentation.hsdeleted−41
@@ -1,41 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Elm.Internal.Documentation where
3−
4−import Control.Applicative ((<$>),(<*>))
5−import Control.Monad
6−import Data.Aeson
7−
8−data Document = Doc
9− { moduleName :: String
10− , structure :: String
11− , entries :: [Entry]
12− } deriving (Show)
13−
14−data Entry = Entry
15− { name :: String
16− , comment :: String
17− , raw :: String
18− , assocPrec :: Maybe (String,Int)
19− } deriving (Show)
20−
21−instance FromJSON Document where
22− parseJSON (Object v) =
23− Doc <$> v .: "name"
24− <*> v .: "document"
25− <*> (concat <$> sequence [ v .: "aliases", v .: "datatypes", v .: "values" ])
26−
27− parseJSON _ = fail "Conversion to Document was expecting an object"
28−
29−instance FromJSON Entry where
30− parseJSON (Object v) =
31− Entry <$> v .: "name"
32− <*> v .: "comment"
33− <*> v .: "raw"
34− <*> (liftM2 (,) <$> v .:? "associativity"
35− <*> v .:? "precedence")
36−
37− parseJSON _ = fail "Conversion to Entry was expecting an object"
38−
39−data Content = Markdown String | Value String
40− deriving Show
41−
compiler/Elm/Internal/Name.hsdeleted−51
@@ -1,51 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Elm.Internal.Name where
3−
4−import Control.Applicative
5−import Control.Monad.Error
6−import Data.Aeson
7−import Data.Binary
8−import qualified Data.Text as T
9−import qualified Data.Maybe as Maybe
10−import Data.Typeable
11−
12−data Name = Name { user :: String, project :: String }
13− deriving (Typeable,Eq)
14−
15−instance Binary Name where
16− get = Name <$> get <*> get
17− put (Name user project) =
18− put user >> put project
19−
20−instance Show Name where
21− show name = user name ++ "/" ++ project name
22−
23−toFilePath :: Name -> FilePath
24−toFilePath name = user name ++ "-" ++ project name
25−
26−fromString :: String -> Maybe Name
27−fromString string =
28− case break (=='/') string of
29− ( user@(_:_), '/' : project@(_:_) )
30− | all (/='/') project -> Just (Name user project)
31− _ -> Nothing
32−
33−fromString' :: String -> ErrorT String IO Name
34−fromString' string =
35− Maybe.maybe (throwError $ errorMsg string) return (fromString string)
36−
37−instance FromJSON Name where
38− parseJSON (String text) =
39− let string = T.unpack text in
40− Maybe.maybe (fail $ errorMsg string) return (fromString string)
41−
42− parseJSON _ = fail "Project name must be a string."
43−
44−instance ToJSON Name where
45− toJSON name = toJSON (show name)
46−
47−errorMsg string =
48− unlines
49− [ "Dependency file has an invalid name: " ++ string
50− , "Must have format user/project and match a public github project."
51− ]
compiler/Elm/Internal/Paths.hsdeleted−23
@@ -1,23 +0,0 @@
1−module Elm.Internal.Paths where
2−
3−import System.IO.Unsafe
4−import qualified Paths_Elm as This
5−
6−-- |Name of directory for all of a project's dependencies.
7−dependencyDirectory :: FilePath
8−dependencyDirectory = "elm_dependencies"
9−
10−-- |Name of the dependency file, specifying dependencies and
11−-- other metadata for building and sharing projects.
12−dependencyFile :: FilePath
13−dependencyFile = "elm_dependencies.json"
14−
15−{-# NOINLINE runtime #-}
16−-- |The absolute path to Elm's runtime system.
17−runtime :: FilePath
18−runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
19−
20−{-# NOINLINE docs #-}
21−-- |The absolute path to Elm's core library documentation.
22−docs :: FilePath
23−docs = unsafePerformIO $ This.getDataFileName "docs.json"
compiler/Elm/Internal/Utils.hsdeleted−28
@@ -1,28 +0,0 @@
1−{- | This module exports functions for compiling Elm to JS.
2−-}
3−module Elm.Internal.Utils (compile, moduleName) where
4−
5−import qualified Data.List as List
6−import qualified Generate.JavaScript as JS
7−import qualified Build.Source as Source
8−import qualified Parse.Module as Parser
9−import qualified SourceSyntax.Module as M
10−import qualified Text.PrettyPrint as P
11−import qualified Metadata.Prelude as Prelude
12−import System.IO.Unsafe
13−
14−-- |This function compiles Elm code to JavaScript. It will return either
15−-- an error message or the compiled JS code.
16−compile :: String -> Either String String
17−compile source =
18− case Source.build False interfaces source of
19− Left docs -> Left . unlines . List.intersperse "" $ map P.render docs
20− Right modul -> Right $ JS.generate modul
21−
22−{-# NOINLINE interfaces #-}
23−interfaces :: M.Interfaces
24−interfaces = unsafePerformIO $ Prelude.interfaces False
25−
26−-- |This function extracts the module name of a given source program.
27−moduleName :: String -> Maybe String
28−moduleName = Parser.getModuleName
compiler/Elm/Internal/Version.hsdeleted−73
@@ -1,73 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
2−module Elm.Internal.Version where
3−
4−import Control.Applicative
5−import Data.Aeson
6−import Data.Binary
7−import Data.Char (isDigit)
8−import qualified Data.List as List
9−import Data.Typeable
10−import qualified Data.Text as T
11−import qualified Paths_Elm as This
12−import qualified Data.Version as Version
13−
14−elmVersion :: Version
15−elmVersion = V ns ""
16− where (Version.Version ns _) = This.version
17−
18−-- Data representation
19−
20−data Version = V [Int] String
21− deriving (Typeable,Eq)
22−
23−instance Ord Version where
24− compare (V ns tag) (V ns' tag') =
25− case compare ns ns' of
26− EQ -> compare tag' tag -- reverse comparison to favor ""
27− cmp -> cmp
28−
29−instance Show Version where
30− show (V ns tag) =
31− List.intercalate "." (map show ns) ++ if null tag then "" else "-" ++ tag
32−
33−instance Binary Version where
34− get = V <$> get <*> get
35− put (V ns tag) = do put ns
36− put tag
37−
38−tagless :: Version -> Bool
39−tagless (V _ tag) = null tag
40−
41−fromString :: String -> Maybe Version
42−fromString version = V <$> splitNumbers possibleNumbers <*> tag
43− where
44− (possibleNumbers, possibleTag) = break (=='-') version
45−
46− tag = case possibleTag of
47− "" -> Just ""
48− '-':rest -> Just rest
49− _ -> Nothing
50−
51− splitNumbers :: String -> Maybe [Int]
52− splitNumbers ns =
53− case span isDigit ns of
54− ("", _) -> Nothing
55− (number, []) -> Just [read number]
56− (number, '.':rest) -> (read number :) <$> splitNumbers rest
57− _ -> Nothing
58−
59−instance FromJSON Version where
60− parseJSON (String text) =
61− let string = T.unpack text in
62− case fromString string of
63− Just v -> return v
64− Nothing -> fail $ unlines
65− [ "Dependency file has an invalid version number: " ++ string
66− , "Must have format 0.1.2 or 0.1.2-tag"
67− ]
68−
69− parseJSON _ = fail "Version number must be stored as a string."
70−
71−instance ToJSON Version where
72− toJSON version = toJSON (show version)
73−
compiler/Generate/Cases.hsdeleted−129
@@ -1,129 +0,0 @@
1−module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
2−
3−import Control.Applicative ((<$>))
4−import Control.Arrow (first)
5−import Control.Monad.State
6−import Data.List (groupBy,sortBy)
7−import Data.Maybe (fromMaybe)
8−
9−import SourceSyntax.Location
10−import SourceSyntax.Literal
11−import SourceSyntax.Pattern
12−import SourceSyntax.Expression
13−import Transform.Substitute
14−
15−
16−toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
17−toMatch patterns = do
18− v <- newVar
19− (,) v <$> match [v] (map (first (:[])) patterns) Fail
20−
21−newVar :: State Int String
22−newVar = do n <- get
23− modify (+1)
24− return $ "_v" ++ show n
25−
26−data Match
27− = Match String [Clause] Match
28− | Break
29− | Fail
30− | Other LExpr
31− | Seq [Match]
32− deriving Show
33−
34−data Clause =
35− Clause (Either String Literal) [String] Match
36− deriving Show
37−
38−matchSubst :: [(String,String)] -> Match -> Match
39−matchSubst _ Break = Break
40−matchSubst _ Fail = Fail
41−matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
42−matchSubst pairs (Other (L s e)) =
43− Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
44−matchSubst pairs (Match n cs m) =
45− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
46− where varSubst v = fromMaybe v (lookup v pairs)
47− clauseSubst (Clause c vs m) =
48− Clause c (map varSubst vs) (matchSubst pairs m)
49−
50−isCon (p:_, _) =
51− case p of
52− PData _ _ -> True
53− PLiteral _ -> True
54− _ -> False
55−
56−isVar p = not (isCon p)
57−
58−match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
59−match [] [] def = return def
60−match [] [([],e)] Fail = return $ Other e
61−match [] [([],e)] Break = return $ Other e
62−match [] cs def = return $ Seq (map (Other . snd) cs ++ [def])
63−match vs@(v:_) cs def
64− | all isVar cs' = matchVar vs cs' def
65− | all isCon cs' = matchCon vs cs' def
66− | otherwise = matchMix vs cs' def
67− where
68− cs' = map (dealias v) cs
69−
70−dealias v c@(p:ps, L s e) =
71− case p of
72− PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
73− _ -> c
74−
75−matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
76−matchVar (v:vs) cs def = match vs (map subVar cs) def
77− where
78− subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)
79− where
80− subOnePattern pattern e =
81− case pattern of
82− PVar x -> subst x (Var v) e
83− PAnything -> e
84− PRecord fs ->
85− foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
86−
87−matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
88−matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
89− where
90− css = groupBy eq (sortBy cmp cs)
91−
92− cmp (p1:_,_) (p2:_,_) =
93− case (p1,p2) of
94− (PData n1 _, PData n2 _) -> compare n1 n2
95− _ -> compare p1 p2
96−
97− eq (p1:_,_) (p2:_,_) =
98− case (p1,p2) of
99− (PData n1 _, PData n2 _) -> n1 == n2
100− _ -> p1 == p2
101−
102− toClause cs =
103− case head cs of
104− (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
105− (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106−
107−matchClause :: Either String Literal
108− -> [String]
109− -> [([Pattern],LExpr)]
110− -> Match
111− -> State Int Clause
112−matchClause c (_:vs) cs def =
113− do vs' <- getVars
114− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
115− where
116−
117− flatten (p:ps, e) =
118− case p of
119− PData _ ps' -> (ps' ++ ps, e)
120− PLiteral _ -> (ps, e)
121−
122− getVars =
123− case head cs of
124− (PData _ ps : _, _) -> forM ps (const newVar)
125− (PLiteral _ : _, _) -> return []
126−
127−matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
128−matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
129− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
compiler/Generate/Html.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Generate.Html (generate, JSSource(..)) where
3−
4−import Text.Blaze (preEscapedToMarkup)
5−import qualified Text.Blaze.Html5 as H
6−import Text.Blaze.Html5 ((!))
7−import qualified Text.Blaze.Html5.Attributes as A
8−import qualified Data.ByteString.Lazy.Char8 as BS
9−
10−data JSSource = Link String | Source BS.ByteString
11−
12−makeScript :: JSSource -> H.Html
13−makeScript source =
14− case source of
15− Link src -> H.script ! A.type_ "text/javascript" ! A.src (H.toValue src) $ ""
16− Source src ->
17− H.script ! A.type_ "text/javascript" $
18− preEscapedToMarkup $ BS.unpack src
19−
20−generate :: FilePath -> String -> [JSSource] -> String -> String -> H.Html
21−generate libLoc title scripts moduleName noscript =
22− H.docTypeHtml $ do
23− H.head $ do
24− H.meta ! A.charset "UTF-8"
25− H.title . H.toHtml $ title
26− makeScript (Link libLoc)
27− mapM_ makeScript scripts
28− H.body $ do
29− H.script ! A.type_ "text/javascript" $
30− preEscapedToMarkup ("Elm.fullscreen(Elm." ++ moduleName ++ ")")
31− H.noscript $ preEscapedToMarkup noscript
compiler/Generate/JavaScript.hsdeleted−383
@@ -1,383 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Generate.JavaScript (generate) where
3−
4−import Control.Arrow (first,(***))
5−import Control.Applicative ((<$>),(<*>))
6−import Control.Monad.State
7−import qualified Data.List as List
8−import qualified Data.Map as Map
9−import qualified Data.Set as Set
10−
11−import Generate.JavaScript.Helpers
12−import qualified Generate.Cases as Case
13−import qualified Generate.JavaScript.Ports as Port
14−import qualified Generate.Markdown as MD
15−import qualified SourceSyntax.Helpers as Help
16−import SourceSyntax.Literal
17−import SourceSyntax.Pattern as Pattern
18−import SourceSyntax.Location
19−import SourceSyntax.Expression
20−import SourceSyntax.Module
21−import Language.ECMAScript3.Syntax
22−import Language.ECMAScript3.PrettyPrint
23−import qualified Transform.SafeNames as MakeSafe
24−
25−varDecl :: String -> Expression () -> VarDecl ()
26−varDecl x expr =
27− VarDecl () (var x) (Just expr)
28−
29−include :: String -> String -> VarDecl ()
30−include alias moduleName =
31− varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
32−
33−internalImports :: String -> Statement ()
34−internalImports name =
35− VarDeclStmt ()
36− [ varDecl "_N" (obj "Elm.Native")
37− , include "_U" "_N.Utils"
38− , include "_L" "_N.List"
39− , include "_E" "_N.Error"
40− , include "_J" "_N.JavaScript"
41− , varDecl "$moduleName" (string name)
42− ]
43−
44−literal :: Literal -> Expression ()
45−literal lit =
46− case lit of
47− Chr c -> obj "_U.chr" <| string [c]
48− Str s -> string s
49− IntNum n -> IntLit () n
50− FloatNum n -> NumLit () n
51− Boolean b -> BoolLit () b
52−
53−expression :: LExpr -> State Int (Expression ())
54−expression (L span expr) =
55− case expr of
56− Var x -> return $ ref x
57− Literal lit -> return $ literal lit
58−
59− Range lo hi ->
60− do lo' <- expression lo
61− hi' <- expression hi
62− return $ obj "_L.range" `call` [lo',hi']
63−
64− Access e x ->
65− do e' <- expression e
66− return $ DotRef () e' (var x)
67−
68− Remove e x ->
69− do e' <- expression e
70− return $ obj "_U.remove" `call` [string x, e']
71−
72− Insert e x v ->
73− do v' <- expression v
74− e' <- expression e
75− return $ obj "_U.insert" `call` [string x, v', e']
76−
77− Modify e fs ->
78− do e' <- expression e
79− fs' <- forM fs $ \(f,v) -> do
80− v' <- expression v
81− return $ ArrayLit () [string f, v']
82− return $ obj "_U.replace" `call` [ArrayLit () fs', e']
83−
84− Record fields ->
85− do fields' <- forM fields $ \(f,e) -> do
86− (,) f <$> expression e
87− let fieldMap = List.foldl' combine Map.empty fields'
88− return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
89− where
90− combine r (k,v) = Map.insertWith (++) k [v] r
91− prop = PropId () . var
92− hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
93− Map.toList . Map.filter (not . null) $ Map.map tail fs
94− visible fs = map (first prop) . Map.toList $ Map.map head fs
95−
96− Binop op e1 e2 -> binop span op e1 e2
97−
98− Lambda p e@(L s _) ->
99− do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
100− body' <- expression body
101− return $ case length args < 2 || length args > 9 of
102− True -> foldr (==>) body' (map (:[]) args)
103− False -> ref ("F" ++ show (length args)) <| (args ==> body')
104− where
105− depattern (args, body) pattern =
106− case pattern of
107− PVar x -> return (args ++ [x], body)
108− _ -> do arg <- Case.newVar
109− return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
110−
111− (patterns, innerBody) = collect [p] e
112−
113− collect patterns lexpr@(L _ expr) =
114− case expr of
115− Lambda p e -> collect (p:patterns) e
116− _ -> (patterns, lexpr)
117−
118− App e1 e2 ->
119− do func' <- expression func
120− args' <- mapM expression args
121− return $ case args' of
122− [arg] -> func' <| arg
123− _ | length args' <= 9 -> ref aN `call` (func':args')
124− | otherwise -> foldl1 (<|) (func':args')
125− where
126− aN = "A" ++ show (length args)
127− (func, args) = getArgs e1 [e2]
128− getArgs func args =
129− case func of
130− (L _ (App f arg)) -> getArgs f (arg : args)
131− _ -> (func, args)
132−
133− Let defs e ->
134− do let (defs',e') = flattenLets defs e
135− stmts <- concat <$> mapM definition defs'
136− exp <- expression e'
137− return $ function [] (stmts ++ [ ret exp ]) `call` []
138−
139− MultiIf branches ->
140− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141− return $ case last branches of
142− (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
143− (L _ (Literal (Boolean True)), _) -> safeIfs branches'
144− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
145− where
146− safeIfs branches = ifs (init branches) (snd (last branches))
147− ifs branches finally = foldr iff finally branches
148− iff (if', then') else' = CondExpr () if' then' else'
149−
150− Case e cases ->
151− do (tempVar,initialMatch) <- Case.toMatch cases
152− (revisedMatch, stmt) <-
153− case e of
154− L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
155− _ -> do e' <- expression e
156− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
157− match' <- match span revisedMatch
158− return (function [] (stmt ++ match') `call` [])
159−
160− ExplicitList es ->
161− do es' <- mapM expression es
162− return $ obj "_J.toList" <| ArrayLit () es'
163−
164− Data name es ->
165− do es' <- mapM expression es
166− return $ ObjectLit () (ctor : fields es')
167− where
168− ctor = (prop "ctor", string name)
169− fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
170−
171− Markdown uid doc es ->
172− do es' <- mapM expression es
173− return $ obj "Text.markdown" `call` (string md : string uid : es')
174− where
175− pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
176− md = pad ++ MD.toHtml doc ++ pad
177−
178− PortIn name tipe ->
179− return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
180−
181− PortOut name tipe value ->
182− do value' <- expression value
183− return $ obj "Native.Ports.portOut" `call`
184− [ string name, Port.outgoing tipe, value' ]
185−
186−definition :: Def -> State Int [Statement ()]
187−definition (Definition pattern expr@(L span _) _) = do
188− expr' <- expression expr
189− let assign x = varDecl x expr'
190− case pattern of
191− PVar x
192− | Help.isOp x ->
193− let op = LBracket () (ref "_op") (string x) in
194− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
195− | otherwise ->
196− return [ VarDeclStmt () [ assign x ] ]
197−
198− PRecord fields ->
199− let setField f = varDecl f (dotSep ["$",f]) in
200− return [ VarDeclStmt () (assign "$" : map setField fields) ]
201−
202− PData name patterns | vars /= Nothing ->
203− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
204− where
205− vars = getVars patterns
206− getVars patterns =
207− case patterns of
208− PVar x : rest -> (x:) `fmap` getVars rest
209− [] -> Just []
210− _ -> Nothing
211−
212− decl x n = varDecl x (dotSep ["$","_" ++ show n])
213− setup vars
214− | Help.isTuple name = assign "$" : vars
215− | otherwise = assign "$raw" : safeAssign : vars
216−
217− safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
218− if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
219− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
220−
221− _ ->
222− do defs' <- concat <$> mapM toDef vars
223− return (VarDeclStmt () [assign "$"] : defs')
224− where
225− vars = Set.toList $ Pattern.boundVars pattern
226− mkVar = L span . Var
227− toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
228− in definition $ Definition (PVar y) expr Nothing
229−
230−match :: SrcSpan -> Case.Match -> State Int [Statement ()]
231−match span mtch =
232− case mtch of
233− Case.Match name clauses mtch' ->
234− do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
235− mtch'' <- match span mtch'
236− return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
237− where
238− isLiteral p = case p of
239− Case.Clause (Right _) _ _ -> True
240− _ -> False
241− access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
242− format isChars e
243− | or isChars = InfixExpr () OpAdd e (string "")
244− | otherwise = e
245−
246− Case.Fail ->
247− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
248−
249− Case.Break -> return [BreakStmt () Nothing]
250− Case.Other e ->
251− do e' <- expression e
252− return [ ret e' ]
253− Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
254− where
255− dropEnd acc [] = acc
256− dropEnd acc (m:ms) =
257− case m of
258− Case.Other _ -> acc ++ [m]
259− _ -> dropEnd (acc ++ [m]) ms
260−
261−clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
262−clause span variable (Case.Clause value vars mtch) =
263− (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
264− where
265− vars' = map (\n -> variable ++ "._" ++ show n) [0..]
266− (isChar, pattern) =
267− case value of
268− Right (Chr c) -> (True, string [c])
269− _ -> (,) False $ case value of
270− Right (Boolean b) -> BoolLit () b
271− Right lit -> literal lit
272− Left name -> string $ case List.elemIndices '.' name of
273− [] -> name
274− is -> drop (last is + 1) name
275−
276−flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
277−flattenLets defs lexpr@(L _ expr) =
278− case expr of
279− Let ds body -> flattenLets (defs ++ ds) body
280− _ -> (defs, lexpr)
281−
282−generate :: MetadataModule -> String
283−generate unsafeModule =
284− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
285− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
286− where
287− modul = MakeSafe.metadataModule unsafeModule
288− thisModule = dotSep ("_elm" : names modul ++ ["values"])
289− programStmts =
290− concat
291− [ setup (Just "_elm") (names modul ++ ["values"])
292− , [ IfSingleStmt () thisModule (ret thisModule) ]
293− , [ internalImports (List.intercalate "." (names modul)) ]
294− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
295− , [ assign ["_op"] (ObjectLit () []) ]
296− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
297− , [ jsExports ]
298− , [ ret thisModule ]
299− ]
300−
301− jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
302− where
303− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
304− entry x = (PropId () (var x), ref x)
305−
306− assign path expr =
307− case path of
308− [x] -> VarDeclStmt () [ varDecl x expr ]
309− _ -> ExprStmt () $
310− AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
311−
312− jsImport modul = setup Nothing path ++ [ include ]
313− where
314− path = split modul
315− include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
316−
317− setup namespace path = map create paths
318− where
319− create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
320− paths = case namespace of
321− Nothing -> tail . init $ List.inits path
322− Just nmspc -> drop 2 . init . List.inits $ nmspc : path
323−
324−binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
325−binop span op e1 e2 =
326− case op of
327− "Basics.." ->
328− do es <- mapM expression (e1 : collect [] e2)
329− return $ ["$"] ==> foldr (<|) (ref "$") es
330− "Basics.<|" ->
331− do e2' <- expression e2
332− es <- mapM expression (collect [] e1)
333− return $ foldr (<|) e2' es
334− "List.++" ->
335− do e1' <- expression e1
336− e2' <- expression e2
337− return $ obj "_L.append" `call` [e1', e2']
338− "::" -> expression (L span (Data "::" [e1,e2]))
339− _ ->
340− do e1' <- expression e1
341− e2' <- expression e2
342− return $ case Map.lookup op opDict of
343− Just f -> f e1' e2'
344− Nothing -> ref "A2" `call` [ func, e1', e2' ]
345− where
346− collect es e =
347− case e of
348− L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
349− _ -> es ++ [e]
350−
351− func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
352− | otherwise = dotSep parts
353− where
354− parts = split op
355− operator = last parts
356−
357− opDict = Map.fromList (infixOps ++ specialOps)
358−
359− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
360− infixOp str op = specialOp str (InfixExpr () op)
361−
362− infixOps = concat
363− [ infixOp "+" OpAdd
364− , infixOp "-" OpSub
365− , infixOp "*" OpMul
366− , infixOp "/" OpDiv
367− , infixOp "&&" OpLAnd
368− , infixOp "||" OpLOr
369− ]
370−
371− specialOps = concat
372− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
373− , specialOp "|>" $ flip (<|)
374− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
375− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
376− , specialOp "<" $ cmp OpLT 0
377− , specialOp ">" $ cmp OpGT 0
378− , specialOp "<=" $ cmp OpLT 1
379− , specialOp ">=" $ cmp OpGT (-1)
380− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
381− ]
382−
383− cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)
compiler/Generate/JavaScript/Helpers.hsdeleted−37
@@ -1,37 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Generate.JavaScript.Helpers where
3−
4−import qualified SourceSyntax.Helpers as Help
5−import Language.ECMAScript3.Syntax
6−
7−split :: String -> [String]
8−split = go []
9− where
10− go vars str =
11− case break (=='.') str of
12− (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
13− | otherwise -> go (vars ++ [x]) rest
14− (x,[]) -> vars ++ [x]
15−
16−var name = Id () name
17−ref name = VarRef () (var name)
18−prop name = PropId () (var name)
19−f <| x = CallExpr () f [x]
20−ret e = ReturnStmt () (Just e)
21−args ==> e = FuncExpr () Nothing (map var args) [ ret e ]
22−function args stmts = FuncExpr () Nothing (map var args) stmts
23−call = CallExpr ()
24−string = StringLit ()
25−
26−dotSep vars =
27− case vars of
28− x:xs -> foldl (DotRef ()) (ref x) (map var xs)
29− [] -> error "dotSep must be called on a non-empty list of variables"
30−
31−obj = dotSep . split
32−
33−equal a b = InfixExpr () OpStrictEq a b
34−instanceof tipe x =
35− InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))
36−typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)
37−member field x = InfixExpr () OpIn (string field) x
compiler/Generate/JavaScript/Ports.hsdeleted−130
@@ -1,130 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Generate.JavaScript.Ports (incoming, outgoing) where
3−
4−import Generate.JavaScript.Helpers
5−import qualified SourceSyntax.Helpers as Help
6−import SourceSyntax.Type as T
7−import Language.ECMAScript3.Syntax
8−
9−data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
10− deriving Show
11−
12−check :: Expression () -> JSType -> Expression () -> Expression ()
13−check x jsType continue =
14− CondExpr () (jsFold OpLOr checks x) continue throw
15− where
16− jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)
17− throw = obj "_E.raise" <| InfixExpr () OpAdd msg x
18− msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")
19− checks = case jsType of
20− JSNumber -> [typeof "number"]
21− JSBoolean -> [typeof "boolean"]
22− JSString -> [typeof "string", instanceof "String"]
23− JSArray -> [instanceof "Array"]
24− JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
25−
26−incoming :: Type -> Expression ()
27−incoming tipe =
28− case tipe of
29− Data "Signal.Signal" [t] ->
30− obj "Native.Ports.incomingSignal" <| incoming t
31− _ -> ["v"] ==> inc tipe (ref "v")
32−
33−inc :: Type -> Expression () -> Expression ()
34−inc tipe x =
35− case tipe of
36− Lambda _ _ -> error "functions should not be allowed through input ports"
37− Var _ -> error "type variables should not be allowed through input ports"
38− Data ctor []
39− | ctor == "Int" -> elm JSNumber
40− | ctor == "Float" -> elm JSNumber
41− | ctor == "Bool" -> elm JSBoolean
42− | ctor == "String" -> elm JSString
43− | ctor == "JavaScript.JSNumber" -> js JSNumber
44− | ctor == "JavaScript.JSBool" -> js JSBoolean
45− | ctor == "JavaScript.JSString" -> js JSString
46− where
47− elm checks = check x checks (obj ("_J.to" ++ ctor) <| x)
48− js checks = check x checks x
49−
50− Data ctor [t]
51− | ctor == "Maybe.Maybe" ->
52− CondExpr () (equal x (NullLit ()))
53− (obj "Maybe.Nothing")
54− (obj "Maybe.Just" <| inc t x)
55−
56− | ctor == "_List" ->
57− check x JSArray (obj "_J.toList" <| array)
58− where
59− array = DotRef () x (var "map") <| incoming t
60−
61− Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
62− where
63− tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
64− values = zipWith convert [0..] ts
65− convert n t = ( PropId () $ var ('_':show n)
66− , inc t (BracketRef () x (IntLit () n)))
67−
68− Data _ _ -> error "bad ADT got to port generation code"
69−
70− Record _ (Just _) -> error "bad record got to port generation code"
71−
72− Record fields Nothing -> check x (JSObject (map fst fields)) object
73− where
74− object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
75− keys = map convert fields
76− convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))
77−
78−outgoing tipe =
79− case tipe of
80− Data "Signal.Signal" [t] ->
81− obj "Native.Ports.outgoingSignal" <| outgoing t
82− _ -> ["v"] ==> out tipe (ref "v")
83−
84−out :: Type -> Expression () -> Expression ()
85−out tipe x =
86− case tipe of
87− Lambda _ _
88− | numArgs > 1 && numArgs < 10 ->
89− func (ref ('A':show numArgs) `call` (x:values))
90− | otherwise -> func (foldl (<|) x values)
91− where
92− ts = T.collectLambdas tipe
93− numArgs = length ts - 1
94− args = map (\n -> '_' : show n) [0..]
95− values = zipWith inc (init ts) (map ref args)
96− func body = function (take numArgs args)
97− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
98− , ret (out (last ts) (ref "_r"))
99− ]
100−
101− Var _ -> error "type variables should not be allowed through input ports"
102− Data ctor []
103− | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x
104− | ctor `elem` jsPrims -> x
105− where
106− jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]
107−
108− Data ctor [t]
109− | ctor == "Maybe.Maybe" ->
110− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
111− (NullLit ())
112− (DotRef () x (var "_0"))
113−
114− | ctor == "_List" ->
115− DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
116−
117− Data ctor ts | Help.isTuple ctor ->
118− ArrayLit () $ zipWith convert [0..] ts
119− where
120− convert n t = out t $ DotRef () x $ var ('_':show n)
121−
122− Data _ _ -> error "bad ADT got to port generation code"
123−
124− Record _ (Just _) -> error "bad record got to port generation code"
125−
126− Record fields Nothing ->
127− ObjectLit () keys
128− where
129− keys = map convert fields
130− convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))
compiler/Generate/Markdown.hsdeleted−39
@@ -1,39 +0,0 @@
1−module Generate.Markdown where
2−
3−import Text.Pandoc
4−import qualified Data.Set as Set
5−
6−toHtml :: String -> String
7−toHtml = writeHtmlString writeOptions . readMarkdown readOptions
8−
9−readOptions =
10− def { readerExtensions = elmExtensions
11− , readerApplyMacros = False
12− }
13−
14−writeOptions =
15− def { writerExtensions = elmExtensions
16− , writerHighlight = True
17− }
18−
19−elmExtensions :: Set.Set Extension
20−elmExtensions = Set.fromList
21− [ Ext_raw_html
22− , Ext_fenced_code_blocks
23− , Ext_fenced_code_attributes
24− , Ext_backtick_code_blocks
25− , Ext_inline_code_attributes
26− , Ext_markdown_in_html_blocks
27− , Ext_escaped_line_breaks
28− , Ext_fancy_lists
29− , Ext_startnum
30− , Ext_definition_lists
31− , Ext_example_lists
32− , Ext_all_symbols_escapable
33− , Ext_intraword_underscores
34− , Ext_blank_before_blockquote
35− , Ext_blank_before_header
36− , Ext_auto_identifiers
37− , Ext_header_attributes
38− , Ext_implicit_header_references
39− ]
compiler/Generate/Noscript.hsdeleted−68
@@ -1,68 +0,0 @@
1−module Generate.Noscript (noscript) where
2−
3−import Data.List (isInfixOf)
4−import qualified SourceSyntax.Declaration as D
5−import SourceSyntax.Expression
6−import SourceSyntax.Literal
7−import SourceSyntax.Location
8−import SourceSyntax.Module
9−import qualified Generate.Markdown as MD
10−
11−noscript :: Extract def => Module def -> String
12−noscript modul = concat (extract modul)
13−
14−class Extract a where
15− extract :: a -> [String]
16−
17−instance Extract def => Extract (Module def) where
18− extract (Module _ _ _ stmts) =
19− map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
20−
21−instance Extract def => Extract (D.Declaration' port def) where
22− extract (D.Definition d) = extract d
23− extract _ = []
24−
25−instance Extract Def where
26− extract (Definition _ e _) = extract e
27−
28−instance Extract e => Extract (Located e) where
29− extract (L _ e) = extract e
30−
31−instance Extract def => Extract (Expr' def) where
32− extract expr =
33− let f = extract in
34− case expr of
35− Literal (Str s) -> [s]
36− Binop op e1 e2 -> case (op, f e1, f e2) of
37− ("++", [s1], [s2]) -> [s1 ++ s2]
38− (_ , ss1 , ss2 ) -> ss1 ++ ss2
39− Lambda v e -> f e
40− App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src
41− | "image" `isInfixOf` func -> extractImage src
42− App (L _ (App (L _ (Var func)) src)) txt
43− | "link" `isInfixOf` func -> extractLink src txt
44− App (L _ (Var func)) e
45− | "header" `isInfixOf` func -> tag "h1" e
46− | "bold" `isInfixOf` func -> tag "b" e
47− | "italic" `isInfixOf` func -> tag "i" e
48− | "monospace" `isInfixOf` func -> tag "code" e
49− App e1 e2 -> f e1 ++ f e2
50− Let defs e -> concatMap extract defs ++ f e
51− Var _ -> []
52− Case e cases -> concatMap (f . snd) cases
53− Data _ es -> concatMap f es
54− MultiIf es -> concatMap (f . snd) es
55− Markdown _ md _ -> [ MD.toHtml md ]
56− _ -> []
57−
58−extractLink src txt =
59− case (extract src, extract txt) of
60− ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
61− ( ss1, ss2) -> ss1 ++ ss2
62−
63−extractImage src =
64− case extract src of
65− [s] -> ["<img src=\"" ++ s ++ "\">"]
66− ss -> ss
67−
68−tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
compiler/Language/Elm/DevTools.hsdeleted−46
@@ -1,46 +0,0 @@
1−{- | This module aims to make it easier to create dev tools for Elm.
2−
3− It provides the ability to:
4−
5− * Detect problems in a program
6− * Figure out types of particular expressions
7− * Canonicalize variables
8− * Convert expressions to JS and HTML
9−
10− This module gives limeted access to the structure of an Elm Program.
11− Giving full access would expose many internal details that are likely to
12− change as Elm progresses. These details have been hidden to avoid breaking
13− changes.
14−-}
15−module Language.Elm.DevTools where
16−
17−data Program
18−
19−-- | Parse an Elm program into an AST.
20−parse :: String -> Either [Problem] Program
21−
22−-- | Get the type of a region of the program. Lets you look
23−-- up the type of particular values and expressions.
24−typeOf :: Program -> Region -> Either [Problem] String
25−
26−-- | Canonicalize a variable. So in a normal module `map` would be canonicalized
27−-- to `List.map`.
28−canonicalize :: Program -> Region -> [String]
29−
30−-- | Any problem that may come up while parsing or typing a program.
31−-- All problems come with a region that is causing the problem.
32−data Problem = Problem { message :: String, region :: Region }
33−
34−type Row = Int
35−type Column = Int
36−
37−-- | Represents a region, spanning two points in the source code.
38−data Region = Region { start :: (Row,Column), end :: (Row,Column) }
39−
40−-- | Takes a specific point in the source code, such as the cursor position.
41−-- It then determines the region that best represents that point. When the
42−-- cursor is within a variable, it chooses the variable. When the cursor is
43−-- on parentheses, it selects the region within the parentheses. When the
44−-- cursor is on keywords like let, it chooses the whole let-expression.
45−region :: (Row,Column) -> Region
46−region pos = Region pos pos
compiler/Metadata/Prelude.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Metadata.Prelude (interfaces, add) where
3−
4−import qualified Data.Map as Map
5−import qualified Control.Exception as E
6−import qualified Paths_Elm as Path
7−import System.Exit
8−import System.IO
9−import SourceSyntax.Module
10−import qualified Build.Interface as Interface
11−
12−add :: Bool -> Module def -> Module def
13−add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
14− where
15− customIms = if noPrelude then [] else concatMap addModule prelude
16−
17− addModule (n, method) = case lookup n ims of
18− Nothing -> [(n, method)]
19− Just (As _) -> [(n, method)]
20− Just _ -> []
21−
22−prelude :: [(String, ImportMethod)]
23−prelude = string : text ++ map (\n -> (n, Hiding [])) modules
24− where
25− text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
26− string = ("String", As "String")
27− modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
28− , "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
29−
30−interfaces :: Bool -> IO Interfaces
31−interfaces noPrelude =
32− if noPrelude
33− then return $ Map.empty
34− else safeReadDocs =<< Path.getDataFileName "interfaces.data"
35−
36−safeReadDocs :: FilePath -> IO Interfaces
37−safeReadDocs name =
38− E.catch (readDocs name) $ \err -> do
39− let _ = err :: IOError
40− hPutStrLn stderr $ unlines $
41− [ "Error reading types for standard library from file " ++ name
42− , " If you are using a stable version of Elm, please report an issue at"
43− , " <http://github.com/evancz/Elm/issues> specifying version numbers for"
44− , " Elm and your OS." ]
45− exitFailure
46−
47−readDocs :: FilePath -> IO Interfaces
48−readDocs filePath = do
49− interfaces <- Interface.load filePath
50− case mapM (Interface.isValid filePath) (interfaces :: [(String, ModuleInterface)]) of
51− Left err -> do
52− hPutStrLn stderr err
53− exitFailure
54−
55− Right [] -> do
56− hPutStrLn stderr "No interfaces found in serialized Prelude!"
57− exitFailure
58−
59− Right ifaces -> return $ Map.fromList ifaces
compiler/Parse/Binop.hsdeleted−83
@@ -1,83 +0,0 @@
1−module Parse.Binop (binops, OpTable) where
2−
3−import Control.Applicative ((<$>))
4−import Data.List (intercalate)
5−import qualified Data.Map as Map
6−
7−import SourceSyntax.Location (merge)
8−import qualified SourceSyntax.Expression as E
9−import SourceSyntax.Declaration (Assoc(..))
10−import Text.Parsec
11−import Parse.Helpers
12−
13−opLevel :: OpTable -> String -> Int
14−opLevel table op = fst $ Map.findWithDefault (9,L) op table
15−
16−opAssoc :: OpTable -> String -> Assoc
17−opAssoc table op = snd $ Map.findWithDefault (9,L) op table
18−
19−hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
20−hasLevel table n (op,_) = opLevel table op == n
21−
22−binops :: IParser E.LParseExpr
23− -> IParser E.LParseExpr
24− -> IParser String
25− -> IParser E.LParseExpr
26−binops term last anyOp =
27− do e <- term
28− table <- getState
29− split table 0 e =<< nextOps
30− where
31− nextOps = choice [ commitIf (whitespace >> anyOp) $ do
32− whitespace ; op <- anyOp ; whitespace
33− expr <- Left <$> try term <|> Right <$> last
34− case expr of
35− Left t -> (:) (op,t) <$> nextOps
36− Right e -> return [(op,e)]
37− , return [] ]
38−
39−split :: OpTable
40− -> Int
41− -> E.LParseExpr
42− -> [(String, E.LParseExpr)]
43− -> IParser E.LParseExpr
44−split _ _ e [] = return e
45−split table n e eops = do
46− assoc <- getAssoc table n eops
47− es <- sequence (splitLevel table n e eops)
48− let ops = map fst (filter (hasLevel table n) eops)
49− case assoc of R -> joinR es ops
50− _ -> joinL es ops
51−
52−splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
53− -> [IParser E.LParseExpr]
54−splitLevel table n e eops =
55− case break (hasLevel table n) eops of
56− (lops, (op,e'):rops) ->
57− split table (n+1) e lops : splitLevel table n e' rops
58− (lops, []) -> [ split table (n+1) e lops ]
59−
60−joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
61−joinL [e] [] = return e
62−joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
63−joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
64−
65−joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
66−joinR [e] [] = return e
67−joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
68− return (merge a e (E.Binop op a e))
69−joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
70−
71−getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
72−getAssoc table n eops
73− | all (==L) assocs = return L
74− | all (==R) assocs = return R
75− | all (==N) assocs = case assocs of [_] -> return N
76− _ -> failure (msg "precedence")
77− | otherwise = failure (msg "associativity")
78− where levelOps = filter (hasLevel table n) eops
79− assocs = map (opAssoc table . fst) levelOps
80− msg problem =
81− concat [ "Conflicting " ++ problem ++ " for binary operators ("
82− , intercalate ", " (map fst eops), "). "
83− , "Consider adding parentheses to disambiguate." ]
compiler/Parse/Declaration.hsdeleted−63
@@ -1,63 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Declaration where
3−
4−import Control.Applicative ((<$>))
5−import Text.Parsec hiding (newline,spaces)
6−
7−import Parse.Helpers
8−import qualified Parse.Expression as Expr
9−import qualified Parse.Type as Type
10−import qualified SourceSyntax.Declaration as D
11−
12−
13−declaration :: IParser D.ParseDeclaration
14−declaration = alias <|> datatype <|> infixDecl <|> port <|> definition
15−
16−definition :: IParser D.ParseDeclaration
17−definition = D.Definition <$> Expr.def
18−
19−alias :: IParser D.ParseDeclaration
20−alias = do
21− reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
22− forcedWS
23− name <- capVar
24− args <- spacePrefix lowVar
25− padded equals
26− tipe <- Type.expr
27− json <- option [] $ do
28− try $ padded (reserved "deriving")
29− string "Json"
30− return [D.Json]
31− return (D.TypeAlias name args tipe json)
32−
33−datatype :: IParser D.ParseDeclaration
34−datatype = do
35− reserved "data" <?> "datatype definition (data T = A | B | ...)"
36− forcedWS
37− name <- capVar <?> "name of data-type"
38− args <- spacePrefix lowVar
39− padded equals
40− tcs <- pipeSep1 Type.constructor
41− return $ D.Datatype name args tcs []
42−
43−
44−infixDecl :: IParser D.ParseDeclaration
45−infixDecl = do
46− assoc <- choice [ reserved "infixl" >> return D.L
47− , reserved "infix" >> return D.N
48− , reserved "infixr" >> return D.R ]
49− forcedWS
50− n <- digit
51− forcedWS
52− D.Fixity assoc (read [n]) <$> anyOp
53−
54−
55−port :: IParser D.ParseDeclaration
56−port =
57− do try (reserved "port")
58− whitespace
59− name <- lowVar
60− whitespace
61− let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }
62− D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
63− , port' equals D.PPDef Expr.expr ]
compiler/Parse/Expression.hsdeleted−238
@@ -1,238 +0,0 @@
1−module Parse.Expression (def,term,typeAnnotation,expr) where
2−
3−import Control.Applicative ((<$>), (<*>))
4−import Data.List (foldl')
5−import Text.Parsec hiding (newline,spaces)
6−import Text.Parsec.Indent
7−
8−import Parse.Helpers
9−import qualified Parse.Pattern as Pattern
10−import qualified Parse.Type as Type
11−import Parse.Binop
12−import Parse.Literal
13−
14−import SourceSyntax.Location as Location
15−import SourceSyntax.Pattern hiding (tuple,list)
16−import qualified SourceSyntax.Literal as Literal
17−import SourceSyntax.Expression
18−
19−
20−-------- Basic Terms --------
21−
22−varTerm :: IParser ParseExpr
23−varTerm = toVar <$> var <?> "variable"
24−
25−toVar :: String -> ParseExpr
26−toVar v = case v of "True" -> Literal (Literal.Boolean True)
27− "False" -> Literal (Literal.Boolean False)
28− _ -> Var v
29−
30−accessor :: IParser ParseExpr
31−accessor = do
32− (start, lbl, end) <- located (try (string "." >> rLabel))
33− let loc e = Location.at start end e
34− return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
35−
36−negative :: IParser ParseExpr
37−negative = do
38− (start, nTerm, end) <-
39− located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
40− let loc e = Location.at start end e
41− return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
42−
43−
44−-------- Complex Terms --------
45−
46−listTerm :: IParser ParseExpr
47−listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
48− where
49− range = do
50− lo <- expr
51− padded (string "..")
52− Range lo <$> expr
53−
54− markdown' = do
55− pos <- getPosition
56− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)
57− (rawText, exprs) <- markdown (interpolation uid)
58− return (Markdown uid (filter (/='\r') rawText) exprs)
59−
60− span uid index =
61− "<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
62−
63− interpolation uid md exprs = do
64− try (string "{{")
65− e <- padded expr
66− string "}}"
67− return (md ++ span uid (length exprs), exprs ++ [e])
68−
69−parensTerm :: IParser LParseExpr
70−parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
71− where
72− opFn = do
73− (start, op, end) <- located anyOp
74− let loc = Location.at start end
75− return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
76− Binop op (loc $ Var "x") (loc $ Var "y")
77−
78− tupleFn = do
79− let comma = char ',' <?> "comma ','"
80− (start, commas, end) <- located (comma >> many (whitespace >> comma))
81− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
82− loc = Location.at start end
83− return $ foldr (\x e -> loc $ Lambda x e)
84− (loc . tuple $ map (loc . Var) vars) (map PVar vars)
85−
86− parened = do
87− (start, es, end) <- located (commaSep expr)
88− return $ case es of
89− [e] -> e
90− _ -> Location.at start end (tuple es)
91−
92−recordTerm :: IParser LParseExpr
93−recordTerm = brackets $ choice [ misc, addLocation record ]
94− where field = do
95− label <- rLabel
96− patterns <- spacePrefix Pattern.term
97− padded equals
98− body <- expr
99− return (label, makeFunction patterns body)
100−
101− record = Record <$> commaSep field
102−
103− change = do
104− lbl <- rLabel
105− padded (string "<-")
106− (,) lbl <$> expr
107−
108− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109−
110− insert r = addLocation $ do
111− string "|" >> whitespace
112− Insert r <$> rLabel <*> (padded equals >> expr)
113−
114− modify r = addLocation
115− (string "|" >> whitespace >> Modify r <$> commaSep1 change)
116−
117− misc = try $ do
118− record <- addLocation (Var <$> rLabel)
119− opt <- padded (optionMaybe (remove record))
120− case opt of
121− Just e -> try (insert e) <|> return e
122− Nothing -> try (insert record) <|> try (modify record)
123−
124−
125−term :: IParser LParseExpr
126−term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
127− <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
128− <?> "basic term (4, x, 'c', etc.)"
129−
130−-------- Applications --------
131−
132−appExpr :: IParser LParseExpr
133−appExpr = do
134− t <- term
135− ts <- constrainedSpacePrefix term $ \str ->
136− if null str then notFollowedBy (char '-') else return ()
137− return $ case ts of
138− [] -> t
139− _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
140−
141−-------- Normal Expressions --------
142−
143−binaryExpr :: IParser LParseExpr
144−binaryExpr = binops appExpr lastExpr anyOp
145− where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
146− <|> lambdaExpr
147−
148−ifExpr :: IParser ParseExpr
149−ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
150− where
151− normal = do
152− bool <- expr
153− padded (reserved "then")
154− thenBranch <- expr
155− whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
156− elseBranch <- expr
157− return $ MultiIf [(bool, thenBranch),
158− (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
159− multiIf = MultiIf <$> spaceSep1 iff
160− where iff = do string "|" ; whitespace
161− b <- expr ; padded arrow
162− (,) b <$> expr
163−
164−lambdaExpr :: IParser LParseExpr
165−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
166− whitespace
167− args <- spaceSep1 Pattern.term
168− padded arrow
169− body <- expr
170− return (makeFunction args body)
171−
172−defSet :: IParser [ParseDef]
173−defSet = block (do d <- def ; whitespace ; return d)
174−
175−letExpr :: IParser ParseExpr
176−letExpr = do
177− reserved "let" ; whitespace
178− defs <- defSet
179− padded (reserved "in")
180− Let defs <$> expr
181−
182−caseExpr :: IParser ParseExpr
183−caseExpr = do
184− reserved "case"; e <- padded expr; reserved "of"; whitespace
185− Case e <$> (with <|> without)
186− where case_ = do p <- Pattern.expr
187− padded arrow
188− (,) p <$> expr
189− with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
190− without = block (do c <- case_ ; whitespace ; return c)
191−
192−expr :: IParser LParseExpr
193−expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
194− <|> lambdaExpr
195− <|> binaryExpr
196− <?> "an expression"
197−
198−defStart :: IParser [Pattern]
199−defStart =
200− choice [ do p1 <- try Pattern.term
201− infics p1 <|> func p1
202− , func =<< (PVar <$> parens symOp)
203− , (:[]) <$> Pattern.expr
204− ] <?> "the definition of a variable (x = ...)"
205− where
206− func pattern =
207− case pattern of
208− PVar _ -> (pattern:) <$> spacePrefix Pattern.term
209− _ -> do try (lookAhead (whitespace >> string "="))
210− return [pattern]
211−
212− infics p1 = do
213− o:p <- try (whitespace >> anyOp)
214− p2 <- (whitespace >> Pattern.term)
215− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
216− else [ PVar (o:p), p1, p2 ]
217−
218−makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
219−makeFunction args body@(L s _) =
220− foldr (\arg body' -> L s $ Lambda arg body') body args
221−
222−definition :: IParser ParseDef
223−definition = withPos $ do
224− (name:args) <- defStart
225− padded equals
226− body <- expr
227− return . Def name $ makeFunction args body
228−
229−typeAnnotation :: IParser ParseDef
230−typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
231− where
232− start = do
233− v <- lowVar <|> parens symOp
234− padded hasType
235− return v
236−
237−def :: IParser ParseDef
238−def = typeAnnotation <|> definition
compiler/Parse/Helpers.hsdeleted−384
@@ -1,384 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Parse.Helpers where
3−
4−import Prelude hiding (until)
5−import Control.Applicative ((<$>),(<*>))
6−import Control.Monad
7−import Control.Monad.State
8−import Data.Char (isUpper)
9−import qualified Data.Set as Set
10−import qualified Data.Map as Map
11−import Text.Parsec hiding (newline,spaces,State)
12−import Text.Parsec.Indent
13−import qualified Text.Parsec.Token as T
14−
15−import SourceSyntax.Helpers as Help
16−import SourceSyntax.Location as Location
17−import SourceSyntax.Expression
18−import SourceSyntax.PrettyPrint
19−import SourceSyntax.Declaration (Assoc)
20−
21−reserveds = [ "if", "then", "else"
22− , "case", "of"
23− , "let", "in"
24− , "data", "type"
25− , "module", "where"
26− , "import", "as", "hiding", "open"
27− , "export", "foreign"
28− , "deriving", "port" ]
29−
30−jsReserveds :: Set.Set String
31−jsReserveds = Set.fromList
32− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
33− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
34− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
35− , "transient", "synchronized", "function", "break", "case", "catch"
36− , "continue", "debugger", "default", "delete", "do", "else", "finally"
37− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
38− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
39− , "const", "enum", "export", "extends", "import", "super", "implements"
40− , "interface", "let", "package", "private", "protected", "public"
41− , "static", "yield"
42− -- reserved by the Elm runtime system
43− , "Elm", "ElmRuntime"
44− , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
45− , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
46− ]
47−
48−expecting = flip (<?>)
49−
50−type OpTable = Map.Map String (Int, Assoc)
51−type SourceM = State SourcePos
52−type IParser a = ParsecT String OpTable SourceM a
53−
54−iParse :: IParser a -> String -> Either ParseError a
55−iParse = iParseWithTable "" Map.empty
56−
57−iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a
58−iParseWithTable sourceName table aParser input =
59− runIndent sourceName $ runParserT aParser table sourceName input
60−
61−var :: IParser String
62−var = makeVar (letter <|> char '_' <?> "variable")
63−
64−lowVar :: IParser String
65−lowVar = makeVar (lower <?> "lower case variable")
66−capVar :: IParser String
67−capVar = makeVar (upper <?> "upper case variable")
68−
69−qualifiedVar :: IParser String
70−qualifiedVar = do
71− vars <- many ((++) <$> capVar <*> string ".")
72− (++) (concat vars) <$> lowVar
73−
74−rLabel :: IParser String
75−rLabel = lowVar
76−
77−innerVarChar :: IParser Char
78−innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
79−
80−makeVar :: IParser Char -> IParser String
81−makeVar p = do v <- (:) <$> p <*> many innerVarChar
82− guard (v `notElem` reserveds)
83− return v
84−
85−reserved :: String -> IParser String
86−reserved word =
87− try (string word >> notFollowedBy innerVarChar) >> return word
88− <?> "reserved word '" ++ word ++ "'"
89−
90−anyOp :: IParser String
91−anyOp = betwixt '`' '`' qualifiedVar <|> symOp <?> "infix operator (e.g. +, *, ||)"
92−
93−symOp :: IParser String
94−symOp = do op <- many1 (satisfy Help.isSymbol)
95− guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
96− case op of
97− "." -> notFollowedBy lower >> return op
98− "\8728" -> return "."
99− _ -> return op
100−
101−padded :: IParser a -> IParser a
102−padded p = do whitespace
103− out <- p
104− whitespace
105− return out
106−
107−equals :: IParser String
108−equals = string "="
109−
110−arrow :: IParser String
111−arrow = string "->" <|> string "\8594" <?> "arrow (->)"
112−
113−hasType :: IParser String
114−hasType = string ":" <?> "':' (a type annotation)'"
115−
116−
117−commitIf check p = commit <|> try p
118− where commit = do (try $ lookAhead check) >> p
119−
120−spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
121−spaceySepBy1 sep p = do
122− a <- p
123− (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))
124−
125−
126−commaSep1 :: IParser a -> IParser [a]
127−commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
128−
129−commaSep :: IParser a -> IParser [a]
130−commaSep = option [] . commaSep1
131−
132−semiSep1 :: IParser a -> IParser [a]
133−semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
134−
135−pipeSep1 :: IParser a -> IParser [a]
136−pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
137−
138−consSep1 :: IParser a -> IParser [a]
139−consSep1 = spaceySepBy1 (string "::" <?> "cons operator '::'")
140−
141−dotSep1 :: IParser a -> IParser [a]
142−dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
143−
144−spaceSep1 :: IParser a -> IParser [a]
145−spaceSep1 p = (:) <$> p <*> spacePrefix p
146−
147−spacePrefix p = constrainedSpacePrefix p (\_ -> return ())
148−
149−constrainedSpacePrefix p constraint =
150− many $ choice [ try (spacing >> lookAhead (oneOf "[({")) >> p
151− , try (spacing >> p)
152− ]
153− where
154− spacing = do
155− n <- whitespace
156− constraint n
157− indented
158−
159−failure msg = do
160− inp <- getInput
161− setInput ('x':inp)
162− anyToken
163− fail msg
164−
165−followedBy a b = do x <- a ; b ; return x
166−
167−betwixt a b c = do char a ; out <- c
168− char b <?> "closing '" ++ [b] ++ "'" ; return out
169−
170−surround a z name p = do
171− char a ; v <- padded p
172− char z <?> unwords ["closing", name, show z]
173− return v
174−
175−braces :: IParser a -> IParser a
176−braces = surround '[' ']' "brace"
177−
178−parens :: IParser a -> IParser a
179−parens = surround '(' ')' "paren"
180−
181−brackets :: IParser a -> IParser a
182−brackets = surround '{' '}' "bracket"
183−
184−addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
185−addLocation expr = do
186− (start, e, end) <- located expr
187− return (Location.at start end e)
188−
189−located :: IParser a -> IParser (SourcePos, a, SourcePos)
190−located p = do
191− start <- getPosition
192− e <- p
193− end <- getPosition
194− return (start, e, end)
195−
196−accessible :: IParser LParseExpr -> IParser LParseExpr
197−accessible expr = do
198− start <- getPosition
199− ce@(L _ e) <- expr
200− let rest f = do
201− let dot = char '.' >> notFollowedBy (char '.')
202− access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
203− case access of
204− Nothing -> return ce
205− Just _ -> accessible $ do
206− v <- var <?> "field access (e.g. List.map)"
207− end <- getPosition
208− return (Location.at start end (f v))
209− case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
210− | otherwise -> rest (Access ce)
211− _ -> rest (Access ce)
212−
213−
214−spaces :: IParser String
215−spaces = concat <$> many1 (multiComment <|> string " ") <?> "spaces"
216−
217−forcedWS :: IParser String
218−forcedWS = choice [ try $ (++) <$> spaces <*> (concat <$> many nl_space)
219− , try $ concat <$> many1 nl_space ]
220− where nl_space = try ((++) <$> (concat <$> many1 newline) <*> spaces)
221−
222−-- Just eats whitespace until the next meaningful character.
223−dumbWhitespace :: IParser String
224−dumbWhitespace = concat <$> many (spaces <|> newline)
225−
226−whitespace :: IParser String
227−whitespace = option "" forcedWS <?> "whitespace"
228−
229−freshLine :: IParser [[String]]
230−freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
231− where space_nl = try $ spaces >> many1 newline
232−
233−newline :: IParser String
234−newline = simpleNewline <|> lineComment <?> "newline"
235−
236−simpleNewline :: IParser String
237−simpleNewline = try (string "\r\n") <|> string "\n"
238−
239−lineComment :: IParser String
240−lineComment = do
241− try (string "--")
242− comment <- anyUntil $ simpleNewline <|> (eof >> return "\n")
243− return ("--" ++ comment)
244−
245−multiComment :: IParser String
246−multiComment = (++) <$> try (string "{-") <*> closeComment
247−
248−closeComment :: IParser String
249−closeComment =
250− anyUntil . choice $
251− [ try (string "-}") <?> "close comment"
252− , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]
253− ]
254−
255−until :: IParser a -> IParser b -> IParser b
256−until p end = go
257− where
258− go = end <|> (p >> go)
259−
260−anyUntil :: IParser String -> IParser String
261−anyUntil end = go
262− where
263− go = end <|> (:) <$> anyChar <*> go
264−
265−ignoreUntil :: IParser a -> IParser (Maybe a)
266−ignoreUntil end = go
267− where
268− ignore p = const () <$> p
269− filler = choice [ try (ignore chr) <|> ignore str
270− , ignore multiComment
271− , ignore (markdown (\_ _ -> mzero))
272− , ignore anyChar
273− ]
274− go = choice [ Just <$> end
275− , filler `until` choice [ const Nothing <$> eof, newline >> go ]
276− ]
277−
278−onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b
279−onFreshLines insert init thing = go init
280− where
281− go values = do
282− optionValue <- ignoreUntil thing
283− case optionValue of
284− Nothing -> return values
285− Just v -> go (insert v values)
286−
287−withSource :: IParser a -> IParser (String, a)
288−withSource p = do
289− start <- getParserState
290− result <- p
291− endPos <- getPosition
292− setParserState start
293− raw <- anyUntilPos endPos
294− return (raw, result)
295−
296−anyUntilPos :: SourcePos -> IParser String
297−anyUntilPos pos = go
298− where
299− go = do currentPos <- getPosition
300− case currentPos == pos of
301− True -> return []
302− False -> (:) <$> anyChar <*> go
303−
304−markdown :: (String -> [a] -> IParser (String, [a])) -> IParser (String, [a])
305−markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
306− where
307− closeMarkdown md stuff =
308− choice [ do try (string "|]")
309− return (md, stuff)
310− , uncurry closeMarkdown =<< interpolation md stuff
311− , do c <- anyChar
312− closeMarkdown (md ++ [c]) stuff
313− ]
314−
315−--str :: IParser String
316−str = expecting "String" $ do
317− s <- choice [ multiStr, singleStr ]
318− processAs T.stringLiteral . sandwich '\"' $ concat s
319− where
320− rawString quote insides =
321− quote >> manyTill insides quote
322−
323− multiStr = rawString (try (string "\"\"\"")) multilineStringChar
324− singleStr = rawString (char '"') stringChar
325−
326− stringChar :: IParser String
327− stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]
328−
329− multilineStringChar :: IParser String
330− multilineStringChar =
331− do noEnd
332− choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]
333− where
334− noEnd = notFollowedBy (string "\"\"\"")
335− expandQuote c = if c == '\"' then "\\\"" else [c]
336−
337− newlineChar :: IParser String
338− newlineChar =
339− choice [ char '\n' >> return "\\n"
340− , char '\r' >> return "\\r" ]
341−
342−sandwich :: Char -> String -> String
343−sandwich delim s = delim : s ++ [delim]
344−
345−escaped :: Char -> IParser String
346−escaped delim = try $ do
347− char '\\'
348− c <- char '\\' <|> char delim
349− return ['\\', c]
350−
351−chr :: IParser Char
352−chr = betwixt '\'' '\'' character <?> "character"
353− where
354− nonQuote = satisfy (/='\'')
355− character = do
356− c <- choice [ escaped '\''
357− , (:) <$> char '\\' <*> many1 nonQuote
358− , (:[]) <$> nonQuote ]
359− processAs T.charLiteral $ sandwich '\'' c
360−
361−processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a
362−processAs processor s = calloutParser s (processor lexer)
363− where
364− calloutParser :: String -> IParser a -> IParser a
365− calloutParser inp p = either (fail . show) return (iParse p inp)
366−
367− lexer :: T.GenTokenParser String u SourceM
368− lexer = T.makeTokenParser elmDef
369−
370− -- I don't know how many of these are necessary for charLiteral/stringLiteral
371− elmDef :: T.GenLanguageDef String u SourceM
372− elmDef = T.LanguageDef
373− { T.commentStart = "{-"
374− , T.commentEnd = "-}"
375− , T.commentLine = "--"
376− , T.nestedComments = True
377− , T.identStart = undefined
378− , T.identLetter = undefined
379− , T.opStart = undefined
380− , T.opLetter = undefined
381− , T.reservedNames = reserveds
382− , T.reservedOpNames = [":", "->", "<-", "|"]
383− , T.caseSensitive = True
384− }
compiler/Parse/Literal.hsdeleted−22
@@ -1,22 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Literal (literal) where
3−
4−import Control.Applicative ((<$>))
5−import Text.Parsec hiding (newline,spaces)
6−import Parse.Helpers
7−import SourceSyntax.Literal
8−
9−literal :: IParser Literal
10−literal = num <|> (Str <$> str) <|> (Chr <$> chr)
11−
12−num :: IParser Literal
13−num = fmap toLit (preNum <?> "number")
14− where toLit n | '.' `elem` n = FloatNum (read n)
15− | otherwise = IntNum (read n)
16− preNum = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
17− postNum = do try $ lookAhead (string "." >> digit)
18− string "."
19− ('.':) <$> many1 digit
20− minus = try $ do string "-"
21− lookAhead digit
22− return "-"
compiler/Parse/Module.hsdeleted−54
@@ -1,54 +0,0 @@
1−module Parse.Module (moduleDef, getModuleName, imports) where
2−
3−import Control.Applicative ((<$>), (<*>))
4−import Data.List (intercalate)
5−import Text.Parsec hiding (newline,spaces)
6−
7−import Parse.Helpers
8−import SourceSyntax.Module (ImportMethod(..), Imports)
9−
10−varList :: IParser [String]
11−varList = parens $ commaSep1 (var <|> parens symOp)
12−
13−getModuleName :: String -> Maybe String
14−getModuleName source =
15− case iParse getModuleName source of
16− Right name -> Just name
17− Left _ -> Nothing
18− where
19− getModuleName = do
20− optional freshLine
21− (names, _) <- moduleDef
22− return (intercalate "." names)
23−
24−moduleDef :: IParser ([String], [String])
25−moduleDef = do
26− try (reserved "module")
27− whitespace
28− names <- dotSep1 capVar <?> "name of module"
29− whitespace
30− exports <- option [] varList
31− whitespace <?> "reserved word 'where'"
32− reserved "where"
33− return (names, exports)
34−
35−imports :: IParser Imports
36−imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
37−
38−import' :: IParser (String, ImportMethod)
39−import' =
40− do reserved "import"
41− whitespace
42− open <- optionMaybe (reserved "open")
43− whitespace
44− name <- intercalate "." <$> dotSep1 capVar
45− case open of
46− Just _ -> return (name, Hiding [])
47− Nothing -> let how = try (whitespace >> (as' <|> importing'))
48− in (,) name <$> option (As name) how
49− where
50− as' :: IParser ImportMethod
51− as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
52−
53− importing' :: IParser ImportMethod
54− importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
compiler/Parse/Parse.hsdeleted−73
@@ -1,73 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Parse.Parse (program, dependencies) where
3−
4−import Control.Applicative ((<$>), (<*>))
5−import qualified Data.List as List
6−import qualified Data.Map as Map
7−import Text.Parsec hiding (newline,spaces)
8−import qualified Text.PrettyPrint as P
9−
10−import qualified SourceSyntax.Declaration as D
11−import qualified SourceSyntax.Module as M
12−import Parse.Helpers
13−import Parse.Declaration (infixDecl)
14−import Parse.Module
15−import qualified Parse.Declaration as Decl
16−import Transform.Declaration (combineAnnotations)
17−
18−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
19− freshLine
20− Decl.declaration <?> "another datatype or variable definition"
21−
22−decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
23− (d:) <$> many freshDef
24−
25−program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)
26−program table src =
27− do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src
28− decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)
29− return $ M.Module names exs ims decls
30−
31−programParser :: IParser (M.Module D.ParseDeclaration)
32−programParser =
33− do optional freshLine
34− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
35− is <- (do try (lookAhead $ reserved "import")
36− imports `followedBy` freshLine) <|> return []
37− declarations <- decls
38− optional freshLine ; optional spaces ; eof
39− return $ M.Module names exports is declarations
40−
41−dependencies :: String -> Either [P.Doc] (String, [String])
42−dependencies =
43− let getName = List.intercalate "." . fst in
44− setupParser $ do
45− optional freshLine
46− (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
47− <*> option [] (map fst <$> imports `followedBy` freshLine)
48−
49−setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
50−setupParserWithTable table p source =
51− do localTable <- setupParser parseFixities source
52− case Map.intersection table localTable of
53− overlap | not (Map.null overlap) -> Left [ msg overlap ]
54− | otherwise ->
55− flip setupParser source $ do
56− putState (Map.union table localTable)
57− p
58− where
59− msg overlap =
60− P.vcat [ P.text "Parse error:"
61− , P.text $ "Overlapping definitions for infix operators: " ++
62− List.intercalate " " (Map.keys overlap)
63− ]
64−
65−parseFixities = do
66− decls <- onFreshLines (:) [] infixDecl
67− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
68−
69−setupParser :: IParser a -> String -> Either [P.Doc] a
70−setupParser p source =
71− case iParse p source of
72− Right result -> Right result
73− Left err -> Left [ P.text $ "Parse error at " ++ show err ]
compiler/Parse/Pattern.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Parse.Pattern (term, expr) where
3−
4−import Control.Applicative ((<$>))
5−import Data.Char (isUpper)
6−import Data.List (intercalate)
7−import Text.Parsec hiding (newline,spaces,State)
8−
9−import Parse.Helpers
10−import Parse.Literal
11−import SourceSyntax.Literal
12−import SourceSyntax.Pattern hiding (tuple, list)
13−import qualified SourceSyntax.Pattern as Pattern
14−
15−basic :: IParser Pattern
16−basic = choice
17− [ char '_' >> return PAnything
18− , do v <- var
19− return $ case v of
20− "True" -> PLiteral (Boolean True)
21− "False" -> PLiteral (Boolean False)
22− c:_ | isUpper c -> PData v []
23− _ -> PVar v
24− , PLiteral <$> literal
25− ]
26−
27−asPattern :: Pattern -> IParser Pattern
28−asPattern pattern = do
29− var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
30− return $ case var of
31− Just v -> PAlias v pattern
32− Nothing -> pattern
33−
34−record :: IParser Pattern
35−record = PRecord <$> brackets (commaSep1 lowVar)
36−
37−tuple :: IParser Pattern
38−tuple = do ps <- parens (commaSep expr)
39− return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
40−
41−list :: IParser Pattern
42−list = Pattern.list <$> braces (commaSep expr)
43−
44−term :: IParser Pattern
45−term =
46− (choice [ record, tuple, list, basic ]) <?> "pattern"
47−
48−patternConstructor :: IParser Pattern
49−patternConstructor = do
50− v <- intercalate "." <$> dotSep1 capVar
51− case v of
52− "True" -> return $ PLiteral (Boolean True)
53− "False" -> return $ PLiteral (Boolean False)
54− _ -> PData v <$> spacePrefix term
55−
56−expr :: IParser Pattern
57−expr = do
58− patterns <- consSep1 (patternConstructor <|> term)
59− asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
compiler/Parse/Type.hsdeleted−74
@@ -1,74 +0,0 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2−module Parse.Type where
3−
4−import Control.Applicative ((<$>),(<*>),(<*))
5−import Data.List (intercalate)
6−import Text.Parsec
7−
8−import SourceSyntax.Type as T
9−import Parse.Helpers
10−
11−tvar :: IParser T.Type
12−tvar = T.Var <$> lowVar <?> "type variable"
13−
14−list :: IParser T.Type
15−list = listOf <$> braces expr
16−
17−tuple :: IParser T.Type
18−tuple = do ts <- parens (commaSep expr)
19− return $ case ts of
20− [t] -> t
21− _ -> tupleOf ts
22−
23−record :: IParser T.Type
24−record =
25− do char '{' ; whitespace
26− rcrd <- extended <|> normal
27− dumbWhitespace ; char '}'
28− return rcrd
29− where
30− normal = flip T.Record Nothing <$> commaSep field
31−
32− -- extended record types require at least one field
33− extended = do
34− ext <- try (lowVar <* (whitespace >> string "|"))
35− whitespace
36− flip T.Record (Just ext) <$> commaSep1 field
37−
38− field = do
39− lbl <- rLabel
40− whitespace >> hasType >> whitespace
41− (,) lbl <$> expr
42−
43−capTypeVar :: IParser String
44−capTypeVar = intercalate "." <$> dotSep1 capVar
45−
46−constructor0 :: IParser T.Type
47−constructor0 =
48− do name <- capTypeVar
49− return (T.Data name [])
50−
51−term :: IParser T.Type
52−term = list <|> tuple <|> record <|> tvar <|> constructor0
53−
54−app :: IParser T.Type
55−app =
56− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"
57− args <- spacePrefix term
58− return (T.Data name args)
59− where
60− tupleCtor = do
61− n <- length <$> parens (many (char ','))
62− return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)
63−
64−expr :: IParser T.Type
65−expr =
66− do t1 <- app <|> term
67− arr <- optionMaybe $ try (whitespace >> arrow)
68− case arr of
69− Just _ -> T.Lambda t1 <$> (whitespace >> expr)
70− Nothing -> return t1
71−
72−constructor :: IParser (String, [T.Type])
73−constructor = (,) <$> (capTypeVar <?> "another type constructor")
74− <*> spacePrefix term
compiler/Paths_Elm.hdeleted−15
@@ -1,15 +0,0 @@
1−-- This is a dummy file, but it should not be removed.
2−-- It makes it possible to build the compiler in GHCi, so you
3−-- can do some testing from within emacs (or whatever inferior
4−-- editor you use instead).
5−
6−module Paths_Elm where
7−
8−import Data.Version
9−import System.FilePath
10−
11−getDataFileName :: FilePath -> IO FilePath
12−getDataFileName path = return ("dist" </> "data" </> path)
13−
14−version :: Version
15−version = Version [0,8,0,3] []
compiler/SourceSyntax/Declaration.hsdeleted−122
@@ -1,122 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module SourceSyntax.Declaration where
3−
4−import Data.Binary
5−import qualified SourceSyntax.Expression as Expr
6−import qualified SourceSyntax.Type as T
7−import SourceSyntax.PrettyPrint
8−import Text.PrettyPrint as P
9−
10−data Declaration' port def
11− = Definition def
12− | Datatype String [String] [(String,[T.Type])] [Derivation]
13− | TypeAlias String [String] T.Type [Derivation]
14− | Port port
15− | Fixity Assoc Int String
16− deriving (Show)
17−
18−data Assoc = L | N | R
19− deriving (Eq)
20−
21−data Derivation = Json | JS | Binary | New
22− deriving (Eq, Show)
23−
24−data ParsePort
25− = PPAnnotation String T.Type
26− | PPDef String Expr.LParseExpr
27− deriving (Show)
28−
29−data Port
30− = Out String Expr.LExpr T.Type
31− | In String T.Type
32− deriving (Show)
33−
34−type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
35−type Declaration = Declaration' Port Expr.Def
36−
37−instance Binary Derivation where
38− get = do n <- getWord8
39− return $ case n of
40− 0 -> Json
41− 1 -> JS
42− 2 -> Binary
43− 3 -> New
44− _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\
45− \so please report an issue at <https://github.com/evancz/Elm/issues>"
46−
47− put derivation =
48− putWord8 $ case derivation of
49− Json -> 0
50− JS -> 1
51− Binary -> 2
52− New -> 3
53−
54−instance Show Assoc where
55− show assoc =
56− case assoc of
57− L -> "left"
58− N -> "non"
59− R -> "right"
60−
61−instance Binary Assoc where
62− get = do n <- getWord8
63− return $ case n of
64− 0 -> L
65− 1 -> N
66− 2 -> R
67− _ -> error "Error reading valid associativity from serialized string"
68−
69− put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }
70−
71−instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where
72− pretty decl =
73− case decl of
74− Definition def -> pretty def
75−
76− Datatype tipe tvars ctors deriveables ->
77− P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
78− (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables
79− where
80− join c ctor = P.text c <+> prettyCtor ctor
81− prettyCtor (name, tipes) =
82− P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
83−
84− TypeAlias name tvars tipe deriveables ->
85− alias <+> prettyDeriving deriveables
86− where
87− name' = P.text name <+> P.hsep (map P.text tvars)
88− alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
89−
90− Port port -> pretty port
91−
92− Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op
93− where
94− assoc' = case assoc of
95− L -> P.text "l"
96− N -> P.empty
97− R -> P.text "r"
98−
99−instance Pretty ParsePort where
100− pretty port =
101− case port of
102− PPAnnotation name tipe -> prettyPort name ":" tipe
103− PPDef name expr -> prettyPort name "=" expr
104−
105−instance Pretty Port where
106− pretty port =
107− case port of
108− In name tipe -> prettyPort name ":" tipe
109− Out name expr tipe -> P.vcat [ prettyPort name ":" tipe
110− , prettyPort name "=" expr ]
111−
112−
113−prettyPort :: (Pretty a) => String -> String -> a -> Doc
114−prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e
115−
116−prettyDeriving :: [Derivation] -> Doc
117−prettyDeriving deriveables =
118− case deriveables of
119− [] -> P.empty
120− [d] -> P.text "deriving" <+> P.text (show d)
121− ds -> P.text "deriving" <+>
122− P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)
compiler/SourceSyntax/Expression.hsdeleted−203
@@ -1,203 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module SourceSyntax.Expression where
3−{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.
4−The first is the fully general version and is labeled with a prime (Expr').
5−The others are specialized versions of the AST that represent specific phases
6−of the compilation process. I expect there to be more phases as we begin to
7−enrich the AST with more information.
8−-}
9−
10−
11−import SourceSyntax.PrettyPrint
12−import Text.PrettyPrint as P
13−import qualified SourceSyntax.Helpers as Help
14−import qualified SourceSyntax.Location as Location
15−import qualified SourceSyntax.Pattern as Pattern
16−import qualified SourceSyntax.Type as SrcType
17−import qualified SourceSyntax.Literal as Literal
18−
19−---- GENERAL AST ----
20−
21−{-| This is a located expression, meaning it is tagged with info about where it
22−came from in the source code. Expr' is defined in terms of LExpr' so that the
23−location information does not need to be an extra field on every constructor.
24−-}
25−type LExpr' def = Location.Located (Expr' def)
26−
27−{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
28−"type holes" that allow us to enrich the AST with additional information as we
29−move through the compilation process. The type holes let us show these
30−structural changes in the types. The only type hole right now is:
31−
32− def: Parsing allows two kinds of definitions (type annotations or definitions),
33− but later checks will see that they are well formed and combine them.
34−
35−-}
36−data Expr' def
37− = Literal Literal.Literal
38− | Var String
39− | Range (LExpr' def) (LExpr' def)
40− | ExplicitList [LExpr' def]
41− | Binop String (LExpr' def) (LExpr' def)
42− | Lambda Pattern.Pattern (LExpr' def)
43− | App (LExpr' def) (LExpr' def)
44− | MultiIf [(LExpr' def,LExpr' def)]
45− | Let [def] (LExpr' def)
46− | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
47− | Data String [LExpr' def]
48− | Access (LExpr' def) String
49− | Remove (LExpr' def) String
50− | Insert (LExpr' def) String (LExpr' def)
51− | Modify (LExpr' def) [(String, LExpr' def)]
52− | Record [(String, LExpr' def)]
53− | Markdown String String [LExpr' def]
54− -- for type checking and code gen only
55− | PortIn String SrcType.Type
56− | PortOut String SrcType.Type (LExpr' def)
57−
58−
59−---- SPECIALIZED ASTs ----
60−
61−{-| Expressions created by the parser. These use a split representation of type
62−annotations and definitions, which is how they appear in source code and how
63−they are parsed.
64−-}
65−type ParseExpr = Expr' ParseDef
66−type LParseExpr = LExpr' ParseDef
67−
68−data ParseDef
69− = Def Pattern.Pattern LParseExpr
70− | TypeAnnotation String SrcType.Type
71− deriving (Show)
72−
73−{-| "Normal" expressions. When the compiler checks that type annotations and
74−ports are all paired with definitions in the appropriate order, it collapses
75−them into a Def that is easier to work with in later phases of compilation.
76−-}
77−type LExpr = LExpr' Def
78−type Expr = Expr' Def
79−
80−data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
81− deriving (Show)
82−
83−
84−---- UTILITIES ----
85−
86−tuple :: [LExpr' def] -> Expr' def
87−tuple es = Data ("_Tuple" ++ show (length es)) es
88−
89−delist :: LExpr' def -> [LExpr' def]
90−delist (Location.L _ (Data "::" [h,t])) = h : delist t
91−delist _ = []
92−
93−saveEnvName :: String
94−saveEnvName = "_save_the_environment!!!"
95−
96−dummyLet :: Pretty def => [def] -> LExpr' def
97−dummyLet defs =
98− Location.none $ Let defs (Location.none $ Var saveEnvName)
99−
100−instance Pretty def => Show (Expr' def) where
101− show = render . pretty
102−
103−instance Pretty def => Pretty (Expr' def) where
104− pretty expr =
105− case expr of
106− Literal lit -> pretty lit
107− Var x -> variable x
108− Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
109− ExplicitList es -> P.brackets (commaCat (map pretty es))
110− Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
111− P.text "-" <> prettyParens e
112− Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
113− where op' = if Help.isOp op then op else "`" ++ op ++ "`"
114− Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
115− where
116− (ps,body) = collectLambdas (Location.none $ Lambda p e)
117− args = P.sep (map Pattern.prettyParens ps)
118− App _ _ -> P.hang func 2 (P.sep args)
119− where func:args = map prettyParens (collectApps (Location.none expr))
120− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
121− where
122− iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
123− Let defs e ->
124− P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
125− , P.text "in" <+> pretty e ]
126− Case e pats ->
127− P.hang pexpr 2 (P.vcat (map pretty' pats))
128− where
129− pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
130− pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
131− Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
132− Data "[]" [] -> P.text "[]"
133− Data name es
134− | Help.isTuple name -> P.parens (commaCat (map pretty es))
135− | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
136− Access e x -> prettyParens e <> P.text "." <> variable x
137− Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
138− Insert (Location.L _ (Remove e y)) x v ->
139− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
140− Insert e x v ->
141− P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
142−
143− Modify e fs ->
144− P.braces $ P.hang (pretty e <+> P.text "|")
145− 4
146− (commaSep $ map field fs)
147− where
148− field (k,v) = variable k <+> P.text "<-" <+> pretty v
149−
150− Record fs ->
151− P.braces $ P.nest 2 (commaSep $ map field fs)
152− where
153− field (x,e) = variable x <+> P.equals <+> pretty e
154−
155− Markdown _ _ _ -> P.text "[markdown| ... |]"
156−
157− PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
158−
159− PortOut _ _ signal -> pretty signal
160−
161−instance Pretty ParseDef where
162− pretty def =
163− case def of
164− TypeAnnotation name tipe ->
165− variable name <+> P.colon <+> pretty tipe
166− Def pattern expr ->
167− pretty pattern <+> P.equals <+> pretty expr
168−
169−instance Pretty Def where
170− pretty (Definition pattern expr maybeTipe) =
171− P.vcat [ annotation, definition ]
172− where
173− definition = pretty pattern <+> P.equals <+> pretty expr
174− annotation = case maybeTipe of
175− Nothing -> P.empty
176− Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
177−
178−collectApps :: LExpr' def -> [LExpr' def]
179−collectApps lexpr@(Location.L _ expr) =
180− case expr of
181− App a b -> collectApps a ++ [b]
182− _ -> [lexpr]
183−
184−collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
185−collectLambdas lexpr@(Location.L _ expr) =
186− case expr of
187− Lambda pattern body -> (pattern : ps, body')
188− where (ps, body') = collectLambdas body
189− _ -> ([], lexpr)
190−
191−prettyParens :: (Pretty def) => LExpr' def -> Doc
192−prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
193− where
194− needed =
195− case expr of
196− Binop _ _ _ -> True
197− Lambda _ _ -> True
198− App _ _ -> True
199− MultiIf _ -> True
200− Let _ _ -> True
201− Case _ _ -> True
202− Data name (_:_) -> name /= "::"
203− _ -> False
compiler/SourceSyntax/Helpers.hsdeleted−18
@@ -1,18 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module SourceSyntax.Helpers where
3−
4−import qualified Data.Char as Char
5−
6−brkt :: String -> String
7−brkt s = "{ " ++ s ++ " }"
8−
9−isTuple :: String -> Bool
10−isTuple name =
11− take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)
12−
13−isOp :: String -> Bool
14−isOp = all isSymbol
15−
16−isSymbol :: Char -> Bool
17−isSymbol c =
18− Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
compiler/SourceSyntax/Literal.hsdeleted−21
@@ -1,21 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module SourceSyntax.Literal where
3−
4−import SourceSyntax.PrettyPrint
5−import qualified Text.PrettyPrint as PP
6−
7−data Literal = IntNum Int
8− | FloatNum Double
9− | Chr Char
10− | Str String
11− | Boolean Bool
12− deriving (Eq, Ord, Show)
13−
14−instance Pretty Literal where
15− pretty literal =
16− case literal of
17− IntNum n -> PP.int n
18− FloatNum n -> PP.double n
19− Chr c -> PP.text . show $ c
20− Str s -> PP.text . show $ s
21− Boolean bool -> PP.text (show bool)
compiler/SourceSyntax/Location.hsdeleted−58
@@ -1,58 +0,0 @@
1−module SourceSyntax.Location where
2−
3−import Text.PrettyPrint
4−import SourceSyntax.PrettyPrint
5−import qualified Text.Parsec.Pos as Parsec
6−
7−data SrcPos = Pos { line :: Int, column :: Int }
8− deriving (Eq, Ord)
9−
10−data SrcSpan = Span SrcPos SrcPos String | NoSpan String
11− deriving (Eq, Ord)
12−
13−data Located e = L SrcSpan e
14− deriving (Eq, Ord)
15−
16−none e = L (NoSpan (render $ pretty e)) e
17−noneNoDocs = L (NoSpan "")
18−
19−at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
20− (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
21− (render $ pretty e)) e
22−
23−merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
24− where span = case (s1,s2) of
25− (Span start _ _, Span _ end _) -> Span start end
26− (Span start end _, _) -> Span start end
27− (_, Span start end _) -> Span start end
28− (_, _) -> NoSpan
29−
30−mergeOldDocs (L s1 _) (L s2 _) e = L span e
31− where span = case (s1,s2) of
32− (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
33− (Span _ _ _, _) -> s1
34− (_, Span _ _ _) -> s2
35− (_, _) -> NoSpan ""
36−
37−sameAs (L s _) = L s
38−
39−
40−instance Show SrcPos where
41− show (Pos r c) = show r ++ "," ++ show c
42−
43−instance Show SrcSpan where
44− show span =
45− case span of
46− NoSpan _ -> ""
47− Span start end _ ->
48− case line start == line end of
49− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
50− True -> "on line " ++ show (line end) ++ ", column " ++
51− show (column start) ++ " to " ++ show (column end)
52−
53−instance Show e => Show (Located e) where
54− show (L _ e) = show e
55−
56−instance Pretty a => Pretty (Located a) where
57− pretty (L _ e) = pretty e
58−
compiler/SourceSyntax/Module.hsdeleted−84
@@ -1,84 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module SourceSyntax.Module where
3−
4−import Data.Binary
5−import qualified Data.Map as Map
6−import Control.Applicative ((<$>), (<*>))
7−
8−import SourceSyntax.Expression (LExpr)
9−import SourceSyntax.Declaration
10−import SourceSyntax.Type
11−
12−import qualified Elm.Internal.Version as Version
13−
14−data Module def =
15− Module [String] Exports Imports [def]
16− deriving (Show)
17−
18−type Exports = [String]
19−
20−type Imports = [(String, ImportMethod)]
21−data ImportMethod = As String | Importing [String] | Hiding [String]
22− deriving (Eq, Ord, Show)
23−
24−instance Binary ImportMethod where
25− put method =
26− let put' n info = putWord8 n >> put info in
27− case method of
28− As s -> put' 0 s
29− Importing ss -> put' 1 ss
30− Hiding ss -> put' 2 ss
31−
32− get = do tag <- getWord8
33− case tag of
34− 0 -> As <$> get
35− 1 -> Importing <$> get
36− 2 -> Hiding <$> get
37− _ -> error "Error reading valid ImportMethod type from serialized string"
38−
39−data MetadataModule =
40− MetadataModule
41− { names :: [String]
42− , path :: FilePath
43− , exports :: [String]
44− , imports :: [(String, ImportMethod)]
45− , program :: LExpr
46− , types :: Map.Map String Type
47− , fixities :: [(Assoc, Int, String)]
48− , aliases :: [Alias]
49− , datatypes :: [ADT]
50− } deriving Show
51−
52−type Interfaces = Map.Map String ModuleInterface
53−type ADT = (String, [String], [(String,[Type])], [Derivation])
54−type Alias = (String, [String], Type, [Derivation])
55−
56−data ModuleInterface = ModuleInterface {
57− iVersion :: Version.Version,
58− iTypes :: Map.Map String Type,
59− iImports :: [(String, ImportMethod)],
60− iAdts :: [ADT],
61− iAliases :: [Alias],
62− iFixities :: [(Assoc, Int, String)]
63−} deriving Show
64−
65−metaToInterface :: MetadataModule -> ModuleInterface
66−metaToInterface metaModule =
67− ModuleInterface
68− { iVersion = Version.elmVersion
69− , iTypes = types metaModule
70− , iImports = imports metaModule
71− , iAdts = datatypes metaModule
72− , iAliases = aliases metaModule
73− , iFixities = fixities metaModule
74− }
75−
76−instance Binary ModuleInterface where
77− get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get
78− put modul = do
79− put (iVersion modul)
80− put (iTypes modul)
81− put (iImports modul)
82− put (iAdts modul)
83− put (iAliases modul)
84− put (iFixities modul)
compiler/SourceSyntax/Pattern.hsdeleted−65
@@ -1,65 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module SourceSyntax.Pattern where
3−
4−import qualified SourceSyntax.Helpers as Help
5−import SourceSyntax.PrettyPrint
6−import Text.PrettyPrint as PP
7−import qualified Data.Set as Set
8−import SourceSyntax.Literal as Literal
9−
10−data Pattern = PData String [Pattern]
11− | PRecord [String]
12− | PAlias String Pattern
13− | PVar String
14− | PAnything
15− | PLiteral Literal.Literal
16− deriving (Eq, Ord, Show)
17−
18−cons :: Pattern -> Pattern -> Pattern
19−cons h t = PData "::" [h,t]
20−
21−nil :: Pattern
22−nil = PData "[]" []
23−
24−list :: [Pattern] -> Pattern
25−list = foldr cons nil
26−
27−tuple :: [Pattern] -> Pattern
28−tuple es = PData ("_Tuple" ++ show (length es)) es
29−
30−boundVars :: Pattern -> Set.Set String
31−boundVars pattern =
32− case pattern of
33− PVar x -> Set.singleton x
34− PAlias x p -> Set.insert x (boundVars p)
35− PData _ ps -> Set.unions (map boundVars ps)
36− PRecord fields -> Set.fromList fields
37− PAnything -> Set.empty
38− PLiteral _ -> Set.empty
39−
40−
41−instance Pretty Pattern where
42− pretty pattern =
43− case pattern of
44− PVar x -> variable x
45− PLiteral lit -> pretty lit
46− PRecord fs -> PP.braces (commaCat $ map variable fs)
47− PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
48− PAnything -> PP.text "_"
49− PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
50− where isCons = case hd of
51− PData "::" _ -> True
52− _ -> False
53− PData name ps ->
54− if Help.isTuple name then
55− PP.parens . commaCat $ map pretty ps
56− else hsep (PP.text name : map prettyParens ps)
57−
58−prettyParens :: Pattern -> Doc
59−prettyParens pattern = parensIf needsThem (pretty pattern)
60− where
61− needsThem =
62− case pattern of
63− PData name (_:_) | not (Help.isTuple name) -> True
64− PAlias _ _ -> True
65− _ -> False
compiler/SourceSyntax/PrettyPrint.hsdeleted−34
@@ -1,34 +0,0 @@
1−
2−module SourceSyntax.PrettyPrint where
3−
4−import Text.PrettyPrint
5−import qualified SourceSyntax.Helpers as Help
6−
7−class Pretty a where
8− pretty :: a -> Doc
9−
10−instance Pretty () where
11− pretty () = empty
12−
13−commaCat docs = cat (punctuate comma docs)
14−commaSep docs = sep (punctuate comma docs)
15−
16−parensIf bool doc = if bool then parens doc else doc
17−
18−variable x =
19− if Help.isOp x then parens (text x)
20− else text (reprime x)
21−
22−reprime :: String -> String
23−reprime = map (\c -> if c == '$' then '\'' else c)
24−
25−eightyCharLines :: Int -> String -> String
26−eightyCharLines indent message = answer
27− where
28− (answer,_,_) = foldl step (spaces, indent-1, "") chunks
29−
30− chunks = map (\w -> (w, length w)) (words message)
31− spaces = replicate indent ' '
32− step (sentence, slen, space) (word, wlen)
33− | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
34− | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
compiler/SourceSyntax/Type.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module SourceSyntax.Type where
3−
4−import Data.Binary
5−import qualified Data.Map as Map
6−import qualified SourceSyntax.Helpers as Help
7−import Control.Applicative ((<$>), (<*>))
8−import SourceSyntax.PrettyPrint
9−import Text.PrettyPrint as P
10−
11−data Type = Lambda Type Type
12− | Var String
13− | Data String [Type]
14− | Record [(String,Type)] (Maybe String)
15− deriving (Eq)
16−
17−fieldMap :: [(String,a)] -> Map.Map String [a]
18−fieldMap fields =
19− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
20−
21−recordOf :: [(String,Type)] -> Type
22−recordOf fields = Record fields Nothing
23−
24−listOf :: Type -> Type
25−listOf t = Data "_List" [t]
26−
27−tupleOf :: [Type] -> Type
28−tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
29−
30−instance Show Type where
31− show = render . pretty
32−
33−instance Pretty Type where
34− pretty tipe =
35− case tipe of
36− Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
37− where
38− t:ts = map prettyLambda (collectLambdas tipe)
39− prettyLambda t = case t of
40− Lambda _ _ -> P.parens (pretty t)
41− _ -> pretty t
42−
43− Var x -> P.text x
44− Data "_List" [t] -> P.brackets (pretty t)
45− Data name tipes
46− | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
47− | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
48− Record fields ext ->
49− P.braces $ case ext of
50− Nothing -> prettyFields
51− Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields
52− where
53− prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
54− prettyFields = commaSep . map prettyField $ fields
55−
56−collectLambdas :: Type -> [Type]
57−collectLambdas tipe =
58− case tipe of
59− Lambda arg body -> arg : collectLambdas body
60− _ -> [tipe]
61−
62−prettyParens :: Type -> Doc
63−prettyParens tipe = parensIf needed (pretty tipe)
64− where
65− needed =
66− case tipe of
67− Lambda _ _ -> True
68− Data "_List" [_] -> False
69− Data _ [] -> False
70− Data _ _ -> True
71− _ -> False
72−
73−instance Binary Type where
74− put tipe =
75− case tipe of
76− Lambda t1 t2 ->
77− putWord8 0 >> put t1 >> put t2
78− Var x ->
79− putWord8 1 >> put x
80− Data ctor tipes ->
81− putWord8 2 >> put ctor >> put tipes
82− Record fs ext ->
83− putWord8 3 >> put fs >> put ext
84−
85− get = do
86− n <- getWord8
87− case n of
88− 0 -> Lambda <$> get <*> get
89− 1 -> Var <$> get
90− 2 -> Data <$> get <*> get
91− 3 -> Record <$> get <*> get
92− _ -> error "Error reading a valid type from serialized string"
compiler/Transform/Canonicalize.hsdeleted−182
@@ -1,182 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Transform.Canonicalize (interface, metadataModule) where
3−
4−import Control.Arrow ((***))
5−import Control.Applicative (Applicative,(<$>),(<*>))
6−import Control.Monad.Identity
7−import qualified Data.Traversable as T
8−import qualified Data.Map as Map
9−import qualified Data.Set as Set
10−import qualified Data.List as List
11−import qualified Data.Either as Either
12−import SourceSyntax.Module
13−import SourceSyntax.Expression
14−import SourceSyntax.Location as Loc
15−import qualified SourceSyntax.Pattern as P
16−import qualified SourceSyntax.Type as Type
17−import Text.PrettyPrint as P
18−
19−interface :: String -> ModuleInterface -> ModuleInterface
20−interface moduleName iface =
21− ModuleInterface
22− { iVersion = iVersion iface
23− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))
24− , iImports = iImports iface
25− , iAdts = map (both prefix renameCtors) (iAdts iface)
26− , iAliases = map (both prefix renameType') (iAliases iface)
27− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing
28− }
29− where
30− both f g (a,b,c,d) = (f a, b, g c, d)
31− prefix name = moduleName ++ "." ++ name
32−
33− pair name = (name, moduleName ++ "." ++ name)
34− canon (name,_,_,_) = pair name
35− canons = Map.fromList $ concat
36− [ map canon (iAdts iface), map canon (iAliases iface) ]
37−
38− renameCtors ctors =
39− map (prefix *** map renameType') ctors
40− renameType' =
41− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
42−
43−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
44−renameType renamer tipe =
45− let rnm = renameType renamer in
46− case tipe of
47− Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
48− Type.Var _ -> return tipe
49− Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
50− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
51− where rnm' (f,t) = (,) f <$> rnm t
52−
53−metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
54−metadataModule ifaces modul =
55− do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
56− [] -> Right ()
57− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
58− program' <- rename initialEnv (program modul)
59− aliases' <- mapM (three4 renameType') (aliases modul)
60− datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
61− return $ modul { program = program'
62− , aliases = aliases'
63− , datatypes = datatypes' }
64− where
65− two2 f (a,b) = (,) a <$> f b
66− three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
67− renameType' =
68− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
69−
70− get1 (a,_,_,_) = a
71− canon (name, importMethod) =
72− let pair pre var = (pre ++ drop (length name + 1) var, var)
73− iface = ifaces Map.! name
74− allNames = concat [ Map.keys (iTypes iface)
75− , map get1 (iAliases iface)
76− , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]
77− in case importMethod of
78− As alias -> map (pair (alias ++ ".")) allNames
79− Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
80− where vs = Set.fromList vars
81− Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
82− where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
83−
84− two n = (n,n)
85− localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))
86− globalEnv =
87− map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
88− map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
89− realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
90− initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
91−
92−type Env = Map.Map String String
93−
94−extend :: Env -> P.Pattern -> Env
95−extend env pattern = Map.union (Map.fromList (zip xs xs)) env
96− where xs = Set.toList (P.boundVars pattern)
97−
98−
99−replace :: String -> Env -> String -> Either String String
100−replace variable env v =
101− if List.isPrefixOf "Native." v then return v else
102− case Map.lookup v env of
103− Just v' -> return v'
104− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg
105− where
106− matches = filter (List.isInfixOf v) (Map.keys env)
107− msg = if null matches then "" else
108− "\nClose matches include: " ++ List.intercalate ", " matches
109−
110−rename :: Env -> LExpr -> Either [Doc] LExpr
111−rename env (L s expr) =
112− let rnm = rename env
113− throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
114− format = Either.either throw return
115− renameType' env = renameType (format . replace "variable" env)
116− in
117− L s <$>
118− case expr of
119− Literal _ -> return expr
120−
121− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
122−
123− Access e x -> Access <$> rnm e <*> return x
124−
125− Remove e x -> flip Remove x <$> rnm e
126−
127− Insert e x v -> flip Insert x <$> rnm e <*> rnm v
128−
129− Modify e fs ->
130− Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs
131−
132− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
133−
134− Binop op e1 e2 ->
135− do op' <- format (replace "variable" env op)
136− Binop op' <$> rnm e1 <*> rnm e2
137−
138− Lambda pattern e ->
139− let env' = extend env pattern in
140− Lambda <$> format (renamePattern env' pattern) <*> rename env' e
141−
142− App e1 e2 -> App <$> rnm e1 <*> rnm e2
143−
144− MultiIf ps -> MultiIf <$> mapM grnm ps
145− where grnm (b,e) = (,) <$> rnm b <*> rnm e
146−
147− Let defs e -> Let <$> mapM rename' defs <*> rename env' e
148− where
149− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
150− rename' (Definition p body mtipe) =
151− Definition <$> format (renamePattern env' p)
152− <*> rename env' body
153− <*> T.traverse (renameType' env') mtipe
154−
155− Var x -> Var <$> format (replace "variable" env x)
156−
157− Data name es -> Data name <$> mapM rnm es
158−
159− ExplicitList es -> ExplicitList <$> mapM rnm es
160−
161− Case e cases -> Case <$> rnm e <*> mapM branch cases
162− where
163− branch (pattern,b) = (,) <$> format (renamePattern env pattern)
164− <*> rename (extend env pattern) b
165−
166− Markdown uid md es -> Markdown uid md <$> mapM rnm es
167−
168− PortIn name st -> PortIn name <$> renameType' env st
169−
170− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
171−
172−
173−renamePattern :: Env -> P.Pattern -> Either String P.Pattern
174−renamePattern env pattern =
175− case pattern of
176− P.PVar _ -> return pattern
177− P.PLiteral _ -> return pattern
178− P.PRecord _ -> return pattern
179− P.PAnything -> return pattern
180− P.PAlias x p -> P.PAlias x <$> renamePattern env p
181− P.PData name ps -> P.PData <$> replace "pattern" env name
182− <*> mapM (renamePattern env) ps
compiler/Transform/Check.hsdeleted−170
@@ -1,170 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.Check (mistakes) where
3−
4−import qualified Control.Arrow as Arrow
5−import qualified Data.List as List
6−import qualified Data.Maybe as Maybe
7−import qualified Data.Set as Set
8−
9−import qualified SourceSyntax.Expression as E
10−import qualified SourceSyntax.Declaration as D
11−import qualified SourceSyntax.Pattern as Pattern
12−import qualified SourceSyntax.Type as T
13−import qualified Transform.Expression as Expr
14−
15−import SourceSyntax.PrettyPrint
16−import Text.PrettyPrint as P
17−
18−
19−mistakes :: [D.Declaration] -> [Doc]
20−mistakes decls =
21− concat [ infiniteTypeAliases decls
22− , illFormedTypes decls
23− , map P.text (duplicateConstructors decls)
24− , map P.text (duplicates decls)
25− , badDerivations decls ]
26−
27−dups :: Ord a => [a] -> [a]
28−dups = map head . filter ((>1) . length) . List.group . List.sort
29−
30−dupErr :: String -> String -> String
31−dupErr err x =
32− "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
33−
34−duplicates :: [D.Declaration] -> [String]
35−duplicates decls =
36− map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
37− case mapM exprDups (portExprs ++ defExprs) of
38− Left name -> [msg name]
39− Right _ -> []
40−
41− where
42− msg = dupErr "definition of"
43−
44− (defPatterns, defExprs) =
45− unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
46−
47− (portNames, portExprs) =
48− Arrow.second concat $ unzip $
49− flip map [ port | D.Port port <- decls ] $ \port ->
50− case port of
51− D.Out name expr _ -> (name, [expr])
52− D.In name _ -> (name, [])
53−
54− getNames = Set.toList . Pattern.boundVars
55−
56− exprDups :: E.LExpr -> Either String E.LExpr
57− exprDups expr = Expr.crawlLet defsDups expr
58−
59− defsDups :: [E.Def] -> Either String [E.Def]
60− defsDups defs =
61− case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
62− [] -> Right defs
63− name:_ -> Left name
64−
65−duplicateConstructors :: [D.Declaration] -> [String]
66−duplicateConstructors decls =
67− map (dupErr "definition of type constructor") (dups typeCtors) ++
68− map (dupErr "definition of data constructor") (dups dataCtors)
69− where
70− typeCtors = [ name | D.Datatype name _ _ _ <- decls ]
71− dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
72−
73−badDerivations :: [D.Declaration] -> [Doc]
74−badDerivations decls = concatMap badDerivation derivations
75− where
76− derivations =
77− [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++
78− [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]
79−
80− badDerivation (decl, tvars, derives) =
81− case (tvars, derives) of
82− (_:_, _)
83− | D.Json `elem` derives -> [report decl D.Json]
84− | D.Binary `elem` derives -> [report decl D.Binary]
85− _ -> []
86−
87− report decl derive =
88− P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
89− , P.text "Make sure all type variables are replaced with concrete types:"
90− , P.text "\n"
91− , nest 4 (pretty decl)
92− ]
93−
94−illFormedTypes :: [D.Declaration] -> [Doc]
95−illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
96− where
97− aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
98− adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]
99−
100− freeVars tipe =
101− case tipe of
102− T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
103− T.Var x -> Set.singleton x
104− T.Data _ ts -> Set.unions (map freeVars ts)
105− T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
106− where ext' = maybe Set.empty Set.singleton ext
107−
108− undeclared tvars tipes = Set.difference used declared
109− where
110− used = Set.unions (map freeVars tipes)
111− declared = Set.fromList tvars
112−
113− isIllFormed (decl, tvars, tipes) =
114− let unbound = undeclared tvars tipes in
115− if Set.null unbound then Nothing
116− else Just (decl, Set.toList unbound)
117−
118− report (decl, tvars) =
119− P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"
120− , P.text "\n"
121− , nest 4 (pretty decl) ]
122− where
123− listing =
124− case tvars of
125− [tvar] -> " " ++ quote tvar ++ " is"
126− _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"
127−
128− addCommas xs
129− | length xs < 3 = concat xs
130− | otherwise = List.intercalate "," xs
131−
132− addAnd xs
133− | length xs < 2 = xs
134− | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
135−
136− quote tvar = "'" ++ tvar ++ "'"
137−
138−
139−infiniteTypeAliases :: [D.Declaration] -> [Doc]
140−infiniteTypeAliases decls =
141− [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls
142− , infiniteType name tipe ]
143− where
144− infiniteType name tipe =
145− let infinite = infiniteType name in
146− case tipe of
147− T.Lambda a b -> infinite a || infinite b
148− T.Var _ -> False
149− T.Data name' ts -> name == name' || any infinite ts
150− T.Record fields _ -> any (infinite . snd) fields
151−
152− indented :: D.Declaration -> Doc
153− indented decl = P.text "\n " <> pretty decl <> P.text "\n"
154−
155− report name args tipe derivations =
156− P.vcat [ P.text $ eightyCharLines 0 msg1
157− , indented $ D.TypeAlias name args tipe derivations
158− , P.text $ eightyCharLines 0 msg2
159− , indented $ D.Datatype name args [(name,[tipe])] derivations
160− , P.text $ eightyCharLines 0 msg3 ++ "\n"
161− ]
162− where
163− msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
164− "Notice that it appears in its own definition, so when \
165− \you expand it, it just keeps getting bigger:"
166− msg2 = "Try this instead:"
167− msg3 = "It looks very similar, but an algebraic data type (ADT) \
168− \actually creates a new type. Unlike with a type alias, this \
169− \freshly created type is meaningful on its own, so an ADT \
170− \does not need to be expanded."
compiler/Transform/Declaration.hsdeleted−63
@@ -1,63 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.Declaration where
3−
4−import Control.Applicative ((<$>))
5−import qualified SourceSyntax.Pattern as P
6−import SourceSyntax.Expression as E
7−import SourceSyntax.Declaration as D
8−
9−import qualified Transform.Expression as Expr
10−import qualified Transform.Definition as Def
11−
12−
13−combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]
14−combineAnnotations = go
15− where
16− msg x = "Syntax Error: The type annotation for '" ++ x ++
17− "' must be directly above its definition."
18−
19− exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
20−
21− go decls =
22− case decls of
23− -- simple cases, pass them through with no changes
24− [] -> return []
25−
26− Datatype name tvars ctors ds : rest ->
27− (:) (Datatype name tvars ctors ds) <$> go rest
28−
29− TypeAlias name tvars alias ds : rest ->
30− (:) (TypeAlias name tvars alias ds) <$> go rest
31−
32− Fixity assoc prec op : rest ->
33− (:) (Fixity assoc prec op) <$> go rest
34−
35− -- combine definitions
36− D.Definition def : defRest ->
37− case def of
38− Def pat expr ->
39− do expr' <- exprCombineAnnotations expr
40− let def' = E.Definition pat expr' Nothing
41− (:) (D.Definition def') <$> go defRest
42−
43− TypeAnnotation name tipe ->
44− case defRest of
45− D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
46− do expr' <- exprCombineAnnotations expr
47− let def' = E.Definition pat expr' (Just tipe)
48− (:) (D.Definition def') <$> go rest
49−
50− _ -> Left (msg name)
51−
52− -- combine ports
53− Port port : portRest ->
54− case port of
55− PPDef name _ -> Left (msg name)
56− PPAnnotation name tipe ->
57− case portRest of
58− Port (PPDef name' expr) : rest | name == name' ->
59− do expr' <- exprCombineAnnotations expr
60− (:) (Port (Out name expr' tipe)) <$> go rest
61−
62− _ -> (:) (Port (In name tipe)) <$> go portRest
63−
compiler/Transform/Definition.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.Definition where
3−
4−import Control.Applicative ((<$>))
5−import qualified SourceSyntax.Pattern as P
6−import SourceSyntax.Expression
7−import qualified Transform.Expression as Expr
8−
9−combineAnnotations :: [ParseDef] -> Either String [Def]
10−combineAnnotations = go
11− where
12− msg x = "Syntax Error: The type annotation for '" ++ x ++
13− "' must be directly above its definition."
14−
15− exprCombineAnnotations = Expr.crawlLet combineAnnotations
16−
17− go defs =
18− case defs of
19− TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
20− do expr' <- exprCombineAnnotations expr
21− let def = Definition pat expr' (Just tipe)
22− (:) def <$> go rest
23−
24− TypeAnnotation name _ : _ -> Left (msg name)
25−
26− Def pat expr : rest ->
27− do expr' <- exprCombineAnnotations expr
28− let def = Definition pat expr' Nothing
29− (:) def <$> go rest
30−
31− [] -> return []
compiler/Transform/Expression.hsdeleted−55
@@ -1,55 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.Expression (crawlLet, checkPorts) where
3−
4−import Control.Applicative ((<$>),(<*>))
5−import SourceSyntax.Expression
6−import SourceSyntax.Location
7−import qualified SourceSyntax.Type as ST
8−
9−crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
10−crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
11−
12−checkPorts :: (String -> ST.Type -> Either a ())
13− -> (String -> ST.Type -> Either a ())
14− -> LExpr
15− -> Either a LExpr
16−checkPorts inCheck outCheck expr =
17− crawl inCheck outCheck (mapM checkDef) expr
18− where
19− checkDef def@(Definition _ body _) =
20− do _ <- checkPorts inCheck outCheck body
21− return def
22−
23−crawl :: (String -> ST.Type -> Either a ())
24− -> (String -> ST.Type -> Either a ())
25− -> ([def] -> Either a [def'])
26− -> LExpr' def
27− -> Either a (LExpr' def')
28−crawl portInCheck portOutCheck defsTransform = go
29− where
30− go (L srcSpan expr) =
31− L srcSpan <$>
32− case expr of
33− Var x -> return (Var x)
34− Lambda p e -> Lambda p <$> go e
35− Binop op e1 e2 -> Binop op <$> go e1 <*> go e2
36− Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases
37− Data name es -> Data name <$> mapM go es
38− Literal lit -> return (Literal lit)
39− Range e1 e2 -> Range <$> go e1 <*> go e2
40− ExplicitList es -> ExplicitList <$> mapM go es
41− App e1 e2 -> App <$> go e1 <*> go e2
42− MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches
43− Access e lbl -> Access <$> go e <*> return lbl
44− Remove e lbl -> Remove <$> go e <*> return lbl
45− Insert e lbl v -> Insert <$> go e <*> return lbl <*> go v
46− Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields
47− Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
48− Markdown uid md es -> Markdown uid md <$> mapM go es
49− Let defs body -> Let <$> defsTransform defs <*> go body
50− PortIn name st ->
51− do portInCheck name st
52− return $ PortIn name st
53− PortOut name st signal ->
54− do portOutCheck name st
55− PortOut name st <$> go signal
compiler/Transform/SafeNames.hsdeleted−72
@@ -1,72 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.SafeNames (metadataModule) where
3−
4−import Control.Arrow (first, (***))
5−import SourceSyntax.Expression
6−import SourceSyntax.Location
7−import SourceSyntax.Module
8−import SourceSyntax.Pattern
9−import qualified Data.Set as Set
10−import qualified Parse.Helpers as PHelp
11−
12−var :: String -> String
13−var = dereserve . deprime
14− where
15− deprime = map (\c -> if c == '\'' then '$' else c)
16− dereserve x = case Set.member x PHelp.jsReserveds of
17− False -> x
18− True -> "$" ++ x
19−
20−pattern :: Pattern -> Pattern
21−pattern pat =
22− case pat of
23− PVar x -> PVar (var x)
24− PLiteral _ -> pat
25− PRecord fs -> PRecord (map var fs)
26− PAnything -> pat
27− PAlias x p -> PAlias (var x) (pattern p)
28− PData name ps -> PData name (map pattern ps)
29−
30−expression :: LExpr -> LExpr
31−expression (L loc expr) =
32− let f = expression in
33− L loc $
34− case expr of
35− Literal _ -> expr
36− Var x -> Var (var x)
37− Range e1 e2 -> Range (f e1) (f e2)
38− ExplicitList es -> ExplicitList (map f es)
39− Binop op e1 e2 -> Binop op (f e1) (f e2)
40− Lambda p e -> Lambda (pattern p) (f e)
41− App e1 e2 -> App (f e1) (f e2)
42− MultiIf ps -> MultiIf (map (f *** f) ps)
43− Let defs body -> Let (map definition defs) (f body)
44− Case e cases -> Case (f e) $ map (pattern *** f) cases
45− Data name es -> Data name (map f es)
46− Access e x -> Access (f e) (var x)
47− Remove e x -> Remove (f e) (var x)
48− Insert e x v -> Insert (f e) (var x) (f v)
49− Modify r fs -> Modify (f r) (map (var *** f) fs)
50− Record fs -> Record (map (var *** f) fs)
51− Markdown uid md es -> Markdown uid md (map f es)
52− PortIn name st -> PortIn name st
53− PortOut name st signal -> PortOut name st (f signal)
54−
55−definition :: Def -> Def
56−definition (Definition p e t) =
57− Definition (pattern p) (expression e) t
58−
59−metadataModule :: MetadataModule -> MetadataModule
60−metadataModule modul =
61− modul
62− { names = map var (names modul)
63− , exports = map var (exports modul)
64− , imports = map (first var) (imports modul)
65− , program = expression (program modul)
66− , aliases =
67− let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)
68− in map makeSafe (aliases modul)
69− , datatypes =
70− let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)
71− in map makeSafe (datatypes modul)
72− }
compiler/Transform/SortDefinitions.hsdeleted−153
@@ -1,153 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.SortDefinitions (sortDefs) where
3−
4−import Control.Monad.State
5−import Control.Applicative ((<$>),(<*>))
6−import qualified Data.Map as Map
7−import SourceSyntax.Expression
8−import SourceSyntax.Location
9−import qualified SourceSyntax.Pattern as P
10−import qualified Data.Graph as Graph
11−import qualified Data.Set as Set
12−import qualified Data.Maybe as Maybe
13−
14−ctors :: P.Pattern -> [String]
15−ctors pattern =
16− case pattern of
17− P.PVar _ -> []
18− P.PAlias _ p -> ctors p
19− P.PData ctor ps -> ctor : concatMap ctors ps
20− P.PRecord _ -> []
21− P.PAnything -> []
22− P.PLiteral _ -> []
23−
24−free :: String -> State (Set.Set String) ()
25−free x = modify (Set.insert x)
26−
27−bound :: Set.Set String -> State (Set.Set String) ()
28−bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
29−
30−sortDefs :: LExpr -> LExpr
31−sortDefs expr = evalState (reorder expr) Set.empty
32−
33−reorder :: LExpr -> State (Set.Set String) LExpr
34−reorder (L s expr) =
35− L s <$>
36− case expr of
37− -- Be careful adding and restricting freeVars
38− Var x -> free x >> return expr
39−
40− Lambda p e ->
41− uncurry Lambda <$> bindingReorder (p,e)
42−
43− Binop op e1 e2 ->
44− do free op
45− Binop op <$> reorder e1 <*> reorder e2
46−
47− Case e cases ->
48− Case <$> reorder e <*> mapM bindingReorder cases
49−
50− Data name es ->
51− do free name
52− Data name <$> mapM reorder es
53−
54− -- Just pipe the reorder though
55− Literal _ -> return expr
56−
57− Range e1 e2 ->
58− Range <$> reorder e1 <*> reorder e2
59−
60− ExplicitList es ->
61− ExplicitList <$> mapM reorder es
62−
63− App e1 e2 ->
64− App <$> reorder e1 <*> reorder e2
65−
66− MultiIf branches ->
67− MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
68−
69− Access e lbl ->
70− Access <$> reorder e <*> return lbl
71−
72− Remove e lbl ->
73− Remove <$> reorder e <*> return lbl
74−
75− Insert e lbl v ->
76− Insert <$> reorder e <*> return lbl <*> reorder v
77−
78− Modify e fields ->
79− Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
80−
81− Record fields ->
82− Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
83−
84− Markdown uid md es -> Markdown uid md <$> mapM reorder es
85−
86− PortOut name st signal -> PortOut name st <$> reorder signal
87−
88− PortIn name st -> return $ PortIn name st
89−
90− -- Actually do some reordering
91− Let defs body ->
92− do body' <- reorder body
93−
94− -- Sort defs into strongly connected components.This
95− -- allows the programmer to write definitions in whatever
96− -- order they please, we can still define things in order
97− -- and generalize polymorphic functions when appropriate.
98− sccs <- Graph.stronglyConnComp <$> buildDefDict defs
99− let defss = map Graph.flattenSCC sccs
100−
101− -- remove let-bound variables from the context
102− forM_ defs $ \(Definition pattern _ _) -> do
103− bound (P.boundVars pattern)
104− mapM free (ctors pattern)
105−
106− let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
107−
108− return let'
109−
110−bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
111−bindingReorder (pattern,expr) =
112− do expr' <- reorder expr
113− bound (P.boundVars pattern)
114− mapM_ free (ctors pattern)
115− return (pattern, expr')
116−
117−
118−reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
119−reorderAndGetDependencies (Definition pattern expr mType) =
120− do globalFrees <- get
121− -- work in a fresh environment
122− put Set.empty
123− expr' <- reorder expr
124− localFrees <- get
125− -- merge with global frees
126− modify (Set.union globalFrees)
127− return (Definition pattern expr' mType, Set.toList localFrees)
128−
129−
130−-- This also reorders the all of the sub-expressions in the Def list.
131−buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
132−buildDefDict defs =
133− do pdefsDeps <- mapM reorderAndGetDependencies defs
134− return $ realDeps (addKey pdefsDeps)
135−
136− where
137− addKey :: [(Def, [String])] -> [(Def, Int, [String])]
138− addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
139−
140− variableToKey :: (Def, Int, [String]) -> [(String, Int)]
141− variableToKey (Definition pattern _ _, key, _) =
142− [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
143−
144− variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
145− variableToKeyMap pdefsDeps =
146− Map.fromList (concatMap variableToKey pdefsDeps)
147−
148− realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
149− realDeps pdefsDeps = map convert pdefsDeps
150− where
151− varDict = variableToKeyMap pdefsDeps
152− convert (pdef, key, deps) =
153− (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
compiler/Transform/Substitute.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Transform.Substitute (subst) where
3−
4−import Control.Arrow (second, (***))
5−import SourceSyntax.Expression
6−import SourceSyntax.Location
7−import qualified SourceSyntax.Pattern as Pattern
8−import qualified Data.Set as Set
9−
10−subst :: String -> Expr -> Expr -> Expr
11−subst old new expr =
12− let f (L s e) = L s (subst old new e) in
13− case expr of
14− Range e1 e2 -> Range (f e1) (f e2)
15− ExplicitList es -> ExplicitList (map f es)
16− Binop op e1 e2 -> Binop op (f e1) (f e2)
17− Lambda p e
18− | Set.member old (Pattern.boundVars p) -> expr
19− | otherwise -> Lambda p (f e)
20− App e1 e2 -> App (f e1) (f e2)
21− MultiIf ps -> MultiIf (map (f *** f) ps)
22−
23− Let defs body
24− | anyShadow -> expr
25− | otherwise -> Let (map substDef defs) (f body)
26− where
27− substDef (Definition p e t) = Definition p (f e) t
28− anyShadow =
29− any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
30−
31− Var x -> if x == old then new else expr
32− Case e cases -> Case (f e) $ map (second f) cases
33− Data name es -> Data name (map f es)
34− Access e x -> Access (f e) x
35− Remove e x -> Remove (f e) x
36− Insert e x v -> Insert (f e) x (f v)
37− Modify r fs -> Modify (f r) (map (second f) fs)
38− Record fs -> Record (map (second f) fs)
39− Literal _ -> expr
40− Markdown uid md es -> Markdown uid md (map f es)
41− PortIn name st -> PortIn name st
42− PortOut name st signal -> PortOut name st (f signal)
compiler/Type/Alias.hsdeleted−139
@@ -1,139 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Alias (realias, rules, canonicalRealias, Rules) where
3−
4−import Control.Applicative ((<$>),(<*>))
5−import Control.Monad
6−import Control.Arrow (second)
7−import Data.Map ((!))
8−import qualified Data.Map as Map
9−import qualified Data.List as List
10−import SourceSyntax.Type
11−import SourceSyntax.Module
12−
13−type Rules = ([Alias], Type -> Type)
14−
15−rules interfaces moduleAliases moduleImports =
16− (collect interfaces moduleAliases, localizer moduleImports)
17−
18−collect interfaces moduleAliases =
19− filter (not . isPrimitive) rawAliases
20− where
21− rawAliases =
22− moduleAliases ++ concatMap iAliases (Map.elems interfaces)
23−
24− isPrimitive (_,_,tipe,_) =
25− case tipe of
26− Data _ [] -> True
27− _ -> False
28−
29−localizer moduleImports = go
30− where
31− go tipe =
32− case tipe of
33− Var _ -> tipe
34− Lambda t1 t2 -> Lambda (go t1) (go t2)
35− Data name ts -> Data (localize name) (map go ts)
36− Record fs ext -> Record (map (second go) fs) ext
37−
38− byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)
39− Map.empty moduleImports
40−
41− separate name =
42− case List.elemIndices '.' name of
43− [] -> ("",name)
44− is -> let i = last is in
45− (take i name, drop (i+1) name)
46−
47− shortest = List.minimumBy (\a b -> compare (length a) (length b))
48−
49− localize name = shortest (name : concatMap (localize' value) methods)
50− where (modul, value) = separate name
51− methods = Map.findWithDefault [] modul byMethod
52−
53− localize' name method =
54− case method of
55− As modul -> [modul ++ "." ++ name]
56− Hiding xs | name `notElem` xs -> [name]
57− Importing xs | name `elem` xs -> [name]
58− _ -> []
59−
60−realias :: Rules -> Type -> Type
61−realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
62−
63−-- Realias using canonical aliases, so results will have aliases
64−-- that are fully qualified and possible to compare.
65−canonicalRealias :: [Alias] -> Type -> Type
66−canonicalRealias aliases tipe =
67− case concatMap tryRealias aliases of
68− [] -> if tipe == tipe' then tipe else f tipe'
69− tipes -> f (bestType tipes)
70− where
71− tryRealias (name, args, aliasTipe, _) =
72− case diff aliasTipe tipe of
73− Nothing -> []
74− Just kvs ->
75− let holes = collectFields kvs
76− hasArgs = List.sort args == Map.keys holes
77− isConsistent = all allEqual (Map.elems holes)
78− in case hasArgs && isConsistent of
79− False -> []
80− True -> [Data name $ map (\arg -> head (holes ! arg)) args]
81−
82− f = canonicalRealias aliases
83− tipe' =
84− case tipe of
85− Var _ -> tipe
86− Lambda t1 t2 -> Lambda (f t1) (f t2)
87− Data name ts -> Data name (map f ts)
88− Record fs ext -> Record (map (second f) fs) ext
89−
90−allEqual [] = True
91−allEqual (x:xs) = all (==x) xs
92−
93−bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs
94− where
95− pairs :: [(Type,Int)]
96− pairs = zip tipes (map numFields tipes)
97−
98− numFields :: Type -> Int
99− numFields tipe =
100− case tipe of
101− Lambda t1 t2 -> numFields t1 + numFields t2
102− Var _ -> 0
103− Data _ ts -> sum (map numFields ts)
104− Record fields _ -> length fields + sum (map (numFields . snd) fields)
105−
106−diff :: Type -> Type -> Maybe [(String,Type)]
107−diff general specific =
108− case (general, specific) of
109− (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2
110− (Var x, t) -> Just [(x,t)]
111− (Data gname gts, Data sname sts)
112− | gname == sname && length gts == length sts ->
113− concat <$> zipWithM diff gts sts
114− (Record [] Nothing, Record [] Nothing) -> Just []
115− (Record _ _, Record [] Nothing) -> Nothing
116− (Record [] Nothing, Record _ _) -> Nothing
117− (Record gfs gext, Record sfs sext) ->
118− let gfields = collectFields gfs
119− sfields = collectFields sfs
120−
121− overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
122− isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)
123− in
124− case isAligned of
125− False -> Nothing
126− True -> let remaining = Map.difference sfields gfields
127− sext' = case sext of
128− Just x | Map.null remaining -> Var x
129− _ -> Record (flattenFields remaining) sext
130− gext' = maybe (Record [] Nothing) Var gext
131− matchMap = Map.intersectionWith (zipWith diff) gfields sfields
132− in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))
133− (_,_) -> Nothing
134−
135−collectFields fields =
136− foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields
137−
138−flattenFields fields =
139− concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)
compiler/Type/Constrain/Declaration.hsdeleted−63
@@ -1,63 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Type.Constrain.Declaration where
3−
4−import SourceSyntax.Declaration
5−import qualified SourceSyntax.Expression as E
6−import qualified SourceSyntax.Location as L
7−import qualified SourceSyntax.Pattern as P
8−import qualified SourceSyntax.Type as T
9−
10−toExpr :: [Declaration] -> [E.Def]
11−toExpr = concatMap toDefs
12−
13−toDefs :: Declaration -> [E.Def]
14−toDefs decl =
15− case decl of
16− Definition def -> [def]
17−
18− Datatype name tvars constructors _ -> concatMap toDefs' constructors
19− where
20− toDefs' (ctor, tipes) =
21− let vars = take (length tipes) arguments
22− tbody = T.Data name $ map T.Var tvars
23− body = L.none . E.Data ctor $ map (L.none . E.Var) vars
24− in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
25−
26− TypeAlias name _ tipe@(T.Record fields ext) _ ->
27− [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
28− where
29− args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
30−
31− var = L.none . E.Var
32− vars = take (length args) arguments
33−
34− efields = zip (map fst fields) (map var vars)
35− record = case ext of
36− Nothing -> L.none $ E.Record efields
37− Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
38−
39− -- Type aliases must be added to an extended equality dictionary,
40− -- but they do not require any basic constraints.
41− -- TODO: with the ability to derive code, you may need to generate stuff!
42− TypeAlias _ _ _ _ -> []
43−
44− Port port ->
45− case port of
46− Out name expr@(L.L s _) tipe ->
47− [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
48− In name tipe ->
49− [ definition name (L.none $ E.PortIn name tipe) tipe ]
50−
51− -- no constraints are needed for fixity declarations
52− Fixity _ _ _ -> []
53−
54−
55−arguments :: [String]
56−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
57−
58−buildFunction :: E.LExpr -> [String] -> E.LExpr
59−buildFunction body@(L.L s _) vars =
60− foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
61−
62−definition :: String -> E.LExpr -> T.Type -> E.Def
63−definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
compiler/Type/Constrain/Expression.hsdeleted−209
@@ -1,209 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Constrain.Expression where
3−
4−import qualified Data.List as List
5−import qualified Data.Map as Map
6−import qualified Data.Set as Set
7−import Control.Applicative ((<$>))
8−import qualified Control.Monad as Monad
9−import Control.Monad.Error
10−import qualified Text.PrettyPrint as PP
11−
12−import SourceSyntax.Location as Loc
13−import SourceSyntax.Pattern (Pattern(PVar), boundVars)
14−import SourceSyntax.Expression
15−import qualified SourceSyntax.Type as SrcT
16−import Type.Type hiding (Descriptor(..))
17−import Type.Fragment
18−import qualified Type.Environment as Env
19−import qualified Type.Constrain.Literal as Literal
20−import qualified Type.Constrain.Pattern as Pattern
21−
22−constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
23−constrain env (L span expr) tipe =
24− let list t = Env.get env Env.types "_List" <| t
25− and = L span . CAnd
26− true = L span CTrue
27− t1 === t2 = L span (CEqual t1 t2)
28− x <? t = L span (CInstance x t)
29− clet schemes c = L span (CLet schemes c)
30− in
31− case expr of
32− Literal lit -> liftIO $ Literal.constrain env span lit tipe
33−
34− Var name | name == saveEnvName -> return (L span CSaveEnv)
35− | otherwise -> return (name <? tipe)
36−
37− Range lo hi ->
38− exists $ \x -> do
39− clo <- constrain env lo x
40− chi <- constrain env hi x
41− return $ and [clo, chi, list x === tipe]
42−
43− ExplicitList exprs ->
44− exists $ \x -> do
45− cs <- mapM (\e -> constrain env e x) exprs
46− return . and $ list x === tipe : cs
47−
48− Binop op e1 e2 ->
49− exists $ \t1 ->
50− exists $ \t2 -> do
51− c1 <- constrain env e1 t1
52− c2 <- constrain env e2 t2
53− return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]
54−
55− Lambda p e ->
56− exists $ \t1 ->
57− exists $ \t2 -> do
58− fragment <- try span $ Pattern.constrain env p t1
59− c2 <- constrain env e t2
60− let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
61− (typeConstraint fragment /\ c2 ))
62− return $ c /\ tipe === (t1 ==> t2)
63−
64− App e1 e2 ->
65− exists $ \t -> do
66− c1 <- constrain env e1 (t ==> tipe)
67− c2 <- constrain env e2 t
68− return $ c1 /\ c2
69−
70− MultiIf branches -> and <$> mapM constrain' branches
71− where
72− bool = Env.get env Env.types "Bool"
73− constrain' (b,e) = do
74− cb <- constrain env b bool
75− ce <- constrain env e tipe
76− return (cb /\ ce)
77−
78− Case exp branches ->
79− exists $ \t -> do
80− ce <- constrain env exp t
81− let branch (p,e) = do
82− fragment <- try span $ Pattern.constrain env p t
83− clet [toScheme fragment] <$> constrain env e tipe
84− and . (:) ce <$> mapM branch branches
85−
86− Data name exprs ->
87− do vars <- forM exprs $ \_ -> liftIO (var Flexible)
88− let pairs = zip exprs (map VarN vars)
89− (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
90− return $ ex vars (cs /\ name <? ctipe)
91− where
92− step (t,c) (e,x) = do
93− c' <- constrain env e x
94− return (x ==> t, c /\ c')
95−
96− Access e label ->
97− exists $ \t ->
98− constrain env e (record (Map.singleton label [tipe]) t)
99−
100− Remove e label ->
101− exists $ \t ->
102− constrain env e (record (Map.singleton label [t]) tipe)
103−
104− Insert e label value ->
105− exists $ \tVal ->
106− exists $ \tRec -> do
107− cVal <- constrain env value tVal
108− cRec <- constrain env e tRec
109− let c = tipe === record (Map.singleton label [tVal]) tRec
110− return (and [cVal, cRec, c])
111−
112− Modify e fields ->
113− exists $ \t -> do
114− oldVars <- forM fields $ \_ -> liftIO (var Flexible)
115− let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
116− cOld <- ex oldVars <$> constrain env e (record oldFields t)
117−
118− newVars <- forM fields $ \_ -> liftIO (var Flexible)
119− let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
120− let cNew = tipe === record newFields t
121−
122− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
123−
124− return $ cOld /\ ex newVars (and (cNew : cs))
125−
126− Record fields ->
127− do vars <- forM fields $ \_ -> liftIO (var Flexible)
128− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
129− let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
130− recordType = record fields' (TermN EmptyRecord1)
131− return . ex vars . and $ tipe === recordType : cs
132−
133− Markdown _ _ es ->
134− do vars <- forM es $ \_ -> liftIO (var Flexible)
135− let tvars = map VarN vars
136− cs <- zipWithM (constrain env) es tvars
137− return . ex vars $ and ("Text.markdown" <? tipe : cs)
138−
139− Let defs body ->
140− do c <- constrain env body tipe
141− (schemes, rqs, fqs, header, c2, c1) <-
142− Monad.foldM (constrainDef env)
143− ([], [], [], Map.empty, true, true)
144− (concatMap expandPattern defs)
145− return $ clet schemes
146− (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
147− (c1 /\ c))
148−
149− PortIn _ _ -> return true
150−
151− PortOut _ _ signal ->
152− constrain env signal tipe
153−
154−constrainDef env info (Definition pattern expr maybeTipe) =
155− let qs = [] -- should come from the def, but I'm not sure what would live there...
156− (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
157− in
158− do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
159− -- Currently, qs is always [].
160− case (pattern, maybeTipe) of
161− (PVar name, Just tipe) -> do
162− flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
163− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
164− env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
165− (vars, typ) <- Env.instantiateType env tipe Map.empty
166− let scheme = Scheme { rigidQuantifiers = [],
167− flexibleQuantifiers = flexiVars ++ vars,
168− constraint = Loc.noneNoDocs CTrue,
169− header = Map.singleton name typ }
170− c <- constrain env' expr typ
171− return ( scheme : schemes
172− , rigidQuantifiers
173− , flexibleQuantifiers
174− , headers
175− , c2
176− , fl rigidVars c /\ c1 )
177−
178− (PVar name, Nothing) -> do
179− v <- liftIO $ var Flexible
180− let tipe = VarN v
181− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
182− env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
183− c <- constrain env' expr tipe
184− return ( schemes
185− , rigidVars ++ rigidQuantifiers
186− , v : flexibleQuantifiers
187− , Map.insert name tipe headers
188− , c /\ c2
189− , c1 )
190−
191− _ -> error (show pattern)
192−
193−expandPattern :: Def -> [Def]
194−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
195− case pattern of
196− PVar _ -> [def]
197− _ -> Definition (PVar x) lexpr maybeType : map toDef vars
198− where
199− vars = Set.toList $ boundVars pattern
200− x = "$" ++ concat vars
201− mkVar = L s . Var
202− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
203−
204−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
205−try span computation = do
206− result <- liftIO $ runErrorT computation
207− case result of
208− Left err -> throwError [err span]
209− Right value -> return value
compiler/Type/Constrain/Literal.hsdeleted−21
@@ -1,21 +0,0 @@
1−module Type.Constrain.Literal where
2−
3−import SourceSyntax.Literal
4−import SourceSyntax.Location
5−import Type.Type
6−import Type.Environment as Env
7−
8−constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
9−constrain env span literal tipe =
10− do tipe' <- litType
11− return . L span $ CEqual tipe tipe'
12− where
13− prim name = return (Env.get env Env.types name)
14−
15− litType =
16− case literal of
17− IntNum _ -> VarN `fmap` var (Is Number)
18− FloatNum _ -> prim "Float"
19− Chr _ -> prim "Char"
20− Str _ -> prim "String"
21− Boolean _ -> prim "Bool"
compiler/Type/Constrain/Pattern.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−module Type.Constrain.Pattern where
3−
4−import Control.Arrow (second)
5−import Control.Applicative ((<$>))
6−import qualified Control.Monad as Monad
7−import Control.Monad.Error
8−import qualified Data.Map as Map
9−import qualified Text.PrettyPrint as PP
10−
11−import SourceSyntax.Pattern
12−import SourceSyntax.Location
13−import SourceSyntax.PrettyPrint
14−import Text.PrettyPrint (render)
15−import qualified SourceSyntax.Location as Loc
16−import Type.Type
17−import Type.Fragment
18−import Type.Environment as Env
19−import qualified Type.Constrain.Literal as Literal
20−
21−
22−constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
23−constrain env pattern tipe =
24− let span = Loc.NoSpan (render $ pretty pattern)
25− t1 === t2 = Loc.L span (CEqual t1 t2)
26− x <? t = Loc.L span (CInstance x t)
27− in
28− case pattern of
29− PAnything -> return emptyFragment
30−
31− PLiteral lit -> do
32− c <- liftIO $ Literal.constrain env span lit tipe
33− return $ emptyFragment { typeConstraint = c }
34−
35− PVar name -> do
36− v <- liftIO $ var Flexible
37− return $ Fragment {
38− typeEnv = Map.singleton name (VarN v),
39− vars = [v],
40− typeConstraint = VarN v === tipe
41− }
42−
43− PAlias name p -> do
44− fragment <- constrain env p tipe
45− return $ fragment {
46− typeEnv = Map.insert name tipe (typeEnv fragment),
47− typeConstraint = name <? tipe /\ typeConstraint fragment
48− }
49−
50− PData name patterns -> do
51− (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
52− let msg = concat [ "Constructor '", name, "' expects ", show kind
53− , " argument", if kind == 1 then "" else "s"
54− , " but was given ", show (length patterns), "." ]
55− err span = PP.vcat [ PP.text $ "Type error " ++ show span
56− , PP.text msg ]
57− case length patterns == kind of
58− False -> throwError err
59− True -> do
60− fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
61− return $ fragment {
62− typeConstraint = typeConstraint fragment /\ tipe === result,
63− vars = cvars ++ vars fragment
64− }
65−
66− PRecord fields -> do
67− pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
68− let tenv = Map.fromList (map (second VarN) pairs)
69− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
70− return $ Fragment {
71− typeEnv = tenv,
72− vars = map snd pairs,
73− typeConstraint = c
74− }
75−
76−instance Error (SrcSpan -> PP.Doc) where
77− noMsg _ = PP.empty
78− strMsg str span =
79− PP.vcat [ PP.text $ "Type error " ++ show span
80− , PP.text str ]
compiler/Type/Environment.hsdeleted−170
@@ -1,170 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Environment where
3−
4−import Control.Applicative ((<$>), (<*>))
5−import Control.Exception (try, SomeException)
6−import Control.Monad
7−import Control.Monad.Trans.Error (ErrorList(..))
8−import Control.Monad.Error (ErrorT, throwError, liftIO)
9−import qualified Control.Monad.State as State
10−import qualified Data.Traversable as Traverse
11−import qualified Data.Map as Map
12−import Data.List (isPrefixOf)
13−import qualified Text.PrettyPrint as PP
14−
15−import qualified SourceSyntax.Type as Src
16−import SourceSyntax.Module (ADT, Alias)
17−import Type.Type
18−
19−type TypeDict = Map.Map String Type
20−type VarDict = Map.Map String Variable
21−
22−data Environment = Environment {
23− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
24− aliases :: Map.Map String ([String], Src.Type),
25− types :: TypeDict,
26− value :: TypeDict
27−}
28−
29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment
30−initialEnvironment datatypes aliases = do
31− types <- makeTypes datatypes
32− let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases
33− env = Environment {
34− constructor = Map.empty,
35− value = Map.empty,
36− types = types,
37− aliases = aliases' }
38−
39− return $ env { constructor = makeConstructors env datatypes }
40−
41−makeTypes :: [ADT] -> IO TypeDict
42−makeTypes datatypes =
43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
44− where
45− nameAndKind (name, tvars, _, _) = (name, length tvars)
46−
47− makeCtor (name, _) = do
48− ctor <- VarN <$> namedVar Constant name
49− return (name, ctor)
50−
51− tuple n = ("_Tuple" ++ show n, n)
52−
53− kind n names = map (\name -> (name, n)) names
54−
55− builtins :: [(String,Int)]
56− builtins = concat [ map tuple [0..9]
57− , kind 1 ["_List"]
58− , kind 0 ["Int","Float","Char","String","Bool"]
59− ]
60−
61−
62−makeConstructors :: Environment
63− -> [ADT]
64− -> Map.Map String (IO (Int, [Variable], [Type], Type))
65−makeConstructors env datatypes = Map.fromList builtins
66− where
67− list t = (types env Map.! "_List") <| t
68−
69− inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
70− inst numTVars tipe = do
71− vars <- forM [1..numTVars] $ \_ -> var Flexible
72− let (args, result) = tipe (map VarN vars)
73− return (length args, vars, args, result)
74−
75− tupleCtor n =
76− let name = "_Tuple" ++ show n
77− in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
78−
79− builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
80− builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
81− , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
82− ] ++ map tupleCtor [0..9]
83− ++ concatMap (ctorToType env) datatypes
84−
85−
86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
87−ctorToType env (name, tvars, ctors, _) =
88− zip (map fst ctors) (map inst ctors)
89− where
90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
91− inst ctor = do
92− ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
93− return (length args, Map.elems dict, args, tipe)
94−
95−
96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
97− go (_, args) = do
98− types <- mapM (instantiator env) args
99− returnType <- instantiator env (Src.Data name (map Src.Var tvars))
100− return (types, returnType)
101−
102−
103−get :: Environment -> (Environment -> Map.Map String a) -> String -> a
104−get env subDict key = Map.findWithDefault err key (subDict env)
105− where
106− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
107−
108−
109−freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
110−freshDataScheme env name = get env constructor name
111−
112−instance ErrorList PP.Doc where
113− listMsg str = [PP.text str]
114−
115−instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
116−instantiateType env sourceType dict =
117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))
118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of
119− Left someError -> throwError [ PP.text $ show someError ]
120− Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)
121−
122−instantiator :: Environment -> Src.Type
123− -> State.StateT (VarDict, TypeDict) IO Type
124−instantiator env sourceType = go sourceType
125− where
126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
127− go sourceType =
128− case sourceType of
129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
130−
131− Src.Var x -> do
132− (dict, aliases) <- State.get
133− case (Map.lookup x dict, Map.lookup x aliases) of
134− (_, Just t) -> return t
135− (Just v, _) -> return (VarN v)
136− _ ->
137− do var <- State.liftIO $ namedVar flex x
138− State.put (Map.insert x var dict, aliases)
139− return (VarN var)
140− where
141− flex | "number" `isPrefixOf` x = Is Number
142− | "comparable" `isPrefixOf` x = Is Comparable
143− | "appendable" `isPrefixOf` x = Is Appendable
144− | otherwise = Flexible
145−
146− Src.Data name ts -> do
147− ts' <- mapM go ts
148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of
149− (Just t, _) -> return $ foldl (<|) t ts'
150− (_, Just (tvars, t)) ->
151− let tvarLen = length tvars
152− msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++
153− " type argument" ++ (if tvarLen == 1 then "" else "s") ++
154− " but was given " ++ show (length ts')
155− in if length ts' /= length tvars then error msg else
156− do (dict, aliases) <- State.get
157− let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases
158− State.put (dict, aliases')
159− t' <- go t
160− State.put (dict, aliases)
161− return t'
162− _ -> error $ "\nCould not find type constructor '" ++
163− name ++ "' while checking types."
164−
165− Src.Record fields ext -> do
166− fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)
167− ext' <- case ext of
168− Nothing -> return $ TermN EmptyRecord1
169− Just x -> go (Src.Var x)
170− return $ TermN (Record1 fields' ext')
compiler/Type/ExtraChecks.hsdeleted−148
@@ -1,148 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.ExtraChecks (mainType, occurs, portTypes) where
3−-- This module contains checks to be run *after* type inference has
4−-- completed successfully. At that point we still need to do occurs
5−-- checks and ensure that `main` has an acceptable type.
6−
7−import Control.Applicative ((<$>),(<*>))
8−import Control.Monad.State
9−import qualified Data.List as List
10−import qualified Data.Map as Map
11−import qualified Data.UnionFind.IO as UF
12−import Type.Type ( Variable, structure, Term1(..), toSrcType )
13−import qualified Type.State as TS
14−import qualified Type.Alias as Alias
15−import Text.PrettyPrint as P
16−import SourceSyntax.PrettyPrint (pretty)
17−import qualified SourceSyntax.Helpers as Help
18−import qualified SourceSyntax.Type as T
19−import qualified SourceSyntax.Expression as E
20−import qualified SourceSyntax.Location as L
21−import qualified Transform.Expression as Expr
22−import qualified Data.Traversable as Traverse
23−
24−throw err = Left [ P.vcat err ]
25−
26−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
27−mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
28− where
29− mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
30− mainCheck rules env =
31− case Map.lookup "main" env of
32− Nothing -> Right env
33− Just mainType
34− | tipe `elem` acceptable -> Right env
35− | otherwise -> throw err
36− where
37− acceptable = [ "Graphics.Element.Element"
38− , "Signal.Signal Graphics.Element.Element" ]
39−
40− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
41− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
42− , P.text "Instead 'main' has type:\n"
43− , P.nest 4 . pretty $ Alias.realias rules mainType
44− , P.text " " ]
45−
46−data Direction = In | Out
47−
48−portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
49−portTypes rules expr =
50− const () <$> Expr.checkPorts (check In) (check Out) expr
51− where
52− check = isValid True False False
53− isValid isTopLevel seenFunc seenSignal direction name tipe =
54− case tipe of
55− T.Data ctor ts
56− | isJs ctor || isElm ctor -> mapM_ valid ts
57− | ctor == "Signal.Signal" -> handleSignal ts
58− | otherwise -> err' True "an unsupported type"
59−
60− T.Var _ -> err "free type variables"
61−
62− T.Lambda _ _ ->
63− case direction of
64− In -> err "functions"
65− Out | seenFunc -> err "higher-order functions"
66− | seenSignal -> err "signals that contain functions"
67− | otherwise ->
68− forM_ (T.collectLambdas tipe)
69− (isValid' True seenSignal direction name)
70−
71− T.Record _ (Just _) -> err "extended records with free type variables"
72−
73− T.Record fields Nothing ->
74− mapM_ (\(k,v) -> (,) k <$> valid v) fields
75−
76− where
77− isValid' = isValid False
78− valid = isValid' seenFunc seenSignal direction name
79−
80− isJs ctor =
81− List.isPrefixOf "JavaScript." ctor
82− && length (filter (=='.') ctor) == 1
83−
84− isElm ctor =
85− ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List"]
86− || Help.isTuple ctor
87−
88− handleSignal ts
89− | seenFunc = err "functions that involve signals"
90− | seenSignal = err "signals-of-signals"
91− | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts
92− | otherwise = err "a signal within a data stucture"
93−
94− dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
95− txt = P.text . concat
96−
97− err = err' False
98− err' couldBeAlias kind =
99− throw $
100− [ txt [ "Type Error: the value ", dir "coming in" "sent out"
101− , " through port '", name, "' is invalid." ]
102− , txt [ "It contains ", kind, ":\n" ]
103− , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
104− , txt [ "Acceptable values for ", dir "incoming" "outgoing"
105− , " ports include JavaScript values and" ]
106− , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
107− , txt [ "Lists, Tuples, ", dir "" "first-order functions, ", "and concrete records." ]
108− ] ++ if couldBeAlias then aliasWarning else []
109−
110− aliasWarning =
111− [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]
112− , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
113− ]
114−
115−occurs :: (String, Variable) -> StateT TS.SolverState IO ()
116−occurs (name, variable) =
117− do vars <- liftIO $ infiniteVars [] variable
118− case vars of
119− [] -> return ()
120− var:_ -> do
121− desc <- liftIO $ UF.descriptor var
122− case structure desc of
123− Nothing ->
124− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
125− Just _ ->
126− do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
127− var' <- liftIO $ UF.fresh desc
128− TS.addError (L.NoSpan name) (Just msg) var var'
129− where
130− msg = "Infinite types are not allowed"
131− fallback _ = return $ P.text msg
132−
133− infiniteVars :: [Variable] -> Variable -> IO [Variable]
134− infiniteVars seen var =
135− let go = infiniteVars (var:seen) in
136− if var `elem` seen
137− then return [var]
138− else do
139− desc <- UF.descriptor var
140− case structure desc of
141− Nothing -> return []
142− Just struct ->
143− case struct of
144− App1 a b -> (++) <$> go a <*> go b
145− Fun1 a b -> (++) <$> go a <*> go b
146− Var1 a -> go a
147− EmptyRecord1 -> return []
148− Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
compiler/Type/Fragment.hsdeleted−28
@@ -1,28 +0,0 @@
1−module Type.Fragment where
2−
3−import qualified Data.List as List
4−import qualified Data.Map as Map
5−
6−import Type.Type
7−import SourceSyntax.Pattern
8−import SourceSyntax.Location (noneNoDocs)
9−
10−data Fragment = Fragment {
11− typeEnv :: Map.Map String Type,
12− vars :: [Variable],
13− typeConstraint :: TypeConstraint
14−} deriving Show
15−
16−emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
17−
18−joinFragment f1 f2 = Fragment {
19− typeEnv = Map.union (typeEnv f1) (typeEnv f2),
20− vars = vars f1 ++ vars f2,
21− typeConstraint = typeConstraint f1 /\ typeConstraint f2
22−}
23−
24−joinFragments = List.foldl' (flip joinFragment) emptyFragment
25−
26−
27−toScheme fragment =
28− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
compiler/Type/Inference.hsdeleted−57
@@ -1,57 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Inference where
3−
4−import qualified Data.Map as Map
5−
6−import qualified Type.Type as T
7−import qualified Type.Environment as Env
8−import qualified Type.Constrain.Expression as TcExpr
9−import qualified Type.Solve as Solve
10−
11−import SourceSyntax.Module as Module
12−import SourceSyntax.Location (noneNoDocs)
13−import SourceSyntax.Type (Type)
14−import Text.PrettyPrint
15−import qualified Type.State as TS
16−import qualified Type.ExtraChecks as Check
17−import Control.Monad.State (execStateT, forM)
18−import Control.Monad.Error (runErrorT, liftIO)
19−import qualified Type.Alias as Alias
20−
21−import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
22− -- the IO monad. I don't think that'd be worthwhile.
23−
24−
25−infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)
26−infer interfaces modul = unsafePerformIO $ do
27− env <- Env.initialEnvironment
28− (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
29− (aliases modul ++ concatMap iAliases (Map.elems interfaces))
30− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
31− do (_, vars, args, result) <- Env.freshDataScheme env name
32− return (name, (vars, foldr (T.==>) result args))
33−
34− attemptConstraint <- runErrorT $ do
35− importedVars <-
36− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
37− (,) name `fmap` Env.instantiateType env tipe Map.empty
38−
39− let allTypes = ctors ++ importedVars
40− vars = concatMap (fst . snd) allTypes
41− header = Map.map snd (Map.fromList allTypes)
42− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
43−
44− fvar <- liftIO $ T.var T.Flexible
45− c <- TcExpr.constrain env (program modul) (T.VarN fvar)
46− return (header, environ c)
47−
48− case attemptConstraint of
49− Left err -> return $ Left err
50− Right (header, constraint) -> do
51− state <- execStateT (Solve.solve constraint) TS.initialState
52− let rules = Alias.rules interfaces (aliases modul) (imports modul)
53− case TS.sErrors state of
54− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
55− [] -> case Check.portTypes rules (program modul) of
56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)
57− Left err -> return (Left err)
compiler/Type/PrettyPrint.hsdeleted−16
@@ -1,16 +0,0 @@
1−
2−module Type.PrettyPrint where
3−
4−import Text.PrettyPrint
5−import qualified SourceSyntax.PrettyPrint as Src
6−
7−data ParensWhen = Fn | App | Never
8−
9−class PrettyType a where
10− pretty :: ParensWhen -> a -> Doc
11−
12−commaSep docs = sep (punctuate comma docs)
13−
14−parensIf bool doc = if bool then parens doc else doc
15−
16−reprime = Src.reprime
compiler/Type/Solve.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Solve (solve) where
3−
4−import Control.Monad
5−import Control.Monad.State
6−import qualified Data.UnionFind.IO as UF
7−import qualified Data.Map as Map
8−import qualified Data.Traversable as Traversable
9−import qualified Data.List as List
10−import Type.Type
11−import Type.Unify
12−import qualified Type.ExtraChecks as Check
13−import qualified Type.State as TS
14−import SourceSyntax.Location (Located(L), SrcSpan)
15−
16−
17−-- | Every variable has rank less than or equal to the maxRank of the pool.
18−-- This sorts variables into the young and old pools accordingly.
19−generalize :: TS.Pool -> StateT TS.SolverState IO ()
20−generalize youngPool = do
21− youngMark <- TS.uniqueMark
22− let youngRank = TS.maxRank youngPool
23− insert dict var = do
24− desc <- liftIO $ UF.descriptor var
25− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })
26− return $ Map.insertWith (++) (rank desc) [var] dict
27−
28− -- Sort the youngPool variables by rank.
29− rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)
30−
31− -- get the ranks right for each entry.
32− -- start at low ranks so that we only have to pass
33− -- over the information once.
34− visitedMark <- TS.uniqueMark
35− mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)
36−
37− -- For variables that have rank lowerer than youngRank, register them in
38− -- the old pool if they are not redundant.
39− let registerIfNotRedundant var = do
40− isRedundant <- liftIO $ UF.redundant var
41− if isRedundant then return var else TS.register var
42−
43− let rankDict' = Map.delete youngRank rankDict
44− Traversable.traverse (mapM registerIfNotRedundant) rankDict'
45−
46− -- For variables with rank youngRank
47− -- If rank < youngRank: register in oldPool
48− -- otherwise generalize
49− let registerIfLowerRank var = do
50− isRedundant <- liftIO $ UF.redundant var
51− case isRedundant of
52− True -> return ()
53− False -> do
54− desc <- liftIO $ UF.descriptor var
55− case rank desc < youngRank of
56− True -> TS.register var >> return ()
57− False -> do
58− let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
59− liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
60−
61− mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
62−
63−
64−-- adjust the ranks of variables such that ranks never increase as you
65−-- move deeper into a variable.
66−adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int
67−adjustRank youngMark visitedMark groupRank variable =
68− let adjust = adjustRank youngMark visitedMark groupRank in
69− do desc <- liftIO $ UF.descriptor variable
70− case () of
71− () | mark desc == youngMark ->
72− do -- Set the variable as marked first because it may be cyclic.
73− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }
74− rank' <- case structure desc of
75− Nothing -> return groupRank
76− Just term ->
77− case term of
78− App1 a b -> max `liftM` adjust a `ap` adjust b
79− Fun1 a b -> max `liftM` adjust a `ap` adjust b
80− Var1 x -> adjust x
81− EmptyRecord1 -> return outermostRank
82− Record1 fields extension ->
83− do ranks <- mapM adjust (concat (Map.elems fields))
84− rnk <- adjust extension
85− return . maximum $ rnk : ranks
86− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { rank = rank' }
87− return rank'
88−
89− | mark desc /= visitedMark ->
90− do let rank' = min groupRank (rank desc)
91− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })
92− return rank'
93−
94− | otherwise -> return (rank desc)
95−
96−
97−
98−solve :: TypeConstraint -> StateT TS.SolverState IO ()
99−solve (L span constraint) =
100− case constraint of
101− CTrue -> return ()
102−
103− CSaveEnv -> TS.saveLocalEnv
104−
105− CEqual term1 term2 -> do
106− t1 <- TS.flatten term1
107− t2 <- TS.flatten term2
108− unify span t1 t2
109−
110− CAnd cs -> mapM_ solve cs
111−
112− CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
113− oldEnv <- TS.getEnv
114− mapM TS.introduce fqs
115− solve constraint'
116− TS.modifyEnv (\_ -> oldEnv)
117−
118− CLet schemes constraint' -> do
119− oldEnv <- TS.getEnv
120− headers <- Map.unions `fmap` mapM (solveScheme span) schemes
121− TS.modifyEnv $ \env -> Map.union headers env
122− solve constraint'
123− mapM Check.occurs $ Map.toList headers
124− TS.modifyEnv (\_ -> oldEnv)
125−
126− CInstance name term -> do
127− env <- TS.getEnv
128− freshCopy <-
129− case Map.lookup name env of
130− Just tipe -> TS.makeInstance tipe
131− Nothing
132− | List.isPrefixOf "Native." name -> liftIO (var Flexible)
133− | otherwise ->
134− error ("Could not find '" ++ name ++ "' when solving type constraints.")
135−
136− t <- TS.flatten term
137− unify span freshCopy t
138−
139−solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
140−solveScheme span scheme =
141− case scheme of
142− Scheme [] [] constraint header -> do
143− solve constraint
144− Traversable.traverse TS.flatten header
145−
146− Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do
147− let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
148− oldPool <- TS.getPool
149−
150− -- fill in a new pool when working on this scheme's constraints
151− freshPool <- TS.nextRankPool
152− TS.switchToPool freshPool
153− mapM TS.introduce quantifiers
154− header' <- Traversable.traverse TS.flatten header
155− solve constraint
156−
157− allDistinct span rigidQuantifiers
158− youngPool <- TS.getPool
159− TS.switchToPool oldPool
160− generalize youngPool
161− mapM (isGeneric span) rigidQuantifiers
162− return header'
163−
164−
165−-- Checks that all of the given variables belong to distinct equivalence classes.
166−-- Also checks that their structure is Nothing, so they represent a variable, not
167−-- a more complex term.
168−allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
169−allDistinct span vars = do
170− seen <- TS.uniqueMark
171− let check var = do
172− desc <- liftIO $ UF.descriptor var
173− case structure desc of
174− Just _ -> TS.addError span (Just msg) var var
175− where msg = "Cannot generalize something that is not a type variable."
176−
177− Nothing -> do
178− if mark desc == seen
179− then let msg = "Duplicate variable during generalization."
180− in TS.addError span (Just msg) var var
181− else return ()
182− liftIO $ UF.setDescriptor var (desc { mark = seen })
183− mapM_ check vars
184−
185−-- Check that a variable has rank == noRank, meaning that it can be generalized.
186−isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
187−isGeneric span var = do
188− desc <- liftIO $ UF.descriptor var
189− if rank desc == noRank
190− then return ()
191− else let msg = "Unable to generalize a type variable. It is not unranked."
192− in TS.addError span (Just msg) var var
compiler/Type/State.hsdeleted−204
@@ -1,204 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.State where
3−
4−import Type.Type
5−import qualified Data.Map as Map
6−import qualified Data.UnionFind.IO as UF
7−import Control.Monad.State
8−import Control.Applicative ((<$>),(<*>), Applicative)
9−import qualified Data.Traversable as Traversable
10−import Text.PrettyPrint as P
11−import SourceSyntax.PrettyPrint
12−import SourceSyntax.Location
13−import qualified Type.Alias as Alias
14−
15−-- Pool
16−-- Holds a bunch of variables
17−-- The rank of each variable is less than or equal to the pool's "maxRank"
18−-- The young pool exists to make it possible to identify these vars in constant time.
19−
20−data Pool = Pool {
21− maxRank :: Int,
22− inhabitants :: [Variable]
23−} deriving Show
24−
25−emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
26−
27−type Env = Map.Map String Variable
28−
29−-- Keeps track of the environment, type variable pool, and a list of errors
30−data SolverState = SS {
31− sEnv :: Env,
32− sSavedEnv :: Env,
33− sPool :: Pool,
34− sMark :: Int,
35− sErrors :: [Alias.Rules -> IO P.Doc]
36−}
37−
38−initialState = SS {
39− sEnv = Map.empty,
40− sSavedEnv = Map.empty,
41− sPool = emptyPool,
42− sMark = noMark + 1, -- The mark must never be equal to noMark!
43− sErrors = []
44−}
45−
46−modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
47−modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
48−
49−addError span hint t1 t2 =
50− modify $ \state -> state { sErrors = makeError : sErrors state }
51− where
52− makeError rules = do
53− let prettiest = pretty . Alias.realias rules
54− t1' <- prettiest <$> toSrcType t1
55− t2' <- prettiest <$> toSrcType t2
56− return . P.vcat $
57− [ P.text $ "Type error" ++ location ++ ":"
58− , maybe P.empty P.text hint
59− , display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
60− , P.text " Expected Type:" <+> t1'
61− , P.text " Actual Type:" <+> t2'
62− ]
63−
64− location = case span of
65− NoSpan _ -> ""
66− Span p1 p2 _ ->
67− if line p1 == line p2 then " on line " ++ show (line p1)
68− else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
69−
70− display msg =
71− P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
72− , P.text " " ]
73−
74−
75−switchToPool pool = modifyPool (\_ -> pool)
76−
77−getPool :: StateT SolverState IO Pool
78−getPool = sPool <$> get
79−
80−getEnv :: StateT SolverState IO Env
81−getEnv = sEnv <$> get
82−
83−saveLocalEnv :: StateT SolverState IO ()
84−saveLocalEnv = do
85− env <- sEnv <$> get
86− modify $ \state -> state { sSavedEnv = env }
87−
88−uniqueMark :: StateT SolverState IO Int
89−uniqueMark = do
90− state <- get
91− let mark = sMark state
92− put $ state { sMark = mark + 1 }
93− return mark
94−
95−nextRankPool :: StateT SolverState IO Pool
96−nextRankPool = do
97− pool <- getPool
98− return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
99−
100−register :: Variable -> StateT SolverState IO Variable
101−register variable = do
102− modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
103− return variable
104−
105−introduce :: Variable -> StateT SolverState IO Variable
106−introduce variable = do
107− pool <- getPool
108− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
109− register variable
110−
111−flatten :: Type -> StateT SolverState IO Variable
112−flatten term =
113− case term of
114− VarN v -> return v
115− TermN t -> do
116− flatStructure <- traverseTerm flatten t
117− pool <- getPool
118− var <- liftIO . UF.fresh $ Descriptor {
119− structure = Just flatStructure,
120− rank = maxRank pool,
121− flex = Flexible,
122− name = Nothing,
123− copy = Nothing,
124− mark = noMark
125− }
126− register var
127−
128−makeInstance :: Variable -> StateT SolverState IO Variable
129−makeInstance var = do
130− alreadyCopied <- uniqueMark
131− freshVar <- makeCopy alreadyCopied var
132− restore alreadyCopied var
133− return freshVar
134−
135−makeCopy :: Int -> Variable -> StateT SolverState IO Variable
136−makeCopy alreadyCopied variable = do
137− desc <- liftIO $ UF.descriptor variable
138− case () of
139− () | mark desc == alreadyCopied ->
140− case copy desc of
141− Just v -> return v
142− Nothing -> error $ "Error copying type variable. This should be impossible." ++
143− " Please report an error to the github repo!"
144−
145− | rank desc /= noRank || flex desc == Constant ->
146− return variable
147−
148− | otherwise -> do
149− pool <- getPool
150− newVar <- liftIO $ UF.fresh $ Descriptor {
151− structure = Nothing,
152− rank = maxRank pool,
153− mark = noMark,
154− flex = case flex desc of
155− Is s -> Is s
156− _ -> Flexible,
157− copy = Nothing,
158− name = case flex desc of
159− Rigid -> Nothing
160− _ -> name desc
161− }
162− register newVar
163−
164− -- Link the original variable to the new variable. This lets us
165− -- avoid making multiple copies of the variable we are instantiating.
166− --
167− -- Need to do this before recursively copying the structure of
168− -- the variable to avoid looping on cyclic terms.
169− liftIO $ UF.modifyDescriptor variable $ \desc ->
170− desc { mark = alreadyCopied, copy = Just newVar }
171−
172− -- Now we recursively copy the structure of the variable.
173− -- We have already marked the variable as copied, so we
174− -- will not repeat this work or crawl this variable again.
175− case structure desc of
176− Nothing -> return newVar
177− Just term -> do
178− newTerm <- traverseTerm (makeCopy alreadyCopied) term
179− liftIO $ UF.modifyDescriptor newVar $ \desc ->
180− desc { structure = Just newTerm }
181− return newVar
182−
183−restore :: Int -> Variable -> StateT SolverState IO Variable
184−restore alreadyCopied variable = do
185− desc <- liftIO $ UF.descriptor variable
186− if mark desc /= alreadyCopied
187− then return variable
188− else do
189− restoredStructure <-
190− Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
191− liftIO $ UF.modifyDescriptor variable $ \desc ->
192− desc { mark = noMark, rank = noRank, structure = restoredStructure }
193− return variable
194−
195−traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
196−traverseTerm f term =
197− case term of
198− App1 a b -> App1 <$> f a <*> f b
199− Fun1 a b -> Fun1 <$> f a <*> f b
200− Var1 x -> Var1 <$> f x
201− EmptyRecord1 -> return EmptyRecord1
202− Record1 fields ext ->
203− Record1 <$> Traversable.traverse (mapM f) fields <*> f ext
204−
compiler/Type/Type.hsdeleted−401
@@ -1,401 +0,0 @@
1−module Type.Type where
2−
3−import qualified Data.Char as Char
4−import qualified Data.List as List
5−import qualified Data.Map as Map
6−import qualified Data.UnionFind.IO as UF
7−import Type.PrettyPrint
8−import Text.PrettyPrint as P
9−import System.IO.Unsafe
10−import Control.Applicative ((<$>),(<*>))
11−import Control.Monad.State
12−import Control.Monad.Error
13−import Data.Traversable (traverse)
14−import SourceSyntax.Location
15−import SourceSyntax.Helpers (isTuple)
16−import qualified SourceSyntax.Type as Src
17−
18−data Term1 a
19− = App1 a a
20− | Fun1 a a
21− | Var1 a
22− | EmptyRecord1
23− | Record1 (Map.Map String [a]) a
24− deriving Show
25−
26−data TermN a
27− = VarN a
28− | TermN (Term1 (TermN a))
29− deriving Show
30−
31−record :: Map.Map String [TermN a] -> TermN a -> TermN a
32−record fs rec = TermN (Record1 fs rec)
33−
34−type Type = TermN Variable
35−type Variable = UF.Point Descriptor
36−
37−type SchemeName = String
38−type TypeName = String
39−
40−type Constraint a b = Located (BasicConstraint a b)
41−data BasicConstraint a b
42− = CTrue
43− | CSaveEnv
44− | CEqual a a
45− | CAnd [Constraint a b]
46− | CLet [Scheme a b] (Constraint a b)
47− | CInstance SchemeName a
48− deriving Show
49−
50−data Scheme a b = Scheme {
51− rigidQuantifiers :: [b],
52− flexibleQuantifiers :: [b],
53− constraint :: Constraint a b,
54− header :: Map.Map String a
55−} deriving Show
56−
57−type TypeConstraint = Constraint Type Variable
58−type TypeScheme = Scheme Type Variable
59−
60−monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
61−
62−infixl 8 /\
63−
64−(/\) :: Constraint a b -> Constraint a b -> Constraint a b
65−a@(L _ c1) /\ b@(L _ c2) =
66− case (c1, c2) of
67− (CTrue, _) -> b
68− (_, CTrue) -> a
69− _ -> mergeOldDocs a b (CAnd [a,b])
70−
71−infixr 9 ==>
72−(==>) :: Type -> Type -> Type
73−a ==> b = TermN (Fun1 a b)
74−
75−f <| a = TermN (App1 f a)
76−
77−data Descriptor = Descriptor {
78− structure :: Maybe (Term1 Variable),
79− rank :: Int,
80− flex :: Flex,
81− name :: Maybe TypeName,
82− copy :: Maybe Variable,
83− mark :: Int
84−} deriving Show
85−
86−noRank = -1
87−outermostRank = 0 :: Int
88−
89−noMark = 0
90−initialMark = 1
91−
92−data Flex = Rigid | Flexible | Constant | Is SuperType
93− deriving (Show, Eq)
94−
95−data SuperType = Number | Comparable | Appendable
96− deriving (Show, Eq)
97−
98−namedVar :: Flex -> String -> IO Variable
99−namedVar flex name = UF.fresh $ Descriptor {
100− structure = Nothing,
101− rank = noRank,
102− flex = flex,
103− name = Just name,
104− copy = Nothing,
105− mark = noMark
106− }
107−
108−var :: Flex -> IO Variable
109−var flex = UF.fresh $ Descriptor {
110− structure = Nothing,
111− rank = noRank,
112− flex = flex,
113− name = Nothing,
114− copy = Nothing,
115− mark = noMark
116− }
117−
118−structuredVar :: Term1 Variable -> IO Variable
119−structuredVar structure = UF.fresh $ Descriptor {
120− structure = Just structure,
121− rank = noRank,
122− flex = Flexible,
123− name = Nothing,
124− copy = Nothing,
125− mark = noMark
126− }
127−
128−
129−-- ex qs constraint == exists qs. constraint
130−ex :: [Variable] -> TypeConstraint -> TypeConstraint
131−ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
132−
133−-- fl qs constraint == forall qs. constraint
134−fl :: [Variable] -> TypeConstraint -> TypeConstraint
135−fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
136−
137−exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
138−exists f = do
139− v <- liftIO $ var Flexible
140− ex [v] <$> f (VarN v)
141−
142−
143−instance Show a => Show (UF.Point a) where
144− show point = unsafePerformIO $ fmap show (UF.descriptor point)
145−
146−
147−instance PrettyType a => PrettyType (UF.Point a) where
148− pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
149−
150−
151−instance PrettyType a => PrettyType (Located a) where
152− pretty when (L _ e) = pretty when e
153−
154−
155−instance PrettyType a => PrettyType (Term1 a) where
156− pretty when term =
157− let prty = pretty Never in
158− case term of
159− App1 f x | P.render px == "_List" -> P.brackets (pretty Never x)
160− | otherwise -> parensIf needed (px <+> pretty App x)
161− where
162− px = prty f
163− needed = case when of
164− App -> True
165− _ -> False
166−
167− Fun1 arg body ->
168− parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)
169− where
170− needed = case when of
171− Never -> False
172− _ -> True
173−
174− Var1 x -> prty x
175−
176− EmptyRecord1 -> P.braces P.empty
177−
178− Record1 fields ext -> P.braces (extend <+> commaSep prettyFields)
179− where
180− prettyExt = prty ext
181− extend | P.render prettyExt == "{}" = P.empty
182− | otherwise = prettyExt <+> P.text "|"
183− mkPretty f t = P.text (reprime f) <+> P.text ":" <+> prty t
184− prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
185−
186−
187−instance PrettyType a => PrettyType (TermN a) where
188− pretty when term =
189− case term of
190− VarN x -> pretty when x
191− TermN t1 -> pretty when t1
192−
193−
194−instance PrettyType Descriptor where
195− pretty when desc =
196− case (structure desc, name desc) of
197− (Just term, _) -> pretty when term
198− (_, Just name) -> if not (isTuple name) then P.text (reprime name) else
199− P.parens . P.text $ replicate (read (drop 6 name) - 1) ','
200− _ -> P.text "?"
201−
202−
203−instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
204− pretty _ constraint =
205− let prty = pretty Never in
206− case constraint of
207− CTrue -> P.text "True"
208− CSaveEnv -> P.text "SaveTheEnvironment!!!"
209− CEqual a b -> prty a <+> P.text "=" <+> prty b
210− CAnd [] -> P.text "True"
211−
212− CAnd cs ->
213− P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
214−
215− CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
216− P.sep [ binder, pretty Never c ]
217− where
218− mergeExists vs (L _ c) =
219− case c of
220− CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
221− _ -> (vs, c)
222−
223− (fqs', c) = mergeExists fqs constraint
224−
225− binder = if null fqs' then P.empty else
226− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
227−
228− CLet schemes constraint ->
229− P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
230− , P.text "in", pretty Never constraint ]
231−
232− CInstance name tipe ->
233− P.text name <+> P.text "<" <+> prty tipe
234−
235−instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
236− pretty _ (Scheme rqs fqs (L _ constraint) headers) =
237− P.sep [ forall, cs, headers' ]
238− where
239− prty = pretty Never
240−
241− forall = if null rqs && null fqs then P.empty else
242− P.text "\x2200" <+> frees <+> rigids
243−
244− frees = P.hsep $ map prty fqs
245− rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
246−
247− cs = case constraint of
248− CTrue -> P.empty
249− CAnd [] -> P.empty
250− _ -> P.brackets (pretty Never constraint)
251−
252− headers' = if Map.size headers > 0 then dict else P.empty
253− dict = P.parens . commaSep . map prettyPair $ Map.toList headers
254− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t
255−
256−
257−extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
258−extraPretty t = pretty Never <$> addNames t
259−
260−addNames :: (Crawl t) => t -> IO t
261−addNames value = do
262− (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)
263− let vars = map head . List.group $ List.sort rawVars
264− suffix s = map (++s) (map (:[]) ['a'..'z'])
265− allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]
266− okayVars = filter (`notElem` vars) allVars
267− runStateT (crawl rename value) (okayVars, 0, 0, 0)
268− return value
269− where
270− getNames desc state@(vars, a, b, c) =
271− let name' = name desc in
272− case name' of
273− Just var -> (name', (var:vars, a, b, c))
274− Nothing -> (name', state)
275−
276− rename desc state@(vars, a, b, c) =
277− case name desc of
278− Just var -> (Just var, state)
279− Nothing ->
280− case flex desc of
281− Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))
282− Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))
283− Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))
284− other -> (Just $ head vars, (tail vars, a, b, c))
285− where mark = case other of
286− Flexible -> ""
287− Rigid -> "!"
288− Constant -> "#"
289−
290−
291−type CrawlState = ([String], Int, Int, Int)
292−
293−-- Code for traversing all the type data-structures and giving
294−-- names to the variables embedded deep in there.
295−class Crawl t where
296− crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))
297− -> t
298− -> StateT CrawlState IO t
299−
300−instance Crawl a => Crawl (Located a) where
301− crawl nextState (L s e) = L s <$> crawl nextState e
302−
303−instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
304− crawl nextState constraint =
305− let rnm = crawl nextState in
306− case constraint of
307− CTrue -> return CTrue
308− CSaveEnv -> return CSaveEnv
309− CEqual a b -> CEqual <$> rnm a <*> rnm b
310− CAnd cs -> CAnd <$> crawl nextState cs
311− CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
312− CInstance name tipe -> CInstance name <$> rnm tipe
313−
314−instance Crawl a => Crawl [a] where
315− crawl nextState list = mapM (crawl nextState) list
316−
317−instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
318− crawl nextState (Scheme rqs fqs c headers) =
319− let rnm = crawl nextState in
320− Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers
321−
322−instance Crawl t => Crawl (TermN t) where
323− crawl nextState tipe =
324− case tipe of
325− VarN x -> VarN <$> crawl nextState x
326− TermN term -> TermN <$> crawl nextState term
327−
328−instance Crawl t => Crawl (Term1 t) where
329− crawl nextState term =
330− let rnm = crawl nextState in
331− case term of
332− App1 a b -> App1 <$> rnm a <*> rnm b
333− Fun1 a b -> Fun1 <$> rnm a <*> rnm b
334− Var1 a -> Var1 <$> rnm a
335− EmptyRecord1 -> return EmptyRecord1
336− Record1 fields ext ->
337− Record1 <$> traverse (mapM rnm) fields <*> rnm ext
338−
339−instance Crawl a => Crawl (UF.Point a) where
340− crawl nextState point = do
341− desc <- liftIO $ UF.descriptor point
342− desc' <- crawl nextState desc
343− liftIO $ UF.setDescriptor point desc'
344− return point
345−
346−instance Crawl Descriptor where
347− crawl nextState desc = do
348− state <- get
349− let (name', state') = nextState desc state
350− structure' <- traverse (crawl nextState) (structure desc)
351− put state'
352− return $ desc { name = name', structure = structure' }
353−
354−
355−toSrcType :: Variable -> IO Src.Type
356−toSrcType variable = do
357− desc <- UF.descriptor =<< addNames variable
358− case structure desc of
359− Just term ->
360− case term of
361− App1 a b -> do
362− Src.Data name ts <- toSrcType a
363− b' <- toSrcType b
364− return (Src.Data name (ts ++ [b']))
365− Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
366− Var1 a -> toSrcType a
367− EmptyRecord1 -> return $ Src.Record [] Nothing
368− Record1 tfields extension -> do
369− fields' <- traverse (mapM toSrcType) tfields
370− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
371− ext' <- toSrcType extension
372− return $ case ext' of
373− Src.Record fs ext -> Src.Record (fs ++ fields) ext
374− Src.Var x -> Src.Record fields (Just x)
375− _ -> error "Used toSrcType on a type that is not well-formed"
376− Nothing ->
377− case name desc of
378− Just x@(c:_) | Char.isLower c -> return (Src.Var x)
379− | otherwise -> return (Src.Data x [])
380− _ -> error $ concat
381− [ "Problem converting the following type "
382− , "from a type-checker type to a source-syntax type:"
383− , P.render (pretty Never variable) ]
384−
385−data AppStructure = List Variable | Tuple [Variable] | Other
386−
387−collectApps :: Variable -> IO AppStructure
388−collectApps variable = go [] variable
389− where
390− go vars variable = do
391− desc <- UF.descriptor variable
392− case (structure desc, vars) of
393− (Nothing, [v]) -> case name desc of
394− Just "_List" -> return (List v)
395− _ -> return Other
396− (Nothing, vs) -> case name desc of
397− Just ctor | isTuple ctor -> return (Tuple vs)
398− _ -> return Other
399− (Just term, _) -> case term of
400− App1 a b -> go (vars ++ [b]) a
401− _ -> return Other
compiler/Type/Unify.hsdeleted−200
@@ -1,200 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Unify (unify) where
3−
4−import Type.Type
5−import qualified Data.UnionFind.IO as UF
6−import qualified Data.Map as Map
7−import qualified Data.Maybe as Maybe
8−import qualified Type.State as TS
9−import Control.Monad.State
10−import SourceSyntax.Location
11−import Type.PrettyPrint
12−import Text.PrettyPrint (render)
13−
14−unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
15−unify span variable1 variable2 = do
16− equivalent <- liftIO $ UF.equivalent variable1 variable2
17− if equivalent then return ()
18− else actuallyUnify span variable1 variable2
19−
20−actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
21−actuallyUnify span variable1 variable2 = do
22− desc1 <- liftIO $ UF.descriptor variable1
23− desc2 <- liftIO $ UF.descriptor variable2
24− let unify' = unify span
25−
26− name' :: Maybe String
27− name' = case (name desc1, name desc2) of
28− (Just name1, Just name2) ->
29− case (flex desc1, flex desc2) of
30− (_, Flexible) -> Just name1
31− (Flexible, _) -> Just name2
32− (Is Number, Is _) -> Just name1
33− (Is _, Is Number) -> Just name2
34− (Is _, Is _) -> Just name1
35− (_, _) -> Nothing
36− (Just name1, _) -> Just name1
37− (_, Just name2) -> Just name2
38− _ -> Nothing
39−
40− flex' :: Flex
41− flex' = case (flex desc1, flex desc2) of
42− (f, Flexible) -> f
43− (Flexible, f) -> f
44− (Is Number, Is _) -> Is Number
45− (Is _, Is Number) -> Is Number
46− (Is super, Is _) -> Is super
47− (_, _) -> Flexible
48−
49− rank' :: Int
50− rank' = min (rank desc1) (rank desc2)
51−
52− merge1 :: StateT TS.SolverState IO ()
53− merge1 = liftIO $ do
54− if rank desc1 < rank desc2 then UF.union variable2 variable1
55− else UF.union variable1 variable2
56− UF.modifyDescriptor variable1 $ \desc ->
57− desc { structure = structure desc1, flex = flex', name = name' }
58−
59− merge2 :: StateT TS.SolverState IO ()
60− merge2 = liftIO $ do
61− if rank desc1 < rank desc2 then UF.union variable2 variable1
62− else UF.union variable1 variable2
63− UF.modifyDescriptor variable2 $ \desc ->
64− desc { structure = structure desc2, flex = flex', name = name' }
65−
66− merge = if rank desc1 < rank desc2 then merge1 else merge2
67−
68− fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
69− fresh structure = do
70− var <- liftIO . UF.fresh $ Descriptor {
71− structure = structure, rank = rank', flex = flex',
72− name = name', copy = Nothing, mark = noMark
73− }
74− TS.register var
75−
76− flexAndUnify var = do
77− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
78− unify' variable1 variable2
79−
80− unifyNumber svar name
81− | name `elem` ["Int","Float","number"] = flexAndUnify svar
82− | otherwise = TS.addError span (Just hint) variable1 variable2
83− where hint = "A number must be an Int or Float."
84−
85− comparableError maybe =
86− TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
87− where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
88−
89− unifyComparable var name
90− | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
91− | otherwise = comparableError Nothing
92−
93− unifyComparableStructure varSuper varFlex =
94− do struct <- liftIO $ collectApps varFlex
95− case struct of
96− Other -> comparableError Nothing
97− List v -> do flexAndUnify varSuper
98− unify' v =<< liftIO (var $ Is Comparable)
99− Tuple vs
100− | length vs > 6 ->
101− comparableError $ Just "Cannot compare a tuple with more than 6 elements."
102− | otherwise ->
103− do flexAndUnify varSuper
104− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
105− zipWithM_ unify' vs cmpVars
106−
107− unifyAppendable varSuper varFlex =
108− do struct <- liftIO $ collectApps varFlex
109− case struct of
110− List _ -> flexAndUnify varSuper
111− _ -> comparableError Nothing
112−
113− rigidError variable = TS.addError span (Just hint) variable1 variable2
114− where
115− var = "'" ++ render (pretty Never variable) ++ "'"
116− hint = "Cannot unify rigid type variable " ++ var ++
117− ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
118− \variables are not shared between a top-level and let-bound type annotations."
119−
120− superUnify =
121− case (flex desc1, flex desc2, name desc1, name desc2) of
122− (Is super1, Is super2, _, _)
123− | super1 == super2 -> merge
124− (Is Number, Is Comparable, _, _) -> merge1
125− (Is Comparable, Is Number, _, _) -> merge2
126−
127− (Is Number, _, _, Just name) -> unifyNumber variable1 name
128− (_, Is Number, Just name, _) -> unifyNumber variable2 name
129−
130− (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
131− (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
132− (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
133− (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
134−
135− (Is Appendable, _, _, Just ctor)
136− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable1
137− (_, Is Appendable, Just ctor, _)
138− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable2
139− (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
140− (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
141−
142− (Rigid, _, _, _) -> rigidError variable1
143− (_, Rigid, _, _) -> rigidError variable2
144− _ -> TS.addError span Nothing variable1 variable2
145−
146− case (structure desc1, structure desc2) of
147− (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
148− (Nothing, _) | flex desc1 == Flexible -> merge2
149− (_, Nothing) | flex desc2 == Flexible -> merge1
150−
151− (Just (Var1 v), _) -> unify' v variable2
152− (_, Just (Var1 v)) -> unify' v variable1
153−
154− (Nothing, _) -> superUnify
155− (_, Nothing) -> superUnify
156−
157− (Just type1, Just type2) ->
158− case (type1,type2) of
159− (App1 term1 term2, App1 term1' term2') ->
160− do merge
161− unify' term1 term1'
162− unify' term2 term2'
163− (Fun1 term1 term2, Fun1 term1' term2') ->
164− do merge
165− unify' term1 term1'
166− unify' term2 term2'
167−
168− (EmptyRecord1, EmptyRecord1) ->
169− return ()
170−
171− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
172− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
173−
174− (Record1 fields1 ext1, Record1 fields2 ext2) ->
175− do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2
176− let mkRecord fs ext = fresh . Just $ Record1 fs ext
177− case (Map.null fields1', Map.null fields2') of
178− (True , True ) -> unify' ext1 ext2
179− (True , False) -> do
180− record2' <- mkRecord fields2' ext2
181− unify' ext1 record2'
182− (False, True ) -> do
183− record1' <- mkRecord fields1' ext1
184− unify' record1' ext2
185− (False, False) -> do
186− record1' <- mkRecord fields1' =<< fresh Nothing
187− record2' <- mkRecord fields2' =<< fresh Nothing
188− unify' record1' ext2
189− unify' ext1 record2'
190− where
191− fields1' = unmerged fields1 fields2
192− fields2' = unmerged fields2 fields1
193−
194− unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a
195−
196− eat (_:xs) (_:ys) = eat xs ys
197− eat xs _ = xs
198−
199− _ -> TS.addError span Nothing variable1 variable2
200−
compiler/src/AST/Canonical.hsnew file+401
@@ -0,0 +1,401 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module AST.Canonical
4+ ( Expr, Expr_(..)
5+ , CaseBranch(..)
6+ , FieldUpdate(..)
7+ , CtorOpts(..)
8+ -- definitions
9+ , Def(..)
10+ , Decls(..)
11+ -- patterns
12+ , Pattern, Pattern_(..)
13+ , PatternCtorArg(..)
14+ -- types
15+ , Annotation(..)
16+ , Type(..)
17+ , AliasType(..)
18+ , FieldType(..)
19+ , fieldsToList
20+ -- modules
21+ , Module(..)
22+ , Alias(..)
23+ , Binop(..)
24+ , Union(..)
25+ , Ctor(..)
26+ , Exports(..)
27+ , Export(..)
28+ , Effects(..)
29+ , Port(..)
30+ , Manager(..)
31+ )
32+ where
33+
34+{- Creating a canonical AST means finding the home module for all variables.
35+So if you have L.map, you need to figure out that it is from the elm/core
36+package in the List module.
37+
38+In later phases (e.g. type inference, exhaustiveness checking, optimization)
39+you need to look up additional info from these modules. What is the type?
40+What are the alternative type constructors? These lookups can be quite costly,
41+especially in type inference. To reduce costs the canonicalization phase
42+caches info needed in later phases. This means we no longer build large
43+dictionaries of metadata with O(log(n)) lookups in those phases. Instead
44+there is an O(1) read of an existing field! I have tried to mark all
45+cached data with comments like:
46+
47+-- CACHE for exhaustiveness
48+-- CACHE for inference
49+
50+So it is clear why the data is kept around.
51+-}
52+
53+
54+import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
55+import Data.Binary
56+import qualified Data.List as List
57+import qualified Data.Map as Map
58+import Data.Name (Name)
59+
60+import qualified AST.Source as Src
61+import qualified AST.Utils.Binop as Binop
62+import qualified AST.Utils.Shader as Shader
63+import qualified Data.Index as Index
64+import qualified Elm.Float as EF
65+import qualified Elm.ModuleName as ModuleName
66+import qualified Elm.String as ES
67+import qualified Reporting.Annotation as A
68+
69+
70+
71+-- EXPRESSIONS
72+
73+
74+type Expr =
75+ A.Located Expr_
76+
77+
78+-- CACHE Annotations for type inference
79+data Expr_
80+ = VarLocal Name
81+ | VarTopLevel ModuleName.Canonical Name
82+ | VarKernel Name Name
83+ | VarForeign ModuleName.Canonical Name Annotation
84+ | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
85+ | VarDebug ModuleName.Canonical Name Annotation
86+ | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
87+ | Chr ES.String
88+ | Str ES.String
89+ | Int Int
90+ | Float EF.Float
91+ | List [Expr]
92+ | Negate Expr
93+ | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
94+ | Lambda [Pattern] Expr
95+ | Call Expr [Expr]
96+ | If [(Expr, Expr)] Expr
97+ | Let Def Expr
98+ | LetRec [Def] Expr
99+ | LetDestruct Pattern Expr Expr
100+ | Case Expr [CaseBranch]
101+ | Accessor Name
102+ | Access Expr (A.Located Name)
103+ | Update Name Expr (Map.Map Name FieldUpdate)
104+ | Record (Map.Map Name Expr)
105+ | Unit
106+ | Tuple Expr Expr (Maybe Expr)
107+ | Shader Shader.Source Shader.Types
108+
109+
110+data CaseBranch =
111+ CaseBranch Pattern Expr
112+
113+
114+data FieldUpdate =
115+ FieldUpdate A.Region Expr
116+
117+
118+
119+-- DEFS
120+
121+
122+data Def
123+ = Def (A.Located Name) [Pattern] Expr
124+ | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type
125+
126+
127+
128+-- DECLARATIONS
129+
130+
131+data Decls
132+ = Declare Def Decls
133+ | DeclareRec Def [Def] Decls
134+ | SaveTheEnvironment
135+
136+
137+
138+-- PATTERNS
139+
140+
141+type Pattern =
142+ A.Located Pattern_
143+
144+
145+data Pattern_
146+ = PAnything
147+ | PVar Name
148+ | PRecord [Name]
149+ | PAlias Pattern Name
150+ | PUnit
151+ | PTuple Pattern Pattern (Maybe Pattern)
152+ | PList [Pattern]
153+ | PCons Pattern Pattern
154+ | PBool Union Bool
155+ | PChr ES.String
156+ | PStr ES.String
157+ | PInt Int
158+ | PCtor
159+ { _p_home :: ModuleName.Canonical
160+ , _p_type :: Name
161+ , _p_union :: Union
162+ , _p_name :: Name
163+ , _p_index :: Index.ZeroBased
164+ , _p_args :: [PatternCtorArg]
165+ }
166+ -- CACHE _p_home, _p_type, and _p_vars for type inference
167+ -- CACHE _p_index to replace _p_name in PROD code gen
168+ -- CACHE _p_opts to allocate less in PROD code gen
169+ -- CACHE _p_alts and _p_numAlts for exhaustiveness checker
170+
171+
172+data PatternCtorArg =
173+ PatternCtorArg
174+ { _index :: Index.ZeroBased -- CACHE for destructors/errors
175+ , _type :: Type -- CACHE for type inference
176+ , _arg :: Pattern
177+ }
178+
179+
180+
181+-- TYPES
182+
183+
184+data Annotation = Forall FreeVars Type
185+ deriving (Eq)
186+
187+
188+type FreeVars = Map.Map Name ()
189+
190+
191+data Type
192+ = TLambda Type Type
193+ | TVar Name
194+ | TType ModuleName.Canonical Name [Type]
195+ | TRecord (Map.Map Name FieldType) (Maybe Name)
196+ | TUnit
197+ | TTuple Type Type (Maybe Type)
198+ | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
199+ deriving (Eq)
200+
201+
202+data AliasType
203+ = Holey 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))
226+
227+
228+
229+-- MODULES
230+
231+
232+data Module =
233+ Module
234+ { _name :: ModuleName.Canonical
235+ , _exports :: Exports
236+ , _docs :: Src.Docs
237+ , _decls :: Decls
238+ , _unions :: Map.Map Name Union
239+ , _aliases :: Map.Map Name Alias
240+ , _binops :: Map.Map Name Binop
241+ , _effects :: Effects
242+ }
243+
244+
245+data Alias = Alias [Name] Type
246+ deriving (Eq)
247+
248+
249+data Binop = Binop_ Binop.Associativity Binop.Precedence Name
250+ deriving (Eq)
251+
252+
253+data Union =
254+ Union
255+ { _u_vars :: [Name]
256+ , _u_alts :: [Ctor]
257+ , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking
258+ , _u_opts :: CtorOpts -- CACHE which optimizations are available
259+ }
260+ deriving (Eq)
261+
262+
263+data CtorOpts
264+ = Normal
265+ | Enum
266+ | Unbox
267+ deriving (Eq, Ord)
268+
269+
270+data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
271+ deriving (Eq)
272+
273+
274+
275+-- EXPORTS
276+
277+
278+data Exports
279+ = ExportEverything A.Region
280+ | Export (Map.Map Name (A.Located Export))
281+
282+
283+data Export
284+ = ExportValue
285+ | ExportBinop
286+ | ExportAlias
287+ | ExportUnionOpen
288+ | ExportUnionClosed
289+ | ExportPort
290+
291+
292+
293+-- EFFECTS
294+
295+
296+data Effects
297+ = NoEffects
298+ | Ports (Map.Map Name Port)
299+ | Manager A.Region A.Region A.Region Manager
300+
301+
302+data Port
303+ = Incoming { _freeVars :: FreeVars, _payload :: Type, _func :: Type }
304+ | Outgoing { _freeVars :: FreeVars, _payload :: Type, _func :: Type }
305+
306+
307+data Manager
308+ = Cmd Name
309+ | Sub Name
310+ | Fx Name Name
311+
312+
313+
314+-- BINARY
315+
316+
317+instance Binary Alias where
318+ get = liftM2 Alias get get
319+ put (Alias a b) = put a >> put b
320+
321+
322+instance Binary Union where
323+ put (Union a b c d) = put a >> put b >> put c >> put d
324+ get = liftM4 Union get get get get
325+
326+
327+instance Binary Ctor where
328+ get = liftM4 Ctor get get get get
329+ put (Ctor a b c d) = put a >> put b >> put c >> put d
330+
331+
332+instance Binary CtorOpts where
333+ put opts =
334+ case opts of
335+ Normal -> putWord8 0
336+ Enum -> putWord8 1
337+ Unbox -> putWord8 2
338+
339+ get =
340+ do n <- getWord8
341+ case n of
342+ 0 -> return Normal
343+ 1 -> return Enum
344+ 2 -> return Unbox
345+ _ -> fail "binary encoding of CtorOpts was corrupted"
346+
347+
348+instance Binary Annotation where
349+ get = liftM2 Forall get get
350+ put (Forall a b) = put a >> put b
351+
352+
353+instance Binary Type where
354+ put tipe =
355+ case tipe of
356+ TLambda a b -> putWord8 0 >> put a >> put b
357+ TVar a -> putWord8 1 >> put a
358+ TRecord a b -> putWord8 2 >> put a >> put b
359+ TUnit -> putWord8 3
360+ TTuple a b c -> putWord8 4 >> put a >> put b >> put c
361+ TAlias a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
362+ TType home name ts ->
363+ let potentialWord = length ts + 7 in
364+ if potentialWord <= fromIntegral (maxBound :: Word8) then
365+ do putWord8 (fromIntegral potentialWord)
366+ put home
367+ put name
368+ mapM_ put ts
369+ else
370+ putWord8 6 >> put home >> put name >> put ts
371+
372+ get =
373+ do word <- getWord8
374+ case word of
375+ 0 -> liftM2 TLambda get get
376+ 1 -> liftM TVar get
377+ 2 -> liftM2 TRecord get get
378+ 3 -> return TUnit
379+ 4 -> liftM3 TTuple get get get
380+ 5 -> liftM4 TAlias get get get get
381+ 6 -> liftM3 TType get get get
382+ n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get)
383+
384+
385+instance Binary AliasType where
386+ put aliasType =
387+ case aliasType of
388+ Holey tipe -> putWord8 0 >> put tipe
389+ Filled tipe -> putWord8 1 >> put tipe
390+
391+ get =
392+ do n <- getWord8
393+ case n of
394+ 0 -> liftM Holey get
395+ 1 -> liftM Filled get
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
compiler/src/AST/Optimized.hsnew file+451
@@ -0,0 +1,451 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Optimized
3+ ( Def(..)
4+ , Expr(..)
5+ , Global(..)
6+ , Path(..)
7+ , Destructor(..)
8+ , Decider(..)
9+ , Choice(..)
10+ , GlobalGraph(..)
11+ , LocalGraph(..)
12+ , Main(..)
13+ , Node(..)
14+ , EffectsType(..)
15+ , empty
16+ , addGlobalGraph
17+ , addLocalGraph
18+ , addKernel
19+ , toKernelGlobal
20+ )
21+ where
22+
23+
24+import Control.Monad (liftM, liftM2, liftM3, liftM4)
25+import Data.Binary (Binary, get, put, getWord8, putWord8)
26+import qualified Data.Map as Map
27+import qualified Data.Name as Name
28+import Data.Name (Name)
29+import qualified Data.Set as Set
30+
31+import qualified AST.Canonical as Can
32+import qualified AST.Utils.Shader as Shader
33+import qualified Data.Index as Index
34+import qualified Elm.Float as EF
35+import qualified Elm.Kernel as K
36+import qualified Elm.ModuleName as ModuleName
37+import qualified Elm.Package as Pkg
38+import qualified Elm.String as ES
39+import qualified Optimize.DecisionTree as DT
40+import qualified Reporting.Annotation as A
41+
42+
43+
44+-- EXPRESSIONS
45+
46+
47+data Expr
48+ = Bool Bool
49+ | Chr ES.String
50+ | Str ES.String
51+ | Int Int
52+ | Float EF.Float
53+ | VarLocal Name
54+ | VarGlobal Global
55+ | VarEnum Global Index.ZeroBased
56+ | VarBox Global
57+ | VarCycle ModuleName.Canonical Name
58+ | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
59+ | VarKernel Name Name
60+ | List [Expr]
61+ | Function [Name] Expr
62+ | Call Expr [Expr]
63+ | TailCall Name [(Name, Expr)]
64+ | If [(Expr, Expr)] Expr
65+ | Let Def Expr
66+ | Destruct Destructor Expr
67+ | Case Name Name (Decider Choice) [(Int, Expr)]
68+ | Accessor Name
69+ | Access Expr Name
70+ | Update Expr (Map.Map Name Expr)
71+ | Record (Map.Map Name Expr)
72+ | Unit
73+ | Tuple Expr Expr (Maybe Expr)
74+ | Shader Shader.Source (Set.Set Name) (Set.Set Name)
75+
76+
77+data Global = Global ModuleName.Canonical Name
78+
79+
80+
81+-- DEFINITIONS
82+
83+
84+data Def
85+ = Def Name Expr
86+ | TailDef Name [Name] Expr
87+
88+
89+data Destructor =
90+ Destructor Name Path
91+
92+
93+data Path
94+ = Index Index.ZeroBased Path
95+ | Field Name Path
96+ | Unbox Path
97+ | Root Name
98+
99+
100+
101+-- BRANCHING
102+
103+
104+data Decider a
105+ = Leaf a
106+ | Chain
107+ { _testChain :: [(DT.Path, DT.Test)]
108+ , _success :: Decider a
109+ , _failure :: Decider a
110+ }
111+ | FanOut
112+ { _path :: DT.Path
113+ , _tests :: [(DT.Test, Decider a)]
114+ , _fallback :: Decider a
115+ }
116+ deriving (Eq)
117+
118+
119+data Choice
120+ = Inline Expr
121+ | Jump Int
122+
123+
124+
125+-- OBJECT GRAPH
126+
127+
128+data GlobalGraph =
129+ GlobalGraph
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
138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name
139+ , _l_fields :: Map.Map Name Int
140+ }
141+
142+
143+data Main
144+ = Static
145+ | Dynamic
146+ { _message :: Can.Type
147+ , _decoder :: Expr
148+ }
149+
150+
151+data Node
152+ = Define Expr (Set.Set Global)
153+ | DefineTailFunc [Name] Expr (Set.Set Global)
154+ | Ctor Index.ZeroBased Int
155+ | Enum Index.ZeroBased
156+ | Box
157+ | Link Global
158+ | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)
159+ | Manager EffectsType
160+ | Kernel [K.Chunk] (Set.Set Global)
161+ | PortIncoming Expr (Set.Set Global)
162+ | PortOutgoing Expr (Set.Set Global)
163+
164+
165+data EffectsType = Cmd | Sub | Fx
166+
167+
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
226+
227+
228+instance Eq Global where
229+ (==) (Global home1 name1) (Global home2 name2) =
230+ name1 == name2 && home1 == home2
231+
232+
233+instance Ord Global where
234+ compare (Global home1 name1) (Global home2 name2) =
235+ case compare name1 name2 of
236+ LT -> LT
237+ EQ -> compare home1 home2
238+ GT -> GT
239+
240+
241+
242+-- BINARY
243+
244+
245+instance Binary Global where
246+ get = liftM2 Global get get
247+ put (Global a b) = put a >> put b
248+
249+
250+instance Binary Expr where
251+ put expr =
252+ case expr of
253+ Bool a -> putWord8 0 >> put a
254+ Chr a -> putWord8 1 >> put a
255+ Str a -> putWord8 2 >> put a
256+ Int a -> putWord8 3 >> put a
257+ Float a -> putWord8 4 >> put a
258+ VarLocal a -> putWord8 5 >> put a
259+ VarGlobal a -> putWord8 6 >> put a
260+ VarEnum a b -> putWord8 7 >> put a >> put b
261+ VarBox a -> putWord8 8 >> put a
262+ VarCycle a b -> putWord8 9 >> put a >> put b
263+ VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d
264+ VarKernel a b -> putWord8 11 >> put a >> put b
265+ List a -> putWord8 12 >> put a
266+ Function a b -> putWord8 13 >> put a >> put b
267+ Call a b -> putWord8 14 >> put a >> put b
268+ TailCall a b -> putWord8 15 >> put a >> put b
269+ If a b -> putWord8 16 >> put a >> put b
270+ Let a b -> putWord8 17 >> put a >> put b
271+ Destruct a b -> putWord8 18 >> put a >> put b
272+ Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d
273+ Accessor a -> putWord8 20 >> put a
274+ Access a b -> putWord8 21 >> put a >> put b
275+ Update a b -> putWord8 22 >> put a >> put b
276+ Record a -> putWord8 23 >> put a
277+ Unit -> putWord8 24
278+ Tuple a b c -> putWord8 25 >> put a >> put b >> put c
279+ Shader a b c -> putWord8 26 >> put a >> put b >> put c
280+
281+ get =
282+ do word <- getWord8
283+ case word of
284+ 0 -> liftM Bool get
285+ 1 -> liftM Chr get
286+ 2 -> liftM Str get
287+ 3 -> liftM Int get
288+ 4 -> liftM Float get
289+ 5 -> liftM VarLocal get
290+ 6 -> liftM VarGlobal get
291+ 7 -> liftM2 VarEnum get get
292+ 8 -> liftM VarBox get
293+ 9 -> liftM2 VarCycle get get
294+ 10 -> liftM4 VarDebug get get get get
295+ 11 -> liftM2 VarKernel get get
296+ 12 -> liftM List get
297+ 13 -> liftM2 Function get get
298+ 14 -> liftM2 Call get get
299+ 15 -> liftM2 TailCall get get
300+ 16 -> liftM2 If get get
301+ 17 -> liftM2 Let get get
302+ 18 -> liftM2 Destruct get get
303+ 19 -> liftM4 Case get get get get
304+ 20 -> liftM Accessor get
305+ 21 -> liftM2 Access get get
306+ 22 -> liftM2 Update get get
307+ 23 -> liftM Record get
308+ 24 -> pure Unit
309+ 25 -> liftM3 Tuple get get get
310+ 26 -> liftM3 Shader get get get
311+ _ -> fail "problem getting Opt.Expr binary"
312+
313+
314+instance Binary Def where
315+ put def =
316+ case def of
317+ Def a b -> putWord8 0 >> put a >> put b
318+ TailDef a b c -> putWord8 1 >> put a >> put b >> put c
319+
320+ get =
321+ do word <- getWord8
322+ case word of
323+ 0 -> liftM2 Def get get
324+ 1 -> liftM3 TailDef get get get
325+ _ -> fail "problem getting Opt.Def binary"
326+
327+
328+instance Binary Destructor where
329+ get = liftM2 Destructor get get
330+ put (Destructor a b) = put a >> put b
331+
332+
333+instance Binary Path where
334+ put destructor =
335+ case destructor of
336+ Index a b -> putWord8 0 >> put a >> put b
337+ Field a b -> putWord8 1 >> put a >> put b
338+ Unbox a -> putWord8 2 >> put a
339+ Root a -> putWord8 3 >> put a
340+
341+ get =
342+ do word <- getWord8
343+ case word of
344+ 0 -> liftM2 Index get get
345+ 1 -> liftM2 Field get get
346+ 2 -> liftM Unbox get
347+ 3 -> liftM Root get
348+ _ -> fail "problem getting Opt.Path binary"
349+
350+
351+instance (Binary a) => Binary (Decider a) where
352+ put decider =
353+ case decider of
354+ Leaf a -> putWord8 0 >> put a
355+ Chain a b c -> putWord8 1 >> put a >> put b >> put c
356+ FanOut a b c -> putWord8 2 >> put a >> put b >> put c
357+
358+ get =
359+ do word <- getWord8
360+ case word of
361+ 0 -> liftM Leaf get
362+ 1 -> liftM3 Chain get get get
363+ 2 -> liftM3 FanOut get get get
364+ _ -> fail "problem getting Opt.Decider binary"
365+
366+
367+instance Binary Choice where
368+ put choice =
369+ case choice of
370+ Inline expr -> putWord8 0 >> put expr
371+ Jump index -> putWord8 1 >> put index
372+
373+ get =
374+ do word <- getWord8
375+ case word of
376+ 0 -> liftM Inline get
377+ 1 -> liftM Jump get
378+ _ -> fail "problem getting Opt.Choice binary"
379+
380+
381+
382+instance Binary GlobalGraph where
383+ get = liftM2 GlobalGraph get get
384+ put (GlobalGraph a b) = put a >> put b
385+
386+
387+instance Binary LocalGraph where
388+ get = liftM3 LocalGraph get get get
389+ put (LocalGraph a b c) = put a >> put b >> put c
390+
391+
392+instance Binary Main where
393+ put main =
394+ case main of
395+ Static -> putWord8 0
396+ Dynamic a b -> putWord8 1 >> put a >> put b
397+
398+ get =
399+ do word <- getWord8
400+ case word of
401+ 0 -> return Static
402+ 1 -> liftM2 Dynamic get get
403+ _ -> fail "problem getting Opt.Main binary"
404+
405+
406+instance Binary Node where
407+ put node =
408+ case node of
409+ Define a b -> putWord8 0 >> put a >> put b
410+ DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
411+ Ctor a b -> putWord8 2 >> put a >> put b
412+ Enum a -> putWord8 3 >> put a
413+ Box -> putWord8 4
414+ Link a -> putWord8 5 >> put a
415+ Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d
416+ Manager a -> putWord8 7 >> put a
417+ Kernel a b -> putWord8 8 >> put a >> put b
418+ PortIncoming a b -> putWord8 9 >> put a >> put b
419+ PortOutgoing a b -> putWord8 10 >> put a >> put b
420+
421+ get =
422+ do word <- getWord8
423+ case word of
424+ 0 -> liftM2 Define get get
425+ 1 -> liftM3 DefineTailFunc get get get
426+ 2 -> liftM2 Ctor get get
427+ 3 -> liftM Enum get
428+ 4 -> return Box
429+ 5 -> liftM Link get
430+ 6 -> liftM4 Cycle get get get get
431+ 7 -> liftM Manager get
432+ 8 -> liftM2 Kernel get get
433+ 9 -> liftM2 PortIncoming get get
434+ 10 -> liftM2 PortOutgoing get get
435+ _ -> fail "problem getting Opt.Node binary"
436+
437+
438+instance Binary EffectsType where
439+ put effectsType =
440+ case effectsType of
441+ Cmd -> putWord8 0
442+ Sub -> putWord8 1
443+ Fx -> putWord8 2
444+
445+ get =
446+ do word <- getWord8
447+ case word of
448+ 0 -> return Cmd
449+ 1 -> return Sub
450+ 2 -> return Fx
451+ _ -> fail "problem getting Opt.EffectsType binary"
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
compiler/src/AST/Utils/Binop.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Utils.Binop
3+ ( Precedence(..)
4+ , Associativity(..)
5+ )
6+ where
7+
8+
9+import Prelude hiding (Either(..))
10+import Control.Monad (liftM)
11+import Data.Binary
12+
13+
14+
15+-- BINOP STUFF
16+
17+
18+newtype Precedence = Precedence Int
19+ deriving (Eq, Ord)
20+
21+
22+data Associativity
23+ = Left
24+ | Non
25+ | Right
26+ deriving (Eq)
27+
28+
29+
30+-- BINARY
31+
32+
33+instance Binary Precedence where
34+ get =
35+ liftM Precedence get
36+
37+ put (Precedence n) =
38+ put n
39+
40+
41+instance Binary Associativity where
42+ get =
43+ do n <- getWord8
44+ case n of
45+ 0 -> return Left
46+ 1 -> return Non
47+ 2 -> return Right
48+ _ -> fail "Error reading valid associativity from serialized string"
49+
50+ put assoc =
51+ putWord8 $
52+ case assoc of
53+ Left -> 0
54+ Non -> 1
55+ Right -> 2
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
compiler/src/AST/Utils/Type.hsnew file+125
@@ -0,0 +1,125 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module AST.Utils.Type
3+ ( delambda
4+ , dealias
5+ , deepDealias
6+ , iteratedDealias
7+ )
8+ where
9+
10+
11+import qualified Data.Map as Map
12+import qualified Data.Name as Name
13+
14+import AST.Canonical (Type(..), AliasType(..), FieldType(..))
15+
16+
17+
18+-- DELAMBDA
19+
20+
21+delambda :: Type -> [Type]
22+delambda tipe =
23+ case tipe of
24+ TLambda arg result ->
25+ arg : delambda result
26+
27+ _ ->
28+ [tipe]
29+
30+
31+
32+-- DEALIAS
33+
34+
35+dealias :: [(Name.Name, Type)] -> AliasType -> Type
36+dealias args aliasType =
37+ case aliasType of
38+ Holey tipe ->
39+ dealiasHelp (Map.fromList args) tipe
40+
41+ Filled tipe ->
42+ tipe
43+
44+
45+dealiasHelp :: Map.Map Name.Name Type -> Type -> Type
46+dealiasHelp typeTable tipe =
47+ case tipe of
48+ TLambda a b ->
49+ TLambda
50+ (dealiasHelp typeTable a)
51+ (dealiasHelp typeTable b)
52+
53+ TVar x ->
54+ Map.findWithDefault tipe x typeTable
55+
56+ TRecord fields ext ->
57+ TRecord (Map.map (dealiasField typeTable) fields) ext
58+
59+ TAlias home name args t' ->
60+ TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'
61+
62+ TType home name args ->
63+ TType home name (map (dealiasHelp typeTable) args)
64+
65+ TUnit ->
66+ TUnit
67+
68+ TTuple a b maybeC ->
69+ TTuple
70+ (dealiasHelp typeTable a)
71+ (dealiasHelp typeTable b)
72+ (fmap (dealiasHelp typeTable) maybeC)
73+
74+
75+dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType
76+dealiasField typeTable (FieldType index tipe) =
77+ FieldType index (dealiasHelp typeTable tipe)
78+
79+
80+
81+-- DEEP DEALIAS
82+
83+
84+deepDealias :: Type -> Type
85+deepDealias tipe =
86+ case tipe of
87+ TLambda a b ->
88+ TLambda (deepDealias a) (deepDealias b)
89+
90+ TVar _ ->
91+ tipe
92+
93+ TRecord fields ext ->
94+ TRecord (Map.map deepDealiasField fields) ext
95+
96+ TAlias _ _ args tipe' ->
97+ deepDealias (dealias args tipe')
98+
99+ TType home name args ->
100+ TType home name (map deepDealias args)
101+
102+ TUnit ->
103+ TUnit
104+
105+ TTuple a b c ->
106+ TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)
107+
108+
109+deepDealiasField :: FieldType -> FieldType
110+deepDealiasField (FieldType index tipe) =
111+ FieldType index (deepDealias tipe)
112+
113+
114+
115+-- ITERATED DEALIAS
116+
117+
118+iteratedDealias :: Type -> Type
119+iteratedDealias tipe =
120+ case tipe of
121+ TAlias _ _ args realType ->
122+ iteratedDealias (dealias args realType)
123+
124+ _ ->
125+ tipe
compiler/src/Canonicalize/Effects.hsnew file+251
@@ -0,0 +1,251 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Effects
4+ ( canonicalize
5+ , checkPayload
6+ )
7+ where
8+
9+import qualified Data.Foldable as F
10+import qualified Data.Map as Map
11+import qualified Data.Name as Name
12+
13+import qualified AST.Canonical as Can
14+import qualified AST.Source as Src
15+import qualified AST.Utils.Type as Type
16+import qualified Canonicalize.Environment as Env
17+import qualified Canonicalize.Type as Type
18+import qualified Elm.ModuleName as ModuleName
19+import qualified Reporting.Annotation as A
20+import qualified Reporting.Error.Canonicalize as Error
21+import qualified Reporting.Result as Result
22+
23+
24+
25+-- RESULT
26+
27+
28+type Result i w a =
29+ Result.Result i w Error.Error a
30+
31+
32+
33+-- CANONICALIZE
34+
35+
36+canonicalize
37+ :: Env.Env
38+ -> [A.Located Src.Value]
39+ -> Map.Map Name.Name union
40+ -> Src.Effects
41+ -> Result i w Can.Effects
42+canonicalize env values unions effects =
43+ case effects of
44+ Src.NoEffects ->
45+ Result.ok Can.NoEffects
46+
47+ Src.Ports ports ->
48+ do pairs <- traverse (canonicalizePort env) ports
49+ return $ Can.Ports (Map.fromList pairs)
50+
51+ Src.Manager region manager ->
52+ let dict = Map.fromList (map toNameRegion values) in
53+ Can.Manager
54+ <$> verifyManager region dict "init"
55+ <*> verifyManager region dict "onEffects"
56+ <*> verifyManager region dict "onSelfMsg"
57+ <*>
58+ case manager of
59+ Src.Cmd cmdType ->
60+ Can.Cmd
61+ <$> verifyEffectType cmdType unions
62+ <* verifyManager region dict "cmdMap"
63+
64+ Src.Sub subType ->
65+ Can.Sub
66+ <$> verifyEffectType subType unions
67+ <* verifyManager region dict "subMap"
68+
69+ Src.Fx cmdType subType ->
70+ Can.Fx
71+ <$> verifyEffectType cmdType unions
72+ <*> verifyEffectType subType unions
73+ <* verifyManager region dict "cmdMap"
74+ <* verifyManager region dict "subMap"
75+
76+
77+
78+-- CANONICALIZE PORT
79+
80+
81+canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port)
82+canonicalizePort env (Src.Port (A.At region portName) tipe) =
83+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
84+ case reverse (Type.delambda (Type.deepDealias ctipe)) of
85+ Can.TType home name [msg] : revArgs
86+ | home == ModuleName.cmd && name == Name.cmd ->
87+ case revArgs of
88+ [] ->
89+ Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg)
90+
91+ [outgoingType] ->
92+ case msg of
93+ Can.TVar _ ->
94+ case checkPayload outgoingType of
95+ Right () ->
96+ Result.ok (portName, Can.Outgoing freeVars outgoingType ctipe)
97+
98+ Left (badType, err) ->
99+ Result.throw (Error.PortPayloadInvalid region portName badType err)
100+
101+ _ ->
102+ Result.throw (Error.PortTypeInvalid region portName Error.CmdBadMsg)
103+
104+ _ ->
105+ Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs)))
106+
107+ | home == ModuleName.sub && name == Name.sub ->
108+ case revArgs of
109+ [Can.TLambda incomingType (Can.TVar msg1)] ->
110+ case msg of
111+ Can.TVar msg2 | msg1 == msg2 ->
112+ case checkPayload incomingType of
113+ Right () ->
114+ Result.ok (portName, Can.Incoming freeVars incomingType ctipe)
115+
116+ Left (badType, err) ->
117+ Result.throw (Error.PortPayloadInvalid region portName badType err)
118+
119+ _ ->
120+ Result.throw (Error.PortTypeInvalid region portName Error.SubBad)
121+
122+ _ ->
123+ Result.throw (Error.PortTypeInvalid region portName Error.SubBad)
124+
125+ _ ->
126+ Result.throw (Error.PortTypeInvalid region portName Error.NotCmdOrSub)
127+
128+
129+
130+-- VERIFY MANAGER
131+
132+
133+verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name
134+verifyEffectType (A.At region name) unions =
135+ if Map.member name unions then
136+ Result.ok name
137+ else
138+ Result.throw (Error.EffectNotFound region name)
139+
140+
141+toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region)
142+toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) =
143+ (name, region)
144+
145+
146+verifyManager :: A.Region -> Map.Map Name.Name A.Region -> Name.Name -> Result i w A.Region
147+verifyManager tagRegion values name =
148+ case Map.lookup name values of
149+ Just region ->
150+ Result.ok region
151+
152+ Nothing ->
153+ Result.throw (Error.EffectFunctionNotFound tagRegion name)
154+
155+
156+
157+-- CHECK PAYLOAD TYPES
158+
159+
160+checkPayload :: Can.Type -> Either (Can.Type, Error.InvalidPayload) ()
161+checkPayload tipe =
162+ case tipe of
163+ Can.TAlias _ _ args aliasedType ->
164+ checkPayload (Type.dealias args aliasedType)
165+
166+ Can.TType home name args ->
167+ case args of
168+ []
169+ | isJson home name -> Right ()
170+ | isString home name -> Right ()
171+ | isIntFloatBool home name -> Right ()
172+
173+ [arg]
174+ | isList home name -> checkPayload arg
175+ | isMaybe home name -> checkPayload arg
176+ | isArray home name -> checkPayload arg
177+
178+ _ ->
179+ Left (tipe, Error.UnsupportedType name)
180+
181+ Can.TUnit ->
182+ Right ()
183+
184+ Can.TTuple a b maybeC ->
185+ do checkPayload a
186+ checkPayload b
187+ case maybeC of
188+ Nothing ->
189+ Right ()
190+
191+ Just c ->
192+ checkPayload c
193+
194+ Can.TVar name ->
195+ Left (tipe, Error.TypeVariable name)
196+
197+ Can.TLambda _ _ ->
198+ Left (tipe, Error.Function)
199+
200+ Can.TRecord _ (Just _) ->
201+ Left (tipe, Error.ExtendedRecord)
202+
203+ Can.TRecord fields Nothing ->
204+ F.traverse_ checkFieldPayload fields
205+
206+
207+checkFieldPayload :: Can.FieldType -> Either (Can.Type, Error.InvalidPayload) ()
208+checkFieldPayload (Can.FieldType _ tipe) =
209+ checkPayload tipe
210+
211+
212+isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool
213+isIntFloatBool home name =
214+ home == ModuleName.basics
215+ &&
216+ (name == Name.int || name == Name.float || name == Name.bool)
217+
218+
219+isString :: ModuleName.Canonical -> Name.Name -> Bool
220+isString home name =
221+ home == ModuleName.string
222+ &&
223+ name == Name.string
224+
225+
226+isJson :: ModuleName.Canonical -> Name.Name -> Bool
227+isJson home name =
228+ home == ModuleName.jsonEncode
229+ &&
230+ name == Name.value
231+
232+
233+isList :: ModuleName.Canonical -> Name.Name -> Bool
234+isList home name =
235+ home == ModuleName.list
236+ &&
237+ name == Name.list
238+
239+
240+isMaybe :: ModuleName.Canonical -> Name.Name -> Bool
241+isMaybe home name =
242+ home == ModuleName.maybe
243+ &&
244+ name == Name.maybe
245+
246+
247+isArray :: ModuleName.Canonical -> Name.Name -> Bool
248+isArray home name =
249+ home == ModuleName.array
250+ &&
251+ name == Name.array
compiler/src/Canonicalize/Environment.hsnew file+275
@@ -0,0 +1,275 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment
4+ ( Env(..)
5+ , Exposed
6+ , Qualified
7+ , Info(..)
8+ , mergeInfo
9+ , Var(..)
10+ , Type(..)
11+ , Ctor(..)
12+ , addLocals
13+ , findType
14+ , findTypeQual
15+ , findCtor
16+ , findCtorQual
17+ , findBinop
18+ , Binop(..)
19+ )
20+ where
21+
22+
23+import qualified Data.Map.Merge.Strict as Map
24+import qualified Data.Map.Strict as Map
25+import qualified Data.Name as Name
26+import qualified Data.OneOrMore as OneOrMore
27+
28+import qualified AST.Utils.Binop as Binop
29+import qualified AST.Canonical as Can
30+import qualified Data.Index as Index
31+import qualified Elm.ModuleName as ModuleName
32+import qualified Reporting.Annotation as A
33+import qualified Reporting.Error.Canonicalize as Error
34+import qualified Reporting.Result as Result
35+
36+
37+
38+-- RESULT
39+
40+
41+type Result i w a =
42+ Result.Result i w Error.Error a
43+
44+
45+
46+-- ENVIRONMENT
47+
48+
49+data Env =
50+ Env
51+ { _home :: ModuleName.Canonical
52+ , _vars :: Map.Map Name.Name Var
53+ , _types :: Exposed Type
54+ , _ctors :: Exposed Ctor
55+ , _binops :: Exposed Binop
56+ , _q_vars :: Qualified Can.Annotation
57+ , _q_types :: Qualified Type
58+ , _q_ctors :: Qualified Ctor
59+ }
60+
61+
62+type Exposed a =
63+ Map.Map Name.Name (Info a)
64+
65+
66+type Qualified 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))
91+
92+
93+
94+-- VARIABLES
95+
96+
97+data Var
98+ = Local A.Region
99+ | TopLevel A.Region
100+ | Foreign ModuleName.Canonical Can.Annotation
101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)
102+
103+
104+
105+-- TYPES
106+
107+
108+data Type
109+ = Alias Int ModuleName.Canonical [Name.Name] Can.Type
110+ | Union Int ModuleName.Canonical
111+
112+
113+
114+-- CTORS
115+
116+
117+data Ctor
118+ = RecordCtor ModuleName.Canonical [Name.Name] Can.Type
119+ | Ctor
120+ { _c_home :: ModuleName.Canonical
121+ , _c_type :: Name.Name
122+ , _c_union :: Can.Union
123+ , _c_index :: Index.ZeroBased
124+ , _c_args :: [Can.Type]
125+ }
126+
127+
128+
129+-- BINOPS
130+
131+
132+data Binop =
133+ Binop
134+ { _op :: Name.Name
135+ , _op_home :: ModuleName.Canonical
136+ , _op_name :: Name.Name
137+ , _op_annotation :: Can.Annotation
138+ , _op_associativity :: Binop.Associativity
139+ , _op_precedence :: Binop.Precedence
140+ }
141+
142+
143+
144+-- VARIABLE -- ADD LOCALS
145+
146+
147+addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env
148+addLocals names (Env home vars ts cs bs qvs qts qcs) =
149+ do newVars <-
150+ Map.mergeA
151+ (Map.mapMissing addLocalLeft)
152+ (Map.mapMissing (\_ homes -> homes))
153+ (Map.zipWithAMatched addLocalBoth)
154+ names
155+ vars
156+
157+ Result.ok (Env home newVars ts cs bs qvs qts qcs)
158+
159+
160+addLocalLeft :: Name.Name -> A.Region -> Var
161+addLocalLeft _ region =
162+ Local region
163+
164+
165+addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var
166+addLocalBoth name region var =
167+ case var of
168+ Foreign _ _ ->
169+ Result.ok (Local region)
170+
171+ Foreigns _ _ ->
172+ Result.ok (Local region)
173+
174+ Local parentRegion ->
175+ Result.throw (Error.Shadowing name parentRegion region)
176+
177+ TopLevel parentRegion ->
178+ Result.throw (Error.Shadowing name parentRegion region)
179+
180+
181+
182+
183+-- FIND TYPE
184+
185+
186+findType :: A.Region -> Env -> Name.Name -> Result i w Type
187+findType region (Env _ _ ts _ _ _ qts _) name =
188+ case Map.lookup name ts of
189+ Just (Specific _ tipe) ->
190+ Result.ok tipe
191+
192+ Just (Ambiguous h hs) ->
193+ Result.throw (Error.AmbiguousType region Nothing name h hs)
194+
195+ Nothing ->
196+ Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))
197+
198+
199+findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type
200+findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =
201+ case Map.lookup prefix qts of
202+ Just qualified ->
203+ case Map.lookup name qualified of
204+ Just (Specific _ tipe) ->
205+ Result.ok tipe
206+
207+ Just (Ambiguous h hs) ->
208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)
209+
210+ Nothing ->
211+ Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
212+
213+ Nothing ->
214+ Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))
215+
216+
217+
218+-- FIND CTOR
219+
220+
221+findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor
222+findCtor region (Env _ _ _ cs _ _ _ qcs) name =
223+ case Map.lookup name cs of
224+ Just (Specific _ ctor) ->
225+ Result.ok ctor
226+
227+ Just (Ambiguous h hs) ->
228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)
229+
230+ Nothing ->
231+ Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))
232+
233+
234+findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor
235+findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =
236+ case Map.lookup prefix qcs of
237+ Just qualified ->
238+ case Map.lookup name qualified of
239+ Just (Specific _ pattern) ->
240+ Result.ok pattern
241+
242+ Just (Ambiguous h hs) ->
243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)
244+
245+ Nothing ->
246+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
247+
248+ Nothing ->
249+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))
250+
251+
252+
253+-- FIND BINOP
254+
255+
256+findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop
257+findBinop region (Env _ _ _ _ binops _ _ _) name =
258+ case Map.lookup name binops of
259+ Just (Specific _ binop) ->
260+ Result.ok binop
261+
262+ Just (Ambiguous h hs) ->
263+ Result.throw (Error.AmbiguousBinop region name h hs)
264+
265+ Nothing ->
266+ Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))
267+
268+
269+
270+-- TO POSSIBLE NAMES
271+
272+
273+toPossibleNames :: Exposed a -> Qualified a -> Error.PossibleNames
274+toPossibleNames exposed qualified =
275+ Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
compiler/src/Canonicalize/Environment/Dups.hsnew file+118
@@ -0,0 +1,118 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Dups
4+ ( detect
5+ , checkFields
6+ , checkFields'
7+ , Dict
8+ , none
9+ , one
10+ , insert
11+ , union
12+ , unions
13+ )
14+ where
15+
16+
17+import qualified Data.Map as Map
18+import qualified Data.Name as Name
19+
20+import qualified Data.OneOrMore as OneOrMore
21+import qualified Reporting.Annotation as A
22+import qualified Reporting.Error.Canonicalize as Error
23+import qualified Reporting.Result as Result
24+
25+
26+
27+-- DUPLICATE TRACKER
28+
29+
30+type Dict value =
31+ Map.Map Name.Name (OneOrMore.OneOrMore (Info value))
32+
33+
34+data Info value =
35+ Info
36+ { _region :: A.Region
37+ , _value :: value
38+ }
39+
40+
41+
42+-- DETECT
43+
44+
45+type ToError =
46+ Name.Name -> A.Region -> A.Region -> Error.Error
47+
48+
49+detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a)
50+detect toError dict =
51+ Map.traverseWithKey (detectHelp toError) dict
52+
53+
54+detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
55+detectHelp toError name values =
56+ case values of
57+ OneOrMore.One (Info _ value) ->
58+ return value
59+
60+ OneOrMore.More left right ->
61+ let
62+ (Info r1 _, Info r2 _) =
63+ OneOrMore.getFirstTwo left right
64+ in
65+ Result.throw (toError name r1 r2)
66+
67+
68+
69+-- CHECK FIELDS
70+
71+
72+checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a)
73+checkFields fields =
74+ detect Error.DuplicateField (foldr addField none fields)
75+
76+
77+addField :: (A.Located Name.Name, a) -> Dict a -> Dict a
78+addField (A.At region name, value) dups =
79+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups
80+
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+
92+
93+-- BUILDING DICTIONARIES
94+
95+
96+none :: Dict a
97+none =
98+ Map.empty
99+
100+
101+one :: Name.Name -> A.Region -> value -> Dict value
102+one name region value =
103+ Map.singleton name (OneOrMore.one (Info region value))
104+
105+
106+insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a
107+insert name region value dict =
108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict
109+
110+
111+union :: Dict a -> Dict a -> Dict a
112+union a b =
113+ Map.unionWith OneOrMore.more a b
114+
115+
116+unions :: [Dict a] -> Dict a
117+unions dicts =
118+ Map.unionsWith OneOrMore.more dicts
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
compiler/src/Canonicalize/Environment/Local.hsnew file+355
@@ -0,0 +1,355 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Local
4+ ( add
5+ )
6+ where
7+
8+
9+import Control.Monad (foldM)
10+import qualified Data.Graph as Graph
11+import qualified Data.List as List
12+import qualified Data.Map.Strict as Map
13+import qualified Data.Name as Name
14+
15+import qualified AST.Canonical as Can
16+import qualified AST.Source as Src
17+import qualified Canonicalize.Environment as Env
18+import qualified Canonicalize.Environment.Dups as Dups
19+import qualified Canonicalize.Type as Type
20+import qualified Data.Index as Index
21+import qualified Elm.ModuleName as ModuleName
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+type Unions = Map.Map Name.Name Can.Union
36+type Aliases = Map.Map Name.Name Can.Alias
37+
38+
39+add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
40+add module_ env =
41+ addCtors module_ =<< addVars module_ =<< addTypes module_ env
42+
43+
44+
45+-- ADD VARS
46+
47+
48+addVars :: Src.Module -> Env.Env -> Result i w Env.Env
49+addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
50+ do topLevelVars <- collectVars module_
51+ let vs2 = Map.union topLevelVars vs
52+ -- Use union to overwrite foreign stuff.
53+ Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
54+
55+
56+collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
58+ let
59+ addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
60+ Dups.insert name region (Env.TopLevel region) dict
61+ in
62+ Dups.detect Error.DuplicateDecl $
63+ List.foldl' addDecl (toEffectDups effects) values
64+
65+
66+toEffectDups :: Src.Effects -> Dups.Dict Env.Var
67+toEffectDups effects =
68+ case effects of
69+ Src.NoEffects ->
70+ Dups.none
71+
72+ Src.Ports ports ->
73+ let
74+ addPort dict (Src.Port (A.At region name) _) =
75+ Dups.insert name region (Env.TopLevel region) dict
76+ in
77+ List.foldl' addPort Dups.none ports
78+
79+ Src.Manager _ manager ->
80+ case manager of
81+ Src.Cmd (A.At region _) ->
82+ Dups.one "command" region (Env.TopLevel region)
83+
84+ Src.Sub (A.At region _) ->
85+ Dups.one "subscription" region (Env.TopLevel region)
86+
87+ Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
88+ Dups.union
89+ (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
90+ (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
91+
92+
93+
94+-- ADD TYPES
95+
96+
97+addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98+addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
99+ let
100+ addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101+ addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
102+ typeNameDups =
103+ List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
104+ in
105+ do _ <- Dups.detect Error.DuplicateType typeNameDups
106+ ts1 <- foldM (addUnion home) ts unions
107+ addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
108+
109+
110+addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111+addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112+ do arity <- checkUnionFreeVars union
113+ let one = Env.Specific home (Env.Union arity home)
114+ Result.ok $ Map.insert name one types
115+
116+
117+
118+-- ADD TYPE ALIASES
119+
120+
121+addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env
122+addAliases aliases env =
123+ let
124+ nodes = map toNode aliases
125+ sccs = Graph.stronglyConnComp nodes
126+ in
127+ foldM addAlias env sccs
128+
129+
130+addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env
131+addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
132+ case scc of
133+ Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134+ do args <- checkAliasFreeVars alias
135+ ctype <- Type.canonicalize env tipe
136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)
137+ let ts1 = Map.insert name one ts
138+ Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
139+
140+ Graph.CyclicSCC [] ->
141+ Result.ok env
142+
143+ Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->
144+ do args <- checkAliasFreeVars alias
145+ let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name
146+ Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
147+
148+
149+
150+-- DETECT TYPE ALIAS CYCLES
151+
152+
153+toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name])
154+toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) =
155+ ( alias, name, getEdges [] tipe )
156+
157+
158+getEdges :: [Name.Name] -> Src.Type -> [Name.Name]
159+getEdges edges (A.At _ tipe) =
160+ case tipe of
161+ Src.TLambda arg result ->
162+ getEdges (getEdges edges arg) result
163+
164+ Src.TVar _ ->
165+ edges
166+
167+ Src.TType _ name args ->
168+ List.foldl' getEdges (name:edges) args
169+
170+ Src.TTypeQual _ _ _ args ->
171+ List.foldl' getEdges edges args
172+
173+ Src.TRecord fields _ ->
174+ List.foldl' (\es (_,t) -> getEdges es t) edges fields
175+
176+ Src.TUnit ->
177+ edges
178+
179+ Src.TTuple a b cs ->
180+ List.foldl' getEdges (getEdges (getEdges edges a) b) cs
181+
182+
183+
184+-- CHECK FREE VARIABLES
185+
186+
187+checkUnionFreeVars :: A.Located Src.Union -> Result i w Int
188+checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =
189+ let
190+ addArg (A.At region arg) dict =
191+ Dups.insert arg region region dict
192+
193+ addCtorFreeVars (_, tipes) freeVars =
194+ List.foldl' addFreeVars freeVars tipes
195+ in
196+ do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args)
197+ let freeVars = foldr addCtorFreeVars Map.empty ctors
198+ case Map.toList (Map.difference freeVars boundVars) of
199+ [] ->
200+ Result.ok (length args)
201+
202+ unbound:unbounds ->
203+ Result.throw $
204+ Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
205+
206+
207+checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]
208+checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =
209+ let
210+ addArg (A.At region arg) dict =
211+ Dups.insert arg region region dict
212+ in
213+ do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args)
214+ let freeVars = addFreeVars Map.empty tipe
215+ let overlap = Map.size (Map.intersection boundVars freeVars)
216+ if Map.size boundVars == overlap && Map.size freeVars == overlap
217+ then Result.ok (map A.toValue args)
218+ else
219+ Result.throw $
220+ Error.TypeVarsMessedUpInAlias aliasRegion name
221+ (map A.toValue args)
222+ (Map.toList (Map.difference boundVars freeVars))
223+ (Map.toList (Map.difference freeVars boundVars))
224+
225+
226+addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region
227+addFreeVars freeVars (A.At region tipe) =
228+ case tipe of
229+ Src.TLambda arg result ->
230+ addFreeVars (addFreeVars freeVars arg) result
231+
232+ Src.TVar name ->
233+ Map.insert name region freeVars
234+
235+ Src.TType _ _ args ->
236+ List.foldl' addFreeVars freeVars args
237+
238+ Src.TTypeQual _ _ _ args ->
239+ List.foldl' addFreeVars freeVars args
240+
241+ Src.TRecord fields maybeExt ->
242+ let
243+ extFreeVars =
244+ case maybeExt of
245+ Nothing ->
246+ freeVars
247+
248+ Just (A.At extRegion ext) ->
249+ Map.insert ext extRegion freeVars
250+ in
251+ List.foldl' (\fvs (_,t) -> addFreeVars fvs t) extFreeVars fields
252+
253+ Src.TUnit ->
254+ freeVars
255+
256+ Src.TTuple a b cs ->
257+ List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs
258+
259+
260+
261+-- ADD CTORS
262+
263+
264+addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265+addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266+ do unionInfo <- traverse (canonicalizeUnion env) unions
267+ aliasInfo <- traverse (canonicalizeAlias env) aliases
268+
269+ ctors <-
270+ Dups.detect Error.DuplicateCtor $
271+ Dups.union
272+ (Dups.unions (map snd unionInfo))
273+ (Dups.unions (map snd aliasInfo))
274+
275+ let cs2 = Map.union ctors cs
276+
277+ Result.ok
278+ ( Env.Env home vs ts cs2 bs qvs qts qcs
279+ , Map.fromList (map fst unionInfo)
280+ , Map.fromList (map fst aliasInfo)
281+ )
282+
283+
284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)
285+
286+
287+
288+-- CANONICALIZE ALIAS
289+
290+
291+canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups )
292+canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) =
293+ do let vars = map A.toValue args
294+ ctipe <- Type.canonicalize env tipe
295+ Result.ok
296+ ( (name, Can.Alias vars ctipe)
297+ ,
298+ case ctipe of
299+ Can.TRecord fields Nothing ->
300+ Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))
301+
302+ _ ->
303+ Dups.none
304+ )
305+
306+toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor
307+toRecordCtor home name vars fields =
308+ let
309+ avars = map (\var -> (var, Can.TVar var)) vars
310+ alias =
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
317+
318+
319+
320+-- CANONICALIZE UNION
321+
322+
323+canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups )
324+canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ name) avars ctors)) =
325+ do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
326+ let vars = map A.toValue avars
327+ let alts = map A.toValue cctors
328+ let union = Can.Union vars alts (length alts) (toOpts ctors)
329+ Result.ok
330+ ( (name, union)
331+ , Dups.unions $ map (toCtor home name union) cctors
332+ )
333+
334+
335+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
336+canonicalizeCtor env index (A.At region ctor, tipes) =
337+ do ctipes <- traverse (Type.canonicalize env) tipes
338+ Result.ok $ A.At region $
339+ Can.Ctor ctor index (length ctipes) ctipes
340+
341+
342+toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts
343+toOpts ctors =
344+ case ctors of
345+ [ (_,[_]) ] ->
346+ Can.Unbox
347+
348+ _ ->
349+ if all (null . snd) ctors then Can.Enum else Can.Normal
350+
351+
352+toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353+toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354+ Dups.one name region $ Env.Specific home $
355+ Env.Ctor home typeName union index args
compiler/src/Canonicalize/Expression.hsnew file+761
@@ -0,0 +1,761 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Expression
4+ ( canonicalize
5+ , FreeLocals
6+ , Uses(..)
7+ , verifyBindings
8+ , gatherTypedArgs
9+ )
10+ where
11+
12+
13+import Control.Monad (foldM)
14+import qualified Data.Graph as Graph
15+import qualified Data.List as List
16+import qualified Data.Map.Strict as Map
17+import qualified Data.Name as Name
18+
19+import qualified AST.Canonical as Can
20+import qualified AST.Source as Src
21+import qualified AST.Utils.Binop as Binop
22+import qualified AST.Utils.Type as Type
23+import qualified Canonicalize.Environment as Env
24+import qualified Canonicalize.Environment.Dups as Dups
25+import qualified Canonicalize.Pattern as Pattern
26+import qualified Canonicalize.Type as Type
27+import qualified Data.Index as Index
28+import qualified Elm.ModuleName as ModuleName
29+import qualified Elm.Package as Pkg
30+import qualified Reporting.Annotation as A
31+import qualified Reporting.Error.Canonicalize as Error
32+import qualified Reporting.Result as Result
33+import qualified Reporting.Warning as W
34+
35+
36+
37+-- RESULTS
38+
39+
40+type Result i w a =
41+ Result.Result i w Error.Error a
42+
43+
44+type FreeLocals =
45+ Map.Map Name.Name Uses
46+
47+
48+data Uses =
49+ Uses
50+ { _direct :: {-# UNPACK #-} !Int
51+ , _delayed :: {-# UNPACK #-} !Int
52+ }
53+
54+
55+
56+-- CANONICALIZE
57+
58+
59+canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
60+canonicalize env (A.At region expression) =
61+ A.At region <$>
62+ case expression of
63+ Src.Str string ->
64+ Result.ok (Can.Str string)
65+
66+ Src.Chr char ->
67+ Result.ok (Can.Chr char)
68+
69+ Src.Int int ->
70+ Result.ok (Can.Int int)
71+
72+ Src.Float float ->
73+ Result.ok (Can.Float float)
74+
75+ Src.Var varType name ->
76+ case varType of
77+ Src.LowVar -> findVar region env name
78+ Src.CapVar -> toVarCtor name <$> Env.findCtor region env name
79+
80+ Src.VarQual varType prefix name ->
81+ case varType of
82+ Src.LowVar -> findVarQual region env prefix name
83+ Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name
84+
85+ Src.List exprs ->
86+ Can.List <$> traverse (canonicalize env) exprs
87+
88+ Src.Op op ->
89+ do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
90+ return (Can.VarOperator op home name annotation)
91+
92+ Src.Negate expr ->
93+ Can.Negate <$> canonicalize env expr
94+
95+ Src.Binops ops final ->
96+ A.toValue <$> canonicalizeBinops region env ops final
97+
98+ Src.Lambda srcArgs body ->
99+ delayedUsage $
100+ do (args, bindings) <-
101+ Pattern.verify Error.DPLambdaArgs $
102+ traverse (Pattern.canonicalize env) srcArgs
103+
104+ newEnv <-
105+ Env.addLocals bindings env
106+
107+ (cbody, freeLocals) <-
108+ verifyBindings W.Pattern bindings (canonicalize newEnv body)
109+
110+ return (Can.Lambda args cbody, freeLocals)
111+
112+ Src.Call func args ->
113+ Can.Call
114+ <$> canonicalize env func
115+ <*> traverse (canonicalize env) args
116+
117+ Src.If branches finally ->
118+ Can.If
119+ <$> traverse (canonicalizeIfBranch env) branches
120+ <*> canonicalize env finally
121+
122+ Src.Let defs expr ->
123+ A.toValue <$> canonicalizeLet region env defs expr
124+
125+ Src.Case expr branches ->
126+ Can.Case
127+ <$> canonicalize env expr
128+ <*> traverse (canonicalizeCaseBranch env) branches
129+
130+ Src.Accessor field ->
131+ Result.ok $ Can.Accessor field
132+
133+ Src.Access record field ->
134+ Can.Access
135+ <$> canonicalize env record
136+ <*> Result.ok field
137+
138+ Src.Update (A.At reg name) fields ->
139+ let
140+ makeCanFields =
141+ Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields
142+ in
143+ Can.Update name
144+ <$> (A.At reg <$> findVar reg env name)
145+ <*> (sequenceA =<< makeCanFields)
146+
147+ Src.Record fields ->
148+ do fieldDict <- Dups.checkFields fields
149+ Can.Record <$> traverse (canonicalize env) fieldDict
150+
151+ Src.Unit ->
152+ Result.ok Can.Unit
153+
154+ Src.Tuple a b cs ->
155+ Can.Tuple
156+ <$> canonicalize env a
157+ <*> canonicalize env b
158+ <*> canonicalizeTupleExtras region env cs
159+
160+ Src.Shader src tipe ->
161+ Result.ok (Can.Shader src tipe)
162+
163+
164+
165+-- CANONICALIZE TUPLE EXTRAS
166+
167+
168+canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
169+canonicalizeTupleExtras region env extras =
170+ case extras of
171+ [] ->
172+ Result.ok Nothing
173+
174+ [three] ->
175+ Just <$> canonicalize env three
176+
177+ _ ->
178+ Result.throw (Error.TupleLargerThanThree region)
179+
180+
181+
182+-- CANONICALIZE IF BRANCH
183+
184+
185+canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
186+canonicalizeIfBranch env (condition, branch) =
187+ (,)
188+ <$> canonicalize env condition
189+ <*> canonicalize env branch
190+
191+
192+
193+-- CANONICALIZE CASE BRANCH
194+
195+
196+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
197+canonicalizeCaseBranch env (pattern, expr) =
198+ directUsage $
199+ do (cpattern, bindings) <-
200+ Pattern.verify Error.DPCaseBranch $
201+ Pattern.canonicalize env pattern
202+ newEnv <- Env.addLocals bindings env
203+
204+ (cexpr, freeLocals) <-
205+ verifyBindings W.Pattern bindings (canonicalize newEnv expr)
206+
207+ return (Can.CaseBranch cpattern cexpr, freeLocals)
208+
209+
210+
211+-- CANONICALIZE BINOPS
212+
213+
214+canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
215+canonicalizeBinops overallRegion env ops final =
216+ let
217+ canonicalizeHelp (expr, A.At region op) =
218+ (,)
219+ <$> canonicalize env expr
220+ <*> Env.findBinop region env op
221+ in
222+ runBinopStepper overallRegion =<< (
223+ More
224+ <$> traverse canonicalizeHelp ops
225+ <*> canonicalize env final
226+ )
227+
228+
229+data Step
230+ = Done Can.Expr
231+ | More [(Can.Expr, Env.Binop)] Can.Expr
232+ | Error Env.Binop Env.Binop
233+
234+
235+runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr
236+runBinopStepper overallRegion step =
237+ case step of
238+ Done expr ->
239+ Result.ok expr
240+
241+ More [] expr ->
242+ Result.ok expr
243+
244+ More ( (expr, op) : rest ) final ->
245+ runBinopStepper overallRegion $
246+ toBinopStep (toBinop op expr) op rest final
247+
248+ Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->
249+ Result.throw (Error.Binop overallRegion op1 op2)
250+
251+
252+toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
253+toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final =
254+ case middle of
255+ [] ->
256+ Done (makeBinop final)
257+
258+ ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest ->
259+ if precedence < rootPrecedence then
260+
261+ More ((makeBinop expr, op) : rest) final
262+
263+ else if precedence > rootPrecedence then
264+
265+ case toBinopStep (toBinop op expr) op rest final of
266+ Done newLast ->
267+ Done (makeBinop newLast)
268+
269+ More newMiddle newLast ->
270+ toBinopStep makeBinop rootOp newMiddle newLast
271+
272+ Error a b ->
273+ Error a b
274+
275+ else
276+
277+ case (rootAssociativity, associativity) of
278+ (Binop.Left, Binop.Left) ->
279+ toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final
280+
281+ (Binop.Right, Binop.Right) ->
282+ toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final
283+
284+ (_, _) ->
285+ Error rootOp op
286+
287+
288+toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr
289+toBinop (Env.Binop op home name annotation _ _) left right =
290+ A.merge left right (Can.Binop op home name annotation left right)
291+
292+
293+
294+-- CANONICALIZE LET
295+
296+
297+canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr
298+canonicalizeLet letRegion env defs body =
299+ directUsage $
300+ do bindings <-
301+ Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $
302+ List.foldl' addBindings Dups.none defs
303+
304+ newEnv <- Env.addLocals bindings env
305+
306+ verifyBindings W.Def bindings $
307+ do nodes <- foldM (addDefNodes newEnv) [] defs
308+ cbody <- canonicalize newEnv body
309+ detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
310+
311+
312+
313+-- ADD BINDINGS
314+
315+
316+addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region
317+addBindings bindings (A.At _ def) =
318+ case def of
319+ Src.Define (A.At region name) _ _ _ ->
320+ Dups.insert name region region bindings
321+
322+ Src.Destruct pattern _ ->
323+ addBindingsHelp bindings pattern
324+
325+
326+addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region
327+addBindingsHelp bindings (A.At region pattern) =
328+ case pattern of
329+ Src.PAnything ->
330+ bindings
331+
332+ Src.PVar name ->
333+ Dups.insert name region region bindings
334+
335+ Src.PRecord fields ->
336+ let
337+ addField dict (A.At fieldRegion name) =
338+ Dups.insert name fieldRegion fieldRegion dict
339+ in
340+ List.foldl' addField bindings fields
341+
342+ Src.PUnit ->
343+ bindings
344+
345+ Src.PTuple a b cs ->
346+ List.foldl' addBindingsHelp bindings (a:b:cs)
347+
348+ Src.PCtor _ _ patterns ->
349+ List.foldl' addBindingsHelp bindings patterns
350+
351+ Src.PCtorQual _ _ _ patterns ->
352+ List.foldl' addBindingsHelp bindings patterns
353+
354+ Src.PList patterns ->
355+ List.foldl' addBindingsHelp bindings patterns
356+
357+ Src.PCons hd tl ->
358+ addBindingsHelp (addBindingsHelp bindings hd) tl
359+
360+ Src.PAlias aliasPattern (A.At nameRegion name) ->
361+ Dups.insert name nameRegion nameRegion $
362+ addBindingsHelp bindings aliasPattern
363+
364+ Src.PChr _ ->
365+ bindings
366+
367+ Src.PStr _ ->
368+ bindings
369+
370+ Src.PInt _ ->
371+ bindings
372+
373+
374+
375+-- BUILD BINDINGS GRAPH
376+
377+
378+type Node =
379+ (Binding, Name.Name, [Name.Name])
380+
381+
382+data Binding
383+ = Define Can.Def
384+ | Edge (A.Located Name.Name)
385+ | Destruct Can.Pattern Can.Expr
386+
387+
388+addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node]
389+addDefNodes env nodes (A.At _ def) =
390+ case def of
391+ Src.Define aname@(A.At _ name) srcArgs body maybeType ->
392+ case maybeType of
393+ Nothing ->
394+ do (args, argBindings) <-
395+ Pattern.verify (Error.DPFuncArgs name) $
396+ traverse (Pattern.canonicalize env) srcArgs
397+
398+ newEnv <-
399+ Env.addLocals argBindings env
400+
401+ (cbody, freeLocals) <-
402+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
403+
404+ let cdef = Can.Def aname args cbody
405+ let node = ( Define cdef, name, Map.keys freeLocals )
406+ logLetLocals args freeLocals (node:nodes)
407+
408+ Just tipe ->
409+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
410+ ((args, resultType), argBindings) <-
411+ Pattern.verify (Error.DPFuncArgs name) $
412+ gatherTypedArgs env name srcArgs ctipe Index.first []
413+
414+ newEnv <-
415+ Env.addLocals argBindings env
416+
417+ (cbody, freeLocals) <-
418+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
419+
420+ let cdef = Can.TypedDef aname freeVars args cbody resultType
421+ let node = ( Define cdef, name, Map.keys freeLocals )
422+ logLetLocals args freeLocals (node:nodes)
423+
424+ Src.Destruct pattern body ->
425+ do (cpattern, _bindings) <-
426+ Pattern.verify Error.DPDestruct $
427+ Pattern.canonicalize env pattern
428+
429+ Result.Result $ \fs ws bad good ->
430+ case canonicalize env body of
431+ Result.Result k ->
432+ k Map.empty ws
433+ (\freeLocals warnings errors ->
434+ bad (Map.unionWith combineUses freeLocals fs) warnings errors
435+ )
436+ (\freeLocals warnings cbody ->
437+ let
438+ names = getPatternNames [] pattern
439+ name = Name.fromManyNames (map A.toValue names)
440+ node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
441+ in
442+ good
443+ (Map.unionWith combineUses fs freeLocals)
444+ warnings
445+ (List.foldl' (addEdge [name]) (node:nodes) names)
446+ )
447+
448+
449+logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value
450+logLetLocals args letLocals value =
451+ Result.Result $ \freeLocals warnings _ good ->
452+ good
453+ ( Map.unionWith combineUses freeLocals $
454+ case args of
455+ [] -> letLocals
456+ _ -> Map.map delayUse letLocals
457+ )
458+ warnings
459+ value
460+
461+
462+addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node]
463+addEdge edges nodes aname@(A.At _ name) =
464+ (Edge aname, name, edges) : nodes
465+
466+
467+getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]
468+getPatternNames names (A.At region pattern) =
469+ case pattern of
470+ Src.PAnything -> names
471+ Src.PVar name -> A.At region name : names
472+ Src.PRecord fields -> fields ++ names
473+ Src.PAlias ptrn name -> getPatternNames (name : names) ptrn
474+ Src.PUnit -> names
475+ Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs
476+ Src.PCtor _ _ args -> List.foldl' getPatternNames names args
477+ Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args
478+ Src.PList patterns -> List.foldl' getPatternNames names patterns
479+ Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl
480+ Src.PChr _ -> names
481+ Src.PStr _ -> names
482+ Src.PInt _ -> names
483+
484+
485+
486+-- GATHER TYPED ARGS
487+
488+
489+gatherTypedArgs
490+ :: Env.Env
491+ -> Name.Name
492+ -> [Src.Pattern]
493+ -> Can.Type
494+ -> Index.ZeroBased
495+ -> [(Can.Pattern, Can.Type)]
496+ -> Result Pattern.DupsDict w ([(Can.Pattern, Can.Type)], Can.Type)
497+gatherTypedArgs env name srcArgs tipe index revTypedArgs =
498+ case srcArgs of
499+ [] ->
500+ return (reverse revTypedArgs, tipe)
501+
502+ srcArg : otherSrcArgs ->
503+ case Type.iteratedDealias tipe of
504+ Can.TLambda argType resultType ->
505+ do arg <- Pattern.canonicalize env srcArg
506+ gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $
507+ (arg, argType) : revTypedArgs
508+
509+ _ ->
510+ let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
511+ Result.throw $
512+ Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs)
513+
514+
515+
516+-- DETECT CYCLES
517+
518+
519+detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
520+detectCycles letRegion sccs body =
521+ case sccs of
522+ [] ->
523+ Result.ok body
524+
525+ scc : subSccs ->
526+ case scc of
527+ Graph.AcyclicSCC binding ->
528+ case binding of
529+ Define def ->
530+ A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body
531+
532+ Edge _ ->
533+ detectCycles letRegion subSccs body
534+
535+ Destruct pattern expr ->
536+ A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body
537+
538+ Graph.CyclicSCC bindings ->
539+ A.At letRegion <$>
540+ (Can.LetRec
541+ <$> checkCycle bindings []
542+ <*> detectCycles letRegion subSccs body
543+ )
544+
545+
546+checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def]
547+checkCycle bindings defs =
548+ case bindings of
549+ [] ->
550+ Result.ok defs
551+
552+ binding : otherBindings ->
553+ case binding of
554+ Define def@(Can.Def name args _) ->
555+ if null args then
556+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
557+ else
558+ checkCycle otherBindings (def:defs)
559+
560+ Define def@(Can.TypedDef name _ args _ _) ->
561+ if null args then
562+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
563+ else
564+ checkCycle otherBindings (def:defs)
565+
566+ Edge name ->
567+ Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
568+
569+ Destruct _ _ ->
570+ -- a Destruct cannot appear in a cycle without any Edge values
571+ -- so we just keep going until we get to the edges
572+ checkCycle otherBindings defs
573+
574+
575+toNames :: [Binding] -> [Can.Def] -> [Name.Name]
576+toNames bindings revDefs =
577+ case bindings of
578+ [] ->
579+ reverse (map getDefName revDefs)
580+
581+ binding : otherBindings ->
582+ case binding of
583+ Define def -> getDefName def : toNames otherBindings revDefs
584+ Edge (A.At _ name) -> name : toNames otherBindings revDefs
585+ Destruct _ _ -> toNames otherBindings revDefs
586+
587+
588+getDefName :: Can.Def -> Name.Name
589+getDefName def =
590+ case def of
591+ Can.Def (A.At _ name) _ _ ->
592+ name
593+
594+ Can.TypedDef (A.At _ name) _ _ _ _ ->
595+ name
596+
597+
598+
599+-- LOG VARIABLE USES
600+
601+
602+logVar :: Name.Name -> a -> Result FreeLocals w a
603+logVar name value =
604+ Result.Result $ \freeLocals warnings _ good ->
605+ good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
606+
607+
608+{-# NOINLINE oneDirectUse #-}
609+oneDirectUse :: Uses
610+oneDirectUse =
611+ Uses 1 0
612+
613+
614+combineUses :: Uses -> Uses -> Uses
615+combineUses (Uses a b) (Uses x y) =
616+ Uses (a + x) (b + y)
617+
618+
619+delayUse :: Uses -> Uses
620+delayUse (Uses direct delayed) =
621+ Uses 0 (direct + delayed)
622+
623+
624+
625+-- MANAGING BINDINGS
626+
627+
628+verifyBindings
629+ :: W.Context
630+ -> Pattern.Bindings
631+ -> Result FreeLocals [W.Warning] value
632+ -> Result info [W.Warning] (value, FreeLocals)
633+verifyBindings context bindings (Result.Result k) =
634+ Result.Result $ \info warnings bad good ->
635+ k Map.empty warnings
636+ (\_ warnings1 err ->
637+ bad info warnings1 err
638+ )
639+ (\freeLocals warnings1 value ->
640+ let
641+ outerFreeLocals =
642+ Map.difference freeLocals bindings
643+
644+ warnings2 =
645+ -- NOTE: Uses Map.size for O(1) lookup. This means there is
646+ -- no dictionary allocation unless a problem is detected.
647+ if Map.size bindings + Map.size outerFreeLocals == Map.size freeLocals then
648+ warnings1
649+ else
650+ Map.foldlWithKey (addUnusedWarning context) warnings1 $
651+ Map.difference bindings freeLocals
652+ in
653+ good info warnings2 (value, outerFreeLocals)
654+ )
655+
656+
657+addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning]
658+addUnusedWarning context warnings name region =
659+ W.UnusedVariable region context name : warnings
660+
661+
662+directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
663+directUsage (Result.Result k) =
664+ Result.Result $ \freeLocals warnings bad good ->
665+ k () warnings
666+ (\() ws es -> bad freeLocals ws es)
667+ (\() ws (value, newFreeLocals) ->
668+ good (Map.unionWith combineUses freeLocals newFreeLocals) ws value
669+ )
670+
671+
672+delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
673+delayedUsage (Result.Result k) =
674+ Result.Result $ \freeLocals warnings bad good ->
675+ k () warnings
676+ (\() ws es -> bad freeLocals ws es)
677+ (\() ws (value, newFreeLocals) ->
678+ let delayedLocals = Map.map delayUse newFreeLocals in
679+ good (Map.unionWith combineUses freeLocals delayedLocals) ws value
680+ )
681+
682+
683+
684+-- FIND VARIABLE
685+
686+
687+findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_
688+findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =
689+ case Map.lookup name vs of
690+ Just var ->
691+ case var of
692+ Env.Local _ ->
693+ logVar name (Can.VarLocal name)
694+
695+ Env.TopLevel _ ->
696+ logVar name (Can.VarTopLevel localHome name)
697+
698+ Env.Foreign home annotation ->
699+ Result.ok $
700+ if home == ModuleName.debug then
701+ Can.VarDebug localHome name annotation
702+ else
703+ Can.VarForeign home name annotation
704+
705+ Env.Foreigns h hs ->
706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)
707+
708+ Nothing ->
709+ Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))
710+
711+
712+findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_
713+findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =
714+ case Map.lookup prefix qvs of
715+ Just qualified ->
716+ case Map.lookup name qualified of
717+ Just (Env.Specific home annotation) ->
718+ Result.ok $
719+ if home == ModuleName.debug then
720+ Can.VarDebug localHome name annotation
721+ else
722+ Can.VarForeign home name annotation
723+
724+ Just (Env.Ambiguous h hs) ->
725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)
726+
727+ Nothing ->
728+ Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
729+
730+ Nothing ->
731+ if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then
732+ Result.ok $ Can.VarKernel (Name.getKernel prefix) name
733+ else
734+ Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))
735+
736+
737+toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames
738+toPossibleNames exposed qualified =
739+ Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)
740+
741+
742+
743+-- FIND CTOR
744+
745+
746+toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_
747+toVarCtor name ctor =
748+ case ctor of
749+ Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->
750+ let
751+ freeVars = Map.fromList (map (\v -> (v, ())) vars)
752+ result = Can.TType home typeName (map Can.TVar vars)
753+ tipe = foldr Can.TLambda result args
754+ in
755+ Can.VarCtor opts home name index (Can.Forall freeVars tipe)
756+
757+ Env.RecordCtor home vars tipe ->
758+ let
759+ freeVars = Map.fromList (map (\v -> (v, ())) vars)
760+ in
761+ Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe)
compiler/src/Canonicalize/Module.hsnew file+296
@@ -0,0 +1,296 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Module
3+ ( canonicalize
4+ )
5+ where
6+
7+
8+import qualified Data.Graph as Graph
9+import qualified Data.Map as Map
10+import qualified Data.Name as Name
11+
12+import qualified AST.Canonical as Can
13+import qualified AST.Source as Src
14+import qualified Canonicalize.Effects as Effects
15+import qualified Canonicalize.Environment as Env
16+import qualified Canonicalize.Environment.Dups as Dups
17+import qualified Canonicalize.Environment.Foreign as Foreign
18+import qualified Canonicalize.Environment.Local as Local
19+import qualified Canonicalize.Expression as Expr
20+import qualified Canonicalize.Pattern as Pattern
21+import qualified Canonicalize.Type as Type
22+import qualified Data.Index as Index
23+import qualified Elm.Interface as I
24+import qualified Elm.ModuleName as ModuleName
25+import qualified Elm.Package as Pkg
26+import qualified Reporting.Annotation as A
27+import qualified Reporting.Error.Canonicalize as Error
28+import qualified Reporting.Result as Result
29+import qualified Reporting.Warning as W
30+
31+
32+
33+-- RESULT
34+
35+
36+type Result i w a =
37+ Result.Result i w Error.Error a
38+
39+
40+
41+-- MODULES
42+
43+
44+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module
45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =
46+ do let home = ModuleName.Canonical pkg (Src.getName modul)
47+ let cbinops = Map.fromList (map canonicalizeBinop binops)
48+
49+ (env, cunions, caliases) <-
50+ Local.add modul =<<
51+ Foreign.createInitialEnv home ifaces imports
52+
53+ cvalues <- canonicalizeValues env values
54+ ceffects <- Effects.canonicalize env values cunions effects
55+ cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports
56+
57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects
58+
59+
60+
61+-- CANONICALIZE BINOP
62+
63+
64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )
65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =
66+ ( op, Can.Binop_ associativity precedence func )
67+
68+
69+
70+-- DECLARATIONS / CYCLE DETECTION
71+--
72+-- There are two phases of cycle detection:
73+--
74+-- 1. Detect cycles using ALL dependencies => needed for type inference
75+-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
76+--
77+
78+
79+canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls
80+canonicalizeValues env values =
81+ do nodes <- traverse (toNodeOne env) values
82+ detectCycles (Graph.stronglyConnComp nodes)
83+
84+
85+detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
86+detectCycles sccs =
87+ case sccs of
88+ [] ->
89+ Result.ok Can.SaveTheEnvironment
90+
91+ scc : otherSccs ->
92+ case scc of
93+ Graph.AcyclicSCC (def, _, _) ->
94+ Can.Declare def <$> detectCycles otherSccs
95+
96+ Graph.CyclicSCC subNodes ->
97+ do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)
98+ case defs of
99+ [] -> detectCycles otherSccs
100+ d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs
101+
102+
103+detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
104+detectBadCycles scc =
105+ case scc of
106+ Graph.AcyclicSCC def ->
107+ Result.ok def
108+
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
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
125+
126+
127+
128+-- DECLARATIONS / CYCLE DETECTION SETUP
129+--
130+-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
131+--
132+
133+-- Phase one nodes track ALL dependencies.
134+-- This allows us to find cyclic values for type inference.
135+type NodeOne =
136+ (NodeTwo, Name.Name, [Name.Name])
137+
138+
139+-- Phase two nodes track DIRECT dependencies.
140+-- This allows us to detect cycles that definitely do not terminate.
141+type NodeTwo =
142+ (Can.Def, Name.Name, [Name.Name])
143+
144+
145+toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne
146+toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =
147+ case maybeType of
148+ Nothing ->
149+ do (args, argBindings) <-
150+ Pattern.verify (Error.DPFuncArgs name) $
151+ traverse (Pattern.canonicalize env) srcArgs
152+
153+ newEnv <-
154+ Env.addLocals argBindings env
155+
156+ (cbody, freeLocals) <-
157+ Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
158+
159+ let def = Can.Def aname args cbody
160+ return
161+ ( toNodeTwo name srcArgs def freeLocals
162+ , name
163+ , Map.keys freeLocals
164+ )
165+
166+ Just srcType ->
167+ do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
168+
169+ ((args,resultType), argBindings) <-
170+ Pattern.verify (Error.DPFuncArgs name) $
171+ Expr.gatherTypedArgs env name srcArgs tipe Index.first []
172+
173+ newEnv <-
174+ Env.addLocals argBindings env
175+
176+ (cbody, freeLocals) <-
177+ Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
178+
179+ let def = Can.TypedDef aname freeVars args cbody resultType
180+ return
181+ ( toNodeTwo name srcArgs def freeLocals
182+ , name
183+ , Map.keys freeLocals
184+ )
185+
186+
187+toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
188+toNodeTwo name args def freeLocals =
189+ case args of
190+ [] ->
191+ (def, name, Map.foldrWithKey addDirects [] freeLocals)
192+
193+ _ ->
194+ (def, name, [])
195+
196+
197+addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]
198+addDirects name (Expr.Uses directUses _) directDeps =
199+ if directUses > 0 then
200+ name:directDeps
201+ else
202+ directDeps
203+
204+
205+
206+-- CANONICALIZE EXPORTS
207+
208+
209+canonicalizeExports
210+ :: [A.Located Src.Value]
211+ -> Map.Map Name.Name union
212+ -> Map.Map Name.Name alias
213+ -> Map.Map Name.Name binop
214+ -> Can.Effects
215+ -> A.Located Src.Exposing
216+ -> Result i w Can.Exports
217+canonicalizeExports values unions aliases binops effects (A.At region exposing) =
218+ case exposing of
219+ Src.Open ->
220+ Result.ok (Can.ExportEverything region)
221+
222+ Src.Explicit exposeds ->
223+ do let names = Map.fromList (map valueToName values)
224+ infos <- traverse (checkExposed names unions aliases binops effects) exposeds
225+ Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
226+
227+
228+valueToName :: A.Located Src.Value -> ( Name.Name, () )
229+valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =
230+ ( name, () )
231+
232+
233+checkExposed
234+ :: Map.Map Name.Name value
235+ -> Map.Map Name.Name union
236+ -> Map.Map Name.Name alias
237+ -> Map.Map Name.Name binop
238+ -> Can.Effects
239+ -> Src.Exposed
240+ -> Result i w (Dups.Dict (A.Located Can.Export))
241+checkExposed values unions aliases binops effects exposed =
242+ case exposed of
243+ Src.Lower (A.At region name) ->
244+ if Map.member name values then
245+ ok name region Can.ExportValue
246+ else
247+ case checkPorts effects name of
248+ Nothing ->
249+ ok name region Can.ExportPort
250+
251+ Just ports ->
252+ Result.throw $ Error.ExportNotFound region Error.BadVar name $
253+ ports ++ Map.keys values
254+
255+ Src.Operator region name ->
256+ if Map.member name binops then
257+ ok name region Can.ExportBinop
258+ else
259+ Result.throw $ Error.ExportNotFound region Error.BadOp name $
260+ Map.keys binops
261+
262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->
263+ if Map.member name unions then
264+ ok name region Can.ExportUnionOpen
265+ else if Map.member name aliases then
266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name
267+ else
268+ Result.throw $ Error.ExportNotFound region Error.BadType name $
269+ Map.keys unions ++ Map.keys aliases
270+
271+ Src.Upper (A.At region name) Src.Private ->
272+ if Map.member name unions then
273+ ok name region Can.ExportUnionClosed
274+ else if Map.member name aliases then
275+ ok name region Can.ExportAlias
276+ else
277+ Result.throw $ Error.ExportNotFound region Error.BadType name $
278+ Map.keys unions ++ Map.keys aliases
279+
280+
281+checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]
282+checkPorts effects name =
283+ case effects of
284+ Can.NoEffects ->
285+ Just []
286+
287+ Can.Ports ports ->
288+ if Map.member name ports then Nothing else Just (Map.keys ports)
289+
290+ Can.Manager _ _ _ _ ->
291+ Just []
292+
293+
294+ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))
295+ok name region export =
296+ Result.ok $ Dups.one name region (A.At region export)
compiler/src/Canonicalize/Pattern.hsnew file+181
@@ -0,0 +1,181 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Pattern
3+ ( verify
4+ , Bindings
5+ , DupsDict
6+ , canonicalize
7+ )
8+ where
9+
10+
11+import qualified Data.List as List
12+import qualified Data.Map.Strict as Map
13+import qualified Data.Name as Name
14+
15+import qualified AST.Canonical as Can
16+import qualified AST.Source as Src
17+import qualified Canonicalize.Environment as Env
18+import qualified Canonicalize.Environment.Dups as Dups
19+import qualified Data.Index as Index
20+import qualified Elm.ModuleName as ModuleName
21+import qualified Reporting.Annotation as A
22+import qualified Reporting.Error.Canonicalize as Error
23+import qualified Reporting.Result as Result
24+
25+
26+
27+-- RESULTS
28+
29+
30+type Result i w a =
31+ Result.Result i w Error.Error a
32+
33+
34+type Bindings =
35+ Map.Map Name.Name A.Region
36+
37+
38+
39+-- VERIFY
40+
41+
42+verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings)
43+verify context (Result.Result k) =
44+ Result.Result $ \info warnings bad good ->
45+ k Dups.none warnings
46+ (\_ warnings1 errors ->
47+ bad info warnings1 errors
48+ )
49+ (\bindings warnings1 value ->
50+ case Dups.detect (Error.DuplicatePattern context) bindings of
51+ Result.Result k1 ->
52+ k1 () ()
53+ (\() () errs -> bad info warnings1 errs)
54+ (\() () dict -> good info warnings1 (value, dict))
55+ )
56+
57+
58+
59+-- CANONICALIZE
60+
61+
62+type DupsDict =
63+ Dups.Dict A.Region
64+
65+
66+canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
67+canonicalize env (A.At region pattern) =
68+ A.At region <$>
69+ case pattern of
70+ Src.PAnything ->
71+ Result.ok Can.PAnything
72+
73+ Src.PVar name ->
74+ logVar name region (Can.PVar name)
75+
76+ Src.PRecord fields ->
77+ logFields fields (Can.PRecord (map A.toValue fields))
78+
79+ Src.PUnit ->
80+ Result.ok Can.PUnit
81+
82+ Src.PTuple a b cs ->
83+ Can.PTuple
84+ <$> canonicalize env a
85+ <*> canonicalize env b
86+ <*> canonicalizeTuple region env cs
87+
88+ Src.PCtor nameRegion name patterns ->
89+ canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name
90+
91+ Src.PCtorQual nameRegion home name patterns ->
92+ canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name
93+
94+ Src.PList patterns ->
95+ Can.PList <$> canonicalizeList env patterns
96+
97+ Src.PCons first rest ->
98+ Can.PCons
99+ <$> canonicalize env first
100+ <*> canonicalize env rest
101+
102+ Src.PAlias ptrn (A.At reg name) ->
103+ do cpattern <- canonicalize env ptrn
104+ logVar name reg (Can.PAlias cpattern name)
105+
106+ Src.PChr chr ->
107+ Result.ok (Can.PChr chr)
108+
109+ Src.PStr str ->
110+ Result.ok (Can.PStr str)
111+
112+ Src.PInt int ->
113+ Result.ok (Can.PInt int)
114+
115+
116+canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
117+canonicalizeCtor env region name patterns ctor =
118+ case ctor of
119+ Env.Ctor home tipe union index args ->
120+ let
121+ toCanonicalArg argIndex argPattern argTipe =
122+ Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern
123+ in
124+ do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
125+ case verifiedList of
126+ Index.LengthMatch cargs ->
127+ if tipe == Name.bool && home == ModuleName.basics then
128+ Result.ok (Can.PBool union (name == Name.true))
129+ else
130+ Result.ok (Can.PCtor home tipe union name index cargs)
131+
132+ Index.LengthMismatch actualLength expectedLength ->
133+ Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)
134+
135+ Env.RecordCtor _ _ _ ->
136+ Result.throw (Error.PatternHasRecordCtor region name)
137+
138+
139+canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
140+canonicalizeTuple tupleRegion env extras =
141+ case extras of
142+ [] ->
143+ Result.ok Nothing
144+
145+ [three] ->
146+ Just <$> canonicalize env three
147+
148+ _ ->
149+ Result.throw $ Error.TupleLargerThanThree tupleRegion
150+
151+
152+canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
153+canonicalizeList env list =
154+ case list of
155+ [] ->
156+ Result.ok []
157+
158+ pattern : otherPatterns ->
159+ (:)
160+ <$> canonicalize env pattern
161+ <*> canonicalizeList env otherPatterns
162+
163+
164+
165+-- LOG BINDINGS
166+
167+
168+logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a
169+logVar name region value =
170+ Result.Result $ \bindings warnings _ ok ->
171+ ok (Dups.insert name region region bindings) warnings value
172+
173+
174+logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175+logFields fields value =
176+ let
177+ addField dict (A.At region name) =
178+ Dups.insert name region region dict
179+ in
180+ Result.Result $ \bindings warnings _ ok ->
181+ ok (List.foldl' addField bindings fields) warnings value
compiler/src/Canonicalize/Type.hsnew file+162
@@ -0,0 +1,162 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Type
4+ ( toAnnotation
5+ , canonicalize
6+ )
7+ where
8+
9+
10+import qualified Data.List as List
11+import qualified Data.Map as Map
12+import qualified Data.Name as Name
13+
14+import qualified AST.Canonical as Can
15+import qualified AST.Source as Src
16+import qualified Canonicalize.Environment as Env
17+import qualified Canonicalize.Environment.Dups as Dups
18+import qualified Reporting.Annotation as A
19+import qualified Reporting.Error.Canonicalize as Error
20+import qualified Reporting.Result as Result
21+
22+
23+
24+-- RESULT
25+
26+
27+type Result i w a =
28+ Result.Result i w Error.Error a
29+
30+
31+
32+-- TO ANNOTATION
33+
34+
35+toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation
36+toAnnotation env srcType =
37+ do tipe <- canonicalize env srcType
38+ Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe
39+
40+
41+
42+-- CANONICALIZE TYPES
43+
44+
45+canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type
46+canonicalize env (A.At typeRegion tipe) =
47+ case tipe of
48+ Src.TVar x ->
49+ Result.ok (Can.TVar x)
50+
51+ Src.TType region name args ->
52+ canonicalizeType env typeRegion name args =<<
53+ Env.findType region env name
54+
55+ Src.TTypeQual region home name args ->
56+ canonicalizeType env typeRegion name args =<<
57+ Env.findTypeQual region env home name
58+
59+ Src.TLambda a b ->
60+ Can.TLambda
61+ <$> canonicalize env a
62+ <*> canonicalize env b
63+
64+ Src.TRecord fields ext ->
65+ do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields)
66+ return $ Can.TRecord cfields (fmap A.toValue ext)
67+
68+ Src.TUnit ->
69+ Result.ok Can.TUnit
70+
71+ Src.TTuple a b cs ->
72+ Can.TTuple
73+ <$> canonicalize env a
74+ <*> canonicalize env b
75+ <*>
76+ case cs of
77+ [] ->
78+ Result.ok Nothing
79+
80+ [c] ->
81+ Just <$> canonicalize env c
82+
83+ _ ->
84+ Result.throw $ Error.TupleLargerThanThree typeRegion
85+
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+
97+
98+-- CANONICALIZE TYPE
99+
100+
101+canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
102+canonicalizeType env region name args info =
103+ do cargs <- traverse (canonicalize env) args
104+ case info of
105+ Env.Alias arity home argNames aliasedType ->
106+ checkArity arity region name args $
107+ Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType)
108+
109+ Env.Union arity home ->
110+ checkArity arity region name args $
111+ Can.TType home name cargs
112+
113+
114+checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer
115+checkArity expected region name args answer =
116+ let actual = length args in
117+ if expected == actual then
118+ Result.ok answer
119+ else
120+ Result.throw (Error.BadArity region Error.TypeArity name expected actual)
121+
122+
123+
124+-- ADD FREE VARS
125+
126+
127+addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name ()
128+addFreeVars freeVars tipe =
129+ case tipe of
130+ Can.TLambda arg result ->
131+ addFreeVars (addFreeVars freeVars result) arg
132+
133+ Can.TVar var ->
134+ Map.insert var () freeVars
135+
136+ Can.TType _ _ args ->
137+ List.foldl' addFreeVars freeVars args
138+
139+ Can.TRecord fields Nothing ->
140+ Map.foldl addFieldFreeVars freeVars fields
141+
142+ Can.TRecord fields (Just ext) ->
143+ Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields
144+
145+ Can.TUnit ->
146+ freeVars
147+
148+ Can.TTuple a b maybeC ->
149+ case maybeC of
150+ Nothing ->
151+ addFreeVars (addFreeVars freeVars a) b
152+
153+ Just c ->
154+ addFreeVars (addFreeVars (addFreeVars freeVars a) b) c
155+
156+ Can.TAlias _ _ 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)
compiler/src/Data/Bag.hsnew file+110
@@ -0,0 +1,110 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Data.Bag
3+ ( Bag(..)
4+ , empty
5+ , one
6+ , append
7+ , map
8+ , toList
9+ , fromList
10+ )
11+ where
12+
13+
14+import Prelude hiding (map)
15+import qualified Data.List as List
16+
17+
18+
19+-- BAGS
20+
21+
22+data Bag a
23+ = Empty
24+ | One a
25+ | Two (Bag a) (Bag a)
26+
27+
28+
29+-- HELPERS
30+
31+
32+empty :: Bag a
33+empty =
34+ Empty
35+
36+
37+one :: a -> Bag a
38+one =
39+ One
40+
41+
42+append :: Bag a -> Bag a -> Bag a
43+append left right =
44+ case (left, right) of
45+ (other, Empty) ->
46+ other
47+
48+ (Empty, other) ->
49+ other
50+
51+ (_, _) ->
52+ Two left right
53+
54+
55+
56+-- MAP
57+
58+
59+map :: (a -> b) -> Bag a -> Bag b
60+map func bag =
61+ case bag of
62+ Empty ->
63+ Empty
64+
65+ One a ->
66+ One (func a)
67+
68+ Two left right ->
69+ Two (map func left) (map func right)
70+
71+
72+
73+-- TO LIST
74+
75+
76+toList :: Bag a -> [a]
77+toList bag =
78+ toListHelp bag []
79+
80+
81+toListHelp :: Bag a -> [a] -> [a]
82+toListHelp bag list =
83+ case bag of
84+ Empty ->
85+ list
86+
87+ One x ->
88+ x : list
89+
90+ Two a b ->
91+ toListHelp a (toListHelp b list)
92+
93+
94+
95+-- FROM LIST
96+
97+
98+fromList :: (a -> b) -> [a] -> Bag b
99+fromList func list =
100+ case list of
101+ [] ->
102+ Empty
103+
104+ first : rest ->
105+ List.foldl' (add func) (One (func first)) rest
106+
107+
108+add :: (a -> b) -> Bag b -> a -> Bag b
109+add func bag value =
110+ Two (One (func value)) bag
compiler/src/Data/Index.hsnew file+132
@@ -0,0 +1,132 @@
1+module Data.Index
2+ ( ZeroBased
3+ , first
4+ , second
5+ , third
6+ , next
7+ , toMachine
8+ , toHuman
9+ , indexedMap
10+ , indexedTraverse
11+ , indexedForA
12+ , VerifiedList(..)
13+ , indexedZipWith
14+ , indexedZipWithA
15+ )
16+ where
17+
18+
19+import Control.Monad (liftM)
20+import Data.Binary
21+
22+
23+
24+-- ZERO BASED
25+
26+
27+newtype ZeroBased = ZeroBased Int
28+ deriving (Eq, Ord)
29+
30+
31+first :: ZeroBased
32+first =
33+ ZeroBased 0
34+
35+
36+second :: ZeroBased
37+second =
38+ ZeroBased 1
39+
40+
41+third :: ZeroBased
42+third =
43+ ZeroBased 2
44+
45+
46+{-# INLINE next #-}
47+next :: ZeroBased -> ZeroBased
48+next (ZeroBased i) =
49+ ZeroBased (i + 1)
50+
51+
52+
53+-- DESTRUCT
54+
55+
56+toMachine :: ZeroBased -> Int
57+toMachine (ZeroBased index) =
58+ index
59+
60+
61+toHuman :: ZeroBased -> Int
62+toHuman (ZeroBased index) =
63+ index + 1
64+
65+
66+
67+-- INDEXED MAP
68+
69+
70+{-# INLINE indexedMap #-}
71+indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b]
72+indexedMap func xs =
73+ zipWith func (map ZeroBased [0 .. length xs]) xs
74+
75+
76+{-# INLINE indexedTraverse #-}
77+indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b]
78+indexedTraverse func xs =
79+ sequenceA (indexedMap func xs)
80+
81+
82+{-# INLINE indexedForA #-}
83+indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b]
84+indexedForA xs func =
85+ sequenceA (indexedMap func xs)
86+
87+
88+
89+-- VERIFIED/INDEXED ZIP
90+
91+
92+data VerifiedList a
93+ = LengthMatch [a]
94+ | LengthMismatch Int Int
95+
96+
97+indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c
98+indexedZipWith func listX listY =
99+ indexedZipWithHelp func 0 listX listY []
100+
101+
102+indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c
103+indexedZipWithHelp func index listX listY revListZ =
104+ case (listX, listY) of
105+ ([], []) ->
106+ LengthMatch (reverse revListZ)
107+
108+ (x:xs, y:ys) ->
109+ indexedZipWithHelp func (index + 1) xs ys $
110+ func (ZeroBased index) x y : revListZ
111+
112+ (_, _) ->
113+ LengthMismatch (index + length listX) (index + length listY)
114+
115+
116+indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c)
117+indexedZipWithA func listX listY =
118+ case indexedZipWith func listX listY of
119+ LengthMatch xs ->
120+ LengthMatch <$> sequenceA xs
121+
122+ LengthMismatch x y ->
123+ pure (LengthMismatch x y)
124+
125+
126+
127+-- BINARY
128+
129+
130+instance Binary ZeroBased where
131+ get = liftM ZeroBased get
132+ put (ZeroBased n) = put n
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

This diff is too big to show here.

compiler/src/Elm/Compiler/Imports.hsnew file+62

This diff is too big to show here.

compiler/src/Elm/Compiler/Type.hsnew file+194

This diff is too big to show here.

compiler/src/Elm/Compiler/Type/Extract.hsnew file+285

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.

compiler/src/Elm/Licenses.hsnew file+185

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.

compiler/src/Generate/JavaScript/Expression.hsnew file+1070

This diff is too big to show here.

compiler/src/Generate/JavaScript/Functions.hsnew file+95

This diff is too big to show here.

compiler/src/Generate/JavaScript/Name.hsnew file+261

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.

compiler/src/Json/Encode.hsnew file+310

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.

compiler/src/Nitpick/PatternMatches.hsnew file+653

This diff is too big to show here.

compiler/src/Optimize/Case.hsnew file+161

This diff is too big to show here.

compiler/src/Optimize/DecisionTree.hsnew file+637

This diff is too big to show here.

compiler/src/Optimize/Expression.hsnew file+490

This diff is too big to show here.

compiler/src/Optimize/Module.hsnew file+369

This diff is too big to show here.

compiler/src/Optimize/Names.hsnew file+173

This diff is too big to show here.

compiler/src/Optimize/Port.hsnew file+327

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.

compiler/src/Reporting/Error/Canonicalize.hsnew file+1261

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.

compiler/src/Reporting/Error/Main.hsnew file+124

This diff is too big to show here.

compiler/src/Reporting/Error/Pattern.hsnew file+195

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.

compiler/src/Reporting/Render/Type.hsnew file+257

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.

compiler/src/Reporting/Result.hsnew file+129

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Warning.hsnew file+104

This diff is too big to show here.

compiler/src/Type/Constrain/Expression.hsnew file+746

This diff is too big to show here.

compiler/src/Type/Constrain/Module.hsnew file+183

This diff is too big to show here.

compiler/src/Type/Constrain/Pattern.hsnew file+237

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Type/Instantiate.hsnew file+77

This diff is too big to show here.

compiler/src/Type/Occurs.hsnew file+80

This diff is too big to show here.

compiler/src/Type/Solve.hsnew file+727

This diff is too big to show here.

compiler/src/Type/Type.hsnew file+726

This diff is too big to show here.

compiler/src/Type/Unify.hsnew file+695

This diff is too big to show here.

compiler/src/Type/UnionFind.hsnew file+172

This diff is too big to show here.

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.txt → docs/upgrade-instructions/earlier.mdrenamed+198−17

This diff is too big to show here.

elm.cabalnew file+238

This diff is too big to show here.

hints/bad-recursion.mdnew file+133

This diff is too big to show here.

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

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/implicit-casts.mdnew file+50

This diff is too big to show here.

hints/import-cycles.mdnew file+184

This diff is too big to show here.

hints/imports.mdnew file+126

This diff is too big to show here.

hints/infinite-type.mdnew file+42

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.mdnew file+139

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/port-modules.mdnew file+32

This diff is too big to show here.

hints/recursive-alias.mdnew file+162

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.mdnew file+70

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.mdnew file+60

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.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.

libraries/Automaton.elm.hiddendeleted−123

This diff is too big to show here.

libraries/AutomatonV2.elm.hiddendeleted−149

This diff is too big to show here.

libraries/Basics.elmdeleted−338

This diff is too big to show here.

libraries/Bitwise.elmdeleted−74

This diff is too big to show here.

libraries/Char.elmdeleted−62

This diff is too big to show here.

libraries/Color.elmdeleted−174

This diff is too big to show here.

libraries/Date.elmdeleted−72

This diff is too big to show here.

libraries/Dict.elmdeleted−354

This diff is too big to show here.

libraries/Either.elmdeleted−68

This diff is too big to show here.

libraries/Graphics/Collage.elmdeleted−261

This diff is too big to show here.

libraries/Graphics/Element.elmdeleted−312

This diff is too big to show here.

libraries/Graphics/Input.elmdeleted−199

This diff is too big to show here.

libraries/Http.elmdeleted−56

This diff is too big to show here.

libraries/JavaScript.elmdeleted−74

This diff is too big to show here.

libraries/JavaScript/Experimental.elmdeleted−41

This diff is too big to show here.

libraries/Json.elmdeleted−134

This diff is too big to show here.

libraries/Keyboard.elmdeleted−77

This diff is too big to show here.

libraries/List.elmdeleted−268

This diff is too big to show here.

libraries/Maybe.elmdeleted−47

This diff is too big to show here.

libraries/Mouse.elmdeleted−41

This diff is too big to show here.

libraries/Native/Basics.jsdeleted−59

This diff is too big to show here.

libraries/Native/Bitwise.jsdeleted−25

This diff is too big to show here.

libraries/Native/Char.jsdeleted−29

This diff is too big to show here.

libraries/Native/Color.jsdeleted−69

This diff is too big to show here.

libraries/Native/Date.jsdeleted−33

This diff is too big to show here.

libraries/Native/Error.jsdeleted−32

This diff is too big to show here.

libraries/Native/Function.jsdeleted−101

This diff is too big to show here.

libraries/Native/Graphics/Collage.jsdeleted−23

This diff is too big to show here.

libraries/Native/Graphics/Input.jsdeleted−303

This diff is too big to show here.

libraries/Native/JavaScript.jsdeleted−100

This diff is too big to show here.

libraries/Native/Json.jsdeleted−72

This diff is too big to show here.

libraries/Native/List.jsdeleted−335

This diff is too big to show here.

libraries/Native/Ports.jsdeleted−83

This diff is too big to show here.

libraries/Native/Regex.jsdeleted−112

This diff is too big to show here.

libraries/Native/Show.jsdeleted−116

This diff is too big to show here.

libraries/Native/Signal/Http.jsdeleted−61

This diff is too big to show here.

libraries/Native/Signal/Keyboard.jsdeleted−117

This diff is too big to show here.

libraries/Native/Signal/Mouse.jsdeleted−51

This diff is too big to show here.

libraries/Native/Signal/Random.jsdeleted−39

This diff is too big to show here.

libraries/Native/Signal/Signal.jsdeleted−235

This diff is too big to show here.

libraries/Native/Signal/Time.jsdeleted−65

This diff is too big to show here.

libraries/Native/Signal/Touch.jsdeleted−152

This diff is too big to show here.

libraries/Native/Signal/WebSocket.jsdeleted−38

This diff is too big to show here.

libraries/Native/Signal/Window.jsdeleted−56

This diff is too big to show here.

libraries/Native/String.jsdeleted−251

This diff is too big to show here.

libraries/Native/Text.jsdeleted−148

This diff is too big to show here.

libraries/Native/Transform2D.jsdeleted−99

This diff is too big to show here.

libraries/Native/Utils.jsdeleted−231

This diff is too big to show here.

libraries/Prelude.elmdeleted−8

This diff is too big to show here.

libraries/Random.elmdeleted−30

This diff is too big to show here.

libraries/Regex.elmdeleted−133

This diff is too big to show here.

libraries/Set.elmdeleted−90

This diff is too big to show here.

libraries/Signal.elmdeleted−167

This diff is too big to show here.

libraries/String.elmdeleted−311

This diff is too big to show here.

libraries/Text.elmdeleted−110

This diff is too big to show here.

libraries/Time.elmdeleted−95

This diff is too big to show here.

libraries/Touch.elmdeleted−34

This diff is too big to show here.

libraries/Transform2D.elmdeleted−92

This diff is too big to show here.

libraries/WebSocket.elmdeleted−22

This diff is too big to show here.

libraries/Window.elmdeleted−27

This diff is too big to show here.

libraries/elm_dependencies.jsondeleted−39

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.

runtime/HotSwap.jsdeleted−42

This diff is too big to show here.

runtime/Init.jsdeleted−239

This diff is too big to show here.

runtime/Render/Collage.jsdeleted−354

This diff is too big to show here.

runtime/Render/Element.jsdeleted−322

This diff is too big to show here.

runtime/Render/Utils.jsdeleted−45

This diff is too big to show here.

runtime/Utils.jsdeleted−54

This diff is too big to show here.

server/LICENSEdeleted−30

This diff is too big to show here.

server/Server.hsdeleted−114

This diff is too big to show here.

server/Setup.hsdeleted−2

This diff is too big to show here.

server/elm-server.cabaldeleted−40

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/Main.hsdeleted−11

This diff is too big to show here.

tests/Tests/Compiler.hsdeleted−45

This diff is too big to show here.

tests/Tests/Property.hsdeleted−54

This diff is too big to show here.

tests/Tests/Property/Arbitrary.hsdeleted−113

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/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/Strings/ExtraClose.elmdeleted−4

This diff is too big to show here.

tests/test-files/good/AliasSubstitution.elmdeleted−6

This diff is too big to show here.

tests/test-files/good/NoExpressions.elmdeleted−3

This diff is too big to show here.

tests/test-files/good/Otherwise.elmdeleted−5

This diff is too big to show here.

tests/test-files/good/QuotesAndComments.elmdeleted−12

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/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.

tests/test-files/good/Strings/Multiline.elmdeleted−6

This diff is too big to show here.

tests/test-files/good/Strings/MultilineNormal.elmdeleted−6

This diff is too big to show here.

tests/test-files/good/Unify/LockedVars.elmdeleted−6

This diff is too big to show here.

tests/test-files/good/Unify/NonHomogeneousRecords.elmdeleted−8

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.