38f7a80...master · elk

.github/CONTRIBUTING.mdnew file+41

@@ -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+2−13

@@ -1,19 +1,8 @@

1+elm-stuff

12dist

23cabal-dev

34.cabal-sandbox/

45cabal.sandbox.config

5−*.o

6−*.hi

7−*.chi

8−*.chs.h

9−*.aes

10−*.elmi

11−*.elmo

12−data

13−*/ElmFiles/*

146.DS_Store

15−build

16−cache

177*~

18−exe.js

19−node_modules/

8+travis.log

.gitmodulesdeleted−6

@@ -1,6 +0,0 @@

1−[submodule "IO"]

2− path = IO

3− url = https://github.com/maxsnew/IO.git

4−[submodule "Elm-Test"]

5− path = Elm-Test

6− url = https://github.com/deadfoxygrandpa/Elm-Test.git

.travis.yml+22−25

@@ -1,31 +1,28 @@

1−# Based on https://github.com/hvr/multi-ghc-travis and https://github.com/ekmett/lens/blob/master/.travis.yml

1+language: minimal

2+services: docker

23

3−# NB: don't set `language: haskell` here

4−

5−# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.

64env:

7− - GHCVER=7.6.3

8− - GHCVER=7.8.2

5+ global:

6+ - LINUX_ARCHIVE=binary-for-linux-64-bit.gz

97

10−# Note: the distinction between `before_install` and `install` is not important.

118before_install:

12− - travis_retry sudo add-apt-repository -y ppa:hvr/ghc

13− - travis_retry sudo apt-get update

14− - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy alex # see note about happy/alex

15− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH

16− - cabal update

17− # Update happy when building with GHC 7.8 or head

18− - |

19− if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.2" ]; then

20− cabal install happy alex

21− export PATH=$HOME/.cabal/bin:$PATH

22− fi

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

2312

24−install:

25− - cabal install --only-dependencies --enable-tests --enable-benchmarks

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

2622

27−# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.

28−script:

29− - cabal configure --enable-tests

30− - cabal build

31− - cabal test

23+notifications:

24+ email:

25+ recipients:

26+ - rlefevre@dmy.fr

27+ on_success: change

28+ on_failure: change

CONTRIBUTING.mddeleted−43

@@ -1,43 +0,0 @@

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−## Licensing

8−

9−You need to sign the [contributor agreement](ContributorAgreement.pdf)

10−and send it to <info@elm-lang.org> before opening your pull request.

11−

12−## Style Guide

13−

14− * Haskell — conform to [these guidelines][haskell]

15− * JavaScript — use [Google's JS style guide][js]

16−

17−[haskell]: https://gist.github.com/evancz/0a1f3717c92fe71702be

18−[js]: https://google-styleguide.googlecode.com/svn/trunk/javascriptguide.xml

19−

20−## Branches

21−

22− * [The master branch][master] is the home of the next release of the compiler

23− so new features and improvements get merged there. Most pull requests

24− should target this branch!

25−

26− * [The stable branch][stable] is for tagging releases and critical bug fixes.

27− This branch is handy for folks who want to build the most recent public

28− release from source.

29−

30−[master]: http://github.com/elm-lang/elm/tree/master

31−[stable]: http://github.com/elm-lang/elm/tree/stable

32−

33−If you are working on a fairly large feature, we will probably want to merge it

34−in as its own branch and do some testing before bringing it into the master

35−branch. This way we can keep releases of the master branch independent of new

36−features.

37−

38−Note that the master branch of the compiler should always be in sync with the

39−master branch of the [website][], and the stable branch of the compiler should

40−always be in sync with the stable branch of the [website][]. Make sure that

41−your changes maintain this compatibility.

42−

43−[website]: https://github.com/elm-lang/elm-lang.org

ContributorAgreement.pdfdeleted

Binary file not shown.

Elm-Testdeleted−1

Submodule changed.

Elm.cabaldeleted−308

@@ -1,308 +0,0 @@

1−Name: Elm

2−Version: 0.13

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

18−

19−Category: Compiler, Language

20−

21−Build-type: Custom

22−

23−Extra-source-files: changelog.md

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/elm-lang/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: AST.Annotation,

41− AST.Declaration,

42− AST.Expression.General,

43− AST.Expression.Source,

44− AST.Expression.Valid,

45− AST.Expression.Canonical,

46− AST.Helpers,

47− AST.Literal,

48− AST.Module,

49− AST.Pattern,

50− AST.PrettyPrint,

51− AST.Type,

52− AST.Variable,

53− Generate.JavaScript,

54− Generate.JavaScript.Helpers,

55− Generate.JavaScript.Ports,

56− Generate.JavaScript.Variable,

57− Generate.Markdown,

58− Generate.Html,

59− Generate.Cases,

60− Transform.Canonicalize,

61− Transform.Canonicalize.Environment,

62− Transform.Canonicalize.Setup,

63− Transform.Canonicalize.Type,

64− Transform.Canonicalize.Variable,

65− Transform.Check,

66− Transform.Expression,

67− Transform.Declaration,

68− Transform.Definition,

69− Transform.Interface,

70− Transform.SortDefinitions,

71− Transform.Substitute,

72− Metadata.Prelude,

73− Parse.Binop,

74− Parse.Declaration,

75− Parse.Expression,

76− Parse.Helpers,

77− Parse.Literal,

78− Parse.Module,

79− Parse.Parse,

80− Parse.Pattern,

81− Parse.Type,

82− Type.Constrain.Expression,

83− Type.Constrain.Literal,

84− Type.Constrain.Pattern,

85− Type.Environment,

86− Type.ExtraChecks,

87− Type.Fragment,

88− Type.Inference,

89− Type.PrettyPrint,

90− Type.Solve,

91− Type.State,

92− Type.Type,

93− Type.Unify,

94− Build.Dependencies,

95− Build.File,

96− Build.Flags,

97− Build.Interface,

98− Build.Print,

99− Build.Source,

100− Build.Utils,

101− Paths_Elm

102−

103− Build-depends: aeson >= 0.7 && < 0.9,

104− aeson-pretty >= 0.7 && < 0.8,

105− base >=4.2 && <5,

106− binary >= 0.7.0.0 && < 0.8,

107− blaze-html >= 0.5 && < 0.8,

108− blaze-markup >= 0.5.1 && < 0.7,

109− bytestring >= 0.9 && < 0.11,

110− cheapskate >= 0.1 && < 0.2,

111− cmdargs >= 0.7 && < 0.11,

112− containers >= 0.3 && < 0.6,

113− directory >= 1.0 && < 2.0,

114− filepath >= 1 && < 2.0,

115− highlighting-kate >= 0.5 && < 0.6,

116− indents >= 0.3 && < 0.4,

117− language-ecmascript >=0.15 && < 0.17,

118− language-glsl >= 0.0.2 && < 0.2,

119− mtl >= 2 && < 3,

120− parsec >= 3.1.1 && < 3.5,

121− pretty >= 1.0 && < 2.0,

122− text >= 1 && < 2,

123− transformers >= 0.2 && < 0.5,

124− union-find >= 0.2 && < 0.3,

125− unordered-containers >= 0.1 && < 0.3

126−

127−Executable elm

128− Main-is: Compiler.hs

129− ghc-options: -threaded -O2

130− Hs-Source-Dirs: compiler

131− other-modules: AST.Annotation,

132− AST.Declaration,

133− AST.Expression.General,

134− AST.Expression.Source,

135− AST.Expression.Valid,

136− AST.Expression.Canonical,

137− AST.Helpers,

138− AST.Literal,

139− AST.Module,

140− AST.Pattern,

141− AST.PrettyPrint,

142− AST.Type,

143− AST.Variable,

144− Generate.JavaScript,

145− Generate.JavaScript.Helpers,

146− Generate.JavaScript.Ports,

147− Generate.JavaScript.Variable,

148− Generate.Markdown,

149− Generate.Html,

150− Generate.Cases,

151− Transform.Canonicalize,

152− Transform.Canonicalize.Environment,

153− Transform.Canonicalize.Setup,

154− Transform.Canonicalize.Type,

155− Transform.Canonicalize.Variable,

156− Transform.Check,

157− Transform.Expression,

158− Transform.Declaration,

159− Transform.Definition,

160− Transform.Interface,

161− Transform.SortDefinitions,

162− Transform.Substitute,

163− Metadata.Prelude,

164− Parse.Binop,

165− Parse.Declaration,

166− Parse.Expression,

167− Parse.Helpers,

168− Parse.Literal,

169− Parse.Module,

170− Parse.Parse,

171− Parse.Pattern,

172− Parse.Type,

173− Type.Constrain.Expression,

174− Type.Constrain.Literal,

175− Type.Constrain.Pattern,

176− Type.Environment,

177− Type.ExtraChecks,

178− Type.Fragment,

179− Type.Inference,

180− Type.PrettyPrint,

181− Type.Solve,

182− Type.State,

183− Type.Type,

184− Type.Unify,

185− Build.Dependencies,

186− Build.File,

187− Build.Flags,

188− Build.Interface,

189− Build.Print,

190− Build.Source,

191− Build.Utils,

192− Paths_Elm

193−

194− Build-depends: aeson >= 0.7 && < 0.9,

195− aeson-pretty >= 0.7 && < 0.8,

196− base >=4.2 && <5,

197− binary >= 0.7.0.0 && < 0.8,

198− blaze-html >= 0.5 && < 0.8,

199− blaze-markup >= 0.5.1 && < 0.7,

200− bytestring >= 0.9 && < 0.11,

201− cheapskate >= 0.1 && < 0.2,

202− cmdargs >= 0.7 && < 0.11,

203− containers >= 0.3 && < 0.6,

204− directory >= 1.0 && < 2.0,

205− filepath >= 1 && < 2.0,

206− highlighting-kate >= 0.5 && < 0.6,

207− indents >= 0.3 && < 0.4,

208− language-ecmascript >=0.15 && < 0.17,

209− language-glsl >= 0.0.2 && < 0.2,

210− mtl >= 2 && < 3,

211− parsec >= 3.1.1 && < 3.5,

212− pretty >= 1.0 && < 2.0,

213− text >= 1 && < 2,

214− transformers >= 0.2 && < 0.5,

215− union-find >= 0.2 && < 0.3,

216− unordered-containers >= 0.1 && < 0.3

217−

218−Executable elm-doc

219− Main-is: Docs.hs

220− Hs-Source-Dirs: compiler

221− other-modules: AST.Annotation,

222− AST.Declaration,

223− AST.Expression.General,

224− AST.Helpers,

225− AST.Literal,

226− AST.Module,

227− AST.Pattern,

228− AST.PrettyPrint,

229− AST.Type,

230− AST.Variable,

231− Parse.Binop,

232− Parse.Declaration,

233− Parse.Expression,

234− Parse.Helpers,

235− Parse.Literal,

236− Parse.Module,

237− Parse.Pattern,

238− Parse.Type

239−

240− Build-depends: aeson >= 0.7 && < 0.9,

241− aeson-pretty >= 0.7 && < 0.8,

242− base >=4.2 && <5,

243− binary >= 0.7.0.0 && < 0.8,

244− bytestring >= 0.9 && < 0.11,

245− cmdargs >= 0.7 && < 0.11,

246− containers >= 0.3 && < 0.6,

247− directory >= 1.0 && < 2.0,

248− filepath >= 1 && < 2.0,

249− indents >= 0.3 && < 0.4,

250− language-glsl >= 0.0.2 && < 0.2,

251− mtl >= 2 && < 3,

252− parsec >= 3.1.1 && < 3.5,

253− pretty >= 1.0 && < 2.0,

254− text >= 1 && < 2,

255− transformers >= 0.2 && < 0.5,

256− union-find >= 0.2 && < 0.3

257−

258−Test-Suite compiler-tests

259− Type: exitcode-stdio-1.0

260− Hs-Source-Dirs: tests/compiler, compiler

261− Main-is: CompilerTest.hs

262− other-modules: Tests.Compiler

263− Tests.Property

264− Tests.Property.Arbitrary

265− AST.Helpers

266− AST.Literal

267− AST.PrettyPrint

268− build-depends: test-framework > 0.8 && < 0.9,

269− test-framework-hunit >= 0.3 && < 0.4,

270− test-framework-quickcheck2 >= 0.3 && < 0.4,

271− HUnit >= 1.1 && < 2,

272− QuickCheck >= 2 && < 3,

273− aeson >= 0.7 && < 0.9,

274− aeson-pretty >= 0.7 && < 0.8,

275− base >=4.2 && <5,

276− binary >= 0.7.0.0 && < 0.8,

277− blaze-html >= 0.5 && < 0.8,

278− blaze-markup >= 0.5.1 && < 0.7,

279− bytestring >= 0.9 && < 0.11,

280− cheapskate >= 0.1 && < 0.2,

281− cmdargs >= 0.7 && < 0.11,

282− containers >= 0.3 && < 0.6,

283− directory >= 1.0 && < 2.0,

284− Elm,

285− filemanip >= 0.3.5 && < 0.4,

286− filepath >= 1 && < 2.0,

287− highlighting-kate >= 0.5 && < 0.6,

288− indents >= 0.3 && < 0.4,

289− language-ecmascript >=0.15 && < 0.17,

290− language-glsl >= 0.0.2 && < 0.2,

291− mtl >= 2 && < 3,

292− parsec >= 3.1.1 && < 3.5,

293− pretty >= 1.0 && < 2.0,

294− process,

295− text >= 1 && < 2,

296− transformers >= 0.2 && < 0.5,

297− union-find >= 0.2 && < 0.3,

298− unordered-containers >= 0.1 && < 0.3

299−

300−Test-Suite library-tests

301− Type: exitcode-stdio-1.0

302− Hs-Source-Dirs: tests/libraries

303− Main-is: LibraryTest.hs

304− build-depends: base >= 4.2 && <5,

305− directory >= 1.0 && < 2.0,

306− Elm,

307− filepath >= 1 && < 2.0,

308− process >= 1 && < 2.0

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!

IOdeleted−1

Submodule changed.

LICENSE+6−25

@@ -1,30 +1,11 @@

22

3+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

44

5−Redistribution and use in source and binary forms, with or without

6−modification, are permitted provided that the following conditions are met:

5+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

76

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.

108

11− * Redistributions in binary form must reproduce the above

12− copyright notice, this list of conditions and the following

13− disclaimer in the documentation and/or other materials provided

14− with the distribution.

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.

1510

16− * Neither the name of Evan Czaplicki nor the names of other

17− contributors may be used to endorse or promote products derived

18− from this software without specific prior written permission.

19−

20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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.

README.md+14−17

@@ -1,25 +1,22 @@

1−Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).

1+# Elm

22

3−[![Build Status](https://travis-ci.org/elm-lang/Elm.png)](https://travis-ci.org/elm-lang/Elm)

3+A delightful language for reliable webapps.

4+

5+Check out the [Home Page](http://elm-lang.org/), [Try Online](http://elm-lang.org/try), or [The Official Guide](http://guide.elm-lang.org/)

6+

7+

8+<br>

49

510## Install

611

7−Follow [these instructions][installer] if you just want to use Elm. To build

8−the compiler from source, run the following commands:

12+✨ [Install](https://guide.elm-lang.org/install/elm.html) ✨

13+

14+For multiple versions, previous versions, and uninstallation, see the instructions [here](https://github.com/elm/compiler/blob/master/installers/README.md).

915

10− [installer]: https://github.com/elm-lang/elm-platform/blob/master/README.md#elm-platform

16+<br>

1117

12−```bash

13−git clone https://github.com/elm-lang/Elm.git

14−cd Elm

15−cabal configure

16−cabal build

17−```

18+## Help

1819

19−This will build the compiler in `/dist/build/elm/elm` but it will not be on

20−your PATH.

20+If you are stuck, ask around on [the Elm slack channel][slack]. Folks are friendly and happy to help with questions!

2121

22−If you are stuck, email

23−[the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)

24−or ask a question in the

25−[#Elm IRC channel](http://webchat.freenode.net/?channels=elm).

22+[slack]: http://elmlang.herokuapp.com/

Setup.hsdeleted−147

@@ -1,147 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−import Distribution.Simple

3−import Distribution.Simple.LocalBuildInfo

4−import Distribution.Simple.Setup

5−import Distribution.PackageDescription

6−

7−import System.Directory

8−import System.FilePath

9−import System.IO

10−import System.Process

11−

12−import qualified Data.Binary as Binary

13−import qualified Data.ByteString.Lazy as BS

14−import qualified Data.List as List

15−

16−-- OVERVIEW

17−-- --------

18−-- Add a post-build callout that compiles the standard libraries with the new

19−-- compiler before cabal copies static files to actually install things.

20−

21−assetsDir :: FilePath

22−assetsDir = "data"

23−

24−tempDir :: FilePath

25−tempDir = "temp"

26−

27−-- The runtime is called:

28−runtime :: FilePath

29−runtime = assetsDir </> "elm-runtime.js"

30−

31−-- The runtime is called:

32−docs :: FilePath

33−docs = assetsDir </> "docs.json"

34−

35−-- The interfaces for the Standard Libraries live in:

36−interfaces :: FilePath

37−interfaces = assetsDir </> "interfaces.data"

38−

39−elm :: LocalBuildInfo -> FilePath

40−elm lbi = buildDir lbi </> "elm" </> "elm"

41−

42−document :: LocalBuildInfo -> FilePath

43−document lbi = buildDir lbi </> "elm-doc" </> "elm-doc"

44−

45−-- Care! This appears to be based on an unstable API

46−-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2

47−

48−

49−main :: IO ()

50−main = defaultMainWithHooks simpleUserHooks { postBuild = myPostBuild }

51−

52−

53−

54−-- Post Build

55−

56−myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()

57−myPostBuild args flags packageDescription lbi = do

58− putStrLn "Custom build step: compiling standard libraries"

59− (elmos, elmis) <- compileLibraries lbi

60− putStrLn "Custom build step: build interfaces.data"

61− buildInterfaces elmis

62− putStrLn "Custom build step: build elm-runtime.js"

63− buildRuntime elmos

64− putStrLn "Custom build step: build docs.json"

65− buildDocs

66− removeDirectoryRecursive tempDir

67− removeDirectoryRecursive ("libraries" </> "docs")

68− postBuild simpleUserHooks args flags packageDescription lbi

69−

70−

71−compileLibraries lbi = do

72− createDirectoryIfMissing True tempDir

73− createDirectoryIfMissing True assetsDir

74− out_c <- canonicalizePath tempDir -- temp (root folder)

75− elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm

76− doc_c <- canonicalizePath (document lbi) -- dist/build/elm-doc/elm-doc

77− rtd_c <- canonicalizePath assetsDir -- data

78−

79− let make file = do

80− let args =

81− [ "--only-js"

82− , "--make"

83− , "--no-prelude"

84− , "--cache-dir=" ++ out_c

85− , "--build-dir=" ++ out_c

86− , file

87− ]

88− let arg = Just [("Elm_datadir", rtd_c)]

89− handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing

90− _exitCode <- waitForProcess handle

91− return ( out_c </> replaceExtension file "elmo"

92− , out_c </> replaceExtension file "elmi"

93− )

94−

95− setCurrentDirectory "libraries"

96− paths <- getFiles ".elm" "."

97− files <- unzip `fmap` mapM make paths

98− mapM_ (\path -> rawSystem doc_c [path]) paths

99− setCurrentDirectory ".."

100− return files

101−

102−buildInterfaces :: [FilePath] -> IO ()

103−buildInterfaces elmis = do

104− createDirectoryIfMissing True assetsDir

105− ifaceHandle <- openBinaryFile interfaces WriteMode

106− BS.hPut ifaceHandle (Binary.encode (length elmis))

107− let append file = do

108− handle <- openBinaryFile file ReadMode

109− bits <- hGetContents handle

110− length bits `seq` hPutStr ifaceHandle bits

111− hClose handle

112− mapM_ append elmis

113− hClose ifaceHandle

114−

115−buildRuntime :: [FilePath] -> IO ()

116−buildRuntime elmos = do

117− createDirectoryIfMissing True assetsDir

118− writeFile runtime

119− "'use strict';\n\

120− \var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

121− \var ElmRuntime = {}; ElmRuntime.Render = {};\n"

122− mapM_ (appendTo runtime) =<< getFiles ".js" "libraries"

123− mapM_ (appendTo runtime) elmos

124− mapM_ (appendTo runtime) =<< getFiles ".js" "runtime"

125−

126−buildDocs :: IO ()

127−buildDocs = do

128− createDirectoryIfMissing True assetsDir

129− writeFile docs "[\n"

130− json <- getFiles ".json" ("libraries" </> "docs")

131− let appends = map (appendTo docs) json

132− addCommas = List.intersperse (appendFile docs ",\n")

133− sequence_ (addCommas appends)

134− appendFile docs "\n]"

135−

136−getFiles ext dir = do

137− contents <- map (dir </>) `fmap` getDirectoryContents dir

138− let files = filter (\f -> takeExtension f == ext) contents

139− dirs = filter (not . hasExtension) contents

140− filess <- mapM (getFiles ext) dirs

141− return (files ++ concat filess)

142−

143−appendTo :: FilePath -> FilePath -> IO ()

144−appendTo destination source = do

145− str <- readFile source

146− length str `seq` return ()

147− 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/AST/Annotation.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module AST.Annotation where

3−

4−import qualified Text.Parsec.Pos as Parsec

5−import qualified Text.PrettyPrint as P

6−import AST.PrettyPrint

7−

8−data Annotated annotation expr = A annotation expr

9− deriving (Show)

10−

11−data Region

12− = Span Position Position P.Doc

13− | None P.Doc

14− deriving (Show)

15−

16−data Position = Position

17− { line :: Int

18− , column :: Int

19− } deriving (Show)

20−

21−type Located expr = Annotated Region expr

22−

23−none e = A (None (pretty e)) e

24−noneNoDocs e = A (None P.empty) e

25−

26−at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr

27− -> Annotated Region expr

28−at start end e =

29− A (Span (position start) (position end) (pretty e)) e

30− where

31− position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)

32−

33−merge (A s1 _) (A s2 _) e =

34− A (span (pretty e)) e

35− where

36− span = case (s1,s2) of

37− (Span start _ _, Span _ end _) -> Span start end

38− (Span start end _, _) -> Span start end

39− (_, Span start end _) -> Span start end

40− (_, _) -> None

41−

42−mergeOldDocs (A s1 _) (A s2 _) e =

43− A span e

44− where

45− span = case (s1,s2) of

46− (Span start _ d1, Span _ end d2) ->

47− Span start end (P.vcat [d1, P.text "\n", d2])

48−

49− (Span _ _ _, _) -> s1

50− (_, Span _ _ _) -> s2

51− (_, _) -> None P.empty

52−

53−sameAs :: Annotated a expr -> expr' -> Annotated a expr'

54−sameAs (A annotation _) expr = A annotation expr

55−

56−getRegionDocs region =

57− case region of

58− Span _ _ doc -> doc

59− None doc -> doc

60−

61−instance Pretty Region where

62− pretty span =

63− case span of

64− None _ -> P.empty

65− Span start end _ ->

66− P.text $

67− case line start == line end of

68− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)

69− True -> "on line " ++ show (line end) ++ ", column " ++

70− show (column start) ++ " to " ++ show (column end)

71−

72−instance Pretty e => Pretty (Annotated a e) where

73− pretty (A _ e) = pretty e

74−

compiler/AST/Declaration.hsdeleted−106

@@ -1,106 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module AST.Declaration where

3−

4−import Data.Binary

5−import qualified AST.Expression.Source as Source

6−import qualified AST.Expression.Valid as Valid

7−import qualified AST.Expression.Canonical as Canonical

8−import qualified AST.Type as T

9−import qualified AST.Variable as Var

10−import AST.PrettyPrint

11−import Text.PrettyPrint as P

12−

13−data Declaration' port def var

14− = Definition def

15− | Datatype String [String] [(String, [T.Type var])]

16− | TypeAlias String [String] (T.Type var)

17− | Port port

18− | Fixity Assoc Int String

19− deriving (Show)

20−

21−data Assoc = L | N | R

22− deriving (Eq)

23−

24−data RawPort

25− = PPAnnotation String T.RawType

26− | PPDef String Source.Expr

27− deriving (Show)

28−

29−data Port expr var

30− = Out String expr (T.Type var)

31− | In String (T.Type var)

32− deriving (Show)

33−

34−type SourceDecl = Declaration' RawPort Source.Def Var.Raw

35−type ValidDecl = Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw

36−type CanonicalDecl = Declaration' (Port Canonical.Expr Var.Canonical)

37− Canonical.Def

38− Var.Canonical

39−

40−portName :: Port expr var -> String

41−portName port =

42− case port of

43− Out name _ _ -> name

44− In name _ -> name

45−

46−instance Show Assoc where

47− show assoc =

48− case assoc of

49− L -> "left"

50− N -> "non"

51− R -> "right"

52−

53−instance Binary Assoc where

54− get = do n <- getWord8

55− return $ case n of

56− 0 -> L

57− 1 -> N

58− 2 -> R

59− _ -> error "Error reading valid associativity from serialized string"

60−

61− put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

62−

63−instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>

64− Pretty (Declaration' port def var) where

65− pretty decl =

66− case decl of

67− Definition def -> pretty def

68−

69− Datatype tipe tvars ctors ->

70− P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

71− (P.sep $ zipWith join ("=" : repeat "|") ctors)

72− where

73− join c ctor = P.text c <+> prettyCtor ctor

74− prettyCtor (name, tipes) =

75− P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))

76−

77− TypeAlias name tvars tipe ->

78− P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)

79− where

80− name' = P.text name <+> P.hsep (map P.text tvars)

81−

82− Port port -> pretty port

83−

84− Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op

85− where

86− assoc' = case assoc of

87− L -> P.text "l"

88− N -> P.empty

89− R -> P.text "r"

90−

91−instance Pretty RawPort where

92− pretty port =

93− case port of

94− PPAnnotation name tipe -> prettyPort name ":" tipe

95− PPDef name expr -> prettyPort name "=" expr

96−

97−instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where

98− pretty port =

99− case port of

100− In name tipe -> prettyPort name ":" tipe

101− Out name expr tipe -> P.vcat [ prettyPort name ":" tipe

102− , prettyPort name "=" expr ]

103−

104−

105−prettyPort :: (Pretty a) => String -> String -> a -> Doc

106−prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e

compiler/AST/Expression/Canonical.hsdeleted−30

@@ -1,30 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−module AST.Expression.Canonical where

4−

5−import AST.PrettyPrint

6−import Text.PrettyPrint as P

7−import qualified AST.Expression.General as General

8−import AST.Type (CanonicalType)

9−import qualified AST.Annotation as Annotation

10−import qualified AST.Pattern as Pattern

11−import qualified AST.Variable as Var

12−

13−

14−{-| Canonicalized expressions. All variables are fully resolved to the module

15−they came from.

16−-}

17−type Expr = General.Expr Annotation.Region Def Var.Canonical

18−type Expr' = General.Expr' Annotation.Region Def Var.Canonical

19−

20−data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType)

21− deriving (Show)

22−

23−instance Pretty Def where

24− pretty (Definition pattern expr maybeTipe) =

25− P.vcat [ annotation, definition ]

26− where

27− definition = pretty pattern <+> P.equals <+> pretty expr

28− annotation = case maybeTipe of

29− Nothing -> P.empty

30− Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

compiler/AST/Expression/General.hsdeleted−195

@@ -1,195 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

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−module AST.Expression.General where

10−

11−import AST.PrettyPrint

12−import Text.PrettyPrint as P

13−import AST.Type (Type)

14−

15−import qualified AST.Annotation as Annotation

16−import qualified AST.Helpers as Help

17−import qualified AST.Literal as Literal

18−import qualified AST.Pattern as Pattern

19−import qualified AST.Variable as Var

20−

21−---- GENERAL AST ----

22−

23−{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

24−"type holes" that allow us to enrich the AST with additional information as we

25−move through the compilation process. The type holes are used to represent:

26−

27− ann: Annotations for arbitrary expressions. Allows you to add information

28− to the AST like position in source code or inferred types.

29−

30− def: Definition style. The source syntax separates type annotations and

31− definitions, but after parsing we check that they are well formed and

32− collapse them.

33−

34− var: Representation of variables. Starts as strings, but is later enriched

35− with information about what module a variable came from.

36−

37−-}

38−type Expr annotation definition variable =

39− Annotation.Annotated annotation (Expr' annotation definition variable)

40−

41−data Expr' ann def var

42− = Literal Literal.Literal

43− | Var var

44− | Range (Expr ann def var) (Expr ann def var)

45− | ExplicitList [Expr ann def var]

46− | Binop var (Expr ann def var) (Expr ann def var)

47− | Lambda (Pattern.Pattern var) (Expr ann def var)

48− | App (Expr ann def var) (Expr ann def var)

49− | MultiIf [(Expr ann def var,Expr ann def var)]

50− | Let [def] (Expr ann def var)

51− | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]

52− | Data String [Expr ann def var]

53− | Access (Expr ann def var) String

54− | Remove (Expr ann def var) String

55− | Insert (Expr ann def var) String (Expr ann def var)

56− | Modify (Expr ann def var) [(String, Expr ann def var)]

57− | Record [(String, Expr ann def var)]

58− | Markdown String String [Expr ann def var]

59− -- for type checking and code gen only

60− | PortIn String (Type var)

61− | PortOut String (Type var) (Expr ann def var)

62− | GLShader String String Literal.GLShaderTipe

63− deriving (Show)

64−

65−

66−---- UTILITIES ----

67−

68−rawVar :: String -> Expr' ann def Var.Raw

69−rawVar x = Var (Var.Raw x)

70−

71−localVar :: String -> Expr' ann def Var.Canonical

72−localVar x = Var (Var.Canonical Var.Local x)

73−

74−tuple :: [Expr ann def var] -> Expr' ann def var

75−tuple es = Data ("_Tuple" ++ show (length es)) es

76−

77−delist :: Expr ann def var -> [Expr ann def var]

78−delist (Annotation.A _ (Data "::" [h,t])) = h : delist t

79−delist _ = []

80−

81−saveEnvName :: String

82−saveEnvName = "_save_the_environment!!!"

83−

84−dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical

85−dummyLet defs =

86− Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))

87−

88−instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where

89− pretty expr =

90− case expr of

91− Literal lit -> pretty lit

92−

93− Var x -> pretty x

94−

95− Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)

96−

97− ExplicitList es -> P.brackets (commaCat (map pretty es))

98−

99− Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e

100− | Var.toString op == "-" ->

101− P.text "-" <> prettyParens e

102−

103− Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op'', prettyParens e2 ]

104− where

105− op' = Var.toString op

106− op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

107−

108− Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

109− where

110− (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)

111− args = P.sep (map Pattern.prettyParens ps)

112−

113− App _ _ -> P.hang func 2 (P.sep args)

114− where

115− func:args = map prettyParens (collectApps (Annotation.A undefined expr))

116−

117− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

118− where

119− iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)

120−

121− Let defs e ->

122− P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))

123− , P.text "in" <+> pretty e ]

124−

125− Case e pats ->

126− P.hang pexpr 2 (P.vcat (map pretty' pats))

127− where

128− pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

129− pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

130−

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−

137− Access e x -> prettyParens e <> P.text "." <> variable x

138−

139− Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

140−

141− Insert (Annotation.A _ (Remove e y)) x v ->

142− P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"

143− , variable x, P.equals, pretty v ]

144−

145− Insert e x v ->

146− P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)

147−

148− Modify e fs ->

149− P.braces $ P.hang (pretty e <+> P.text "|")

150− 4

151− (commaSep $ map field fs)

152− where

153− field (k,v) = variable k <+> P.text "<-" <+> pretty v

154−

155− Record fs ->

156− P.braces $ P.nest 2 (commaSep $ map field fs)

157− where

158− field (x,e) = variable x <+> P.equals <+> pretty e

159−

160− Markdown _ _ _ -> P.text "[markdown| ... |]"

161−

162− GLShader _ _ _ -> P.text "[glsl| ... |]"

163−

164− PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

165−

166− PortOut _ _ signal -> pretty signal

167−

168−collectApps :: Expr ann def var -> [Expr ann def var]

169−collectApps annExpr@(Annotation.A _ expr) =

170− case expr of

171− App a b -> collectApps a ++ [b]

172− _ -> [annExpr]

173−

174−collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)

175−collectLambdas lexpr@(Annotation.A _ expr) =

176− case expr of

177− Lambda pattern body ->

178− let (ps, body') = collectLambdas body

179− in (pattern : ps, body')

180−

181− _ -> ([], lexpr)

182−

183−prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc

184−prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

185− where

186− needed =

187− case expr of

188− Binop _ _ _ -> True

189− Lambda _ _ -> True

190− App _ _ -> True

191− MultiIf _ -> True

192− Let _ _ -> True

193− Case _ _ -> True

194− Data name (_:_) -> not (name == "::" || Help.isTuple name)

195− _ -> False

compiler/AST/Expression/Source.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−module AST.Expression.Source where

4−

5−import AST.PrettyPrint

6−import Text.PrettyPrint as P

7−import qualified AST.Expression.General as General

8−import AST.Type (RawType)

9−import qualified AST.Variable as Var

10−import qualified AST.Annotation as Annotation

11−import qualified AST.Pattern as Pattern

12−

13−

14−{-| Expressions created by the parser. These use a split representation of type

15−annotations and definitions, which is how they appear in source code and how

16−they are parsed.

17−-}

18−type Expr = General.Expr Annotation.Region Def Var.Raw

19−type Expr' = General.Expr' Annotation.Region Def Var.Raw

20−

21−data Def

22− = Definition Pattern.RawPattern Expr

23− | TypeAnnotation String RawType

24− deriving (Show)

25−

26−instance Pretty Def where

27− pretty def =

28− case def of

29− TypeAnnotation name tipe ->

30− variable name <+> P.colon <+> pretty tipe

31− Definition pattern expr ->

32− pretty pattern <+> P.equals <+> pretty expr

compiler/AST/Expression/Valid.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−module AST.Expression.Valid where

4−

5−import AST.PrettyPrint

6−import Text.PrettyPrint as P

7−import qualified AST.Expression.General as General

8−import AST.Type (RawType)

9−import qualified AST.Variable as Var

10−import qualified AST.Annotation as Annotation

11−import qualified AST.Pattern as Pattern

12−

13−

14−{-| "Normal" expressions. When the compiler checks that type annotations and

15−ports are all paired with definitions in the appropriate order, it collapses

16−them into a Def that is easier to work with in later phases of compilation.

17−-}

18−type Expr = General.Expr Annotation.Region Def Var.Raw

19−type Expr' = General.Expr' Annotation.Region Def Var.Raw

20−

21−data Def = Definition Pattern.RawPattern Expr (Maybe RawType)

22− deriving (Show)

23−

24−instance Pretty Def where

25− pretty (Definition pattern expr maybeTipe) =

26− P.vcat [ annotation, definition ]

27− where

28− definition = pretty pattern <+> P.equals <+> pretty expr

29− annotation = case maybeTipe of

30− Nothing -> P.empty

31− Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

compiler/AST/Helpers.hsdeleted−27

@@ -1,27 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module AST.Helpers where

3−

4−import qualified Data.Char as Char

5−

6−splitDots :: String -> [String]

7−splitDots = go []

8− where

9− go vars str =

10− case break (=='.') str of

11− (x,_:rest) | isOp x -> vars ++ [x ++ '.' : rest]

12− | otherwise -> go (vars ++ [x]) rest

13− (x,[]) -> vars ++ [x]

14−

15−brkt :: String -> String

16−brkt s = "{ " ++ s ++ " }"

17−

18−isTuple :: String -> Bool

19−isTuple name =

20− take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)

21−

22−isOp :: String -> Bool

23−isOp = all isSymbol

24−

25−isSymbol :: Char -> Bool

26−isSymbol c =

27− Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"

compiler/AST/Literal.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module AST.Literal where

3−

4−import AST.PrettyPrint

5−import Data.Map (Map)

6−import qualified Text.PrettyPrint as PP

7−

8−data Literal = IntNum Int

9− | FloatNum Double

10− | Chr Char

11− | Str String

12− | Boolean Bool

13− deriving (Eq, Ord, Show)

14−

15−instance Pretty Literal where

16− pretty literal =

17− case literal of

18− IntNum n -> PP.int n

19− FloatNum n -> PP.double n

20− Chr c -> PP.text . show $ c

21− Str s -> PP.text . show $ s

22− Boolean bool -> PP.text (show bool)

23−

24−data GLTipe = Int | Float | V2 | V3 | V4 | M4 | Texture

25− deriving (Show)

26−

27−glTipeName :: GLTipe -> String

28−glTipeName glTipe =

29− case glTipe of

30− Int -> "Int"

31− Float -> "Float"

32− V2 -> "Math.Vector2.Vec2"

33− V3 -> "Math.Vector3.Vec3"

34− V4 -> "Math.Vector4.Vec4"

35− M4 -> "Math.Matrix4.Mat4"

36− Texture -> "Graphics.WebGL.Texture"

37−

38−data GLShaderTipe = GLShaderTipe

39− { attribute :: Map String GLTipe

40− , uniform :: Map String GLTipe

41− , varying :: Map String GLTipe

42− } deriving (Show)

43−

compiler/AST/Module.hsdeleted−128

@@ -1,128 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module AST.Module where

3−

4−import Data.Binary

5−import qualified Data.List as List

6−import qualified Data.Map as Map

7−import Control.Applicative ((<$>),(<*>))

8−

9−import qualified AST.Expression.Canonical as Canonical

10−import qualified AST.Declaration as Decl

11−import qualified AST.Type as Type

12−import qualified AST.Variable as Var

13−

14−import AST.PrettyPrint

15−import Text.PrettyPrint as P

16−

17−import qualified Elm.Internal.Version as Version

18−

19−data Module exs body = Module

20− { names :: [String]

21− , path :: FilePath

22− , exports :: exs

23− , imports :: [(String, ImportMethod)]

24− , body :: body

25− }

26−

27−getName :: Module exs body -> String

28−getName modul =

29− List.intercalate "." (names modul)

30−

31−data CanonicalBody = CanonicalBody

32− { program :: Canonical.Expr

33− , types :: Types

34− , fixities :: [(Decl.Assoc, Int, String)]

35− , aliases :: Aliases

36− , datatypes :: ADTs

37− , ports :: [String]

38− }

39−

40−type SourceModule = Module (Var.Listing Var.Value) [Decl.SourceDecl]

41−type ValidModule = Module (Var.Listing Var.Value) [Decl.ValidDecl]

42−type CanonicalModule = Module [Var.Value] CanonicalBody

43−

44−type Interfaces = Map.Map String Interface

45−

46−type Types = Map.Map String Type.CanonicalType

47−type Aliases = Map.Map String ( [String], Type.CanonicalType )

48−type ADTs = Map.Map String (AdtInfo String)

49−

50−type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )

51−type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

52−

53−data Interface = Interface

54− { iVersion :: Version.Version

55− , iExports :: [Var.Value]

56− , iTypes :: Types

57− , iImports :: [(String, ImportMethod)]

58− , iAdts :: ADTs

59− , iAliases :: Aliases

60− , iFixities :: [(Decl.Assoc, Int, String)]

61− , iPorts :: [String]

62− }

63−

64−toInterface :: CanonicalModule -> Interface

65−toInterface modul =

66− let body' = body modul in

67− Interface

68− { iVersion = Version.elmVersion

69− , iExports = exports modul

70− , iTypes = types body'

71− , iImports = imports modul

72− , iAdts = datatypes body'

73− , iAliases = aliases body'

74− , iFixities = fixities body'

75− , iPorts = ports body'

76− }

77−

78−instance Binary Interface where

79− get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

80− put modul = do

81− put (iVersion modul)

82− put (iExports modul)

83− put (iTypes modul)

84− put (iImports modul)

85− put (iAdts modul)

86− put (iAliases modul)

87− put (iFixities modul)

88− put (iPorts modul)

89−

90−data ImportMethod

91− = As !String

92− | Open !(Var.Listing Var.Value)

93−

94−open :: ImportMethod

95−open = Open (Var.openListing)

96−

97−importing :: [Var.Value] -> ImportMethod

98−importing xs = Open (Var.Listing xs False)

99−

100−instance Binary ImportMethod where

101− put method =

102− case method of

103− As alias -> putWord8 0 >> put alias

104− Open listing -> putWord8 1 >> put listing

105−

106− get = do tag <- getWord8

107− case tag of

108− 0 -> As <$> get

109− 1 -> Open <$> get

110− _ -> error "Error reading valid ImportMethod type from serialized string"

111−

112−instance (Pretty exs, Pretty body) => Pretty (Module exs body) where

113− pretty (Module names _ exs ims body) =

114− P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]

115− where

116− modul = P.text "module" <+> name <+> pretty exs <+> P.text "where"

117− name = P.text (List.intercalate "." names)

118−

119− prettyImports = P.vcat $ map prettyMethod ims

120−

121−prettyMethod :: (String, ImportMethod) -> Doc

122−prettyMethod (name, method) =

123− case method of

124− As alias

125− | name == alias -> P.empty

126− | otherwise -> P.text "as" <+> P.text alias

127−

128− Open listing -> pretty listing

compiler/AST/Pattern.hsdeleted−79

@@ -1,79 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module AST.Pattern where

3−

4−import qualified AST.Helpers as Help

5−import AST.PrettyPrint

6−import Text.PrettyPrint as PP

7−import qualified Data.Set as Set

8−

9−import qualified AST.Variable as Var

10−import AST.Literal as Literal

11−

12−data Pattern var

13− = Data var [Pattern var]

14− | Record [String]

15− | Alias String (Pattern var)

16− | Var String

17− | Anything

18− | Literal Literal.Literal

19− deriving (Eq, Ord, Show)

20−

21−type RawPattern = Pattern Var.Raw

22−type CanonicalPattern = Pattern Var.Canonical

23−

24−cons :: RawPattern -> RawPattern -> RawPattern

25−cons h t = Data (Var.Raw "::") [h,t]

26−

27−nil :: RawPattern

28−nil = Data (Var.Raw "[]") []

29−

30−list :: [RawPattern] -> RawPattern

31−list = foldr cons nil

32−

33−tuple :: [RawPattern] -> RawPattern

34−tuple es = Data (Var.Raw ("_Tuple" ++ show (length es))) es

35−

36−boundVarList :: Pattern var -> [String]

37−boundVarList = Set.toList . boundVars

38−

39−boundVars :: Pattern var -> Set.Set String

40−boundVars pattern =

41− case pattern of

42− Var x -> Set.singleton x

43− Alias x p -> Set.insert x (boundVars p)

44− Data _ ps -> Set.unions (map boundVars ps)

45− Record fields -> Set.fromList fields

46− Anything -> Set.empty

47− Literal _ -> Set.empty

48−

49−

50−instance Var.ToString var => Pretty (Pattern var) where

51− pretty pattern =

52− case pattern of

53− Var x -> variable x

54− Literal lit -> pretty lit

55− Record fs -> PP.braces (commaCat $ map variable fs)

56− Alias x p -> prettyParens p <+> PP.text "as" <+> variable x

57− Anything -> PP.text "_"

58− Data name [hd,tl] | Var.toString name == "::" ->

59− parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

60− where

61− isCons = case hd of

62− Data ctor _ -> Var.toString ctor == "::"

63− _ -> False

64−

65− Data name ps

66− | Help.isTuple name' -> PP.parens . commaCat $ map pretty ps

67− | otherwise -> hsep (PP.text name' : map prettyParens ps)

68− where

69− name' = Var.toString name

70−

71−prettyParens :: Var.ToString var => Pattern var -> Doc

72−prettyParens pattern =

73− parensIf needsThem (pretty pattern)

74− where

75− needsThem =

76− case pattern of

77− Data name (_:_) | not (Help.isTuple (Var.toString name)) -> True

78− Alias _ _ -> True

79− _ -> False

compiler/AST/PrettyPrint.hsdeleted−42

@@ -1,42 +0,0 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−module AST.PrettyPrint where

3−

4−import Control.Monad.Trans.Error

5−import Text.PrettyPrint as P

6−import qualified AST.Helpers as Help

7−

8−class Pretty a where

9− pretty :: a -> Doc

10−

11−instance Pretty Doc where

12− pretty doc = doc

13−

14−instance Pretty String where

15− pretty = P.text

16−

17−renderPretty :: (Pretty a) => a -> String

18−renderPretty e = render (pretty e)

19−

20−commaCat docs = cat (punctuate comma docs)

21−commaSep docs = sep (punctuate comma docs)

22−

23−parensIf :: Bool -> Doc -> Doc

24−parensIf bool doc = if bool then parens doc else doc

25−

26−variable :: String -> Doc

27−variable x =

28− if Help.isOp x then parens (text x) else text x

29−

30−eightyCharLines :: Int -> String -> String

31−eightyCharLines indent message = answer

32− where

33− (answer,_,_) = foldl step (spaces, indent-1, "") chunks

34−

35− chunks = map (\w -> (w, length w)) (words message)

36− spaces = replicate indent ' '

37− step (sentence, slen, space) (word, wlen)

38− | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

39− | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

40−

41−instance ErrorList Doc where

42− listMsg str = [ P.text str ]

compiler/AST/Type.hsdeleted−138

@@ -1,138 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module AST.Type where

3−

4−import Control.Applicative ((<$>), (<*>))

5−import Data.Binary

6−import qualified Data.Map as Map

7−

8−import qualified AST.Variable as Var

9−import AST.PrettyPrint

10−import qualified AST.Helpers as Help

11−import Text.PrettyPrint as P

12−

13−data Type var

14− = Lambda (Type var) (Type var)

15− | Var String

16− | Type var

17− | App (Type var) [Type var]

18− | Record [(String, Type var)] (Maybe (Type var))

19− | Aliased Var.Canonical (Type var)

20− deriving (Eq,Show)

21−

22−type RawType = Type Var.Raw

23−type CanonicalType = Type Var.Canonical

24−

25−fieldMap :: [(String,a)] -> Map.Map String [a]

26−fieldMap fields =

27− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

28−

29−recordOf :: [(String, Type var)] -> Type var

30−recordOf fields = Record fields Nothing

31−

32−listOf :: RawType -> RawType

33−listOf t = App (Type (Var.Raw "_List")) [t]

34−

35−tupleOf :: [RawType] -> RawType

36−tupleOf ts = App (Type t) ts

37− where

38− t = Var.Raw ("_Tuple" ++ show (length ts))

39−

40−instance (Var.ToString var, Pretty var) => Pretty (Type var) where

41− pretty tipe =

42− case tipe of

43− Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

44− where

45− t:ts = map prettyLambda (collectLambdas tipe)

46− prettyLambda t = case t of

47− Lambda _ _ -> P.parens (pretty t)

48− _ -> pretty t

49−

50− Var x -> P.text x

51−

52− Type var ->

53− let v = Var.toString var in

54− P.text (if v == "_Tuple0" then "()" else v)

55−

56− App f args ->

57− case (f,args) of

58− (Type name, [t])

59− | Var.toString name == "_List" -> P.brackets (pretty t)

60−

61− (Type name, _)

62− | Help.isTuple (Var.toString name) ->

63− P.parens . P.sep . P.punctuate P.comma $ map pretty args

64−

65− _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)

66−

67− Record _ _ ->

68− P.braces $ case flattenRecord tipe of

69− (fields, Nothing) -> prettyFields fields

70− (fields, Just x) ->

71− P.hang (P.text x <+> P.text "|") 4 (prettyFields fields)

72− where

73− prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

74− prettyFields fields = commaSep (map prettyField fields)

75−

76− Aliased name t ->

77− let t' = pretty t in

78− if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]

79− then t'

80− else pretty name

81−

82−collectLambdas :: Type var -> [Type var]

83−collectLambdas tipe =

84− case tipe of

85− Lambda arg body -> arg : collectLambdas body

86− _ -> [tipe]

87−

88−prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc

89−prettyParens tipe = parensIf (needed tipe) (pretty tipe)

90− where

91− needed t =

92− case t of

93− Aliased _ t' -> needed t'

94−

95− Lambda _ _ -> True

96−

97− App (Type name) [_] | Var.toString name == "_List" -> False

98− App (Type name) _ | Help.isTuple (Var.toString name) -> False

99− App t' [] -> needed t'

100− App _ _ -> True

101−

102− _ -> False

103−

104−flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )

105−flattenRecord tipe =

106− case tipe of

107− Var x -> ([], Just x)

108−

109− Record fields Nothing -> (fields, Nothing)

110−

111− Record fields (Just ext) ->

112− let (fields',ext') = flattenRecord ext

113− in (fields' ++ fields, ext')

114−

115− Aliased _ tipe' -> flattenRecord tipe'

116−

117− _ -> error "Trying to flatten ill-formed record."

118−

119−instance Binary var => Binary (Type var) where

120− put tipe =

121− case tipe of

122− Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2

123− Var x -> putWord8 1 >> put x

124− Type name -> putWord8 2 >> put name

125− App t1 t2 -> putWord8 3 >> put t1 >> put t2

126− Record fs ext -> putWord8 4 >> put fs >> put ext

127− Aliased var t -> putWord8 5 >> put var >> put t

128−

129− get = do

130− n <- getWord8

131− case n of

132− 0 -> Lambda <$> get <*> get

133− 1 -> Var <$> get

134− 2 -> Type <$> get

135− 3 -> App <$> get <*> get

136− 4 -> Record <$> get <*> get

137− 5 -> Aliased <$> get <*> get

138− _ -> error "Error reading a valid type from serialized string"

compiler/AST/Variable.hsdeleted−152

@@ -1,152 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module AST.Variable where

3−

4−import Data.Binary

5−import Control.Applicative ((<$>), (<*>))

6−import Text.PrettyPrint as P

7−import qualified AST.Helpers as Help

8−import AST.PrettyPrint

9−

10−newtype Raw = Raw String

11− deriving (Eq,Ord,Show)

12−

13−data Home

14− = BuiltIn

15− | Module !String

16− | Local

17− deriving (Eq,Ord,Show)

18−

19−data Canonical = Canonical

20− { home :: !Home

21− , name :: !String

22− } deriving (Eq,Ord,Show)

23−

24−local :: String -> Canonical

25−local x = Canonical Local x

26−

27−builtin :: String -> Canonical

28−builtin x = Canonical BuiltIn x

29−

30−-- To help with pattern matching on some common canonical variables:

31−is :: String -> String -> Canonical -> Bool

32−is home name var =

33− var == Canonical (Module home) name

34−

35−isJson :: Canonical -> Bool

36−isJson = is "Json" "Value"

37−

38−isMaybe :: Canonical -> Bool

39−isMaybe = is "Maybe" "Maybe"

40−

41−isArray :: Canonical -> Bool

42−isArray = is "Array" "Array"

43−

44−isSignal :: Canonical -> Bool

45−isSignal = is "Signal" "Signal"

46−

47−isList :: Canonical -> Bool

48−isList v = v == Canonical BuiltIn "_List"

49−

50−isTuple :: Canonical -> Bool

51−isTuple v =

52− case v of

53− Canonical BuiltIn name -> Help.isTuple name

54− _ -> False

55−

56−isPrimitive :: Canonical -> Bool

57−isPrimitive v =

58− case v of

59− Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]

60− _ -> False

61−

62−isPrim :: String -> Canonical -> Bool

63−isPrim prim v =

64− case v of

65− Canonical BuiltIn name -> name == prim

66− _ -> False

67−

68−isText :: Canonical -> Bool

69−isText = is "Text" "Text"

70−

71−class ToString a where

72− toString :: a -> String

73−

74−instance ToString Raw where

75− toString (Raw x) = x

76−

77−instance ToString Canonical where

78− toString (Canonical home name) =

79− case home of

80− BuiltIn -> name

81− Module path -> path ++ "." ++ name

82− Local -> name

83−

84−-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)

85−data Listing a = Listing

86− { _explicits :: [a]

87− , _open :: Bool

88− } deriving (Eq,Ord,Show)

89−

90−openListing :: Listing a

91−openListing = Listing [] True

92−

93−-- | A value that can be imported or exported

94−data Value

95− = Value !String

96− | Alias !String

97− | ADT !String !(Listing String)

98− deriving (Eq,Ord,Show)

99−

100−instance Pretty Raw where

101− pretty (Raw var) = variable var

102−

103−instance Pretty Canonical where

104− pretty var = P.text (toString var)

105−

106−instance Pretty a => Pretty (Listing a) where

107− pretty (Listing explicits open) =

108− P.parens (commaCat (map pretty explicits ++ dots))

109− where

110− dots = [if open then P.text ".." else P.empty]

111−

112−instance Pretty Value where

113− pretty portable =

114− case portable of

115− Value name -> P.text name

116− Alias name -> P.text name

117− ADT name ctors ->

118− P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })

119−

120−instance Binary Canonical where

121− put (Canonical home name) =

122− case home of

123− BuiltIn -> putWord8 0 >> put name

124− Module path -> putWord8 1 >> put path >> put name

125− Local -> putWord8 2 >> put name

126−

127− get = do tag <- getWord8

128− case tag of

129− 0 -> Canonical BuiltIn <$> get

130− 1 -> Canonical . Module <$> get <*> get

131− 2 -> Canonical Local <$> get

132− _ -> error "Unexpected tag when deserializing canonical variable"

133−

134−instance Binary Value where

135− put portable =

136− case portable of

137− Value name -> putWord8 0 >> put name

138− Alias name -> putWord8 1 >> put name

139− ADT name ctors -> putWord8 2 >> put name >> put ctors

140−

141− get = do tag <- getWord8

142− case tag of

143− 0 -> Value <$> get

144− 1 -> Alias <$> get

145− 2 -> ADT <$> get <*> get

146− _ -> error "Error reading valid import/export information from serialized string"

147−

148−instance (Binary a) => Binary (Listing a) where

149− put (Listing explicits open) =

150− put explicits >> put open

151−

152− get = Listing <$> get <*> get

compiler/Build/Dependencies.hsdeleted−158

@@ -1,158 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Build.Dependencies (Recipe(..), getBuildRecipe, readDeps) where

3−

4−import Control.Monad.Error

5−import qualified Control.Monad.State as State

6−import qualified Data.Graph as Graph

7−import qualified Data.List as List

8−import qualified Data.Map as Map

9−import qualified Data.Set as Set

10−import System.Directory

11−import System.FilePath as FP

12−

13−import qualified AST.Module as Module

14−import qualified Parse.Parse as Parse

15−import qualified Elm.Internal.Paths as Path

16−import qualified Elm.Internal.Name as N

17−import qualified Elm.Internal.Version as V

18−import qualified Elm.Internal.Dependencies as Deps

19−

20−data Recipe = Recipe

21− { _elmFiles :: [FilePath]

22− , _jsFiles :: [FilePath]

23− }

24−

25−getBuildRecipe :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO Recipe

26−getBuildRecipe srcDirs builtIns root =

27− do directories <- getDependencies

28− jsFiles <- nativeFiles ("." : directories)

29− let allSrcDirs = srcDirs ++ directories

30− nodes <- collectDependencies allSrcDirs builtIns root

31− elmFiles <- sortElmFiles nodes

32− return (Recipe elmFiles jsFiles)

33−

34−-- | Based on the projects elm_dependencies.json, find all of the paths and

35−-- dependency information we might need.

36−getDependencies :: ErrorT String IO [FilePath]

37−getDependencies =

38− do exists <- liftIO $ doesFileExist Path.dependencyFile

39− if not exists then return [] else getPaths

40− where

41− getPaths :: ErrorT String IO [FilePath]

42− getPaths =

43− Deps.withDeps Path.dependencyFile $ \deps ->

44− mapM getPath (Deps.dependencies deps)

45−

46− getPath :: (N.Name, V.Version) -> ErrorT String IO FilePath

47− getPath (name,version) = do

48− let path = Path.dependencyDirectory </> N.toFilePath name </> show version

49− exists <- liftIO $ doesDirectoryExist path

50− if exists

51− then return path

52− else throwError (notFound name version)

53−

54− notFound :: N.Name -> V.Version -> String

55− notFound name version =

56− unlines

57− [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"

58− , show name ++ " " ++ show version ++ " but it was not found."

59− , "You may need to install it with:"

60− , ""

61− , " elm-get install " ++ show name ++ " " ++ show version ]

62−

63−nativeFiles :: [FilePath] -> ErrorT String IO [FilePath]

64−nativeFiles directories =

65− do exists <- liftIO $ doesFileExist Path.dependencyFile

66− if not exists

67− then return []

68− else concat `fmap` mapM getNativeFiles directories

69− where

70− getNativeFiles dir =

71− Deps.withDeps (dir </> Path.dependencyFile) $ \deps ->

72− return (map (toPath dir) (Deps.native deps))

73−

74− toPath dir moduleName =

75− dir </> joinPath (split moduleName) <.> "js"

76−

77−split :: String -> [String]

78−split moduleName = go [] moduleName

79− where

80− go paths str =

81− case break (=='.') str of

82− (path, _:rest) -> go (paths ++ [path]) rest

83− (path, []) -> paths ++ [path]

84−

85−type DependencyNode = (FilePath, String, [String])

86−

87−sortElmFiles :: [DependencyNode] -> ErrorT String IO [FilePath]

88−sortElmFiles depends =

89− if null mistakes

90− then return (concat sccs)

91− else throwError $ msg ++ unlines (map show mistakes)

92− where

93− sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends

94−

95− mistakes = filter (\scc -> length scc > 1) sccs

96− msg = "A cyclical module dependency or was detected in:\n"

97−

98−collectDependencies :: [FilePath] -> Module.Interfaces -> FilePath

99− -> ErrorT String IO [DependencyNode]

100−collectDependencies srcDirs rawBuiltIns filePath =

101− State.evalStateT (go Nothing filePath) Set.empty

102− where

103− builtIns :: Set.Set String

104− builtIns = Set.fromList $ Map.keys rawBuiltIns

105−

106− go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [DependencyNode]

107− go parentModuleName filePath = do

108− filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath

109− (moduleName, deps) <- lift $ readDeps filePath'

110− seen <- State.get

111− let realDeps = Set.difference (Set.fromList deps) builtIns

112− newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen

113− State.put (Set.insert moduleName (Set.union newDeps seen))

114− rest <- mapM (go (Just moduleName) . toFilePath) (Set.toList newDeps)

115− return ((makeRelative "." filePath', moduleName, Set.toList realDeps) : concat rest)

116−

117−readDeps :: FilePath -> ErrorT String IO (String, [String])

118−readDeps path = do

119− txt <- lift $ readFile path

120− case Parse.dependencies txt of

121− Right o -> return o

122− Left err -> throwError $ msg ++ show err

123− where msg = "Error resolving dependencies in " ++ path ++ ":\n"

124−

125−findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath

126−findSrcFile parentModuleName dirs path =

127− foldr tryDir notFound dirs

128− where

129− tryDir dir next = do

130− let path' = dir </> path

131− exists <- liftIO $ doesFileExist path'

132− if exists

133− then return path'

134− else next

135−

136− parentModuleName' =

137− case parentModuleName of

138− Just name -> "module '" ++ name ++ "'"

139− Nothing -> "the main module"

140−

141− notFound = throwError $ unlines

142− [ "When finding the imports declared in " ++ parentModuleName' ++ ", could not find file: " ++ path

143− , " If you created this module, but it is in a subdirectory that does not"

144− , " exactly match the module name, you may need to use the --src-dir flag."

145− , ""

146− , " If it is part of a 3rd party library, it needs to be declared"

147− , " as a dependency in your project's " ++ Path.dependencyFile ++ " file."

148− ]

149−

150−isNative :: String -> Bool

151−isNative name = List.isPrefixOf "Native." name

152−

153−toFilePath :: String -> FilePath

154−toFilePath name = map swapDots name ++ ext

155− where

156− swapDots '.' = '/'

157− swapDots c = c

158− ext = if isNative name then ".js" else ".elm"

compiler/Build/File.hsdeleted−176

@@ -1,176 +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.List as List

14−import qualified Data.Maybe as Maybe

15−import qualified Data.Map as Map

16−import qualified Data.ByteString.Lazy as L

17−

18−import qualified Build.Dependencies as Deps

19−import qualified Build.Flags as Flag

20−import qualified Build.Interface as Interface

21−import qualified Build.Print as Print

22−import qualified Build.Source as Source

23−import qualified Build.Utils as Utils

24−import qualified Generate.JavaScript as JS

25−import qualified Parse.Module as Parser

26−import qualified AST.Module as Module

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, Module.Interface)

36−

37−evalBuild :: Flag.Flags -> Module.Interfaces -> Build ()

38− -> IO (Map.Map String Module.Interface, Maybe String)

39−evalBuild flags interfaces build =

40− do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

41− return (fmap snd ifaces, getLast moduleNames)

42− where

43− notUpdated iface = (False, iface)

44−

45−-- | Builds a list of files, returning the moduleName of the last one.

46−-- Returns \"\" if the list is empty

47−build :: Flag.Flags -> Module.Interfaces -> [FilePath] -> IO String

48−build flags interfaces files =

49− do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

50− let removeTopName = Maybe.maybe id Map.delete topName

51− mapM_ (checkPorts topName) (Map.toList $ removeTopName ifaces)

52− return $ Maybe.fromMaybe "" topName

53− where

54− checkPorts topName (name,iface)

55− | null ports = return ()

56− | otherwise = Print.failure msg

57− where

58− ports = Module.iPorts iface

59− msg = concat

60− [ "Port Error: ports may only appear in the main module, but\n"

61− , " sub-module ", name, " declares the following port"

62− , if length ports == 1 then "" else "s", ": "

63− , List.intercalate ", " ports

64− , case topName of

65− Nothing -> ""

66− Just tname -> "\n All ports must appear in module " ++ tname

67− ]

68−

69−buildAll :: [FilePath] -> Build ()

70−buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)

71− where build1 :: Integer -> FilePath -> Build ()

72− build1 num fname = do

73− shouldCompile <- shouldBeCompiled fname

74− if shouldCompile

75− then compile number fname

76− else retrieve fname

77−

78− where number = join ["[", show num, " of ", show total, "]"]

79−

80− total = length fs

81−

82−shouldBeCompiled :: FilePath -> Build Bool

83−shouldBeCompiled filePath = do

84− flags <- ask

85− let alreadyCompiled = liftIO $ do

86− existsi <- doesFileExist (Utils.elmi flags filePath)

87− existso <- doesFileExist (Utils.elmo flags filePath)

88− return $ existsi && existso

89−

90− outDated = liftIO $ do

91− tsrc <- getModificationTime filePath

92− tint <- getModificationTime (Utils.elmo flags filePath)

93− return (tsrc > tint)

94−

95− dependenciesUpdated = do

96− eDeps <- liftIO . runErrorT $ Deps.readDeps filePath

97− case eDeps of

98− -- Should never actually reach here

99− Left err -> liftIO $ Print.failure err

100− Right (_, deps) -> anyM wasCompiled deps

101−

102−

103− in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated

104−

105−wasCompiled :: String -> Build Bool

106−wasCompiled modul = maybe False fst . Map.lookup modul <$> get

107−

108−-- Short-circuiting monadic (||)

109−infixr 2 `orM`

110−orM :: (Monad m) => m Bool -> m Bool -> m Bool

111−orM m1 m2 = do b1 <- m1

112− if b1

113− then return b1

114− else m2

115−

116−anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool

117−anyM f = foldr (orM . f) (return False)

118−

119−retrieve :: FilePath -> Build ()

120−retrieve filePath = do

121− flags <- ask

122− iface <- liftIO $ Interface.load (Utils.elmi flags filePath)

123− case Interface.isValid filePath iface of

124− Right (name, interface) ->

125− do liftIO $ when (Flag.print_types flags) (Print.types (Module.iTypes interface))

126− update name interface False

127−

128− Left err -> liftIO $ Print.failure err

129−

130−compile :: String -> FilePath -> Build ()

131−compile number filePath =

132− do flags <- ask

133− binterfaces <- get

134− source <- liftIO $ readFile filePath

135− let interfaces = snd <$> binterfaces

136− name = getName source

137− liftIO $ do

138− printStatus name

139− createDirectoryIfMissing True (Flag.cache_dir flags)

140− createDirectoryIfMissing True (Flag.build_dir flags)

141−

142− canonicalModule <-

143− liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of

144− Right modul -> return modul

145− Left errors -> do Print.errors errors

146− exitFailure

147−

148− liftIO $ when (Flag.print_types flags) $ do

149− Print.types (Module.types (Module.body canonicalModule))

150−

151− let newInters = Module.toInterface canonicalModule

152− generateCache name newInters canonicalModule

153− update name newInters True

154−

155− where

156− getName source = case Parser.getModuleName source of

157− Just n -> n

158− Nothing -> "Main"

159−

160− printStatus name =

161− hPutStrLn stdout $ concat [ number, " Compiling ", name

162− , replicate (max 1 (20 - length name)) ' '

163− , "( " ++ filePath ++ " )" ]

164−

165− generateCache name interfs canonicalModule = do

166− flags <- ask

167− liftIO $ do

168− createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

169− writeFile (Utils.elmo flags filePath) (JS.generate canonicalModule)

170− withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

171− L.hPut handle (Binary.encode (name, interfs))

172−

173−update :: String -> Module.Interface -> Bool -> Build ()

174−update name inter wasUpdated =

175− do modify (Map.insert name (wasUpdated, inter))

176− tell (Last . Just $ name)

compiler/Build/Flags.hsdeleted−63

@@ -1,63 +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− , set_runtime :: Maybe FilePath

11− , get_runtime :: Bool

12− , bundle_runtime :: Bool

13− , only_js :: Bool

14− , print_types :: Bool

15− , scripts :: [FilePath]

16− , no_prelude :: Bool

17− , cache_dir :: FilePath

18− , build_dir :: FilePath

19− , src_dir :: [FilePath]

20− }

21− deriving (Data,Typeable,Show,Eq)

22−

23−flags :: Flags

24−flags = Flags

25− { files = def &= args &= typ "FILES"

26−

27− , make = False

28− &= help "automatically compile dependencies."

29−

30− , only_js = False

31− &= help "Compile only to JavaScript."

32−

33− , no_prelude = False

34− &= help "Do not import Prelude by default, used only when compiling standard libraries."

35−

36− , scripts = [] &= typFile

37− &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

38−

39− , set_runtime = Nothing &= typFile

40− &= help "Specify a custom location for Elm's runtime system."

41−

42− , get_runtime = False

43− &= help "Print the absolute path to the default Elm runtime."

44−

45− , bundle_runtime = False

46− &= help "Bundle the runtime with the generated html or js to create a standalone file."

47−

48− , cache_dir = "cache" &= typFile

49− &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."

50−

51− , build_dir = "build" &= typFile

52− &= help "Directory for generated HTML and JS files. Defaults to build/ directory."

53−

54− , src_dir = ["."] &= typFile

55− &= help "Additional source directories besides project root. Searched when using --make"

56−

57− , print_types = False

58− &= help "Print out inferred types of top-level definitions."

59−

60− } &= help "Compile Elm programs to HTML, CSS, and JavaScript."

61− &= helpArg [explicit, name "help", name "h"]

62− &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]

63− &= summary ("The Elm Compiler " ++ show Version.elmVersion ++ ", (c) Evan Czaplicki 2011-2014")

compiler/Build/Interface.hsdeleted−41

@@ -1,41 +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 Build.Print as Print

8−import qualified Elm.Internal.Version as Version

9−import System.Directory (doesFileExist)

10−import AST.Module as Module

11−

12−load :: Binary.Binary a => FilePath -> IO a

13−load filePath =

14− do exists <- doesFileExist filePath

15− case exists of

16− False -> Print.failure $ "Unable to find file " ++ filePath ++ " for deserialization!"

17− True -> do

18− bytes <- L.readFile filePath

19− case Binary.decodeOrFail bytes of

20− Right (_, _, binaryInfo) -> return binaryInfo

21− Left (_, offset, err) -> Print.failure $ msg offset err

22−

23− where

24− msg offset err = concat

25− [ "Error reading build artifact: ", filePath, "\n"

26− , " '", err, "' at offset ", show offset, "\n"

27− , " The file was generated by a previous build and may be outdated or corrupt.\n"

28− , " Please remove the file and try again."

29− ]

30−

31−isValid :: FilePath -> (String, Module.Interface) -> Either String (String, Module.Interface)

32−isValid filePath (name, interface) =

33− let version = iVersion interface in

34− if version == Version.elmVersion

35− then Right (name, interface)

36− else Left $ concat

37− [ "Error reading build artifact: ", filePath, "\n"

38− , " It was generated by version ", show version, " of the compiler,\n"

39− , " but you are using version ", show Version.elmVersion, "\n"

40− , " Please remove the file and try again.\n"

41− ]

compiler/Build/Print.hsdeleted−28

@@ -1,28 +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 AST.Module as Module

9−import qualified AST.PrettyPrint as Pretty

10−import qualified Text.PrettyPrint as P

11−

12−types :: Module.Types -> IO ()

13−types ts =

14− do putStrLn ""

15− mapM_ printType (Map.toList ts)

16− putStrLn ""

17− where

18− printType (n,t) = do

19− print $ P.hsep [ Pretty.variable n

20− , P.text ":"

21− , Pretty.pretty t ]

22−

23−errors :: [P.Doc] -> IO ()

24−errors errs =

25− mapM_ print (List.intersperse (P.text " ") errs)

26−

27−failure :: String -> IO a

28−failure msg = hPutStrLn stderr msg >> exitFailure

compiler/Build/Source.hsdeleted−35

@@ -1,35 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Build.Source (build) where

3−

4−import qualified Data.Map as Map

5−import Text.PrettyPrint (Doc)

6−

7−import qualified AST.Module as Module

8−import qualified Parse.Parse as Parse

9−import qualified Metadata.Prelude as Prelude

10−import qualified Transform.Check as Check

11−import qualified Type.Inference as TI

12−import qualified Transform.Canonicalize as Canonical

13−

14−build :: Bool -> Module.Interfaces -> String -> Either [Doc] Module.CanonicalModule

15−build noPrelude interfaces source =

16− do let infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

17− . concatMap Module.iFixities $ Map.elems interfaces

18−

19− -- Parse the source code and validate that it is well formed.

20− validModule <- do

21− modul <- Prelude.add noPrelude `fmap` Parse.program infixes source

22− case Check.mistakes (Module.body modul) of

23− [] -> return modul

24− ms -> Left ms

25−

26− -- Canonicalize all variables, pinning down where they came from.

27− canonicalModule <- Canonical.module' interfaces validModule

28−

29− -- Run type inference on the program.

30− types <- TI.infer interfaces canonicalModule

31−

32− -- Add the real list of tyes

33− let body = (Module.body canonicalModule) { Module.types = types }

34−

35− return $ canonicalModule { Module.body = body }

compiler/Build/Utils.hsdeleted−64

@@ -1,64 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Build.Utils where

3−

4−import Control.Monad.Error

5−import System.Directory (doesFileExist)

6−import System.Environment (getEnv)

7−import System.FilePath ((</>), replaceExtension)

8−import System.IO.Error (tryIOError)

9−import qualified Build.Flags as Flag

10−import qualified Build.Print as Print

11−import qualified Paths_Elm as This

12−

13−buildPath :: Flag.Flags -> FilePath -> String -> FilePath

14−buildPath flags filePath ext =

15− Flag.build_dir flags </> replaceExtension filePath ext

16−

17−cachePath :: Flag.Flags -> FilePath -> String -> FilePath

18−cachePath flags filePath ext =

19− Flag.cache_dir flags </> replaceExtension filePath ext

20−

21−elmo :: Flag.Flags -> FilePath -> FilePath

22−elmo flags filePath =

23− cachePath flags filePath "elmo"

24−

25−elmi :: Flag.Flags -> FilePath -> FilePath

26−elmi flags filePath =

27− cachePath flags filePath "elmi"

28−

29−-- |The absolute path to a data file

30−getDataFile :: FilePath -> IO FilePath

31−getDataFile name = do

32− path <- This.getDataFileName name

33− exists <- doesFileExist path

34− if exists

35− then return path

36− else do

37− environment <- tryIOError (getEnv "ELM_HOME")

38− case environment of

39− Right env -> return (env </> "compiler" </> name)

40− Left _ ->

41− fail $ unlines

42− [ "Unable to find the ELM_HOME environment variable when searching"

43− , "for the " ++ name ++ " file."

44− , ""

45− , "If you installed Elm Platform with the Mac or Windows installer, it looks like"

46− , "ELM_HOME was not set automatically. Look up how to set environment variables"

47− , "on your platform and set ELM_HOME to the directory that contains Elm's static"

48− , "files:"

49− , ""

50− , " * On Mac it is /usr/local/share/elm"

51− , " * On Windows it is one of the following:"

52− , " C:/Program Files/Elm Platform/0.13/share"

53− , " C:/Program Files (x86)/Elm Platform/0.13/share"

54− , ""

55− , "If it seems like a more complex issue, please report it here:"

56− , " <https://github.com/elm-lang/elm-platform/issues>"

57− ]

58−

59−run :: ErrorT String IO a -> IO a

60−run command = do

61− either <- runErrorT command

62− case either of

63− Left err -> Print.failure err

64− Right result -> return result

compiler/Compiler.hsdeleted−89

@@ -1,89 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Main where

3−

4−import Control.Monad (foldM, when)

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.Exit (exitSuccess)

11−import System.FilePath

12−import GHC.Conc

13−

14−import Build.Dependencies (getBuildRecipe, Recipe(..))

15−import qualified Generate.Html as Html

16−import qualified Metadata.Prelude as Prelude

17−import qualified Build.Utils as Utils

18−import qualified Build.Flags as Flag

19−import qualified Build.File as File

20−import qualified Elm.Internal.Paths as Path

21−

22−main :: IO ()

23−main = do setNumCapabilities =<< getNumProcessors

24− compileArgs =<< CmdArgs.cmdArgs Flag.flags

25−

26−compileArgs :: Flag.Flags -> IO ()

27−compileArgs flags =

28− do when (Flag.get_runtime flags) $ do

29− putStrLn Path.runtime

30− exitSuccess

31− case Flag.files flags of

32− [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"

33− fs -> mapM_ (build flags) fs

34−

35−build :: Flag.Flags -> FilePath -> IO ()

36−build flags rootFile =

37− do let noPrelude = Flag.no_prelude flags

38− builtIns <- Prelude.interfaces noPrelude

39−

40− (Recipe elmFiles jsFiles) <-

41− if Flag.make flags

42− then Utils.run (getBuildRecipe (Flag.src_dir flags) builtIns rootFile)

43− else return (Recipe [rootFile] [])

44−

45− moduleName <- File.build flags builtIns elmFiles

46−

47− let elmos = map (Utils.elmo flags) elmFiles

48− js <- foldM appendToOutput BS.empty (elmos ++ jsFiles)

49−

50− (extension, code) <-

51− if Flag.only_js flags

52− then do putStr "Generating JavaScript ... "

53− makeJs js

54− else do putStr "Generating HTML ... "

55− makeHtml js moduleName

56−

57− let targetFile = Utils.buildPath flags rootFile extension

58− createDirectoryIfMissing True (takeDirectory targetFile)

59− BS.writeFile targetFile code

60− putStrLn "Done"

61−

62− where

63− appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString

64− appendToOutput js filePath = do

65− src <- BS.readFile filePath

66− return (BS.append src js)

67−

68− getRuntime :: IO Html.JSSource

69− getRuntime =

70− let runtimePath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags) in

71− case Flag.bundle_runtime flags of

72− False -> return (Html.Link runtimePath)

73− True -> Html.Source `fmap` BS.readFile runtimePath

74−

75− makeJs :: BS.ByteString -> IO (String, BS.ByteString)

76− makeJs js =

77− do runtime <- getRuntime

78− case runtime of

79− Html.Link _ -> return ("js", js)

80− Html.Source rts -> return ("js", BS.append rts js)

81−

82− makeHtml :: BS.ByteString -> String -> IO (String, BS.ByteString)

83− makeHtml js moduleName =

84− do runtime <- getRuntime

85− return ("html", BS.pack $ renderHtml (html runtime))

86− where

87− sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]

88− html runtime =

89− Html.generate runtime (takeBaseName rootFile) (sources js) moduleName ""

compiler/Docs.hsdeleted−224

@@ -1,224 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

3−module Main where

4−

5−import System.Console.CmdArgs

6−import System.Directory

7−import System.FilePath

8−import System.Exit

9−import System.IO

10−

11−import Control.Applicative ((<$>))

12−import Control.Arrow (second)

13−import Data.Aeson

14−import Data.Aeson.Encode.Pretty

15−import Data.Aeson.Types (Pair)

16−import qualified Data.List as List

17−import qualified Data.Map as Map

18−import qualified Data.ByteString.Lazy as BS

19−import qualified Data.Text as Text

20−

21−import qualified AST.Helpers as Help

22−import qualified AST.Type as T

23−import qualified AST.Declaration as D

24−import qualified AST.Expression.Source as Src

25−import qualified AST.Variable as Var

26−

27−import Text.Parsec hiding (newline,spaces)

28−import Parse.Declaration (alias,datatype,infixDecl)

29−import Parse.Expression (typeAnnotation)

30−import Parse.Helpers

31−import Parse.Module (moduleDef)

32−

33−data Flags = Flags

34− { files :: [FilePath] }

35− deriving (Data,Typeable,Show,Eq)

36−

37−defaultFlags :: Flags

38−defaultFlags = Flags

39− { files = def &= args &= typ "FILES"

40− } &= help "Generate documentation for Elm"

41− &= summary ("Generate documentation for Elm, (c) Evan Czaplicki")

42−

43−main :: IO ()

44−main = do

45− flags <- cmdArgs defaultFlags

46− mapM_ parseFile (files flags)

47−

48−config :: Config

49−config = Config { confIndent = 2, confCompare = keyOrder keys }

50− where

51− keys = ["tag","name","document","comment","raw","aliases","datatypes"

52− ,"values","typeVariables","type","constructors"]

53−

54−parseFile :: FilePath -> IO ()

55−parseFile path = do

56− source <- readFile path

57− case iParse docs source of

58− Right json -> do

59− putStrLn $ "Documenting " ++ path

60− let docPath = "docs" </> replaceExtension path ".json"

61− createDirectoryIfMissing True (dropFileName docPath)

62− BS.writeFile docPath (encodePretty' config json)

63− Left err -> do

64− hPutStrLn stderr $ "Parse error in " ++ path ++ " at " ++ show err

65− exitFailure

66−

67−docs :: IParser Value

68−docs = do

69− (name, _exports, structure) <- moduleDocs

70− things <- document

71− return $ documentToJson name structure things

72−

73−docComment :: IParser String

74−docComment = do

75− try (string "{-|")

76− contents <- closeComment

77− let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents

78− return $ dropWhile (==' ') (reverse reversed)

79−

80−moduleDocs :: IParser (String, Var.Listing Var.Value, String)

81−moduleDocs = do

82− optional freshLine

83− (names,exports) <- moduleDef

84− manyTill (string " " <|> newline <?> "more whitespace")

85− (lookAhead (string "{-|") <?> "module documentation comment")

86− structure <- docComment

87− return (List.intercalate "." names, exports, structure)

88−

89−document :: IParser [(String, D.SourceDecl, String)]

90−document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

91−

92−docThing :: IParser (String, D.SourceDecl, String)

93−docThing = uncommentable <|> commented <|> uncommented ""

94− where

95− uncommentable = do

96− ifx <- infixDecl

97− return ("", ifx, "")

98−

99− commented = do

100− comment <- docComment

101− freshLine

102− uncommented comment

103−

104− uncommented comment = do

105− (src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]

106− return (comment, def, src)

107−

108−

109−documentToJson :: String -> String -> [(String, D.SourceDecl, String)] -> Value

110−documentToJson name structure things =

111− object

112− [ "name" .= name

113− , "document" .= structure

114− , "values" .= toList values

115− , "aliases" .= toList aliases

116− , "datatypes" .= toList adts

117− ]

118− where

119− (values, aliases, adts) =

120− collect Map.empty Map.empty Map.empty Map.empty things

121−

122− toList :: Map.Map String [Pair] -> [Value]

123− toList dict =

124− map object (Map.elems dict)

125−

126−type Pairs = Map.Map String [Pair]

127−

128−collect :: Map.Map String (D.Assoc, Int) -> Pairs -> Pairs -> Pairs

129− -> [(String, D.SourceDecl, String)]

130− -> (Pairs, Pairs, Pairs)

131−collect infixes types aliases adts things =

132− case things of

133− [] -> (Map.union customOps nonCustomOps, aliases, adts)

134− where

135− nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes

136− addDefaultInfix name pairs

137− | all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs

138− | otherwise = pairs

139−

140− customOps = Map.intersectionWith addInfix infixes types

141− addInfix (assoc,prec) pairs =

142− [ "associativity" .= show assoc, "precedence" .= prec ] ++ pairs

143−

144− (comment, decl, source) : rest ->

145− let insert name fields dict = Map.insert name (obj name fields) dict

146− obj name fields =

147− [ "name" .= name

148− , "raw" .= source

149− , "comment" .= comment

150− ] ++ fields

151− in

152− case decl of

153− D.Definition def ->

154− case def of

155− Src.TypeAnnotation name tipe ->

156− collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

157−

158− Src.Definition _ _ ->

159− collect infixes types aliases adts rest

160−

161− D.Datatype name vars ctors ->

162− let tipe = T.App (T.Type (Var.Raw name)) (map T.Var vars)

163− fields = [ "typeVariables" .= vars

164− , "constructors" .= map (ctorToJson tipe) ctors

165− ]

166− in collect infixes types aliases (insert name fields adts) rest

167−

168− D.TypeAlias name vars tipe ->

169− let fields = [ "typeVariables" .= vars, "type" .= tipe ]

170− in collect infixes types (insert name fields aliases) adts rest

171−

172− D.Port _ ->

173− collect infixes types aliases adts rest

174−

175− D.Fixity assoc prec name ->

176− collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

177−

178−

179−instance Var.ToString var => ToJSON (T.Type var) where

180− toJSON tipe =

181− object (getFields tipe)

182− where

183− getFields tipe =

184− case tipe of

185− T.Lambda _ _ ->

186− let tipes = T.collectLambdas tipe in

187− [ "tag" .= ("function" :: Text.Text)

188− , "args" .= toJSON (init tipes)

189− , "result" .= toJSON (last tipes)

190− ]

191−

192− T.Var x ->

193− [ "tag" .= ("var" :: Text.Text)

194− , "name" .= toJSON x

195− ]

196−

197− T.Type name ->

198− [ "tag" .= ("adt" :: Text.Text)

199− , "name" .= toJSON (Var.toString name)

200− , "args" .= ([] :: [()])

201− ]

202−

203− T.App (T.Type name) ts ->

204− [ "tag" .= ("adt" :: Text.Text)

205− , "name" .= toJSON (Var.toString name)

206− , "args" .= map toJSON ts

207− ]

208−

209− T.App _ _ -> error "This is an unexpected error with elm-doc, please report it at <https://github.com/elm-lang/Elm/issues>"

210−

211− T.Record fields ext ->

212− [ "tag" .= ("record" :: Text.Text)

213− , "fields" .= toJSON (map (toJSON . second toJSON) fields)

214− , "extension" .= toJSON ext

215− ]

216−

217− T.Aliased _ t ->

218− getFields t

219−

220−ctorToJson :: T.RawType -> (String, [T.RawType]) -> Value

221−ctorToJson tipe (ctor, tipes) =

222− object [ "name" .= ctor

223− , "type" .= foldr T.Lambda tipe tipes

224− ]

compiler/Dummy.cabaldeleted−291

@@ -1,291 +0,0 @@

1−Name: Elm

2−Version: 0.12

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

18−

19−Category: Compiler, Language

20−

21−Build-type: Custom

22−

23−Extra-source-files: changelog.md

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: AST.Annotation,

41− AST.Declaration,

42− AST.Expression.General,

43− AST.Expression.Source,

44− AST.Expression.Valid,

45− AST.Expression.Canonical,

46− AST.Helpers,

47− AST.Literal,

48− AST.Module,

49− AST.Pattern,

50− AST.PrettyPrint,

51− AST.Type,

52− AST.Variable,

53− Generate.JavaScript,

54− Generate.JavaScript.Helpers,

55− Generate.JavaScript.Ports,

56− Generate.Markdown,

57− Generate.Html,

58− Generate.Cases,

59− Transform.Canonicalize,

60− Transform.Check,

61− Transform.Expression,

62− Transform.Declaration,

63− Transform.Definition,

64− Transform.SortDefinitions,

65− Transform.Substitute,

66− Metadata.Prelude,

67− Parse.Binop,

68− Parse.Declaration,

69− Parse.Expression,

70− Parse.Helpers,

71− Parse.Literal,

72− Parse.Module,

73− Parse.Parse,

74− Parse.Pattern,

75− Parse.Type,

76− Type.Alias,

77− Type.Constrain.Expression,

78− Type.Constrain.Literal,

79− Type.Constrain.Pattern,

80− Type.Environment,

81− Type.ExtraChecks,

82− Type.Fragment,

83− Type.Inference,

84− Type.PrettyPrint,

85− Type.Solve,

86− Type.State,

87− Type.Type,

88− Type.Unify,

89− Build.Dependencies,

90− Build.File,

91− Build.Flags,

92− Build.Interface,

93− Build.Print,

94− Build.Source,

95− Build.Utils,

96− Paths_Elm

97−

98− Build-depends: aeson,

99− base >=4.2 && <5,

100− binary >= 0.7.0.0,

101− blaze-html >= 0.5 && < 0.8,

102− blaze-markup,

103− bytestring,

104− cmdargs,

105− containers >= 0.3,

106− directory,

107− filepath,

108− indents,

109− language-ecmascript >=0.15 && < 1.0,

110− language-glsl,

111− mtl >= 2,

112− pandoc >= 1.10,

113− parsec >= 3.1.1,

114− pretty,

115− text,

116− transformers >= 0.2,

117− union-find,

118− unordered-containers

119−

120−Executable elm

121− Main-is: Compiler.hs

122− ghc-options: -threaded -O2

123− Hs-Source-Dirs: compiler

124− other-modules: AST.Annotation,

125− AST.Declaration,

126− AST.Expression.General,

127− AST.Expression.Source,

128− AST.Expression.Valid,

129− AST.Expression.Canonical,

130− AST.Helpers,

131− AST.Literal,

132− AST.Module,

133− AST.Pattern,

134− AST.PrettyPrint,

135− AST.Type,

136− AST.Variable,

137− Generate.JavaScript,

138− Generate.JavaScript.Helpers,

139− Generate.JavaScript.Ports,

140− Generate.Markdown,

141− Generate.Html,

142− Generate.Cases,

143− Transform.Canonicalize,

144− Transform.Check,

145− Transform.Expression,

146− Transform.Declaration,

147− Transform.Definition,

148− Transform.SortDefinitions,

149− Transform.Substitute,

150− Metadata.Prelude,

151− Parse.Binop,

152− Parse.Declaration,

153− Parse.Expression,

154− Parse.Helpers,

155− Parse.Literal,

156− Parse.Module,

157− Parse.Parse,

158− Parse.Pattern,

159− Parse.Type,

160− Type.Alias,

161− Type.Constrain.Expression,

162− Type.Constrain.Literal,

163− Type.Constrain.Pattern,

164− Type.Environment,

165− Type.ExtraChecks,

166− Type.Fragment,

167− Type.Inference,

168− Type.PrettyPrint,

169− Type.Solve,

170− Type.State,

171− Type.Type,

172− Type.Unify,

173− Build.Dependencies,

174− Build.File,

175− Build.Flags,

176− Build.Interface,

177− Build.Print,

178− Build.Source,

179− Build.Utils,

180− Paths_Elm

181−

182− Build-depends: aeson,

183− base >=4.2 && <5,

184− binary >= 0.7.0.0,

185− blaze-html >= 0.5 && < 0.8,

186− blaze-markup,

187− bytestring,

188− cmdargs,

189− containers >= 0.3,

190− directory,

191− filepath,

192− indents,

193− language-ecmascript >=0.15 && < 1.0,

194− language-glsl,

195− mtl >= 2,

196− pandoc >= 1.10,

197− parsec >= 3.1.1,

198− pretty,

199− text,

200− transformers >= 0.2,

201− union-find,

202− unordered-containers

203−

204−Executable elm-doc

205− Main-is: Docs.hs

206− Hs-Source-Dirs: compiler

207− other-modules: AST.Annotation,

208− AST.Declaration,

209− AST.Expression.General,

210− AST.Helpers,

211− AST.Literal,

212− AST.Module,

213− AST.Pattern,

214− AST.PrettyPrint,

215− AST.Type,

216− AST.Variable,

217− Parse.Binop,

218− Parse.Declaration,

219− Parse.Expression,

220− Parse.Helpers,

221− Parse.Literal,

222− Parse.Module,

223− Parse.Pattern,

224− Parse.Type

225−

226− Build-depends: aeson,

227− aeson-pretty,

228− base >=4.2 && <5,

229− binary >= 0.7.0.0,

230− bytestring,

231− cmdargs,

232− containers >= 0.3,

233− directory,

234− filepath,

235− indents,

236− language-glsl,

237− mtl >= 2,

238− pandoc >= 1.10,

239− parsec >= 3.1.1,

240− pretty,

241− text,

242− union-find

243−

244−Test-Suite compiler-tests

245− Type: exitcode-stdio-1.0

246− Hs-Source-Dirs: tests/hs, compiler

247− Main-is: CompilerTest.hs

248− other-modules: Tests.Compiler

249− Tests.Property

250− Tests.Property.Arbitrary

251− AST.Helpers

252− AST.Literal

253− AST.PrettyPrint

254− build-depends: test-framework,

255− test-framework-hunit,

256− test-framework-quickcheck2 >= 0.3,

257− HUnit,

258− QuickCheck >= 2 && < 3,

259− aeson,

260− base >=4.2 && <5,

261− binary >= 0.7.0.0,

262− blaze-html == 0.5.* || == 0.6.*,

263− blaze-markup == 0.5.1.*,

264− bytestring,

265− cmdargs,

266− containers >= 0.3,

267− directory,

268− Elm,

269− filemanip,

270− filepath,

271− indents,

272− language-ecmascript >=0.15 && < 1.0,

273− language-glsl,

274− mtl >= 2,

275− pandoc >= 1.10,

276− parsec >= 3.1.1,

277− pretty,

278− text,

279− transformers >= 0.2,

280− union-find,

281− unordered-containers

282−

283−Test-Suite lib-tests

284− Type: exitcode-stdio-1.0

285− Hs-Source-Dirs: tests/hs

286− Main-is: LibTest.hs

287− build-depends: base,

288− directory,

289− Elm,

290− filepath,

291− process >= 1.2

compiler/Elm/Internal/Dependencies.hsdeleted−156

@@ -1,156 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Elm.Internal.Dependencies where

3−

4−import Control.Applicative

5−import Control.Arrow (first)

6−import Control.Monad.Error

7−import qualified Control.Exception as E

8−import Data.Aeson

9−import Data.Aeson.Types (Parser)

10−import Data.Aeson.Encode.Pretty

11−import Data.Maybe (fromMaybe)

12−import qualified Data.List as List

13−import qualified Data.ByteString.Lazy as BS

14−import qualified Data.HashMap.Strict as Map

15−import qualified Data.Text as T

16−

17−import qualified Elm.Internal.Name as N

18−import qualified Elm.Internal.Version as V

19−import qualified Elm.Internal.Paths as Path

20−

21−data Deps = Deps

22− { name :: N.Name

23− , version :: V.Version

24− , summary :: String

25− , description :: String

26− , license :: String

27− , repo :: String

28− , exposed :: [String]

29− , native :: [String]

30− , elmVersion :: V.Version

31− , dependencies :: [(N.Name,V.Version)]

32− } deriving (Show, Eq, Ord)

33−

34−instance ToJSON Deps where

35− toJSON d =

36− object $

37− [ "version" .= version d

38− , "summary" .= summary d

39− , "description" .= description d

40− , "license" .= license d

41− , "repository" .= repo d

42− , "exposed-modules" .= exposed d

43− , "elm-version" .= elmVersion d

44− , "dependencies" .= (jsonDeps . dependencies $ d)

45− ] ++ nativeModules

46− where

47− jsonDeps = Map.fromList . map (first (T.pack . show))

48− nativeModules

49− | null (native d) = []

50− | otherwise = [ "native-modules" .= native d ]

51−

52−instance FromJSON Deps where

53− parseJSON (Object obj) =

54− do version <- get obj "version" "your projects version number"

55−

56− summary <- get obj "summary" "a short summary of your project"

57− when (length summary >= 80) $

58− fail "'summary' must be less than 80 characters"

59−

60− desc <- get obj "description" "an extended description of your project \

61− \and how to get started with it."

62− license <- get obj "license" "license information (BSD3 is recommended)"

63−

64− repo <- get obj "repository" "a link to the project's GitHub repo"

65− name <- case repoToName repo of

66− Left err -> fail err

67− Right nm -> return nm

68−

69− exposed <- get obj "exposed-modules" "a list of modules exposed to users"

70−

71− native <- fromMaybe [] <$> (obj .:? "native-modules")

72−

73− elmVersion <- get obj "elm-version" "the version of the Elm compiler you are using"

74−

75− deps <- getDependencies obj

76−

77− return $ Deps name version summary desc license repo exposed native elmVersion deps

78−

79− parseJSON _ = mzero

80−

81−getDependencies :: Object -> Parser [(N.Name, V.Version)]

82−getDependencies obj =

83− toDeps =<< get obj "dependencies" "a listing of your project's dependencies"

84− where

85− toDeps deps =

86− forM (Map.toList deps) $ \(f,v) ->

87− case (N.fromString f, V.fromString v) of

88− (Just name, Just version) -> return (name,version)

89− (Nothing, _) -> fail $ N.errorMsg f

90− (_, Nothing) -> fail $ "invalid version number " ++ v

91−

92−get :: FromJSON a => Object -> T.Text -> String -> Parser a

93−get obj field desc =

94− do maybe <- obj .:? field

95− case maybe of

96− Just value -> return value

97− Nothing -> fail $ "Missing field " ++ show field ++ ", " ++ desc ++ ".\n" ++

98− " Check out an example " ++ Path.dependencyFile ++ " file here:" ++

99− " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"

100−

101−repoToName :: String -> Either String N.Name

102−repoToName repo

103− | not (end `List.isSuffixOf` repo) = Left msg

104− | otherwise =

105− do path <- getPath

106− let raw = take (length path - length end) path

107− case N.fromString raw of

108− Nothing -> Left msg

109− Just name -> Right name

110− where

111− getPath | http `List.isPrefixOf` repo = Right $ drop (length http ) repo

112− | https `List.isPrefixOf` repo = Right $ drop (length https) repo

113− | otherwise = Left msg

114− http = "http://github.com/"

115− https = "https://github.com/"

116− end = ".git"

117− msg = "the 'repository' field must point to a GitHub project for now, something\n\

118− \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\

119− \and PROJECT is the repo you want to upload."

120−

121−withDeps :: FilePath -> (Deps -> ErrorT String IO a) -> ErrorT String IO a

122−withDeps path handle =

123− do json <- readPath

124− case eitherDecode json of

125− Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err

126− Right ds -> handle ds

127− where

128− readPath :: ErrorT String IO BS.ByteString

129− readPath = do

130− result <- liftIO $ E.catch (Right <$> BS.readFile path)

131− (\err -> return $ Left (err :: IOError))

132− case result of

133− Right bytes -> return bytes

134− Left _ -> throwError $

135− "could not find " ++ path ++ " file. You may need to create one.\n" ++

136− " For an example of how to fill in the dependencies file, check out\n" ++

137− " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"

138−

139−depsAt :: FilePath -> ErrorT String IO Deps

140−depsAt filePath = withDeps filePath return

141−

142−-- | Encode dependencies in a canonical JSON format

143−prettyJSON :: Deps -> BS.ByteString

144−prettyJSON = encodePretty' config

145− where config = defConfig { confCompare = order }

146− order = keyOrder [ "name"

147− , "version"

148− , "summary"

149− , "description"

150− , "license"

151− , "repo"

152− , "exposed-modules"

153− , "native-modules"

154− , "elm-version"

155− , "dependencies"

156− ]

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, Ord)

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−24

@@ -1,24 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Elm.Internal.Paths where

3−

4−import Build.Utils (getDataFile)

5−import System.IO.Unsafe (unsafePerformIO)

6−

7−-- |Name of directory for all of a project's dependencies.

8−dependencyDirectory :: FilePath

9−dependencyDirectory = "elm_dependencies"

10−

11−-- |Name of the dependency file, specifying dependencies and

12−-- other metadata for building and sharing projects.

13−dependencyFile :: FilePath

14−dependencyFile = "elm_dependencies.json"

15−

16−{-# NOINLINE runtime #-}

17−-- |The absolute path to Elm's runtime system.

18−runtime :: FilePath

19−runtime = unsafePerformIO $ getDataFile "elm-runtime.js"

20−

21−{-# NOINLINE docs #-}

22−-- |The absolute path to Elm's core library documentation.

23−docs :: FilePath

24−docs = unsafePerformIO $ getDataFile "docs.json"

compiler/Elm/Internal/Utils.hsdeleted−35

@@ -1,35 +0,0 @@

1−{- | This module exports functions for compiling Elm to JS.

2−-}

3−module Elm.Internal.Utils (compile, moduleName, nameAndImports) 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 AST.Module as M

10−import Parse.Parse (dependencies)

11−import qualified Text.PrettyPrint as P

12−import qualified Metadata.Prelude as Prelude

13−import System.IO.Unsafe

14−

15−-- |This function compiles Elm code to JavaScript. It will return either

16−-- an error message or the compiled JS code.

17−compile :: String -> Either String String

18−compile source =

19− case Source.build False interfaces source of

20− Left docs -> Left . unlines . List.intersperse "" $ map P.render docs

21− Right modul -> Right $ JS.generate modul

22−

23−{-# NOINLINE interfaces #-}

24−interfaces :: M.Interfaces

25−interfaces = unsafePerformIO $ Prelude.interfaces False

26−

27−-- |This function extracts the module name of a given source program.

28−moduleName :: String -> Maybe String

29−moduleName = Parser.getModuleName

30−

31−-- |This function extracts the module name and imported modules from a given

32−-- source program.

33−nameAndImports :: String -> Maybe (String, [String])

34−nameAndImports src =

35− either (const Nothing) Just (dependencies src)

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−211

@@ -1,211 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

3−

4−import Control.Applicative ((<$>))

5−import Control.Arrow (first)

6−import Control.Monad.State (State)

7−import qualified Control.Monad.State as State

8−import Data.List (groupBy,sortBy)

9−import Data.Maybe (fromMaybe)

10−

11−import qualified AST.Annotation as A

12−import qualified AST.Expression.General as Expr

13−import qualified AST.Expression.Canonical as Canonical

14−import qualified AST.Literal as Literal

15−import qualified AST.Pattern as P

16−import qualified AST.Variable as Var

17−import Transform.Substitute (subst)

18−

19−toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

20−toMatch patterns = do

21− v <- newVar

22− (,) v <$> match [v] (map (first (:[])) patterns) Fail

23−

24−

25−newVar :: State Int String

26−newVar =

27− do n <- State.get

28− State.modify (+1)

29− return $ "_v" ++ show n

30−

31−

32−data Match

33− = Match String [Clause] Match

34− | Break

35− | Fail

36− | Other Canonical.Expr

37− | Seq [Match]

38− deriving Show

39−

40−

41−data Clause =

42− Clause (Either Var.Canonical Literal.Literal) [String] Match

43− deriving Show

44−

45−

46−type Case =

47− ([P.CanonicalPattern], Canonical.Expr)

48−

49−

50−matchSubst :: [(String,String)] -> Match -> Match

51−matchSubst pairs match =

52− case match of

53− Break -> Break

54−

55− Fail -> Fail

56−

57− Seq ms ->

58− Seq (map (matchSubst pairs) ms)

59−

60− Other (A.A a e) ->

61− Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs

62−

63− Match n cs m ->

64− Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

65− where

66− varSubst v = fromMaybe v (lookup v pairs)

67− clauseSubst (Clause c vs m) =

68− Clause c (map varSubst vs) (matchSubst pairs m)

69−

70−

71−isCon :: ([P.Pattern var], expr) -> Bool

72−isCon ([] , _) = noMatch "isCon"

73−isCon (p:_, _) =

74− case p of

75− P.Data _ _ -> True

76− P.Literal _ -> True

77− _ -> False

78−

79−

80−isVar :: ([P.Pattern var], expr) -> Bool

81−isVar p = not (isCon p)

82−

83−

84−match :: [String] -> [Case] -> Match -> State Int Match

85−match variables cases match =

86− case (variables, cases, match) of

87− ([], [], _) ->

88− return match

89−

90− ([], [([], expr)], Fail) ->

91− return $ Other expr

92−

93− ([], [([], expr)], Break) ->

94− return $ Other expr

95−

96− ([], _, _) ->

97− return $ Seq (map (Other . snd) cases ++ [match])

98−

99− (var:_, _, _)

100− | all isVar cases' -> matchVar variables cases' match

101− | all isCon cases' -> matchCon variables cases' match

102− | otherwise -> matchMix variables cases' match

103− where

104− cases' = map (dealias var) cases

105−

106−

107−dealias :: String -> Case -> Case

108−dealias _ ([], _) = noMatch "dealias"

109−dealias v c@(p:ps, A.A a e) =

110− case p of

111− P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e)

112− _ -> c

113−

114−

115−matchVar :: [String] -> [Case] -> Match -> State Int Match

116−matchVar [] _ _ = noMatch "matchVar"

117−matchVar (v:vs) cs def =

118− match vs (map subVar cs) def

119− where

120− subVar ([], _) = noMatch "matchVar.subVar"

121− subVar (p:ps, (A.A a expr)) =

122− (ps, A.A a $ subOnePattern p expr)

123− where

124− subOnePattern pattern expr =

125− case pattern of

126− P.Anything -> expr

127−

128− P.Var x ->

129− subst x (Expr.localVar v) expr

130−

131− P.Record fs ->

132− foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs

133−

134− _ -> noMatch "matchVar.subVar"

135−

136−

137−matchCon :: [String] -> [Case] -> Match -> State Int Match

138−matchCon variables cases match =

139− case variables of

140− [] -> noMatch "matchCon"

141−

142− var : _vars ->

143− flip (Match var) match <$> mapM toClause caseGroups

144− where

145− caseGroups :: [[Case]]

146− caseGroups =

147− groupBy eq (sortBy cmp cases)

148−

149− eq :: Case -> Case -> Bool

150− eq (patterns1, _) (patterns2, _) =

151− case (patterns1, patterns2) of

152− (pattern1:_, pattern2:_) ->

153− case (pattern1, pattern2) of

154− (P.Data name1 _, P.Data name2 _) -> name1 == name2

155− (_, _) -> pattern1 == pattern2

156− (_, _) -> noMatch "matchCon.eq"

157−

158− cmp :: Case -> Case -> Ordering

159− cmp (patterns1, _) (patterns2, _) =

160− case (patterns1, patterns2) of

161− (pattern1:_, pattern2:_) ->

162− case (pattern1, pattern2) of

163− (P.Data name1 _, P.Data name2 _) -> compare name1 name2

164− (_, _) -> compare pattern1 pattern2

165− (_, _) -> noMatch "matchCon.cmp"

166−

167− toClause :: [Case] -> State Int Clause

168− toClause cases =

169− case head cases of

170− (P.Data name _ : _, _) ->

171− matchClause (Left name) variables cases Break

172−

173− (P.Literal lit : _, _) ->

174− matchClause (Right lit) variables cases Break

175−

176− _ -> noMatch "matchCon"

177−

178−

179−matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match

180− -> State Int Clause

181−matchClause _ [] _ _ = noMatch "matchClause"

182−matchClause c (_:vs) cs mtch =

183− do vs' <- getVars

184− Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch

185− where

186− flatten ([], _) = noMatch "matchClause.flatten"

187− flatten (p:ps, e) =

188− case p of

189− P.Data _ ps' -> (ps' ++ ps, e)

190− P.Literal _ -> (ps, e)

191− _ -> noMatch "matchClause.flatten"

192−

193− getVars :: State Int [String]

194− getVars =

195− case head cs of

196− (P.Data _ ps : _, _) -> State.forM ps (const newVar)

197− (P.Literal _ : _, _) -> return []

198− _ -> noMatch "matchClause.getVars"

199−

200−

201−matchMix :: [String] -> [Case] -> Match -> State Int Match

202−matchMix vs cs def =

203− State.foldM (flip $ match vs) def (reverse css)

204− where

205− css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

206−

207−

208−noMatch :: String -> a

209−noMatch name =

210− error $ "unexpected pattern in '" ++ name ++

211− "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

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 :: JSSource -> String -> [JSSource] -> String -> String -> H.Html

21−generate runtime 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 runtime

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−442

@@ -1,442 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Generate.JavaScript (generate) where

3−

4−import Control.Applicative ((<$>),(<*>))

5−import Control.Arrow (first,(***))

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−import Language.ECMAScript3.PrettyPrint

11−import Language.ECMAScript3.Syntax

12−

13−import Generate.JavaScript.Helpers as Help

14−import qualified Generate.Cases as Case

15−import qualified Generate.JavaScript.Ports as Port

16−import qualified Generate.JavaScript.Variable as Var

17−import qualified Generate.Markdown as MD

18−

19−import AST.Annotation

20−import AST.Module

21−import AST.Expression.General

22−import qualified AST.Expression.Canonical as Canonical

23−import qualified AST.Module as Module

24−import qualified AST.Helpers as Help

25−import AST.Literal

26−import qualified AST.Pattern as P

27−import qualified AST.Variable as Var

28−

29−varDecl :: String -> Expression () -> VarDecl ()

30−varDecl x expr =

31− VarDecl () (var x) (Just expr)

32−

33−internalImports :: String -> [VarDecl ()]

34−internalImports name =

35− [ varDecl "_N" (obj ["Elm","Native"])

36− , include "_U" "Utils"

37− , include "_L" "List"

38− , include "_A" "Array"

39− , include "_E" "Error"

40− , varDecl Help.localModuleName (string name)

41− ]

42− where

43− include :: String -> String -> VarDecl ()

44− include alias modul =

45− varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")

46−

47−_Utils :: String -> Expression ()

48−_Utils x = obj ["_U", x]

49−

50−_List :: String -> Expression ()

51−_List x = obj ["_L", x]

52−

53−literal :: Literal -> Expression ()

54−literal lit =

55− case lit of

56− Chr c -> _Utils "chr" <| string [c]

57− Str s -> string s

58− IntNum n -> IntLit () n

59− FloatNum n -> NumLit () n

60− Boolean b -> BoolLit () b

61−

62−expression :: Canonical.Expr -> State Int (Expression ())

63−expression (A region expr) =

64− case expr of

65− Var var -> return $ Var.canonical var

66−

67− Literal lit -> return $ literal lit

68−

69− Range lo hi ->

70− do lo' <- expression lo

71− hi' <- expression hi

72− return $ _List "range" `call` [lo',hi']

73−

74− Access e x ->

75− do e' <- expression e

76− return $ DotRef () e' (var x)

77−

78− Remove e x ->

79− do e' <- expression e

80− return $ _Utils "remove" `call` [string x, e']

81−

82− Insert e x v ->

83− do v' <- expression v

84− e' <- expression e

85− return $ _Utils "insert" `call` [string x, v', e']

86−

87− Modify e fs ->

88− do e' <- expression e

89− fs' <- forM fs $ \(f,v) -> do

90− v' <- expression v

91− return $ ArrayLit () [string f, v']

92− return $ _Utils "replace" `call` [ArrayLit () fs', e']

93−

94− Record fields ->

95− do fields' <- forM fields $ \(f,e) -> do

96− (,) f <$> expression e

97− let fieldMap = List.foldl' combine Map.empty fields'

98− return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap

99− where

100− combine r (k,v) = Map.insertWith (++) k [v] r

101− hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .

102− Map.toList . Map.filter (not . null) $ Map.map tail fs

103− visible fs = map (first prop) . Map.toList $ Map.map head fs

104−

105− Binop op e1 e2 -> binop region op e1 e2

106−

107− Lambda p e@(A ann _) ->

108− do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)

109− body' <- expression body

110− return $ case length args < 2 || length args > 9 of

111− True -> foldr (==>) body' (map (:[]) args)

112− False -> ref ("F" ++ show (length args)) <| (args ==> body')

113− where

114− depattern (args, body) pattern =

115− case pattern of

116− P.Var x -> return (args ++ [ Var.varName x ], body)

117− _ -> do arg <- Case.newVar

118− return ( args ++ [arg]

119− , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

120−

121− (patterns, innerBody) = collect [p] e

122−

123− collect patterns lexpr@(A _ expr) =

124− case expr of

125− Lambda p e -> collect (p:patterns) e

126− _ -> (patterns, lexpr)

127−

128− App e1 e2 ->

129− do func' <- expression func

130− args' <- mapM expression args

131− return $ case args' of

132− [arg] -> func' <| arg

133− _ | length args' <= 9 -> ref aN `call` (func':args')

134− | otherwise -> foldl1 (<|) (func':args')

135− where

136− aN = "A" ++ show (length args)

137− (func, args) = getArgs e1 [e2]

138− getArgs func args =

139− case func of

140− (A _ (App f arg)) -> getArgs f (arg : args)

141− _ -> (func, args)

142−

143− Let defs e ->

144− do let (defs',e') = flattenLets defs e

145− stmts <- concat <$> mapM definition defs'

146− exp <- expression e'

147− return $ function [] (stmts ++ [ ret exp ]) `call` []

148−

149− MultiIf branches ->

150− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

151− return $ case last branches of

152− (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

153− safeIfs branches'

154− (A _ (Literal (Boolean True)), _) -> safeIfs branches'

155− _ -> ifs branches' (throw "If" region)

156− where

157− safeIfs branches = ifs (init branches) (snd (last branches))

158− ifs branches finally = foldr iff finally branches

159− iff (if', then') else' = CondExpr () if' then' else'

160−

161− Case e cases ->

162− do (tempVar,initialMatch) <- Case.toMatch cases

163− (revisedMatch, stmt) <-

164− case e of

165− A _ (Var (Var.Canonical Var.Local x)) ->

166− return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])

167− _ ->

168− do e' <- expression e

169− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

170− match' <- match region revisedMatch

171− return (function [] (stmt ++ match') `call` [])

172−

173− ExplicitList es ->

174− do es' <- mapM expression es

175− return $ _List "fromArray" <| ArrayLit () es'

176−

177− Data name es ->

178− do es' <- mapM expression es

179− return $ ObjectLit () (ctor : fields es')

180− where

181− ctor = (prop "ctor", string name)

182− fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]

183−

184− Markdown uid doc es ->

185− do es' <- mapM expression es

186− return $ Var.value "Text" "markdown" `call` (string md : string uid : es')

187− where

188− pad = "<div style=\"height:0;width:0;\"> </div>"

189− md = pad ++ MD.toHtml doc ++ pad

190−

191− GLShader _uid src _tipe ->

192− return $ ObjectLit () [(PropString () "src", literal (Str src))]

193−

194− PortIn name tipe ->

195− return $ Var.value "Native.Ports" "portIn" `call`

196− [ string name, Port.incoming tipe ]

197−

198− PortOut name tipe value ->

199− do value' <- expression value

200− return $ Var.value "Native.Ports" "portOut" `call`

201− [ string name, Port.outgoing tipe, value' ]

202−

203−definition :: Canonical.Def -> State Int [Statement ()]

204−definition (Canonical.Definition pattern expr@(A region _) _) = do

205− expr' <- expression expr

206− let assign x = varDecl x expr'

207− case pattern of

208− P.Var x

209− | Help.isOp x ->

210− let op = LBracket () (ref "_op") (string x) in

211− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

212− | otherwise ->

213− return [ VarDeclStmt () [ assign (Var.varName x) ] ]

214−

215− P.Record fields ->

216− let setField f = varDecl f (obj ["$",f]) in

217− return [ VarDeclStmt () (assign "$" : map setField fields) ]

218−

219− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

220− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

221− where

222− vars = getVars patterns

223− getVars patterns =

224− case patterns of

225− P.Var x : rest -> (Var.varName x :) `fmap` getVars rest

226− [] -> Just []

227− _ -> Nothing

228−

229− decl x n = varDecl x (obj ["$","_" ++ show n])

230− setup vars

231− | Help.isTuple name = assign "$" : vars

232− | otherwise = assign "_raw" : safeAssign : vars

233−

234− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

235− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

236− exception = Help.throw "Case" region

237−

238− _ ->

239− do defs' <- concat <$> mapM toDef vars

240− return (VarDeclStmt () [assign "_"] : defs')

241− where

242− vars = P.boundVarList pattern

243− mkVar = A region . localVar

244− toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

245− in definition $ Canonical.Definition (P.Var y) expr Nothing

246−

247−match :: Region -> Case.Match -> State Int [Statement ()]

248−match region mtch =

249− case mtch of

250− Case.Match name clauses mtch' ->

251− do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses

252− mtch'' <- match region mtch'

253− return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

254− where

255− isLiteral p = case p of

256− Case.Clause (Right _) _ _ -> True

257− _ -> False

258−

259− access name

260− | any isLiteral clauses = obj [name]

261− | otherwise = obj (Help.splitDots name ++ ["ctor"])

262−

263− format isChars e

264− | or isChars = InfixExpr () OpAdd e (string "")

265− | otherwise = e

266−

267− Case.Fail ->

268− return [ ExprStmt () (Help.throw "Case" region) ]

269−

270− Case.Break -> return [BreakStmt () Nothing]

271−

272− Case.Other e ->

273− do e' <- expression e

274− return [ ret e' ]

275−

276− Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)

277− where

278− dropEnd acc [] = acc

279− dropEnd acc (m:ms) =

280− case m of

281− Case.Other _ -> acc ++ [m]

282− _ -> dropEnd (acc ++ [m]) ms

283−

284−clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

285−clause region variable (Case.Clause value vars mtch) =

286− (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)

287− where

288− vars' = map (\n -> variable ++ "._" ++ show n) [0..]

289− (isChar, pattern) =

290− case value of

291− Right (Chr c) -> (True, string [c])

292− _ -> (,) False $ case value of

293− Right (Boolean b) -> BoolLit () b

294− Right lit -> literal lit

295− Left (Var.Canonical _ name) ->

296− string name

297−

298−flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

299−flattenLets defs lexpr@(A _ expr) =

300− case expr of

301− Let ds body -> flattenLets (defs ++ ds) body

302− _ -> (defs, lexpr)

303−

304−generate :: CanonicalModule -> String

305−generate modul =

306− show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

307− [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

308− where

309− names :: [String]

310− names = Module.names modul

311−

312− thisModule :: Expression ()

313− thisModule = obj ("_elm" : names ++ ["values"])

314−

315− programStmts :: [Statement ()]

316− programStmts =

317− concat

318− [ [ ExprStmt () (string "use strict") ]

319− , setup "_elm" (names ++ ["values"])

320− , [ IfSingleStmt () thisModule (ret thisModule) ]

321− , [ VarDeclStmt () localVars ]

322− , body

323− , [ jsExports ]

324− , [ ret thisModule ]

325− ]

326−

327− localVars :: [VarDecl ()]

328− localVars = varDecl "_op" (ObjectLit () []) :

329− internalImports (Module.getName modul) ++

330− explicitImports

331− where

332− explicitImports :: [VarDecl ()]

333− explicitImports =

334− map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

335−

336− jsImport :: String -> VarDecl ()

337− jsImport name =

338− varDecl (Var.moduleName name) $

339− obj ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"

340−

341− body :: [Statement ()]

342− body = concat $ evalState defs 0

343− where

344− defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)

345−

346− setup namespace path = map create paths

347− where

348− create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

349− paths = drop 2 . init . List.inits $ namespace : path

350−

351− jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

352− where

353− exs = map entry $ "_op" : concatMap extract (exports modul)

354− entry x = (prop x, ref x)

355− extract value =

356− case value of

357− Var.Alias _ -> []

358− Var.Value x | Help.isOp x -> []

359− | otherwise -> [Var.varName x]

360− Var.ADT _ (Var.Listing ctors _) -> map Var.varName ctors

361−

362− assign path expr =

363− case path of

364− [x] -> VarDeclStmt () [ varDecl x expr ]

365− _ -> ExprStmt () $

366− AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

367−

368−binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

369− -> State Int (Expression ())

370−binop region func@(Var.Canonical home op) e1 e2 =

371− case (home, op) of

372− (Var.Module "Basics", ">>") ->

373− do es <- mapM expression (collectLeftAssoc [e2] e1)

374− return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es

375−

376− (Var.Module "Basics", "<<") ->

377− do es <- mapM expression (e1 : collectRightAssoc [] e2)

378− return $ ["$"] ==> foldr (<|) (ref "$") es

379−

380− (Var.Module "Basics", "<|") ->

381− do e2' <- expression e2

382− es <- mapM expression (collectRightAssoc [] e1)

383− return $ foldr (<|) e2' es

384−

385− (Var.Module "List", "++") ->

386− do e1' <- expression e1

387− e2' <- expression e2

388− return $ _List "append" `call` [e1', e2']

389−

390− (Var.BuiltIn, "::") ->

391− expression (A region (Data "::" [e1,e2]))

392−

393− (Var.Module "Basics", _) ->

394− do e1' <- expression e1

395− e2' <- expression e2

396− return $ case Map.lookup op basicOps of

397− Just f -> f e1' e2'

398− Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]

399−

400− _ ->

401− do e1' <- expression e1

402− e2' <- expression e2

403− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

404−

405− where

406− collectRightAssoc es e =

407− case e of

408− A _ (Binop (Var.Canonical (Var.Module "Basics") "<<") e1 e2) ->

409− collectRightAssoc (es ++ [e1]) e2

410− _ -> es ++ [e]

411−

412− collectLeftAssoc es e =

413− case e of

414− A _ (Binop (Var.Canonical (Var.Module "Basics") ">>") e1 e2) ->

415− collectLeftAssoc (e2 : es) e1

416− _ -> e : es

417−

418− basicOps = Map.fromList (infixOps ++ specialOps)

419−

420− infixOps =

421− let infixOp str op = (str, InfixExpr () op) in

422− [ infixOp "+" OpAdd

423− , infixOp "-" OpSub

424− , infixOp "*" OpMul

425− , infixOp "/" OpDiv

426− , infixOp "&&" OpLAnd

427− , infixOp "||" OpLOr

428− ]

429−

430− specialOps =

431− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

432− , (,) "|>" $ flip (<|)

433− , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

434− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

435− , (,) "<" $ cmp OpLT 0

436− , (,) ">" $ cmp OpGT 0

437− , (,) "<=" $ cmp OpLT 1

438− , (,) ">=" $ cmp OpGT (-1)

439− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

440− ]

441−

442− cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/JavaScript/Helpers.hsdeleted−66

@@ -1,66 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Generate.JavaScript.Helpers where

3−

4−import AST.Annotation (Region)

5−import qualified AST.PrettyPrint as PP

6−import Language.ECMAScript3.Syntax

7−

8−-- Creating Variables

9−

10−var :: String -> Id ()

11−var name = Id () name

12−

13−ref :: String -> Expression ()

14−ref name = VarRef () (var name)

15−

16−prop :: String -> Prop ()

17−prop name = PropId () (var name)

18−

19−string = StringLit ()

20−

21−obj :: [String] -> Expression ()

22−obj vars =

23− case vars of

24− x:xs -> foldl (DotRef ()) (ref x) (map var xs)

25− [] -> error "dotSep must be called on a non-empty list of variables"

26−

27−-- Specific Utilities

28−

29−localModuleName :: String

30−localModuleName = "$moduleName"

31−

32−throw :: String -> Region -> Expression ()

33−throw kind region =

34− obj ["_E",kind] `call` [ ref localModuleName, string (PP.renderPretty region) ]

35−

36−-- Function Calls

37−

38−(<|) :: Expression () -> Expression () -> Expression ()

39−(<|) f x = CallExpr () f [x]

40−

41−ret :: Expression () -> Statement ()

42−ret e = ReturnStmt () (Just e)

43−

44−(==>) :: [String] -> Expression () -> Expression ()

45−(==>) args e = FuncExpr () Nothing (map var args) [ ret e ]

46−

47−function :: [String] -> [Statement ()] -> Expression ()

48−function args stmts = FuncExpr () Nothing (map var args) stmts

49−

50−call :: Expression () -> [Expression ()] -> Expression ()

51−call = CallExpr ()

52−

53−-- Checks

54−

55−equal :: Expression () -> Expression () -> Expression ()

56−equal a b = InfixExpr () OpStrictEq a b

57−

58−instanceof :: String -> Expression () -> Expression ()

59−instanceof tipe x =

60− InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

61−

62−typeof :: String -> Expression () -> Expression ()

63−typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

64−

65−member :: String -> Expression () -> Expression ()

66−member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hsdeleted−173

@@ -1,173 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Generate.JavaScript.Ports (incoming, outgoing) where

3−

4−import Generate.JavaScript.Helpers

5−import qualified Generate.JavaScript.Variable as V

6−import AST.Type as T

7−import qualified AST.Variable as Var

8−import Language.ECMAScript3.Syntax

9−

10−data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

11− deriving Show

12−

13−check :: Expression () -> JSType -> Expression () -> Expression ()

14−check x jsType continue =

15− CondExpr () (jsFold OpLOr checks x) continue throw

16− where

17− jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

18− throw = obj ["_E","raise"] <| InfixExpr () OpAdd msg x

19− msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

20− checks =

21− case jsType of

22− JSNumber -> [typeof "number"]

23− JSBoolean -> [typeof "boolean"]

24− JSString -> [typeof "string", instanceof "String"]

25− JSArray -> [(obj ["_U","isJSArray"] <|)]

26− JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

27−

28−incoming :: CanonicalType -> Expression ()

29−incoming tipe =

30− case tipe of

31− Aliased _ t -> incoming t

32−

33− App (Type v) [t]

34− | Var.isSignal v -> V.value "Native.Ports" "incomingSignal" <| incoming t

35−

36− _ -> ["v"] ==> inc tipe (ref "v")

37−

38−inc :: CanonicalType -> Expression () -> Expression ()

39−inc tipe x =

40− case tipe of

41− Lambda _ _ -> error "functions should not be allowed through input ports"

42− Var _ -> error "type variables should not be allowed through input ports"

43− Aliased _ t ->

44− inc t x

45−

46− Type (Var.Canonical Var.BuiltIn name)

47− | name == "Int" -> from JSNumber

48− | name == "Float" -> from JSNumber

49− | name == "Bool" -> from JSBoolean

50− | name == "String" -> from JSString

51− where

52− from checks = check x checks x

53−

54− Type name

55− | Var.isJson name -> V.value "Native.Json" "fromJS" <| x

56− | Var.isTuple name -> incomingTuple [] x

57− | otherwise -> error "bad type got to incoming port generation code"

58−

59− App f args ->

60− case f : args of

61− Type name : [t]

62− | Var.isMaybe name ->

63− CondExpr ()

64− (equal x (NullLit ()))

65− (V.value "Maybe" "Nothing")

66− (V.value "Maybe" "Just" <| inc t x)

67−

68− | Var.isList name ->

69− check x JSArray (obj ["_L","fromArray"] <| array)

70−

71− | Var.isArray name ->

72− check x JSArray (obj ["_A","fromJSArray"] <| array)

73− where

74− array = DotRef () x (var "map") <| incoming t

75−

76− Type name : ts

77− | Var.isTuple name -> incomingTuple ts x

78−

79− _ -> error "bad ADT got to incoming port generation code"

80−

81− Record _ (Just _) ->

82− error "bad record got to incoming port generation code"

83−

84− Record fields Nothing ->

85− check x (JSObject (map fst fields)) object

86− where

87− object = ObjectLit () $ (prop "_", ObjectLit () []) : keys

88− keys = map convert fields

89− convert (f,t) = (prop f, inc t (DotRef () x (var f)))

90−

91−incomingTuple :: [CanonicalType] -> Expression () -> Expression ()

92−incomingTuple types x =

93− check x JSArray (ObjectLit () fields)

94− where

95− fields = (prop "ctor", ctor) : zipWith convert [0..] types

96−

97− ctor = string ("_Tuple" ++ show (length types))

98−

99− convert n t =

100− ( prop ('_':show n)

101− , inc t (BracketRef () x (IntLit () n))

102− )

103−

104−outgoing :: CanonicalType -> Expression ()

105−outgoing tipe =

106− case tipe of

107− Aliased _ t -> outgoing t

108−

109− App (Type v) [t]

110− | Var.isSignal v -> V.value "Native.Ports" "outgoingSignal" <| outgoing t

111−

112− _ -> ["v"] ==> out tipe (ref "v")

113−

114−out :: CanonicalType -> Expression () -> Expression ()

115−out tipe x =

116− case tipe of

117− Aliased _ t -> out t x

118−

119− Lambda _ _

120− | numArgs > 1 && numArgs < 10 ->

121− func (ref ('A':show numArgs) `call` (x:values))

122− | otherwise -> func (foldl (<|) x values)

123− where

124− ts = T.collectLambdas tipe

125− numArgs = length ts - 1

126− args = map (\n -> '_' : show n) [0..]

127− values = zipWith inc (init ts) (map ref args)

128− func body =

129− function (take numArgs args)

130− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

131− , ret (out (last ts) (ref "_r"))

132− ]

133−

134− Var _ -> error "type variables should not be allowed through input ports"

135−

136− Type (Var.Canonical Var.BuiltIn name)

137− | name `elem` ["Int","Float","Bool","String"] -> x

138−

139− Type name

140− | Var.isJson name -> V.value "Native.Json" "toJS" <| x

141− | Var.isTuple name -> ArrayLit () []

142− | otherwise -> error "bad type got to outgoing port generation code"

143−

144− App f args ->

145− case f : args of

146− Type name : [t]

147− | Var.isMaybe name ->

148− CondExpr ()

149− (equal (DotRef () x (var "ctor")) (string "Nothing"))

150− (NullLit ())

151− (out t (DotRef () x (var "_0")))

152−

153− | Var.isArray name ->

154− DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t

155−

156− | Var.isList name ->

157− DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t

158−

159− Type name : ts

160− | Var.isTuple name ->

161− let convert n t = out t $ DotRef () x $ var ('_':show n)

162− in ArrayLit () $ zipWith convert [0..] ts

163−

164− _ -> error "bad ADT got to outgoing port generation code"

165−

166− Record _ (Just _) ->

167− error "bad record got to outgoing port generation code"

168−

169− Record fields Nothing ->

170− ObjectLit () keys

171− where

172− keys = map convert fields

173− convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))

compiler/Generate/JavaScript/Variable.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Generate.JavaScript.Variable where

3−

4−import qualified AST.Helpers as Help

5−import qualified AST.Variable as Var

6−import qualified Data.Set as Set

7−import qualified Generate.JavaScript.Helpers as JS

8−import qualified Language.ECMAScript3.Syntax as JS

9−

10−swap :: Char -> Char -> Char -> Char

11−swap from to c = if c == from then to else c

12−

13−canonical :: Var.Canonical -> JS.Expression ()

14−canonical (Var.Canonical home name) =

15− case Help.isOp name of

16− True -> JS.BracketRef () (JS.obj (home' ++ ["_op"])) (JS.string name)

17− False -> JS.obj (home' ++ [ varName name ])

18− where

19− home' =

20− case home of

21− Var.Local -> []

22− Var.BuiltIn -> []

23− Var.Module path -> [ moduleName path ]

24−

25−moduleName :: String -> String

26−moduleName x = '$' : map (swap '.' '$') x

27−

28−varName :: String -> String

29−varName x = map (swap '\'' '$') x'

30− where

31− x' = if Set.member x jsReserveds then '$' : x else x

32−

33−value :: String -> String -> JS.Expression ()

34−value home name =

35− canonical (Var.Canonical (Var.Module home) name)

36−

37−jsReserveds :: Set.Set String

38−jsReserveds = Set.fromList

39− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

40− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

41− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

42− , "transient", "synchronized", "function", "break", "case", "catch"

43− , "continue", "debugger", "default", "delete", "do", "else", "finally"

44− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

45− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

46− , "const", "enum", "export", "extends", "import", "super", "implements"

47− , "interface", "let", "package", "private", "protected", "public"

48− , "static", "yield"

49− -- reserved by the Elm runtime system

50− , "Elm", "ElmRuntime"

51− , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

52− , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

53− ]

compiler/Generate/Markdown.hsdeleted−42

@@ -1,42 +0,0 @@

1−module Generate.Markdown where

2−

3−import qualified Cheapskate as CS

4−import qualified Cheapskate.Html as CS

5−import qualified Data.Set as Set

6−import qualified Data.Text as Text

7−import qualified Text.Blaze.Html.Renderer.String as Blaze

8−import qualified Text.Highlighting.Kate as Kate

9−

10−import Debug.Trace

11−

12−(|>) :: a -> (a -> b) -> b

13−x |> f = f x

14−

15−toHtml :: String -> String

16−toHtml rawMarkdown =

17− Text.pack rawMarkdown

18− |> CS.markdown options

19− |> CS.walk highlightCode

20− |> CS.renderDoc

21− |> Blaze.renderHtml

22−

23−options :: CS.Options

24−options =

25− CS.Options

26− { CS.sanitize = False

27− , CS.allowRawHtml = True

28− , CS.preserveHardBreaks = False

29− , CS.debug = False

30− }

31−

32−highlightCode :: CS.Block -> CS.Block

33−highlightCode block =

34− case block of

35− CS.CodeBlock (CS.CodeAttr lang _info) src ->

36− Kate.highlightAs (Text.unpack lang) (Text.unpack src)

37− |> Kate.formatHtmlBlock Kate.defaultFormatOpts

38− |> Blaze.renderHtml

39− |> Text.pack

40− |> CS.HtmlBlock

41−

42− _ -> block

compiler/Metadata/Prelude.hsdeleted−126

@@ -1,126 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Metadata.Prelude (interfaces, add) where

3−

4−import qualified Data.Map as Map

5−import qualified Data.Set as Set

6−import qualified Control.Exception as E

7−import System.Exit

8−import System.IO

9−import AST.Module as Module

10−import qualified AST.Variable as Var

11−import qualified Build.Interface as Interface

12−import Build.Utils (getDataFile)

13−

14−

15−-- DEFINITION OF THE PRELUDE

16−

17−type ImportDict =

18− Map.Map String ([String], Var.Listing Var.Value)

19−

20−prelude :: ImportDict

21−prelude = Map.unions [ string, text, maybe, openImports ]

22− where

23− importing :: String -> [Var.Value] -> ImportDict

24− importing name values =

25− Map.singleton name ([], Var.Listing values False)

26−

27− openImports :: ImportDict

28− openImports =

29− Map.fromList $ map (\name -> (name, ([], Var.openListing))) $

30− [ "Basics", "Signal", "List", "Time", "Color"

31− , "Graphics.Element", "Graphics.Collage"

32− , "Native.Ports", "Native.Json"

33− ]

34−

35− maybe :: ImportDict

36− maybe = importing "Maybe" [ Var.ADT "Maybe" Var.openListing ]

37−

38− string :: ImportDict

39− string = importing "String" [Var.Value "show"]

40−

41− text :: ImportDict

42− text = importing "Text" (Var.ADT "Text" (Var.Listing [] False) : values)

43− where

44− values =

45− map Var.Value

46− [ "toText", "leftAligned", "rightAligned", "centered", "justified"

47− , "plainText", "asText", "typeface", "monospace", "bold", "italic"

48− ]

49−

50−

51−-- ADDING PRELUDE TO A MODULE

52−

53−add :: Bool -> Module exs body -> Module exs body

54−add noPrelude (Module moduleName path exports imports decls) =

55− Module moduleName path exports ammendedImports decls

56− where

57− ammendedImports =

58− importDictToList $

59− foldr addImport (if noPrelude then Map.empty else prelude) imports

60−

61−importDictToList :: ImportDict -> [(String, ImportMethod)]

62−importDictToList dict =

63− concatMap toImports (Map.toList dict)

64− where

65− toImports (name, (qualifiers, listing@(Var.Listing explicits open))) =

66− map (\qualifier -> (name, As qualifier)) qualifiers

67− ++

68− if open || not (null explicits)

69− then [(name, Open listing)]

70− else []

71−

72−addImport :: (String, ImportMethod) -> ImportDict -> ImportDict

73−addImport (name, method) importDict =

74− Map.alter mergeMethods name importDict

75− where

76− mergeMethods :: Maybe ([String], Var.Listing Var.Value)

77− -> Maybe ([String], Var.Listing Var.Value)

78− mergeMethods entry =

79− let (qualifiers, listing) =

80− case entry of

81− Nothing -> ([], Var.Listing [] False)

82− Just v -> v

83− in

84− case method of

85− As qualifier -> Just (qualifier : qualifiers, listing)

86− Open newListing ->

87− Just (qualifiers, mergeListings newListing listing)

88−

89− mergeListings (Var.Listing explicits1 open1) (Var.Listing explicits2 open2) =

90− Var.Listing

91− (Set.toList (Set.fromList (explicits1 ++ explicits2)))

92− (open1 || open2)

93−

94−

95−-- EXTRACT INTERFACES FROM STATIC FILE

96−

97−interfaces :: Bool -> IO Interfaces

98−interfaces noPrelude =

99− if noPrelude

100− then return Map.empty

101− else safeReadDocs =<< getDataFile "interfaces.data"

102−

103−safeReadDocs :: FilePath -> IO Interfaces

104−safeReadDocs name =

105− E.catch (readDocs name) $ \err -> do

106− let _ = err :: IOError

107− hPutStrLn stderr $ unlines $

108− [ "Error reading types for standard library from file " ++ name

109− , " If you are using a stable version of Elm, please report an issue at"

110− , " <http://github.com/elm-lang/Elm/issues> specifying version numbers for"

111− , " Elm and your OS." ]

112− exitFailure

113−

114−readDocs :: FilePath -> IO Interfaces

115−readDocs filePath = do

116− interfaces <- Interface.load filePath

117− case mapM (Interface.isValid filePath) (interfaces :: [(String, Module.Interface)]) of

118− Left err -> do

119− hPutStrLn stderr err

120− exitFailure

121−

122− Right [] -> do

123− hPutStrLn stderr "No interfaces found in serialized Prelude!"

124− exitFailure

125−

126− Right ifaces -> return $ Map.fromList ifaces

compiler/Parse/Binop.hsdeleted−86

@@ -1,86 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Parse.Binop (binops, OpTable) where

3−

4−import Control.Applicative ((<$>))

5−import qualified Data.List as List

6−import qualified Data.Map as Map

7−

8−import AST.Annotation (merge)

9−import AST.Declaration (Assoc(..))

10−import AST.Expression.General (Expr'(Binop))

11−import qualified AST.Expression.Source as Source

12−import qualified AST.Variable as Var

13−import Text.Parsec

14−import Parse.Helpers

15−

16−opLevel :: OpTable -> String -> Int

17−opLevel table op = fst $ Map.findWithDefault (9,L) op table

18−

19−opAssoc :: OpTable -> String -> Assoc

20−opAssoc table op = snd $ Map.findWithDefault (9,L) op table

21−

22−hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

23−hasLevel table n (op,_) = opLevel table op == n

24−

25−binops :: IParser Source.Expr

26− -> IParser Source.Expr

27− -> IParser String

28− -> IParser Source.Expr

29−binops term last anyOp =

30− do e <- term

31− table <- getState

32− split table 0 e =<< nextOps

33− where

34− nextOps = choice [ commitIf (whitespace >> anyOp) $ do

35− whitespace ; op <- anyOp ; whitespace

36− expr <- Left <$> try term <|> Right <$> last

37− case expr of

38− Left t -> (:) (op,t) <$> nextOps

39− Right e -> return [(op,e)]

40− , return [] ]

41−

42−split :: OpTable

43− -> Int

44− -> Source.Expr

45− -> [(String, Source.Expr)]

46− -> IParser Source.Expr

47−split _ _ e [] = return e

48−split table n e eops = do

49− assoc <- getAssoc table n eops

50− es <- sequence (splitLevel table n e eops)

51− let ops = map fst (filter (hasLevel table n) eops)

52− case assoc of R -> joinR es ops

53− _ -> joinL es ops

54−

55−splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]

56− -> [IParser Source.Expr]

57−splitLevel table n e eops =

58− case break (hasLevel table n) eops of

59− (lops, (_op,e'):rops) ->

60− split table (n+1) e lops : splitLevel table n e' rops

61− (lops, []) -> [ split table (n+1) e lops ]

62−

63−joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

64−joinL [e] [] = return e

65−joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops

66−joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

67−

68−joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

69−joinR [e] [] = return e

70−joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

71− return (merge a e (Binop (Var.Raw op) a e))

72−joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

73−

74−getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

75−getAssoc table n eops

76− | all (==L) assocs = return L

77− | all (==R) assocs = return R

78− | all (==N) assocs = case assocs of [_] -> return N

79− _ -> failure (msg "precedence")

80− | otherwise = failure (msg "associativity")

81− where levelOps = filter (hasLevel table n) eops

82− assocs = map (opAssoc table . fst) levelOps

83− msg problem =

84− concat [ "Conflicting " ++ problem ++ " for binary operators ("

85− , List.intercalate ", " (map fst eops), "). "

86− , "Consider adding parentheses to disambiguate." ]

compiler/Parse/Declaration.hsdeleted−58

@@ -1,58 +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 AST.Declaration as D

11−

12−declaration :: IParser D.SourceDecl

13−declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

14−

15−definition :: IParser D.SourceDecl

16−definition = D.Definition <$> Expr.def

17−

18−alias :: IParser D.SourceDecl

19−alias = do

20− reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

21− forcedWS

22− name <- capVar

23− args <- spacePrefix lowVar

24− padded equals

25− tipe <- Type.expr

26− return (D.TypeAlias name args tipe)

27−

28−datatype :: IParser D.SourceDecl

29−datatype = do

30− reserved "data" <?> "datatype definition (data T = A | B | ...)"

31− forcedWS

32− name <- capVar <?> "name of data-type"

33− args <- spacePrefix lowVar

34− padded equals

35− tcs <- pipeSep1 Type.constructor

36− return $ D.Datatype name args tcs

37−

38−

39−infixDecl :: IParser D.SourceDecl

40−infixDecl = do

41− assoc <- choice [ reserved "infixl" >> return D.L

42− , reserved "infix" >> return D.N

43− , reserved "infixr" >> return D.R ]

44− forcedWS

45− n <- digit

46− forcedWS

47− D.Fixity assoc (read [n]) <$> anyOp

48−

49−

50−port :: IParser D.SourceDecl

51−port =

52− do try (reserved "port")

53− whitespace

54− name <- lowVar

55− whitespace

56− let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }

57− D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr

58− , port' equals D.PPDef Expr.expr ]

compiler/Parse/Expression.hsdeleted−248

@@ -1,248 +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.Binop

9−import Parse.Helpers as Help

10−import Parse.Literal

11−import qualified Parse.Pattern as Pattern

12−import qualified Parse.Type as Type

13−

14−import AST.Annotation as Annotation

15−import AST.Expression.General

16−import qualified AST.Expression.Source as Source

17−import qualified AST.Literal as L

18−import qualified AST.Pattern as P

19−import qualified AST.Variable as Var

20−

21−

22−-------- Basic Terms --------

23−

24−varTerm :: IParser Source.Expr'

25−varTerm = toVar <$> var <?> "variable"

26−

27−toVar :: String -> Source.Expr'

28−toVar v = case v of "True" -> Literal (L.Boolean True)

29− "False" -> Literal (L.Boolean False)

30− _ -> rawVar v

31−

32−accessor :: IParser Source.Expr'

33−accessor = do

34− (start, lbl, end) <- located (try (string "." >> rLabel))

35− let loc e = Annotation.at start end e

36− return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

37−

38−negative :: IParser Source.Expr'

39−negative = do

40− (start, nTerm, end) <-

41− located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

42− let loc e = Annotation.at start end e

43− return (Binop (Var.Raw "-") (loc $ Literal (L.IntNum 0)) nTerm)

44−

45−

46−-------- Complex Terms --------

47−

48−listTerm :: IParser Source.Expr'

49−listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

50− where

51− range = do

52− lo <- expr

53− padded (string "..")

54− Range lo <$> expr

55−

56− markdown' = do

57− pos <- getPosition

58− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

59− (rawText, exprs) <- Help.markdown (interpolation uid)

60− return (Markdown uid (filter (/='\r') rawText) exprs)

61−

62− shader' = do

63− pos <- getPosition

64− let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

65− (rawSrc, tipe) <- Help.shader

66− return $ GLShader uid (filter (/='\r') rawSrc) tipe

67−

68− span uid index =

69− "<span id=\"md-" ++ uid ++ "-" ++ show index ++

70− "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"

71−

72− interpolation uid exprs = do

73− try (string "{{")

74− e <- padded expr

75− string "}}"

76− return (span uid (length exprs), exprs ++ [e])

77−

78−parensTerm :: IParser Source.Expr

79−parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

80− where

81− opFn = do

82− (start, op, end) <- located anyOp

83− let loc = Annotation.at start end

84− return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $

85− Binop (Var.Raw op) (loc (rawVar "x")) (loc (rawVar "y"))

86−

87− tupleFn = do

88− let comma = char ',' <?> "comma ','"

89− (start, commas, end) <- located (comma >> many (whitespace >> comma))

90− let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

91− loc = Annotation.at start end

92− return $ foldr (\x e -> loc $ Lambda x e)

93− (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)

94−

95− parened = do

96− (start, es, end) <- located (commaSep expr)

97− return $ case es of

98− [e] -> e

99− _ -> Annotation.at start end (tuple es)

100−

101−recordTerm :: IParser Source.Expr

102−recordTerm = brackets $ choice [ misc, addLocation record ]

103− where

104− field = do

105− label <- rLabel

106− patterns <- spacePrefix Pattern.term

107− padded equals

108− body <- expr

109− return (label, makeFunction patterns body)

110−

111− record = Record <$> commaSep field

112−

113− change = do

114− lbl <- rLabel

115− padded (string "<-")

116− (,) lbl <$> expr

117−

118− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)

119−

120− insert r = addLocation $ do

121− string "|" >> whitespace

122− Insert r <$> rLabel <*> (padded equals >> expr)

123−

124− modify r =

125− addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)

126−

127− misc = try $ do

128− record <- addLocation (rawVar <$> rLabel)

129− opt <- padded (optionMaybe (remove record))

130− case opt of

131− Just e -> try (insert e) <|> return e

132− Nothing -> try (insert record) <|> try (modify record)

133−

134−

135−term :: IParser Source.Expr

136−term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

137− <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

138− <?> "basic term (4, x, 'c', etc.)"

139−

140−-------- Applications --------

141−

142−appExpr :: IParser Source.Expr

143−appExpr = do

144− t <- term

145− ts <- constrainedSpacePrefix term $ \str ->

146− if null str then notFollowedBy (char '-') else return ()

147− return $ case ts of

148− [] -> t

149− _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts

150−

151−-------- Normal Expressions --------

152−

153−binaryExpr :: IParser Source.Expr

154−binaryExpr = binops appExpr lastExpr anyOp

155− where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

156− <|> lambdaExpr

157−

158−ifExpr :: IParser Source.Expr'

159−ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

160− where

161− normal = do

162− bool <- expr

163− padded (reserved "then")

164− thenBranch <- expr

165− whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace

166− elseBranch <- expr

167− return $ MultiIf [(bool, thenBranch),

168− (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]

169− multiIf = MultiIf <$> spaceSep1 iff

170− where iff = do string "|" ; whitespace

171− b <- expr ; padded arrow

172− (,) b <$> expr

173−

174−lambdaExpr :: IParser Source.Expr

175−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

176− whitespace

177− args <- spaceSep1 Pattern.term

178− padded arrow

179− body <- expr

180− return (makeFunction args body)

181−

182−defSet :: IParser [Source.Def]

183−defSet = block (do d <- def ; whitespace ; return d)

184−

185−letExpr :: IParser Source.Expr'

186−letExpr = do

187− reserved "let" ; whitespace

188− defs <- defSet

189− padded (reserved "in")

190− Let defs <$> expr

191−

192−caseExpr :: IParser Source.Expr'

193−caseExpr = do

194− reserved "case"; e <- padded expr; reserved "of"; whitespace

195− Case e <$> (with <|> without)

196− where case_ = do p <- Pattern.expr

197− padded arrow

198− (,) p <$> expr

199− with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

200− without = block (do c <- case_ ; whitespace ; return c)

201−

202−expr :: IParser Source.Expr

203−expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

204− <|> lambdaExpr

205− <|> binaryExpr

206− <?> "an expression"

207−

208−defStart :: IParser [P.RawPattern]

209−defStart =

210− choice [ do p1 <- try Pattern.term

211− infics p1 <|> func p1

212− , func =<< (P.Var <$> parens symOp)

213− , (:[]) <$> Pattern.expr

214− ] <?> "the definition of a variable (x = ...)"

215− where

216− func pattern =

217− case pattern of

218− P.Var _ -> (pattern:) <$> spacePrefix Pattern.term

219− _ -> do try (lookAhead (whitespace >> string "="))

220− return [pattern]

221−

222− infics p1 = do

223− o:p <- try (whitespace >> anyOp)

224− p2 <- (whitespace >> Pattern.term)

225− return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

226− else [ P.Var (o:p), p1, p2 ]

227−

228−makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

229−makeFunction args body@(A ann _) =

230− foldr (\arg body' -> A ann $ Lambda arg body') body args

231−

232−definition :: IParser Source.Def

233−definition = withPos $ do

234− (name:args) <- defStart

235− padded equals

236− body <- expr

237− return . Source.Definition name $ makeFunction args body

238−

239−typeAnnotation :: IParser Source.Def

240−typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr

241− where

242− start = do

243− v <- lowVar <|> parens symOp

244− padded hasType

245− return v

246−

247−def :: IParser Source.Def

248−def = typeAnnotation <|> definition

compiler/Parse/Helpers.hsdeleted−422

@@ -1,422 +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.Map as Map

10−import qualified Language.GLSL.Parser as GLP

11−import Language.GLSL.Syntax as GLS

12−import Text.Parsec hiding (newline,spaces,State)

13−import Text.Parsec.Indent

14−import qualified Text.Parsec.Token as T

15−

16−import AST.Annotation as Annotation

17−import AST.Declaration (Assoc)

18−import AST.Expression.General

19−import qualified AST.Expression.Source as Source

20−import AST.Helpers as Help

21−import AST.Literal as Literal

22−import AST.PrettyPrint

23−import qualified AST.Variable as Variable

24−

25−reserveds = [ "if", "then", "else"

26− , "case", "of"

27− , "let", "in"

28− , "data", "type"

29− , "module", "where"

30− , "import", "as", "hiding", "open"

31− , "export", "foreign"

32− , "deriving", "port"

33− ]

34−

35−expecting = flip (<?>)

36−

37−type OpTable = Map.Map String (Int, Assoc)

38−type SourceM = State SourcePos

39−type IParser a = ParsecT String OpTable SourceM a

40−

41−iParse :: IParser a -> String -> Either ParseError a

42−iParse = iParseWithTable "" Map.empty

43−

44−iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a

45−iParseWithTable sourceName table aParser input =

46− runIndent sourceName $ runParserT aParser table sourceName input

47−

48−var :: IParser String

49−var = makeVar (letter <|> char '_' <?> "variable")

50−

51−lowVar :: IParser String

52−lowVar = makeVar (lower <?> "lower case variable")

53−capVar :: IParser String

54−capVar = makeVar (upper <?> "upper case variable")

55−

56−qualifiedVar :: IParser String

57−qualifiedVar = do

58− vars <- many ((++) <$> capVar <*> string ".")

59− (++) (concat vars) <$> lowVar

60−

61−rLabel :: IParser String

62−rLabel = lowVar

63−

64−innerVarChar :: IParser Char

65−innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""

66−

67−makeVar :: IParser Char -> IParser String

68−makeVar p = do

69− v <- (:) <$> p <*> many innerVarChar

70− if v `elem` reserveds

71− then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords"

72− else return v

73−

74−reserved :: String -> IParser String

75−reserved word =

76− try (string word >> notFollowedBy innerVarChar) >> return word

77− <?> "reserved word '" ++ word ++ "'"

78−

79−anyOp :: IParser String

80−anyOp = betwixt '`' '`' qualifiedVar <|> symOp <?> "infix operator (e.g. +, *, ||)"

81−

82−symOp :: IParser String

83−symOp = do op <- many1 (satisfy Help.isSymbol)

84− guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])

85− case op of

86− "." -> notFollowedBy lower >> return op

87− "\8728" -> return "."

88− _ -> return op

89−

90−padded :: IParser a -> IParser a

91−padded p = do whitespace

92− out <- p

93− whitespace

94− return out

95−

96−equals :: IParser String

97−equals = string "="

98−

99−arrow :: IParser String

100−arrow = string "->" <|> string "\8594" <?> "arrow (->)"

101−

102−hasType :: IParser String

103−hasType = string ":" <?> "':' (a type annotation)'"

104−

105−

106−commitIf check p = commit <|> try p

107− where commit = do (try $ lookAhead check) >> p

108−

109−spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

110−spaceySepBy1 sep p = do

111− a <- p

112− (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p))

113−

114−

115−commaSep1 :: IParser a -> IParser [a]

116−commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")

117−

118−commaSep :: IParser a -> IParser [a]

119−commaSep = option [] . commaSep1

120−

121−semiSep1 :: IParser a -> IParser [a]

122−semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")

123−

124−pipeSep1 :: IParser a -> IParser [a]

125−pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")

126−

127−consSep1 :: IParser a -> IParser [a]

128−consSep1 = spaceySepBy1 (string "::" <?> "cons operator '::'")

129−

130−dotSep1 :: IParser a -> IParser [a]

131−dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)

132−

133−spaceSep1 :: IParser a -> IParser [a]

134−spaceSep1 p = (:) <$> p <*> spacePrefix p

135−

136−spacePrefix p = constrainedSpacePrefix p (\_ -> return ())

137−

138−constrainedSpacePrefix p constraint =

139− many $ choice [ try (spacing >> lookAhead (oneOf "[({")) >> p

140− , try (spacing >> p)

141− ]

142− where

143− spacing = do

144− n <- whitespace

145− constraint n

146− indented

147−

148−failure msg = do

149− inp <- getInput

150− setInput ('x':inp)

151− anyToken

152− fail msg

153−

154−followedBy a b = do x <- a ; b ; return x

155−

156−betwixt a b c = do char a ; out <- c

157− char b <?> "closing '" ++ [b] ++ "'" ; return out

158−

159−surround a z name p = do

160− char a

161− v <- padded p

162− char z <?> unwords ["closing", name, show z]

163− return v

164−

165−braces :: IParser a -> IParser a

166−braces = surround '[' ']' "brace"

167−

168−parens :: IParser a -> IParser a

169−parens = surround '(' ')' "paren"

170−

171−brackets :: IParser a -> IParser a

172−brackets = surround '{' '}' "bracket"

173−

174−addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)

175−addLocation expr = do

176− (start, e, end) <- located expr

177− return (Annotation.at start end e)

178−

179−located :: IParser a -> IParser (SourcePos, a, SourcePos)

180−located p = do

181− start <- getPosition

182− e <- p

183− end <- getPosition

184− return (start, e, end)

185−

186−accessible :: IParser Source.Expr -> IParser Source.Expr

187−accessible expr = do

188− start <- getPosition

189− ce@(A _ e) <- expr

190− let rest f = do

191− let dot = char '.' >> notFollowedBy (char '.')

192− access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

193− case access of

194− Nothing -> return ce

195− Just _ -> accessible $ do

196− v <- var <?> "field access (e.g. List.map)"

197− end <- getPosition

198− return (Annotation.at start end (f v))

199− case e of

200− Var (Variable.Raw (c:cs))

201− | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))

202− | otherwise -> rest (Access ce)

203− _ -> rest (Access ce)

204−

205−

206−spaces :: IParser String

207−spaces = concat <$> many1 (multiComment <|> string " ") <?> "spaces"

208−

209−forcedWS :: IParser String

210−forcedWS = choice [ try $ (++) <$> spaces <*> (concat <$> many nl_space)

211− , try $ concat <$> many1 nl_space ]

212− where nl_space = try ((++) <$> (concat <$> many1 newline) <*> spaces)

213−

214−-- Just eats whitespace until the next meaningful character.

215−dumbWhitespace :: IParser String

216−dumbWhitespace = concat <$> many (spaces <|> newline)

217−

218−whitespace :: IParser String

219−whitespace = option "" forcedWS <?> "whitespace"

220−

221−freshLine :: IParser [[String]]

222−freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""

223− where space_nl = try $ spaces >> many1 newline

224−

225−newline :: IParser String

226−newline = simpleNewline <|> lineComment <?> "newline"

227−

228−simpleNewline :: IParser String

229−simpleNewline = try (string "\r\n") <|> string "\n"

230−

231−lineComment :: IParser String

232−lineComment = do

233− try (string "--")

234− comment <- anyUntil $ simpleNewline <|> (eof >> return "\n")

235− return ("--" ++ comment)

236−

237−multiComment :: IParser String

238−multiComment = (++) <$> try (string "{-") <*> closeComment

239−

240−closeComment :: IParser String

241−closeComment =

242− anyUntil . choice $

243− [ try (string "-}") <?> "close comment"

244− , concat <$> sequence [ try (string "{-"), closeComment, closeComment ]

245− ]

246−

247−until :: IParser a -> IParser b -> IParser b

248−until p end = go

249− where

250− go = end <|> (p >> go)

251−

252−anyUntil :: IParser String -> IParser String

253−anyUntil end = go

254− where

255− go = end <|> (:) <$> anyChar <*> go

256−

257−ignoreUntil :: IParser a -> IParser (Maybe a)

258−ignoreUntil end = go

259− where

260− ignore p = const () <$> p

261− filler = choice [ try (ignore chr) <|> ignore str

262− , ignore multiComment

263− , ignore (markdown (\_ -> mzero))

264− , ignore anyChar

265− ]

266− go = choice [ Just <$> end

267− , filler `until` choice [ const Nothing <$> eof, newline >> go ]

268− ]

269−

270−onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b

271−onFreshLines insert init thing = go init

272− where

273− go values = do

274− optionValue <- ignoreUntil thing

275− case optionValue of

276− Nothing -> return values

277− Just v -> go (insert v values)

278−

279−withSource :: IParser a -> IParser (String, a)

280−withSource p = do

281− start <- getParserState

282− result <- p

283− endPos <- getPosition

284− setParserState start

285− raw <- anyUntilPos endPos

286− return (raw, result)

287−

288−anyUntilPos :: SourcePos -> IParser String

289−anyUntilPos pos = go

290− where

291− go = do currentPos <- getPosition

292− case currentPos == pos of

293− True -> return []

294− False -> (:) <$> anyChar <*> go

295−

296−markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])

297−markdown interpolation =

298− do try (string "[markdown|")

299− closeMarkdown id []

300− where

301− closeMarkdown markdownBuilder stuff =

302− choice [ do try (string "|]")

303− return (markdownBuilder "", stuff)

304− , do (markdown,stuff') <- interpolation stuff

305− closeMarkdown (markdownBuilder . (markdown++)) stuff'

306− , do c <- anyChar

307− closeMarkdown (markdownBuilder . (c:)) stuff

308− ]

309−

310−shader :: IParser (String, Literal.GLShaderTipe)

311−shader =

312− do try (string "[glsl|")

313− rawSrc <- closeShader id

314− case glSource rawSrc of

315− Left err -> parserFail . show $ err

316− Right tipe -> return (rawSrc, tipe)

317− where

318− closeShader builder = choice

319− [ do try (string "|]")

320− return (builder "")

321− , do c <- anyChar

322− closeShader (builder . (c:))

323− ]

324−

325−glSource :: String -> Either ParseError Literal.GLShaderTipe

326−glSource src =

327− case GLP.parse src of

328− Right (TranslationUnit decls) ->

329− Right . foldr addGLinput emptyDecls . join . map extractGLinputs $ decls

330− Left e -> Left e

331− where

332− emptyDecls = Literal.GLShaderTipe Map.empty Map.empty Map.empty

333− addGLinput (qual,tipe,name) glDecls = case qual of

334− Attribute -> glDecls { attribute = Map.insert name tipe $ attribute glDecls }

335− Uniform -> glDecls { uniform = Map.insert name tipe $ uniform glDecls }

336− Varying -> glDecls { varying = Map.insert name tipe $ varying glDecls }

337− _ -> error "Should never happen due to below filter"

338− extractGLinputs decl = case decl of

339− Declaration (InitDeclaration (TypeDeclarator (FullType (Just (TypeQualSto qual)) (TypeSpec _prec (TypeSpecNoPrecision tipe _mexpr1)))) [InitDecl name _mexpr2 _mexpr3]) ->

340− if elem qual [Attribute, Varying, Uniform]

341− then case tipe of

342− GLS.Int -> return (qual,Literal.Int,name)

343− GLS.Float -> return (qual,Literal.Float,name)

344− GLS.Vec2 -> return (qual,V2,name)

345− GLS.Vec3 -> return (qual,V3,name)

346− GLS.Vec4 -> return (qual,V4,name)

347− GLS.Mat4 -> return (qual,M4,name)

348− GLS.Sampler2D -> return (qual,Texture,name)

349− _ -> []

350− else []

351− _ -> []

352−

353−--str :: IParser String

354−str = expecting "String" $ do

355− s <- choice [ multiStr, singleStr ]

356− processAs T.stringLiteral . sandwich '\"' $ concat s

357− where

358− rawString quote insides =

359− quote >> manyTill insides quote

360−

361− multiStr = rawString (try (string "\"\"\"")) multilineStringChar

362− singleStr = rawString (char '"') stringChar

363−

364− stringChar :: IParser String

365− stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]

366−

367− multilineStringChar :: IParser String

368− multilineStringChar =

369− do noEnd

370− choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]

371− where

372− noEnd = notFollowedBy (string "\"\"\"")

373− expandQuote c = if c == '\"' then "\\\"" else [c]

374−

375− newlineChar :: IParser String

376− newlineChar =

377− choice [ char '\n' >> return "\\n"

378− , char '\r' >> return "\\r" ]

379−

380−sandwich :: Char -> String -> String

381−sandwich delim s = delim : s ++ [delim]

382−

383−escaped :: Char -> IParser String

384−escaped delim = try $ do

385− char '\\'

386− c <- char '\\' <|> char delim

387− return ['\\', c]

388−

389−chr :: IParser Char

390−chr = betwixt '\'' '\'' character <?> "character"

391− where

392− nonQuote = satisfy (/='\'')

393− character = do

394− c <- choice [ escaped '\''

395− , (:) <$> char '\\' <*> many1 nonQuote

396− , (:[]) <$> nonQuote ]

397− processAs T.charLiteral $ sandwich '\'' c

398−

399−processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a

400−processAs processor s = calloutParser s (processor lexer)

401− where

402− calloutParser :: String -> IParser a -> IParser a

403− calloutParser inp p = either (fail . show) return (iParse p inp)

404−

405− lexer :: T.GenTokenParser String u SourceM

406− lexer = T.makeTokenParser elmDef

407−

408− -- I don't know how many of these are necessary for charLiteral/stringLiteral

409− elmDef :: T.GenLanguageDef String u SourceM

410− elmDef = T.LanguageDef

411− { T.commentStart = "{-"

412− , T.commentEnd = "-}"

413− , T.commentLine = "--"

414− , T.nestedComments = True

415− , T.identStart = undefined

416− , T.identLetter = undefined

417− , T.opStart = undefined

418− , T.opLetter = undefined

419− , T.reservedNames = reserveds

420− , T.reservedOpNames = [":", "->", "<-", "|"]

421− , T.caseSensitive = True

422− }

compiler/Parse/Literal.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Parse.Literal (literal) where

3−

4−import Control.Applicative ((<$>))

5−import Text.Parsec hiding (newline,spaces)

6−import Parse.Helpers

7−import AST.Literal

8−

9−literal :: IParser Literal

10−literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"

11−

12−num :: IParser Literal

13−num = toLit <$> (number <?> "number")

14− where

15− toLit n

16− | any (`elem` ".eE") n = FloatNum (read n)

17− | otherwise = IntNum (read n)

18−

19− number = concat <$> sequence

20− [ option "" minus

21− , many1 digit

22− , option "" decimals

23− , option "" exponent ]

24−

25− minus = try $ do

26− string "-"

27− lookAhead digit

28− return "-"

29−

30− decimals = do

31− try $ lookAhead (string "." >> digit)

32− string "."

33− n <- many1 digit

34− return ('.' : n)

35−

36− exponent = do

37− string "e" <|> string "E"

38− op <- option "" (string "+" <|> string "-")

39− n <- many1 digit

40− return ('e' : op ++ n)

compiler/Parse/Module.hsdeleted−76

@@ -1,76 +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 AST.Module (ImportMethod(..))

9−import AST.Variable (Listing(..), Value(..), openListing)

10−

11−getModuleName :: String -> Maybe String

12−getModuleName source =

13− case iParse getModuleName source of

14− Right name -> Just name

15− Left _ -> Nothing

16− where

17− getModuleName = do

18− optional freshLine

19− (names, _) <- moduleDef

20− return (intercalate "." names)

21−

22−moduleDef :: IParser ([String], Listing Value)

23−moduleDef = do

24− try (reserved "module")

25− whitespace

26− names <- dotSep1 capVar <?> "name of module"

27− whitespace

28− exports <- option (Listing [] True) (listing value)

29− whitespace <?> "reserved word 'where'"

30− reserved "where"

31− return (names, exports)

32−

33−imports :: IParser [(String, ImportMethod)]

34−imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

35−

36−import' :: IParser (String, ImportMethod)

37−import' =

38− do reserved "import"

39− whitespace

40− name <- intercalate "." <$> dotSep1 capVar

41− (,) name <$> option (As name) method

42− where

43− method :: IParser ImportMethod

44− method = as' <|> importing'

45−

46− as' :: IParser ImportMethod

47− as' = do

48− try (whitespace >> reserved "as")

49− whitespace

50− As <$> capVar <?> "alias for module"

51−

52− importing' :: IParser ImportMethod

53− importing' = Open <$> listing value

54−

55−listing :: IParser a -> IParser (Listing a)

56−listing item =

57− do try (whitespace >> char '(')

58− whitespace

59− listing <- choice [ const openListing <$> string ".."

60− , Listing <$> commaSep1 item <*> return False

61− ] <?> "listing of values (x,y,z)"

62− whitespace

63− char ')'

64− return listing

65−

66−value :: IParser Value

67−value = val <|> tipe

68− where

69− val = Value <$> (lowVar <|> parens symOp)

70−

71− tipe = do

72− name <- capVar

73− maybeCtors <- optionMaybe (listing capVar)

74− case maybeCtors of

75− Nothing -> return (Alias name)

76− Just ctors -> return (ADT name ctors)

compiler/Parse/Parse.hsdeleted−77

@@ -1,77 +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 AST.Declaration as D

11−import qualified AST.Module as M

12−import qualified AST.Variable as Var

13−import Parse.Helpers

14−import Parse.Declaration (infixDecl)

15−import Parse.Module

16−import qualified Parse.Declaration as Decl

17−import Transform.Declaration (combineAnnotations)

18−

19−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

20− freshLine

21− Decl.declaration <?> "another datatype or variable definition"

22−

23−decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

24− (d:) <$> many freshDef

25−

26−program :: OpTable -> String -> Either [P.Doc] M.ValidModule

27−program table src =

28− do (M.Module names filePath exs ims parseDecls) <-

29− setupParserWithTable table programParser src

30− decls <-

31− either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

32− return $ M.Module names filePath exs ims decls

33−

34−programParser :: IParser M.SourceModule

35−programParser =

36− do optional freshLine

37− (names,exports) <-

38− option (["Main"], Var.openListing) (moduleDef `followedBy` freshLine)

39− is <- (do try (lookAhead $ reserved "import")

40− imports `followedBy` freshLine) <|> return []

41− declarations <- decls

42− optional freshLine ; optional spaces ; eof

43− return $ M.Module names "" exports is declarations

44−

45−dependencies :: String -> Either [P.Doc] (String, [String])

46−dependencies =

47− let getName = List.intercalate "." . fst in

48− setupParser $ do

49− optional freshLine

50− (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

51− <*> option [] (map fst <$> imports `followedBy` freshLine)

52−

53−setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a

54−setupParserWithTable table p source =

55− do localTable <- setupParser parseFixities source

56− case Map.intersection table localTable of

57− overlap | not (Map.null overlap) -> Left [ msg overlap ]

58− | otherwise ->

59− flip setupParser source $ do

60− putState (Map.union table localTable)

61− p

62− where

63− msg overlap =

64− P.vcat [ P.text "Parse error:"

65− , P.text $ "Overlapping definitions for infix operators: " ++

66− List.intercalate " " (Map.keys overlap)

67− ]

68−

69−parseFixities = do

70− decls <- onFreshLines (:) [] infixDecl

71− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]

72−

73−setupParser :: IParser a -> String -> Either [P.Doc] a

74−setupParser p source =

75− case iParse p source of

76− Right result -> Right result

77− Left err -> Left [ P.text $ "Parse error at " ++ show err ]

compiler/Parse/Pattern.hsdeleted−62

@@ -1,62 +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 qualified Data.List as List

7−import Text.Parsec hiding (newline,spaces,State)

8−

9−import Parse.Helpers

10−import Parse.Literal

11−import AST.Literal

12−import qualified AST.Pattern as P

13−import qualified AST.Variable as Var

14−

15−basic :: IParser P.RawPattern

16−basic = choice

17− [ char '_' >> return P.Anything

18− , do v <- var

19− return $ case v of

20− "True" -> P.Literal (Boolean True)

21− "False" -> P.Literal (Boolean False)

22− c:_ | isUpper c -> P.Data (Var.Raw v) []

23− _ -> P.Var v

24− , P.Literal <$> literal

25− ]

26−

27−asPattern :: P.RawPattern -> IParser P.RawPattern

28−asPattern pattern = do

29− var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

30− return $ case var of

31− Just v -> P.Alias v pattern

32− Nothing -> pattern

33−

34−record :: IParser P.RawPattern

35−record = P.Record <$> brackets (commaSep1 lowVar)

36−

37−tuple :: IParser P.RawPattern

38−tuple = do

39− ps <- parens (commaSep expr)

40− return $ case ps of

41− [p] -> p

42− _ -> P.tuple ps

43−

44−list :: IParser P.RawPattern

45−list = P.list <$> braces (commaSep expr)

46−

47−term :: IParser P.RawPattern

48−term =

49− (choice [ record, tuple, list, basic ]) <?> "pattern"

50−

51−patternConstructor :: IParser P.RawPattern

52−patternConstructor = do

53− v <- List.intercalate "." <$> dotSep1 capVar

54− case v of

55− "True" -> return $ P.Literal (Boolean True)

56− "False" -> return $ P.Literal (Boolean False)

57− _ -> P.Data (Var.Raw v) <$> spacePrefix term

58−

59−expr :: IParser P.RawPattern

60−expr = do

61− patterns <- consSep1 (patternConstructor <|> term)

62− asPattern (foldr1 P.cons patterns) <?> "pattern"

compiler/Parse/Type.hsdeleted−78

@@ -1,78 +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 qualified AST.Type as T

9−import qualified AST.Variable as Var

10−import Parse.Helpers

11−

12−tvar :: IParser T.RawType

13−tvar = T.Var <$> lowVar <?> "type variable"

14−

15−list :: IParser T.RawType

16−list = T.listOf <$> braces expr

17−

18−tuple :: IParser T.RawType

19−tuple = do ts <- parens (commaSep expr)

20− return $ case ts of

21− [t] -> t

22− _ -> T.tupleOf ts

23−

24−record :: IParser T.RawType

25−record =

26− do char '{' ; whitespace

27− rcrd <- extended <|> normal

28− dumbWhitespace ; char '}'

29− return rcrd

30− where

31− normal = flip T.Record Nothing <$> commaSep field

32−

33− -- extended record types require at least one field

34− extended = do

35− ext <- try (lowVar <* (whitespace >> string "|"))

36− whitespace

37− flip T.Record (Just (T.Var ext)) <$> commaSep1 field

38−

39− field = do

40− lbl <- rLabel

41− whitespace >> hasType >> whitespace

42− (,) lbl <$> expr

43−

44−capTypeVar :: IParser String

45−capTypeVar = intercalate "." <$> dotSep1 capVar

46−

47−constructor0 :: IParser T.RawType

48−constructor0 =

49− do name <- capTypeVar

50− return (T.Type (Var.Raw name))

51−

52−term :: IParser T.RawType

53−term = list <|> tuple <|> record <|> tvar <|> constructor0

54−

55−app :: IParser T.RawType

56−app =

57− do f <- constructor0 <|> try tupleCtor <?> "type constructor"

58− args <- spacePrefix term

59− return $ case args of

60− [] -> f

61− _ -> T.App f args

62− where

63− tupleCtor = do

64− n <- length <$> parens (many (char ','))

65− let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)

66− return (T.Type (Var.Raw ctor))

67−

68−expr :: IParser T.RawType

69−expr =

70− do t1 <- app <|> term

71− arr <- optionMaybe $ try (whitespace >> arrow)

72− case arr of

73− Just _ -> T.Lambda t1 <$> (whitespace >> expr)

74− Nothing -> return t1

75−

76−constructor :: IParser (String, [T.RawType])

77−constructor = (,) <$> (capTypeVar <?> "another type constructor")

78− <*> spacePrefix term

compiler/Paths_Elmdeleted−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/Transform/Canonicalize.hsdeleted−276

@@ -1,276 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Transform.Canonicalize (module') where

3−

4−import Control.Applicative ((<$>),(<*>))

5−import Control.Monad.Error (runErrorT, throwError)

6−import Control.Monad.State (runState)

7−import qualified Data.List as List

8−import qualified Data.Map as Map

9−import qualified Data.Set as Set

10−import qualified Data.Traversable as T

11−

12−import AST.Expression.General (Expr'(..), dummyLet)

13−import qualified AST.Expression.Valid as Valid

14−import qualified AST.Expression.Canonical as Canonical

15−

16−import AST.Module (CanonicalBody(..))

17−import qualified AST.Module as Module

18−import qualified AST.Type as Type

19−import qualified AST.Variable as Var

20−import qualified AST.Annotation as A

21−import qualified AST.Declaration as D

22−import AST.PrettyPrint (pretty, commaSep)

23−import qualified AST.Pattern as P

24−import Text.PrettyPrint as P

25−

26−import Transform.Canonicalize.Environment as Env

27−import qualified Transform.Canonicalize.Setup as Setup

28−import qualified Transform.Canonicalize.Type as Canonicalize

29−import qualified Transform.Canonicalize.Variable as Canonicalize

30−import qualified Transform.SortDefinitions as Transform

31−import qualified Transform.Declaration as Transform

32−

33−module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule

34−module' interfaces modul =

35− filterImports <$> modul'

36− where

37− (modul', usedModules) =

38− runState (runErrorT (moduleHelp interfaces modul)) Set.empty

39−

40− filterImports m =

41− let used (name,_) = Set.member name usedModules

42− in m { Module.imports = filter used (Module.imports m) }

43−

44−moduleHelp :: Module.Interfaces -> Module.ValidModule

45− -> Canonicalizer [Doc] Module.CanonicalModule

46−moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

47− do env <- Setup.environment interfaces modul

48− canonicalDecls <- mapM (declaration env) decls

49− exports' <- resolveExports locals exports

50− return $ modul { Module.exports = exports'

51− , Module.body = body canonicalDecls

52− }

53− where

54− locals :: [Var.Value]

55− locals = concatMap declToValue decls

56−

57− body :: [D.CanonicalDecl] -> Module.CanonicalBody

58− body decls =

59− Module.CanonicalBody

60− { program =

61− let expr = Transform.toExpr (Module.getName modul) decls

62− in Transform.sortDefs (dummyLet expr)

63− , types = Map.empty

64− , datatypes =

65− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]

66− , fixities =

67− [ (assoc,level,op) | D.Fixity assoc level op <- decls ]

68− , aliases =

69− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

70− , ports =

71− [ D.portName port | D.Port port <- decls ]

72− }

73−

74−resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]

75−resolveExports fullList (Var.Listing partialList open) =

76− if open

77− then return fullList

78− else do

79− valueExports <- getValueExports

80− aliasExports <- concat `fmap` mapM getAliasExport aliases

81− adtExports <- mapM getAdtExport adts

82− return $ valueExports ++ aliasExports ++ adtExports

83− where

84− (allValues, allAliases, allAdts) = splitValues fullList

85−

86− (values, aliases, adts) = splitValues partialList

87−

88− getValueExports =

89− case Set.toList (Set.difference values' allValues') of

90− [] -> return (map Var.Value values)

91− xs -> notFound xs

92− where

93− allValues' = Set.fromList allValues

94− values' = Set.fromList values

95−

96− getAliasExport alias

97− | alias `elem` allAliases =

98− let recordConstructor =

99− if alias `elem` allValues then [Var.Value alias] else []

100− in

101− return $ Var.Alias alias : recordConstructor

102−

103− | otherwise =

104− case List.find (\(name, _ctors) -> name == alias) allAdts of

105− Nothing -> notFound [alias]

106− Just (name, _ctor) ->

107− return [Var.ADT name (Var.Listing [] False)]

108−

109− getAdtExport (name, Var.Listing ctors open) =

110− case lookup name allAdts of

111− Nothing -> notFound [name]

112− Just (Var.Listing allCtors _)

113− | open -> return $ Var.ADT name (Var.Listing allCtors False)

114− | otherwise ->

115− case filter (`notElem` allCtors) ctors of

116− [] -> return $ Var.ADT name (Var.Listing ctors False)

117− unfoundCtors -> notFound unfoundCtors

118−

119− notFound xs =

120− throwError [ P.text "Export Error: trying to export non-existent values:" <+>

121− commaSep (map pretty xs)

122− ]

123−

124−{-| Split a list of values into categories so we can work with them

125−independently.

126−-}

127−splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])

128−splitValues mixedValues =

129− case mixedValues of

130− [] -> ([], [], [])

131− x:xs ->

132− let (values, aliases, adts) = splitValues xs in

133− case x of

134− Var.Value name -> (name : values, aliases, adts)

135− Var.Alias name -> (values, name : aliases, adts)

136− Var.ADT name listing ->

137− (values, aliases, (name, listing) : adts)

138−

139−

140−

141−declToValue :: D.ValidDecl -> [Var.Value]

142−declToValue decl =

143− case decl of

144− D.Definition (Valid.Definition pattern _ _) ->

145− map Var.Value (P.boundVarList pattern)

146−

147− D.Datatype name _tvs ctors ->

148− [ Var.ADT name (Var.Listing (map fst ctors) False) ]

149−

150− D.TypeAlias name _ tipe ->

151− case tipe of

152− Type.Record _ _ ->

153− [ Var.Alias name, Var.Value name ]

154− _ -> [ Var.Alias name ]

155−

156− _ -> []

157−

158−declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl

159−declaration env decl =

160− let canonicalize kind context pattern env v =

161− let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon

162− throw err = P.vcat [ ctx, P.text err ]

163− in

164− Env.onError throw (kind env v)

165− in

166− case decl of

167− D.Definition (Valid.Definition p e t) ->

168− do p' <- canonicalize pattern "definition" p env p

169− e' <- expression env e

170− t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t

171− return $ D.Definition (Canonical.Definition p' e' t')

172−

173− D.Datatype name tvars ctors ->

174− D.Datatype name tvars <$> mapM canonicalize' ctors

175− where

176− canonicalize' (ctor,args) =

177− (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args

178−

179− D.TypeAlias name tvars expanded ->

180− do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

181− return (D.TypeAlias name tvars expanded')

182−

183− D.Port port -> do

184− Env.uses "Native.Ports"

185− Env.uses "Native.Json"

186− D.Port <$> case port of

187− D.In name t ->

188− do t' <- canonicalize Canonicalize.tipe "port" name env t

189− return (D.In name t')

190− D.Out name e t ->

191− do e' <- expression env e

192− t' <- canonicalize Canonicalize.tipe "port" name env t

193− return (D.Out name e' t')

194−

195− D.Fixity assoc prec op -> return $ D.Fixity assoc prec op

196−

197−

198−expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr

199−expression env (A.A ann expr) =

200− let go = expression env

201− tipe' environ = format . Canonicalize.tipe environ

202− throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon

203− , P.text err ]

204− format = Env.onError throw

205− in

206− A.A ann <$>

207− case expr of

208− Literal lit -> return (Literal lit)

209−

210− Range e1 e2 -> Range <$> go e1 <*> go e2

211−

212− Access e x -> Access <$> go e <*> return x

213−

214− Remove e x -> flip Remove x <$> go e

215−

216− Insert e x v -> flip Insert x <$> go e <*> go v

217−

218− Modify e fs ->

219− Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs

220−

221− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs

222−

223− Binop (Var.Raw op) e1 e2 ->

224− do op' <- format (Canonicalize.variable env op)

225− Binop op' <$> go e1 <*> go e2

226−

227− Lambda p e ->

228− let env' = update p env in

229− Lambda <$> format (pattern env' p) <*> expression env' e

230−

231− App e1 e2 -> App <$> go e1 <*> go e2

232−

233− MultiIf ps -> MultiIf <$> mapM go' ps

234− where go' (b,e) = (,) <$> go b <*> go e

235−

236− Let defs e -> Let <$> mapM rename' defs <*> expression env' e

237− where

238− env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs

239− rename' (Valid.Definition p body mtipe) =

240− Canonical.Definition

241− <$> format (pattern env' p)

242− <*> expression env' body

243− <*> T.traverse (tipe' env') mtipe

244−

245− Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x)

246−

247− Data name es -> Data name <$> mapM go es

248−

249− ExplicitList es -> ExplicitList <$> mapM go es

250−

251− Case e cases -> Case <$> go e <*> mapM branch cases

252− where

253− branch (p,b) = (,) <$> format (pattern env p)

254− <*> expression (update p env) b

255−

256− Markdown uid md es ->

257− do Env.uses "Text"

258− Markdown uid md <$> mapM go es

259−

260− PortIn name st -> PortIn name <$> tipe' env st

261−

262− PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal

263−

264− GLShader uid src tipe -> return (GLShader uid src tipe)

265−

266−pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern

267−pattern env ptrn =

268− case ptrn of

269− P.Var x -> return $ P.Var x

270− P.Literal lit -> return $ P.Literal lit

271− P.Record fs -> return $ P.Record fs

272− P.Anything -> return P.Anything

273− P.Alias x p -> P.Alias x <$> pattern env p

274− P.Data (Var.Raw name) ps ->

275− P.Data <$> Canonicalize.pvar env name

276− <*> mapM (pattern env) ps

compiler/Transform/Canonicalize/Environment.hsdeleted−84

@@ -1,84 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Environment where

3−

4−import Control.Arrow (second)

5−import qualified Control.Monad.Error as Error

6−import qualified Control.Monad.State as State

7−import qualified Data.Map as Map

8−import qualified Data.Set as Set

9−

10−import AST.Expression.General (saveEnvName)

11−import qualified AST.Pattern as P

12−import qualified AST.Type as Type

13−import qualified AST.Variable as Var

14−

15−import Text.PrettyPrint (Doc)

16−

17−type Dict a = Map.Map String [a]

18−

19−dict :: [(String,a)] -> Dict a

20−dict pairs = Map.fromList $ map (second (:[])) pairs

21−

22−insert :: String -> a -> Dict a -> Dict a

23−insert key value = Map.insertWith (++) key [value]

24−

25−type Canonicalizer err a = Error.ErrorT err (State.State (Set.Set String)) a

26−

27−uses :: (Error.Error e) => String -> Canonicalizer e ()

28−uses home =

29− Error.lift (State.modify (Set.insert home))

30−

31−using :: Var.Canonical -> Canonicalizer String Var.Canonical

32−using var@(Var.Canonical home _) =

33− do case home of

34− Var.BuiltIn -> return ()

35− Var.Module path -> uses path

36− Var.Local -> return ()

37− return var

38−

39−onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a

40−onError handler canonicalizer =

41− do usedModules <- Error.lift State.get

42− let (result, usedModules') =

43− State.runState (Error.runErrorT canonicalizer) usedModules

44− Error.lift (State.put usedModules')

45− case result of

46− Left err -> Error.throwError [handler err]

47− Right x -> return x

48−

49−data Environment = Env

50− { _home :: String

51− , _values :: Dict Var.Canonical

52− , _adts :: Dict Var.Canonical

53− , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)

54− , _patterns :: Dict Var.Canonical

55− }

56−

57−builtIns :: String -> Environment

58−builtIns home =

59− Env { _home = home

60− , _values = builtIn (tuples ++ [saveEnvName])

61− , _adts = builtIn (tuples ++ ["_List","Int","Float","Char","Bool","String"])

62− , _aliases = dict []

63− , _patterns = builtIn (tuples ++ ["::","[]"])

64− }

65− where

66− builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs

67− tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

68−

69−update :: P.Pattern var -> Environment -> Environment

70−update ptrn env =

71− env { _values = foldr put (_values env) (P.boundVarList ptrn) }

72− where

73− put x = Map.insert x [Var.local x]

74−

75−merge :: Environment -> Environment -> Environment

76−merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)

77− | n1 /= n2 = error "trying to merge incompatable environments"

78− | otherwise =

79− Env { _home = n1

80− , _values = Map.unionWith (++) v1 v2

81− , _adts = Map.unionWith (++) t1 t2

82− , _aliases = Map.unionWith (++) a1 a2

83− , _patterns = Map.unionWith (++) p1 p2

84− }

compiler/Transform/Canonicalize/Setup.hsdeleted−230

@@ -1,230 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Setup (environment) where

3−

4−import Control.Arrow (first)

5−import Control.Monad (foldM)

6−import Control.Monad.Error (throwError)

7−import qualified Data.Graph as Graph

8−import qualified Data.List as List

9−import qualified Data.Map as Map

10−

11−import qualified AST.Expression.Valid as Valid

12−

13−import AST.Module (Interface(iAdts, iTypes, iAliases))

14−import qualified AST.Module as Module

15−import qualified AST.Type as Type

16−import qualified AST.Variable as Var

17−import qualified AST.Declaration as D

18−import AST.PrettyPrint (pretty, eightyCharLines)

19−import qualified AST.Pattern as P

20−import Text.PrettyPrint as P

21−

22−import Transform.Canonicalize.Environment as Env

23−import qualified Transform.Canonicalize.Type as Canonicalize

24−import qualified Transform.Interface as Interface

25−

26−environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment

27−environment interfaces modul@(Module.Module _ _ _ imports decls) =

28− do () <- allImportsAvailable

29− let moduleName = Module.getName modul

30− nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports

31− let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls

32− addTypeAliases moduleName aliases env

33− where

34− allImportsAvailable :: Canonicalizer [Doc] ()

35− allImportsAvailable =

36− case filter (not . found) modules of

37− [] -> return ()

38− missings -> throwError [ P.text (missingModuleError missings) ]

39− where

40− modules = map fst imports

41−

42− found m = Map.member m interfaces || List.isPrefixOf "Native." m

43−

44− missingModuleError missings =

45− concat [ "The following imports were not found: "

46− , List.intercalate ", " missings

47− , "\n You may need to compile with the --make "

48− , "flag to detect modules you have written." ]

49−

50−addImports :: String -> Module.Interfaces -> Environment -> (String, Module.ImportMethod)

51− -> Canonicalizer [Doc] Environment

52−addImports moduleName interfaces environ (name, method)

53− | List.isPrefixOf "Native." name = return environ

54− | otherwise =

55− case method of

56− Module.As name' ->

57− return (updateEnviron (name' ++ "."))

58−

59− Module.Open (Var.Listing vs open)

60− | open -> return (updateEnviron "")

61− | otherwise -> foldM (addValue name interface) environ vs

62− where

63− interface = Interface.filterExports ((Map.!) interfaces name)

64−

65− updateEnviron prefix =

66− let dict' = dict . map (first (prefix++)) in

67− merge environ $

68− Env { _home = moduleName

69− , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors

70− , _adts = dict' $ map pair (Map.keys (iAdts interface))

71− , _aliases = dict' $ map alias (Map.toList (iAliases interface))

72− , _patterns = dict' $ ctors

73− }

74−

75− canonical :: String -> Var.Canonical

76− canonical = Var.Canonical (Var.Module name)

77−

78− pair :: String -> (String, Var.Canonical)

79− pair key = (key, canonical key)

80−

81− alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))

82−

83− ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))

84−

85−addValue :: String -> Module.Interface -> Environment -> Var.Value

86− -> Canonicalizer [Doc] Environment

87−addValue name interface env value =

88− let insert' x = insert x (Var.Canonical (Var.Module name) x)

89− msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++

90− "'.\n It is not exported by module " ++ name ++ "."

91− notFound x = throwError [ P.text (msg x) ]

92− in

93− case value of

94− Var.Value x

95− | Map.notMember x (iTypes interface) -> notFound x

96− | otherwise ->

97− return $ env { _values = insert' x (_values env) }

98−

99− Var.Alias x ->

100− case Map.lookup x (iAliases interface) of

101− Just (tvars, t) ->

102− return $ env

103− { _aliases = insert x v (_aliases env)

104− , _values = updatedValues

105− }

106− where

107− v = (Var.Canonical (Var.Module name) x, tvars, t)

108− updatedValues =

109− if Map.member x (iTypes interface)

110− then insert' x (_values env)

111− else _values env

112−

113− Nothing ->

114− case Map.lookup x (iAdts interface) of

115− Nothing -> notFound x

116− Just (_,_) ->

117− return $ env { _adts = insert' x (_adts env) }

118−

119− Var.ADT x (Var.Listing xs open) ->

120− case Map.lookup x (iAdts interface) of

121− Nothing -> notFound x

122− Just (_tvars, ctors) ->

123− do ctors' <- filterNames (map fst ctors)

124− return $ env { _adts = insert' x (_adts env)

125− , _values = foldr insert' (_values env) ctors'

126− , _patterns = foldr insert' (_patterns env) ctors'

127− }

128− where

129− filterNames names

130− | open = return names

131− | otherwise =

132− case filter (`notElem` names) xs of

133− [] -> return names

134− c:_ -> notFound c

135−

136−type Node = ((String, [String], Type.RawType), String, [String])

137−

138−node :: String -> [String] -> Type.RawType -> Node

139−node name tvars alias = ((name, tvars, alias), name, edges alias)

140− where

141− edges tipe =

142− case tipe of

143− Type.Lambda t1 t2 -> edges t1 ++ edges t2

144− Type.Var _ -> []

145− Type.Type (Var.Raw x) -> [x]

146− Type.App t ts -> edges t ++ concatMap edges ts

147− Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs

148− Type.Aliased _ t -> edges t

149−

150−addTypeAliases :: String -> [Node] -> Environment -> Canonicalizer [Doc] Environment

151−addTypeAliases moduleName nodes environ =

152− foldM addTypeAlias environ (Graph.stronglyConnComp nodes)

153− where

154− addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)

155− -> Canonicalizer [Doc] Environment

156− addTypeAlias env scc =

157− case Graph.flattenSCC scc of

158− [(name, tvars, alias)] ->

159− do alias' <- Env.onError throw (Canonicalize.tipe env alias)

160− let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')

161− return $ env { _aliases = insert name value (_aliases env) }

162− where

163− throw err =

164− let msg = "Problem with type alias '" ++ name ++ "':"

165− in P.vcat [ P.text msg, P.text err ]

166−

167− aliases ->

168− throwError [ P.vcat [ P.text (eightyCharLines 0 msg1)

169− , indented (map typeAlias aliases)

170− , P.text (eightyCharLines 0 msg2)

171− , indented (map datatype aliases)

172− , P.text (eightyCharLines 0 msg3)

173− ]

174− ]

175−

176− typeAlias (n,ts,t) = D.TypeAlias n ts t

177− datatype (n,ts,t) = D.Datatype n ts [(n,[t])]

178−

179− indented :: [D.ValidDecl] -> Doc

180− indented decls = P.vcat (map prty decls) <> P.text "\n"

181− where

182− prty decl = P.text "\n " <> pretty decl

183−

184− msg1 = "The following type aliases are mutually recursive, forming an \

185− \infinite type. When you expand them, they just keep getting bigger:"

186− msg2 = "Instead, you can try something like this:"

187− msg3 = "It looks very similar, but an algebraic data type (ADT) \

188− \actually creates a new type. Unlike with a type alias, this \

189− \freshly created type is meaningful on its own, so an ADT \

190− \does not need to be expanded."

191−

192−

193−-- When canonicalizing, all _values should be Local, but all _adts and _patterns

194−-- should be fully namespaced. With _adts, they may appear in types that can

195−-- escape the module.

196−addDecl :: String -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)

197−addDecl moduleName info@(nodes,env) decl =

198− let namespacedVar = Var.Canonical (Var.Module moduleName)

199− addLocal x e = insert x (Var.local x) e

200− addNamespaced x e = insert x (namespacedVar x) e

201− in

202− case decl of

203− D.Definition (Valid.Definition pattern _ _) ->

204− (,) nodes $ env

205− { _values = foldr addLocal (_values env) (P.boundVarList pattern) }

206−

207− D.Datatype name _ ctors ->

208− (,) nodes $ env

209− { _values = addCtors addLocal (_values env)

210− , _adts = addNamespaced name (_adts env)

211− , _patterns = addCtors addNamespaced (_patterns env)

212− }

213− where

214− addCtors how e = foldr how e (map fst ctors)

215−

216− D.TypeAlias name tvars alias ->

217− (,) (node name tvars alias : nodes) $ env

218− { _values = case alias of

219− Type.Record _ _ -> addLocal name (_values env)

220− _ -> _values env

221− }

222−

223− D.Port port ->

224− let portName = case port of

225− D.Out name _ _ -> name

226− D.In name _ -> name

227− in

228− (,) nodes $ env { _values = addLocal portName (_values env) }

229−

230− D.Fixity _ _ _ -> info

compiler/Transform/Canonicalize/Type.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Type (tipe) where

3−

4−import Control.Arrow (second)

5−import Control.Applicative ((<$>),(<*>))

6−import Control.Monad.Error

7−import qualified Data.Map as Map

8−import Data.Traversable (traverse)

9−

10−import qualified AST.Type as T

11−import qualified AST.Variable as Var

12−

13−import Transform.Canonicalize.Environment

14−import qualified Transform.Canonicalize.Variable as Canonicalize

15−

16−tipe :: Environment -> T.RawType -> Canonicalizer String T.CanonicalType

17−tipe env typ =

18− let go = tipe env in

19− case typ of

20− T.Var x -> return (T.Var x)

21− T.Type _ -> canonicalizeApp env typ []

22− T.App t ts -> canonicalizeApp env t ts

23−

24− T.Lambda a b -> T.Lambda <$> go a <*> go b

25− T.Aliased name t -> T.Aliased name <$> go t

26−

27− T.Record fields ext ->

28− let go' (f,t) = (,) f <$> go t

29− in T.Record <$> mapM go' fields <*> traverse go ext

30−

31−canonicalizeApp :: Environment -> T.RawType -> [T.RawType]

32− -> Canonicalizer String T.CanonicalType

33−canonicalizeApp env f args =

34− case f of

35− T.Type (Var.Raw rawName) ->

36− do answer <- Canonicalize.tvar env rawName

37− case answer of

38− Right alias -> canonicalizeAlias env alias args

39− Left name -> case args of

40− [] -> return (T.Type name)

41− _:_ -> T.App (T.Type name) <$> mapM (tipe env) args

42−

43− _ -> T.App <$> tipe env f <*> mapM (tipe env) args

44−

45−canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)

46− -> [T.RawType]

47− -> Canonicalizer String T.CanonicalType

48−canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

49− do when (tipesLen /= tvarsLen) (throwError msg)

50− tipes' <- mapM (tipe env) tipes

51− let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe

52− return $ T.Aliased name tipe'

53− where

54− tipesLen = length tipes

55− tvarsLen = length tvars

56−

57− msg :: String

58− msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++

59− " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

60− " but was given " ++ show tipesLen

61−

62− replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType

63− replace typeTable t =

64− let go = replace typeTable in

65− case t of

66− T.Lambda a b -> T.Lambda (go a) (go b)

67− T.Var x -> Map.findWithDefault t x typeTable

68− T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)

69− T.Aliased original t' -> T.Aliased original (go t')

70− T.Type _ -> t

71− T.App f args -> T.App (go f) (map go args)

compiler/Transform/Canonicalize/Variable.hsdeleted−94

@@ -1,94 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Variable where

3−

4−import Control.Monad.Error

5−import qualified Data.List as List

6−import qualified Data.Map as Map

7−import Data.Maybe (fromMaybe)

8−

9−import AST.Helpers as Help

10−import qualified AST.Type as Type

11−import qualified AST.Variable as Var

12−import Transform.Canonicalize.Environment as Env

13−

14−variable :: Environment -> String -> Canonicalizer String Var.Canonical

15−variable env var =

16− case modul of

17− Just ms@(m:_)

18− | m == "Native" -> Env.using (Var.Canonical home name)

19− where

20− home = Var.Module (List.intercalate "." ms)

21−

22− _ ->

23− case Map.lookup var (_values env) of

24− Just [v] -> Env.using v

25− Just vs -> preferLocals env "variable" vs var

26− Nothing -> notFound "variable" (Map.keys (_values env)) var

27− where

28− (modul, name) =

29− case Help.splitDots var of

30− [x] -> (Nothing, x)

31− xs -> (Just (init xs), last xs)

32−

33−tvar :: Environment -> String

34− -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))

35−tvar env var =

36− case adts ++ aliases of

37− [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var

38− [v] -> found extract v

39− vs -> preferLocals' env extract "type" vs var

40− where

41− adts = map Left . fromMaybe [] $ Map.lookup var (_adts env)

42− aliases = map Right . fromMaybe [] $ Map.lookup var (_aliases env)

43−

44− extract value =

45− case value of

46− Left v -> v

47− Right (v,_,_) -> v

48−

49−pvar :: Environment -> String -> Canonicalizer String Var.Canonical

50−pvar env var =

51− case Map.lookup var (_patterns env) of

52− Just [v] -> Env.using v

53− Just vs -> preferLocals env "pattern" vs var

54− Nothing -> notFound "pattern" (Map.keys (_patterns env)) var

55−

56−found :: (a -> Var.Canonical) -> a -> Canonicalizer String a

57−found extract v = do

58− _ <- Env.using (extract v)

59− return v

60−

61−notFound :: String -> [String] -> String -> Canonicalizer String a

62−notFound kind possibilities var =

63− throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg

64− where

65− matches = filter (List.isInfixOf var) possibilities

66− msg = if null matches then "" else

67− "\nClose matches include: " ++ List.intercalate ", " matches

68−

69−preferLocals :: Environment -> String -> [Var.Canonical] -> String

70− -> Canonicalizer String Var.Canonical

71−preferLocals env = preferLocals' env id

72−

73−preferLocals' :: Environment -> (a -> Var.Canonical) -> String -> [a] -> String

74− -> Canonicalizer String a

75−preferLocals' env extract kind possibilities var =

76− case filter (isLocal . extract) possibilities of

77− [] -> ambiguous possibilities

78− [v] -> found extract v

79− locals -> ambiguous locals

80− where

81− isLocal :: Var.Canonical -> Bool

82− isLocal (Var.Canonical home _) =

83− case home of

84− Var.Local -> True

85− Var.BuiltIn -> False

86− Var.Module name -> name == Env._home env

87−

88− ambiguous possibleVars =

89− throwError msg

90− where

91− vars = map (Var.toString . extract) possibleVars

92− msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++

93− " Disambiguate between: " ++ List.intercalate ", " vars

94−

compiler/Transform/Check.hsdeleted−153

@@ -1,153 +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 AST.Expression.Valid as Valid

10−import qualified AST.Declaration as D

11−import qualified AST.Pattern as Pattern

12−import qualified AST.Type as T

13−import qualified AST.Variable as Var

14−import qualified Transform.Expression as Expr

15−

16−import AST.PrettyPrint

17−import Text.PrettyPrint as P

18−

19−

20−mistakes :: [D.ValidDecl] -> [Doc]

21−mistakes decls =

22− concat [ infiniteTypeAliases decls

23− , illFormedTypes decls

24− , map P.text (duplicateConstructors decls)

25− , map P.text (duplicates 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.ValidDecl] -> [String]

35−duplicates decls =

36− map msg (dups (portNames ++ concatMap Pattern.boundVarList 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 (Valid.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− exprDups :: Valid.Expr -> Either String Valid.Expr

55− exprDups expr = Expr.crawlLet defsDups expr

56−

57− defsDups :: [Valid.Def] -> Either String [Valid.Def]

58− defsDups defs =

59− let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in

60− case dups $ concatMap varsIn defs of

61− [] -> Right defs

62− name:_ -> Left name

63−

64−duplicateConstructors :: [D.ValidDecl] -> [String]

65−duplicateConstructors decls =

66− map (dupErr "definition of type constructor") (dups typeCtors) ++

67− map (dupErr "definition of data constructor") (dups dataCtors)

68− where

69− typeCtors = [ name | D.Datatype name _ _ <- decls ]

70− dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

71−

72−illFormedTypes :: [D.ValidDecl] -> [Doc]

73−illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

74− where

75− aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

76− adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]

77−

78− freeVars tipe =

79− case tipe of

80− T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

81− T.Var x -> Set.singleton x

82− T.Type _ -> Set.empty

83− T.App t ts -> Set.unions (map freeVars (t:ts))

84− T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

85− where ext' = maybe Set.empty freeVars ext

86− T.Aliased _ t -> freeVars t

87−

88− undeclared tvars tipes = Set.difference used declared

89− where

90− used = Set.unions (map freeVars tipes)

91− declared = Set.fromList tvars

92−

93− isIllFormed (decl, tvars, tipes) =

94− let unbound = undeclared tvars tipes in

95− if Set.null unbound then Nothing

96− else Just (decl, Set.toList unbound)

97−

98− report (decl, tvars) =

99− P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:"

100− , P.text "\n"

101− , nest 4 (pretty decl) ]

102− where

103− listing =

104− case tvars of

105− [tvar] -> " " ++ quote tvar ++ " is"

106− _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are"

107−

108− addCommas xs

109− | length xs < 3 = concat xs

110− | otherwise = List.intercalate "," xs

111−

112− addAnd xs

113− | length xs < 2 = xs

114− | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs

115−

116− quote tvar = "'" ++ tvar ++ "'"

117−

118−

119−infiniteTypeAliases :: [D.ValidDecl] -> [Doc]

120−infiniteTypeAliases decls =

121− [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

122− , infiniteType name tipe ]

123− where

124− infiniteType :: String -> T.Type Var.Raw -> Bool

125− infiniteType name tipe =

126− let infinite = infiniteType name in

127− case tipe of

128− T.Lambda a b -> infinite a || infinite b

129− T.Var _ -> False

130− T.Type (Var.Raw name') -> name == name'

131− T.App t ts -> any infinite (t:ts)

132− T.Record fields _ -> any (infinite . snd) fields

133− T.Aliased _ t -> infinite t

134−

135− indented :: D.ValidDecl -> Doc

136− indented decl = P.text "\n " <> pretty decl <> P.text "\n"

137−

138− report name args tipe =

139− P.vcat [ P.text $ eightyCharLines 0 msg1

140− , indented $ D.TypeAlias name args tipe

141− , P.text $ eightyCharLines 0 msg2

142− , indented $ D.Datatype name args [(name,[tipe])]

143− , P.text $ eightyCharLines 0 msg3 ++ "\n"

144− ]

145− where

146− msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

147− "Notice that it appears in its own definition, so when \

148− \you expand it, it just keeps getting bigger:"

149− msg2 = "Try this instead:"

150− msg3 = "It looks very similar, but an algebraic data type (ADT) \

151− \actually creates a new type. Unlike with a type alias, this \

152− \freshly created type is meaningful on its own, so an ADT \

153− \does not need to be expanded."

compiler/Transform/Declaration.hsdeleted−128

@@ -1,128 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration (combineAnnotations, toExpr) where

3−

4−import Control.Applicative ((<$>))

5−

6−import qualified AST.Annotation as A

7−import qualified AST.Declaration as D

8−import qualified AST.Expression.General as E

9−import qualified AST.Expression.Source as Source

10−import qualified AST.Expression.Valid as Valid

11−import qualified AST.Expression.Canonical as Canonical

12−import qualified AST.Pattern as P

13−import qualified AST.Type as T

14−import qualified AST.Variable as Var

15−

16−import qualified Transform.Expression as Expr

17−import qualified Transform.Definition as Def

18−

19−

20−combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

21−combineAnnotations = go

22− where

23− msg x = "Syntax Error: The type annotation for '" ++ x ++

24− "' must be directly above its definition."

25−

26− exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations

27−

28− go decls =

29− case decls of

30− -- simple cases, pass them through with no changes

31− [] -> return []

32−

33− D.Datatype name tvars ctors : rest ->

34− (:) (D.Datatype name tvars ctors) <$> go rest

35−

36− D.TypeAlias name tvars alias : rest ->

37− (:) (D.TypeAlias name tvars alias) <$> go rest

38−

39− D.Fixity assoc prec op : rest ->

40− (:) (D.Fixity assoc prec op) <$> go rest

41−

42− -- combine definitions

43− D.Definition def : defRest ->

44− case def of

45− Source.Definition pat expr ->

46− do expr' <- exprCombineAnnotations expr

47− let def' = Valid.Definition pat expr' Nothing

48− (:) (D.Definition def') <$> go defRest

49−

50− Source.TypeAnnotation name tipe ->

51− case defRest of

52− D.Definition (Source.Definition pat@(P.Var name') expr) : rest

53− | name == name' ->

54− do expr' <- exprCombineAnnotations expr

55− let def' = Valid.Definition pat expr' (Just tipe)

56− (:) (D.Definition def') <$> go rest

57−

58− _ -> Left (msg name)

59−

60− -- combine ports

61− D.Port port : portRest ->

62− case port of

63− D.PPDef name _ -> Left (msg name)

64− D.PPAnnotation name tipe ->

65− case portRest of

66− D.Port (D.PPDef name' expr) : rest | name == name' ->

67− do expr' <- exprCombineAnnotations expr

68− (:) (D.Port (D.Out name expr' tipe)) <$> go rest

69−

70− _ -> (:) (D.Port (D.In name tipe)) <$> go portRest

71−

72−

73−toExpr :: String -> [D.CanonicalDecl] -> [Canonical.Def]

74−toExpr moduleName = concatMap (toDefs moduleName)

75−

76−toDefs :: String -> D.CanonicalDecl -> [Canonical.Def]

77−toDefs moduleName decl =

78− let typeVar = Var.Canonical (Var.Module moduleName) in

79− case decl of

80− D.Definition def -> [def]

81−

82− D.Datatype name tvars constructors -> concatMap toDefs' constructors

83− where

84− toDefs' (ctor, tipes) =

85− let vars = take (length tipes) arguments

86− tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

87− body = A.none . E.Data ctor $ map (A.none . E.localVar) vars

88− in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

89−

90− D.TypeAlias name _ tipe@(T.Record fields ext) ->

91− [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]

92− where

93− result = T.Aliased (typeVar name) tipe

94−

95− args = map snd fields ++ maybe [] (:[]) ext

96−

97− var = A.none . E.localVar

98− vars = take (length args) arguments

99−

100− efields = zip (map fst fields) (map var vars)

101− record = case ext of

102− Nothing -> A.none $ E.Record efields

103− Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

104−

105− -- Type aliases must be added to an extended equality dictionary,

106− -- but they do not require any basic constraints.

107− D.TypeAlias _ _ _ -> []

108−

109− D.Port port ->

110− case port of

111− D.Out name expr@(A.A s _) tipe ->

112− [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

113− D.In name tipe ->

114− [ definition name (A.none $ E.PortIn name tipe) tipe ]

115−

116− -- no constraints are needed for fixity declarations

117− D.Fixity _ _ _ -> []

118−

119−

120−arguments :: [String]

121−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

122−

123−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

124−buildFunction body@(A.A s _) vars =

125− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

126−

127−definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def

128−definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)

compiler/Transform/Definition.hsdeleted−35

@@ -1,35 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Definition where

3−

4−import Control.Applicative ((<$>))

5−import qualified AST.Pattern as P

6−import qualified AST.Expression.Source as Source

7−import qualified AST.Expression.Valid as Valid

8−import qualified Transform.Expression as Expr

9−

10−combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

11−combineAnnotations = go

12− where

13− msg x = "Syntax Error: The type annotation for '" ++ x ++

14− "' must be directly above its definition."

15−

16− exprCombineAnnotations = Expr.crawlLet combineAnnotations

17−

18− go defs =

19− case defs of

20− Source.TypeAnnotation name tipe : rest ->

21− case rest of

22− Source.Definition pat@(P.Var name') expr : rest'

23− | name == name' ->

24− do expr' <- exprCombineAnnotations expr

25− let def = Valid.Definition pat expr' (Just tipe)

26− (:) def <$> go rest'

27−

28− _ -> Left (msg name)

29−

30− Source.Definition pat expr : rest ->

31− do expr' <- exprCombineAnnotations expr

32− let def = Valid.Definition pat expr' Nothing

33− (:) def <$> go rest

34−

35− [] -> return []

compiler/Transform/Expression.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Expression (crawlLet, checkPorts) where

3−

4−import Control.Applicative ((<$>),(<*>))

5−import AST.Annotation ( Annotated(A) )

6−import AST.Expression.General

7−import qualified AST.Expression.Canonical as Canonical

8−import AST.Type (Type, CanonicalType)

9−

10−crawlLet :: ([def] -> Either a [def'])

11− -> Expr ann def var

12− -> Either a (Expr ann def' var)

13−crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

14−

15−checkPorts :: (String -> CanonicalType -> Either a ())

16− -> (String -> CanonicalType -> Either a ())

17− -> Canonical.Expr

18− -> Either a Canonical.Expr

19−checkPorts inCheck outCheck expr =

20− crawl inCheck outCheck (mapM checkDef) expr

21− where

22− checkDef def@(Canonical.Definition _ body _) =

23− do _ <- checkPorts inCheck outCheck body

24− return def

25−

26−crawl :: (String -> Type var -> Either a ())

27− -> (String -> Type var -> Either a ())

28− -> ([def] -> Either a [def'])

29− -> Expr ann def var

30− -> Either a (Expr ann def' var)

31−crawl portInCheck portOutCheck defsTransform = go

32− where

33− go (A srcSpan expr) =

34− A srcSpan <$>

35− case expr of

36− Var x -> return (Var x)

37− Lambda p e -> Lambda p <$> go e

38− Binop op e1 e2 -> Binop op <$> go e1 <*> go e2

39− Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases

40− Data name es -> Data name <$> mapM go es

41− Literal lit -> return (Literal lit)

42− Range e1 e2 -> Range <$> go e1 <*> go e2

43− ExplicitList es -> ExplicitList <$> mapM go es

44− App e1 e2 -> App <$> go e1 <*> go e2

45− MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches

46− Access e lbl -> Access <$> go e <*> return lbl

47− Remove e lbl -> Remove <$> go e <*> return lbl

48− Insert e lbl v -> Insert <$> go e <*> return lbl <*> go v

49− Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields

50− Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields

51− Markdown uid md es -> Markdown uid md <$> mapM go es

52− Let defs body -> Let <$> defsTransform defs <*> go body

53− GLShader uid src gltipe -> return $ GLShader uid src gltipe

54− PortIn name st ->

55− do portInCheck name st

56− return $ PortIn name st

57− PortOut name st signal ->

58− do portOutCheck name st

59− PortOut name st <$> go signal

compiler/Transform/Interface.hsdeleted−58

@@ -1,58 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Transform.Interface (filterExports) where

3−

4−import qualified Data.Map as Map

5−import qualified AST.Module as Module

6−import qualified AST.Type as Type

7−import qualified AST.Variable as Var

8−

9−filterExports :: Module.Interface -> Module.Interface

10−filterExports interface =

11− interface

12− { Module.iTypes =

13− Map.fromList (concatMap getTypes exportedValues)

14− , Module.iAliases =

15− Map.fromList (concatMap getAliases exportedValues)

16− , Module.iAdts =

17− Map.fromList (concatMap getAdts exportedValues)

18− }

19− where

20− exportedValues :: [Var.Value]

21− exportedValues = Module.iExports interface

22−

23− get :: Map.Map String a -> String -> [(String, a)]

24− get dict x =

25− case Map.lookup x dict of

26− Just t -> [(x,t)]

27− Nothing -> []

28−

29− getTypes :: Var.Value -> [(String, Type.CanonicalType)]

30− getTypes value =

31− case value of

32− Var.Value x -> getType x

33− Var.Alias _ -> []

34− Var.ADT _ (Var.Listing ctors _) -> concatMap getType ctors

35−

36− getType :: String -> [(String, Type.CanonicalType)]

37− getType name =

38− get (Module.iTypes interface) name

39−

40− getAliases :: Var.Value -> [(String, ([String], Type.CanonicalType))]

41− getAliases value =

42− case value of

43− Var.Value _ -> []

44− Var.Alias name -> get (Module.iAliases interface) name

45− Var.ADT _ _ -> []

46−

47− getAdts :: Var.Value -> [(String, Module.AdtInfo String)]

48− getAdts value =

49− case value of

50− Var.Value _ -> []

51− Var.Alias _ -> []

52− Var.ADT name (Var.Listing exportedCtors _) ->

53− case Map.lookup name (Module.iAdts interface) of

54− Nothing -> []

55− Just (tvars, ctors) ->

56− [(name, (tvars, filter isExported ctors))]

57− where

58− isExported (ctor, _) = ctor `elem` exportedCtors

compiler/Transform/SortDefinitions.hsdeleted−172

@@ -1,172 +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.Graph as Graph

7−import qualified Data.Map as Map

8−import qualified Data.Maybe as Maybe

9−import qualified Data.Set as Set

10−

11−import AST.Annotation

12−import AST.Expression.General (Expr'(..))

13−import qualified AST.Expression.Canonical as Canonical

14−import qualified AST.Pattern as P

15−import qualified AST.Variable as V

16−

17−ctors :: P.CanonicalPattern -> [String]

18−ctors pattern =

19− case pattern of

20− P.Var _ -> []

21− P.Alias _ p -> ctors p

22− P.Record _ -> []

23− P.Anything -> []

24− P.Literal _ -> []

25− P.Data (V.Canonical home name) ps ->

26− case home of

27− V.Local -> name : rest

28− V.BuiltIn -> rest

29− V.Module _ -> rest

30− where

31− rest = concatMap ctors ps

32−

33−free :: String -> State (Set.Set String) ()

34−free x = modify (Set.insert x)

35−

36−freeIfLocal :: V.Canonical -> State (Set.Set String) ()

37−freeIfLocal (V.Canonical home name) =

38− do case home of

39− V.Local -> free name

40− V.BuiltIn -> return ()

41− V.Module _ -> return ()

42−

43−bound :: Set.Set String -> State (Set.Set String) ()

44−bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

45−

46−sortDefs :: Canonical.Expr -> Canonical.Expr

47−sortDefs expr = evalState (reorder expr) Set.empty

48−

49−reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

50−reorder (A ann expr) =

51− A ann <$>

52− case expr of

53− -- Be careful adding and restricting freeVars

54− Var var -> freeIfLocal var >> return expr

55−

56− Lambda p e ->

57− uncurry Lambda <$> bindingReorder (p,e)

58−

59− Binop op e1 e2 ->

60− do freeIfLocal op

61− Binop op <$> reorder e1 <*> reorder e2

62−

63− Case e cases ->

64− Case <$> reorder e <*> mapM bindingReorder cases

65−

66− Data name es ->

67− do free name

68− Data name <$> mapM reorder es

69−

70− -- Just pipe the reorder though

71− Literal _ -> return expr

72−

73− Range e1 e2 ->

74− Range <$> reorder e1 <*> reorder e2

75−

76− ExplicitList es ->

77− ExplicitList <$> mapM reorder es

78−

79− App e1 e2 ->

80− App <$> reorder e1 <*> reorder e2

81−

82− MultiIf branches ->

83− MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches

84−

85− Access e lbl ->

86− Access <$> reorder e <*> return lbl

87−

88− Remove e lbl ->

89− Remove <$> reorder e <*> return lbl

90−

91− Insert e lbl v ->

92− Insert <$> reorder e <*> return lbl <*> reorder v

93−

94− Modify e fields ->

95− Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields

96−

97− Record fields ->

98− Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

99−

100− Markdown uid md es -> Markdown uid md <$> mapM reorder es

101−

102− GLShader _ _ _ -> return expr

103−

104− PortOut name st signal -> PortOut name st <$> reorder signal

105−

106− PortIn name st -> return $ PortIn name st

107−

108− -- Actually do some reordering

109− Let defs body ->

110− do body' <- reorder body

111−

112− -- Sort defs into strongly connected components.This

113− -- allows the programmer to write definitions in whatever

114− -- order they please, we can still define things in order

115− -- and generalize polymorphic functions when appropriate.

116− sccs <- Graph.stronglyConnComp <$> buildDefDict defs

117− let defss = map Graph.flattenSCC sccs

118−

119− -- remove let-bound variables from the context

120− forM_ defs $ \(Canonical.Definition pattern _ _) -> do

121− bound (P.boundVars pattern)

122− mapM free (ctors pattern)

123−

124− let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss

125−

126− return let'

127−

128−bindingReorder :: (P.CanonicalPattern, Canonical.Expr)

129− -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)

130−bindingReorder (pattern,expr) =

131− do expr' <- reorder expr

132− bound (P.boundVars pattern)

133− mapM_ free (ctors pattern)

134− return (pattern, expr')

135−

136−

137−reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])

138−reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

139− do globalFrees <- get

140− -- work in a fresh environment

141− put Set.empty

142− expr' <- reorder expr

143− localFrees <- get

144− -- merge with global frees

145− modify (Set.union globalFrees)

146− return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

147−

148−

149−-- This also reorders the all of the sub-expressions in the Def list.

150−buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

151−buildDefDict defs =

152− do pdefsDeps <- mapM reorderAndGetDependencies defs

153− return $ realDeps (addKey pdefsDeps)

154−

155− where

156− addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

157− addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

158−

159− variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

160− variableToKey (Canonical.Definition pattern _ _, key, _) =

161− [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

162−

163− variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

164− variableToKeyMap pdefsDeps =

165− Map.fromList (concatMap variableToKey pdefsDeps)

166−

167− realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

168− realDeps pdefsDeps = map convert pdefsDeps

169− where

170− varDict = variableToKeyMap pdefsDeps

171− convert (pdef, key, deps) =

172− (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

compiler/Transform/Substitute.hsdeleted−91

@@ -1,91 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Substitute (subst) where

3−

4−import Control.Arrow (second, (***))

5−import qualified Data.Set as Set

6−

7−import AST.Annotation

8−import AST.Expression.General (Expr'(..))

9−import qualified AST.Expression.Canonical as Canonical

10−import qualified AST.Pattern as Pattern

11−import qualified AST.Variable as V

12−

13−

14−subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

15−subst old new expression =

16− let f (A a e) = A a (subst old new e) in

17− case expression of

18− Range e1 e2 ->

19− Range (f e1) (f e2)

20−

21− ExplicitList exprs ->

22− ExplicitList (map f exprs)

23−

24− Binop op e1 e2 ->

25− Binop op (f e1) (f e2)

26−

27− Lambda pattern body

28− | Set.member old (Pattern.boundVars pattern) -> expression

29− | otherwise -> Lambda pattern (f body)

30−

31− App e1 e2 ->

32− App (f e1) (f e2)

33−

34− MultiIf branches ->

35− MultiIf (map (f *** f) branches)

36−

37− Let defs body

38− | anyShadow -> expression

39− | otherwise -> Let (map substDef defs) (f body)

40− where

41− substDef (Canonical.Definition p e t) =

42− Canonical.Definition p (f e) t

43−

44− anyShadow =

45− any (Set.member old . Pattern.boundVars)

46− [ pattern | Canonical.Definition pattern _ _ <- defs ]

47−

48− Var (V.Canonical home x) ->

49− case home of

50− V.Module _ -> expression

51− V.BuiltIn -> expression

52− V.Local -> if x == old then new else expression

53−

54− Case e cases ->

55− Case (f e) (map substCase cases)

56− where

57− substCase (pattern, expr) =

58− if Set.member old (Pattern.boundVars pattern)

59− then (pattern, expr)

60− else (pattern, f expr)

61−

62− Data tag values ->

63− Data tag (map f values)

64−

65− Access record field ->

66− Access (f record) field

67−

68− Remove record field ->

69− Remove (f record) field

70−

71− Insert record field value ->

72− Insert (f record) field (f value)

73−

74− Modify record fields ->

75− Modify (f record) (map (second f) fields)

76−

77− Record fields ->

78− Record (map (second f) fields)

79−

80− Literal _ -> expression

81−

82− Markdown uid md exprs ->

83− Markdown uid md (map f exprs)

84−

85− GLShader _ _ _ -> expression

86−

87− PortIn name st ->

88− PortIn name st

89−

90− PortOut name st signal ->

91− PortOut name st (f signal)

compiler/Type/Constrain/Expression.hsdeleted−231

@@ -1,231 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.Constrain.Expression where

3−

4−import Control.Applicative ((<$>))

5−import qualified Control.Monad as Monad

6−import Control.Monad.Error

7−import qualified Data.List as List

8−import qualified Data.Map as Map

9−import qualified Text.PrettyPrint as PP

10−

11−import AST.Literal as Lit

12−import AST.Annotation as Ann

13−import AST.Expression.General

14−import qualified AST.Expression.Canonical as Canonical

15−import qualified AST.Pattern as P

16−import qualified AST.Type as ST

17−import qualified AST.Variable as V

18−import Type.Type hiding (Descriptor(..))

19−import Type.Fragment

20−import qualified Type.Environment as Env

21−import qualified Type.Constrain.Literal as Literal

22−import qualified Type.Constrain.Pattern as Pattern

23−

24−constrain :: Env.Environment -> Canonical.Expr -> Type

25− -> ErrorT [PP.Doc] IO TypeConstraint

26−constrain env (A region expr) tipe =

27− let list t = Env.get env Env.types "_List" <| t

28− and = A region . CAnd

29− true = A region CTrue

30− t1 === t2 = A region (CEqual t1 t2)

31− x <? t = A region (CInstance x t)

32− clet schemes c = A region (CLet schemes c)

33− in

34− case expr of

35− Literal lit -> liftIO $ Literal.constrain env region lit tipe

36−

37− GLShader _uid _src gltipe ->

38− exists $ \attr ->

39− exists $ \unif ->

40− let

41− shaderTipe a u v = Env.get env Env.types "Graphics.WebGL.Shader" <| a <| u <| v

42− glTipe = Env.get env Env.types . Lit.glTipeName

43− makeRec accessor baseRec =

44− let decls = accessor gltipe

45− in if Map.size decls == 0

46− then baseRec

47− else record (Map.map (\t -> [glTipe t]) decls) baseRec

48− attribute = makeRec Lit.attribute attr

49− uniform = makeRec Lit.uniform unif

50− varying = makeRec Lit.varying (termN EmptyRecord1)

51− in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

52−

53− Var var

54− | name == saveEnvName -> return (A region CSaveEnv)

55− | otherwise -> return (name <? tipe)

56− where

57− name = V.toString var

58−

59− Range lo hi ->

60− existsNumber $ \n -> do

61− clo <- constrain env lo n

62− chi <- constrain env hi n

63− return $ and [clo, chi, list n === tipe]

64−

65− ExplicitList exprs ->

66− exists $ \x -> do

67− cs <- mapM (\e -> constrain env e x) exprs

68− return . and $ list x === tipe : cs

69−

70− Binop op e1 e2 ->

71− exists $ \t1 ->

72− exists $ \t2 -> do

73− c1 <- constrain env e1 t1

74− c2 <- constrain env e2 t2

75− return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]

76−

77− Lambda p e ->

78− exists $ \t1 ->

79− exists $ \t2 -> do

80− fragment <- try region $ Pattern.constrain env p t1

81− c2 <- constrain env e t2

82− let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]

83− (typeConstraint fragment /\ c2 ))

84− return $ c /\ tipe === (t1 ==> t2)

85−

86− App e1 e2 ->

87− exists $ \t -> do

88− c1 <- constrain env e1 (t ==> tipe)

89− c2 <- constrain env e2 t

90− return $ c1 /\ c2

91−

92− MultiIf branches -> and <$> mapM constrain' branches

93− where

94− bool = Env.get env Env.types "Bool"

95− constrain' (b,e) = do

96− cb <- constrain env b bool

97− ce <- constrain env e tipe

98− return (cb /\ ce)

99−

100− Case exp branches ->

101− exists $ \t -> do

102− ce <- constrain env exp t

103− let branch (p,e) = do

104− fragment <- try region $ Pattern.constrain env p t

105− clet [toScheme fragment] <$> constrain env e tipe

106− and . (:) ce <$> mapM branch branches

107−

108− Data name exprs ->

109− do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

110− let pairs = zip exprs (map varN vars)

111− (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

112− return $ ex vars (cs /\ name <? ctipe)

113− where

114− step (t,c) (e,x) = do

115− c' <- constrain env e x

116− return (x ==> t, c /\ c')

117−

118− Access e label ->

119− exists $ \t ->

120− constrain env e (record (Map.singleton label [tipe]) t)

121−

122− Remove e label ->

123− exists $ \t ->

124− constrain env e (record (Map.singleton label [t]) tipe)

125−

126− Insert e label value ->

127− exists $ \tVal ->

128− exists $ \tRec -> do

129− cVal <- constrain env value tVal

130− cRec <- constrain env e tRec

131− let c = tipe === record (Map.singleton label [tVal]) tRec

132− return (and [cVal, cRec, c])

133−

134− Modify e fields ->

135− exists $ \t -> do

136− oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

137− let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

138− cOld <- ex oldVars <$> constrain env e (record oldFields t)

139−

140− newVars <- forM fields $ \_ -> liftIO (variable Flexible)

141− let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

142− let cNew = tipe === record newFields t

143−

144− cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

145−

146− return $ cOld /\ ex newVars (and (cNew : cs))

147−

148− Record fields ->

149− do vars <- forM fields $ \_ -> liftIO (variable Flexible)

150− cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

151− let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

152− recordType = record fields' (termN EmptyRecord1)

153− return . ex vars . and $ tipe === recordType : cs

154−

155− Markdown _ _ es ->

156− do vars <- forM es $ \_ -> liftIO (variable Flexible)

157− let tvars = map varN vars

158− cs <- zipWithM (constrain env) es tvars

159− return . ex vars $ and ("Text.markdown" <? tipe : cs)

160−

161− Let defs body ->

162− do c <- constrain env body tipe

163− (schemes, rqs, fqs, header, c2, c1) <-

164− Monad.foldM (constrainDef env)

165− ([], [], [], Map.empty, true, true)

166− (concatMap expandPattern defs)

167− return $ clet schemes

168− (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

169− (c1 /\ c))

170−

171− PortIn _ _ -> return true

172−

173− PortOut _ _ signal ->

174− constrain env signal tipe

175−

176−constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

177− let qs = [] -- should come from the def, but I'm not sure what would live there...

178− (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

179− in

180− do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here.

181− -- Currently, qs is always [].

182− case (pattern, maybeTipe) of

183− (P.Var name, Just tipe) -> do

184− flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

185− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

186− env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

187− (vars, typ) <- Env.instantiateType env tipe Map.empty

188− let scheme = Scheme { rigidQuantifiers = [],

189− flexibleQuantifiers = flexiVars ++ vars,

190− constraint = Ann.noneNoDocs CTrue,

191− header = Map.singleton name typ }

192− c <- constrain env' expr typ

193− return ( scheme : schemes

194− , rigidQuantifiers

195− , flexibleQuantifiers

196− , headers

197− , c2

198− , fl rigidVars c /\ c1 )

199−

200− (P.Var name, Nothing) -> do

201− v <- liftIO $ variable Flexible

202− let tipe = varN v

203− inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

204− env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

205− c <- constrain env' expr tipe

206− return ( schemes

207− , rigidVars ++ rigidQuantifiers

208− , v : flexibleQuantifiers

209− , Map.insert name tipe headers

210− , c /\ c2

211− , c1 )

212−

213− _ -> error ("problem in constrainDef with " ++ show pattern)

214−

215−expandPattern :: Canonical.Def -> [Canonical.Def]

216−expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

217− case pattern of

218− P.Var _ -> [def]

219− _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars

220− where

221− vars = P.boundVarList pattern

222− x = "$" ++ concat vars

223− mkVar = A r . localVar

224− toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

225−

226−try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

227−try region computation = do

228− result <- liftIO $ runErrorT computation

229− case result of

230− Left err -> throwError [err region]

231− Right value -> return value

compiler/Type/Constrain/Literal.hsdeleted−22

@@ -1,22 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.Constrain.Literal where

3−

4−import AST.Annotation

5−import AST.Literal

6−import Type.Type

7−import Type.Environment as Env

8−

9−constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint

10−constrain env region literal tipe =

11− do tipe' <- litType

12− return . A region $ CEqual tipe tipe'

13− where

14− prim name = return (Env.get env Env.types name)

15−

16− litType =

17− case literal of

18− IntNum _ -> varN `fmap` variable (Is Number)

19− FloatNum _ -> prim "Float"

20− Chr _ -> prim "Char"

21− Str _ -> prim "String"

22− Boolean _ -> prim "Bool"

compiler/Type/Constrain/Pattern.hsdeleted−82

@@ -1,82 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−module Type.Constrain.Pattern where

4−

5−import Control.Arrow (second)

6−import Control.Applicative ((<$>))

7−import qualified Control.Monad as Monad

8−import Control.Monad.Error

9−import qualified Data.Map as Map

10−import qualified Text.PrettyPrint as PP

11−

12−import qualified AST.Annotation as A

13−import qualified AST.Pattern as P

14−import qualified AST.Variable as V

15−import AST.PrettyPrint (pretty)

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 -> P.CanonicalPattern -> Type

23− -> ErrorT (A.Region -> PP.Doc) IO Fragment

24−constrain env pattern tipe =

25− let region = A.None (pretty pattern)

26− t1 === t2 = A.A region (CEqual t1 t2)

27− in

28− case pattern of

29− P.Anything -> return emptyFragment

30−

31− P.Literal lit -> do

32− c <- liftIO $ Literal.constrain env region lit tipe

33− return $ emptyFragment { typeConstraint = c }

34−

35− P.Var name -> do

36− v <- liftIO $ variable Flexible

37− return $ Fragment {

38− typeEnv = Map.singleton name (varN v),

39− vars = [v],

40− typeConstraint = varN v === tipe

41− }

42−

43− P.Alias name p -> do

44− v <- liftIO $ variable Flexible

45− fragment <- constrain env p tipe

46− return $ fragment

47− { typeEnv = Map.insert name (varN v) (typeEnv fragment)

48− , vars = v : vars fragment

49− , typeConstraint = varN v === tipe /\ typeConstraint fragment

50− }

51−

52− P.Data name patterns -> do

53− (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)

54− let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind

55− , " argument", if kind == 1 then "" else "s"

56− , " but was given ", show (length patterns), "." ]

57− err span = PP.vcat [ PP.text $ "Type error " ++ show span

58− , PP.text msg ]

59− case length patterns == kind of

60− False -> throwError err

61− True -> do

62− fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)

63− return $ fragment {

64− typeConstraint = typeConstraint fragment /\ tipe === result,

65− vars = cvars ++ vars fragment

66− }

67−

68− P.Record fields -> do

69− pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

70− let tenv = Map.fromList (map (second varN) pairs)

71− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

72− return $ Fragment {

73− typeEnv = tenv,

74− vars = map snd pairs,

75− typeConstraint = c

76− }

77−

78−instance Error (A.Region -> PP.Doc) where

79− noMsg _ = PP.empty

80− strMsg str span =

81− PP.vcat [ PP.text $ "Type error " ++ show span

82− , PP.text str ]

compiler/Type/Environment.hsdeleted−168

@@ -1,168 +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.Error (ErrorT, throwError, liftIO)

8−import qualified Control.Monad.State as State

9−import qualified Data.Traversable as Traverse

10−import qualified Data.Map as Map

11−import Data.List (isPrefixOf)

12−import qualified Text.PrettyPrint as PP

13−

14−import qualified AST.Type as T

15−import qualified AST.Variable as V

16−import AST.Module (CanonicalAdt, AdtInfo)

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− , types :: TypeDict

25− , value :: TypeDict

26− }

27−

28−initialEnvironment :: [CanonicalAdt] -> IO Environment

29−initialEnvironment datatypes = do

30− types <- makeTypes datatypes

31− let env = Environment

32− { constructor = Map.empty

33− , value = Map.empty

34− , types = types

35− }

36− return $ env { constructor = makeConstructors env datatypes }

37−

38−makeTypes :: [CanonicalAdt] -> IO TypeDict

39−makeTypes datatypes =

40− do adts <- mapM makeImported datatypes

41− bs <- mapM makeBuiltin builtins

42− return (Map.fromList (adts ++ bs))

43− where

44− makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

45− makeImported (var, _) = do

46− tvar <- namedVar Constant var

47− return (V.toString var, varN tvar)

48−

49− makeBuiltin :: (String, Int) -> IO (String, Type)

50− makeBuiltin (name, _) = do

51− name' <- namedVar Constant (V.builtin name)

52− return (name, varN name')

53−

54− builtins :: [(String, Int)]

55− builtins = concat [ map tuple [0..9]

56− , kind 1 ["_List"]

57− , kind 0 ["Int","Float","Char","String","Bool"]

58− ]

59− where

60− tuple n = ("_Tuple" ++ show n, n)

61− kind n names = map (\name -> (name, n)) names

62−

63−

64−

65−makeConstructors :: Environment

66− -> [CanonicalAdt]

67− -> Map.Map String (IO (Int, [Variable], [Type], Type))

68−makeConstructors env datatypes = Map.fromList builtins

69− where

70− list t = (types env Map.! "_List") <| t

71−

72− inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

73− inst numTVars tipe = do

74− vars <- forM [1..numTVars] $ \_ -> variable Flexible

75− let (args, result) = tipe (map (varN) vars)

76− return (length args, vars, args, result)

77−

78− tupleCtor n =

79− let name = "_Tuple" ++ show n

80− in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))

81−

82− builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

83− builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))

84− , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

85− ] ++ map tupleCtor [0..9]

86− ++ concatMap (ctorToType env) datatypes

87−

88−

89−ctorToType :: Environment

90− -> (V.Canonical, AdtInfo V.Canonical)

91− -> [(String, IO (Int, [Variable], [Type], Type))]

92−ctorToType env (name, (tvars, ctors)) =

93− zip (map (V.toString . fst) ctors) (map inst ctors)

94− where

95− inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

96− inst ctor = do

97− ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty

98− return (length args, Map.elems dict, args, tipe)

99−

100−

101− go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

102− go (_, args) = do

103− types <- mapM (instantiator env) args

104− returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))

105− return (types, returnType)

106−

107−

108−get :: Environment -> (Environment -> Map.Map String a) -> String -> a

109−get env subDict key = Map.findWithDefault (error msg) key (subDict env)

110− where

111− msg = "Could not find type constructor '" ++ key ++ "' while checking types."

112−

113−

114−freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

115−freshDataScheme env name = get env constructor name

116−

117−instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

118−instantiateType env sourceType dict =

119− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

120− case result :: Either SomeException (Type, VarDict) of

121− Left someError -> throwError [ PP.text $ show someError ]

122− Right (tipe, dict') -> return (Map.elems dict', tipe)

123−

124−instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type

125−instantiator env sourceType = go sourceType

126− where

127− go :: T.CanonicalType -> State.StateT VarDict IO Type

128− go sourceType =

129− case sourceType of

130− T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

131−

132− T.Var x -> do

133− dict <- State.get

134− case Map.lookup x dict of

135− Just v -> return (varN v)

136− Nothing ->

137− do v <- State.liftIO $ namedVar flex (V.local x)

138− State.put (Map.insert x v dict)

139− return (varN v)

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− T.Aliased name t -> do

147− t' <- go t

148− case t' of

149− VarN _ v -> return (VarN (Just name) v)

150− TermN _ term -> return (TermN (Just name) term)

151−

152− T.Type name ->

153− case Map.lookup (V.toString name) (types env) of

154− Just t -> return t

155− Nothing -> error $ "Could not find type constructor '" ++

156− V.toString name ++ "' while checking types."

157−

158− T.App t ts -> do

159− t' <- go t

160− ts' <- mapM go ts

161− return $ foldl (<|) t' ts'

162−

163− T.Record fields ext -> do

164− fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

165− ext' <- case ext of

166− Nothing -> return $ termN EmptyRecord1

167− Just x -> go x

168− return $ termN (Record1 fields' ext')

compiler/Type/ExtraChecks.hsdeleted−156

@@ -1,156 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−{-| This module contains checks to be run *after* type inference has completed

4−successfully. At that point we still need to do occurs checks and ensure that

5−`main` has an acceptable type.

6−-}

7−module Type.ExtraChecks (mainType, occurs, portTypes) where

8−

9−import Control.Applicative ((<$>),(<*>))

10−import Control.Monad.Error

11−import Control.Monad.State

12−import qualified Data.Map as Map

13−import qualified Data.Traversable as Traverse

14−import qualified Data.UnionFind.IO as UF

15−import Text.PrettyPrint as P

16−

17−import qualified AST.Annotation as A

18−import qualified AST.Expression.Canonical as Canonical

19−import qualified AST.PrettyPrint as PP

20−import qualified AST.Type as ST

21−import qualified AST.Variable as V

22−import qualified Transform.Expression as Expr

23−import qualified Type.Type as TT

24−import qualified Type.State as TS

25−

26−throw :: [Doc] -> Either [Doc] a

27−throw err = Left [ P.vcat err ]

28−

29−mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

30−mainType environment =

31− do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment

32− mainCheck environment'

33− where

34− mainCheck :: (Monad m) => Map.Map String ST.CanonicalType

35− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)

36− mainCheck env =

37− case Map.lookup "main" env of

38− Nothing -> return env

39− Just typeOfMain

40− | tipe `elem` acceptable -> return env

41− | otherwise -> throwError err

42− where

43− acceptable = [ "Graphics.Element.Element"

44− , "Signal.Signal Graphics.Element.Element" ]

45−

46− tipe = PP.renderPretty typeOfMain

47− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

48− , P.text "Instead 'main' has type:\n"

49− , P.nest 4 (PP.pretty typeOfMain)

50− , P.text " " ]

51−

52−data Direction = In | Out

53−

54−portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()

55−portTypes expr =

56− case Expr.checkPorts (check In) (check Out) expr of

57− Left err -> throwError err

58− Right _ -> return ()

59− where

60− check = isValid True False False

61− isValid isTopLevel seenFunc seenSignal direction name tipe =

62− case tipe of

63− ST.Aliased _ t -> valid t

64−

65− ST.Type v

66− | V.isJson v -> return ()

67− | V.isPrimitive v -> return ()

68− | V.isTuple v -> return ()

69− | otherwise -> err "an unsupported type"

70−

71− ST.App t [] -> valid t

72−

73− ST.App (ST.Type v) [t]

74− | V.isSignal v -> handleSignal t

75− | V.isMaybe v -> valid t

76− | V.isArray v -> valid t

77− | V.isList v -> valid t

78−

79− ST.App (ST.Type v) ts

80− | V.isTuple v -> mapM_ valid ts

81−

82− ST.App _ _ -> err "an unsupported type"

83−

84− ST.Var _ -> err "free type variables"

85−

86− ST.Lambda _ _ ->

87− case direction of

88− In -> err "functions"

89− Out | seenFunc -> err "higher-order functions"

90− | seenSignal -> err "signals that contain functions"

91− | otherwise ->

92− forM_ (ST.collectLambdas tipe)

93− (isValid' True seenSignal direction name)

94−

95− ST.Record _ (Just _) -> err "extended records with free type variables"

96−

97− ST.Record fields Nothing ->

98− mapM_ (\(k,v) -> (,) k <$> valid v) fields

99−

100− where

101− isValid' = isValid False

102− valid = isValid' seenFunc seenSignal direction name

103−

104− handleSignal t

105− | seenFunc = err "functions that involve signals"

106− | seenSignal = err "signals-of-signals"

107− | isTopLevel = isValid' seenFunc True direction name t

108− | otherwise = err "a signal within a data stucture"

109−

110− dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

111− txt = P.text . concat

112−

113− err kind =

114− throw $

115− [ txt [ "Type Error: the value ", dir "coming in" "sent out"

116− , " through port '", name, "' is invalid." ]

117− , txt [ "It contains ", kind, ":\n" ]

118− , P.nest 4 (PP.pretty tipe) <> P.text "\n"

119− , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]

120− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]

121− , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]

122− ]

123−

124−occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

125−occurs (name, variable) =

126− do vars <- liftIO $ infiniteVars [] variable

127− case vars of

128− [] -> return ()

129− var:_ -> do

130− desc <- liftIO $ UF.descriptor var

131− case TT.structure desc of

132− Nothing ->

133− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }

134− Just _ ->

135− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

136− var' <- liftIO $ UF.fresh desc

137− TS.addError (A.None (P.text name)) (Just msg) var var'

138− where

139− msg = "Infinite types are not allowed"

140−

141− infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

142− infiniteVars seen var =

143− let go = infiniteVars (var:seen) in

144− if var `elem` seen

145− then return [var]

146− else do

147− desc <- UF.descriptor var

148− case TT.structure desc of

149− Nothing -> return []

150− Just struct ->

151− case struct of

152− TT.App1 a b -> (++) <$> go a <*> go b

153− TT.Fun1 a b -> (++) <$> go a <*> go b

154− TT.Var1 a -> go a

155− TT.EmptyRecord1 -> return []

156− TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

compiler/Type/Fragment.hsdeleted−27

@@ -1,27 +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 AST.Pattern

8−import AST.Annotation (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−toScheme fragment =

27− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

compiler/Type/Inference.hsdeleted−93

@@ -1,93 +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 qualified AST.Annotation as A

12−import AST.Module as Module

13−import AST.Type (CanonicalType)

14−import qualified AST.Variable as Var

15−import Text.PrettyPrint

16−import qualified Type.State as TS

17−import qualified Type.ExtraChecks as Check

18−import Control.Arrow (first, second)

19−import Control.Monad.State (execStateT, forM)

20−import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)

21−

22−import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

23− -- the IO monad. I don't think that'd be worthwhile.

24−

25−

26−infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)

27−infer interfaces modul = unsafePerformIO $ runErrorT $ do

28− (header, constraint) <- genConstraints interfaces modul

29−

30− state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState

31−

32− () <- case TS.sErrors state of

33− errors@(_:_) -> throwError errors

34− [] -> return ()

35−

36− () <- Check.portTypes (program (body modul))

37−

38− let header' = Map.delete "::" header

39− types = Map.difference (TS.sSavedEnv state) header'

40−

41− Check.mainType types

42−

43−

44−genConstraints :: Interfaces -> CanonicalModule

45− -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)

46−genConstraints interfaces modul = do

47− env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)

48−

49− ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do

50− (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name

51− return (name, (vars, foldr (T.==>) result args))

52−

53− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)

54−

55− let allTypes = concat (ctors : importedVars)

56− vars = concatMap (fst . snd) allTypes

57− header = Map.map snd (Map.fromList allTypes)

58− environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]

59−

60− fvar <- liftIO $ T.variable T.Flexible

61− c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)

62− return (header, environ c)

63−

64−

65−canonicalizeValues :: Env.Environment -> (String, Interface)

66− -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]

67−canonicalizeValues env (moduleName, iface) =

68− forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do

69− tipe' <- Env.instantiateType env tipe Map.empty

70− return (moduleName ++ "." ++ name, tipe')

71−

72−canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]

73−canonicalizeAdts interfaces modul =

74− localAdts ++ importedAdts

75− where

76− localAdts :: [CanonicalAdt]

77− localAdts = format (Module.getName modul, datatypes (body modul))

78−

79− importedAdts :: [CanonicalAdt]

80− importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)

81−

82− format :: (String, Module.ADTs) -> [CanonicalAdt]

83− format (home, adts) =

84− map canonical (Map.toList adts)

85− where

86− canonical :: (String, AdtInfo String) -> CanonicalAdt

87− canonical (name, (tvars, ctors)) =

88− ( toVar name

89− , (tvars, map (first toVar) ctors)

90− )

91−

92− toVar :: String -> Var.Canonical

93− toVar = Var.Canonical (Var.Module home)

compiler/Type/PrettyPrint.hsdeleted−16

@@ -1,16 +0,0 @@

1−

2−module Type.PrettyPrint where

3−

4−import Text.PrettyPrint

5−import qualified AST.PrettyPrint as Src

6−

7−data ParensWhen = Fn | App | Never

8−

9−class PrettyType a where

10− pretty :: ParensWhen -> a -> Doc

11−

12−commaSep :: [Doc] -> Doc

13−commaSep docs = sep (punctuate comma docs)

14−

15−parensIf :: Bool -> Doc -> Doc

16−parensIf bool doc = if bool then parens doc else doc

compiler/Type/Solve.hsdeleted−196

@@ -1,196 +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.List as List

7−import qualified Data.Map as Map

8−import qualified Data.Traversable as Traversable

9−import qualified Data.UnionFind.IO as UF

10−import Type.Type

11−import Type.Unify

12−import qualified Type.ExtraChecks as Check

13−import qualified Type.State as TS

14−import qualified AST.Annotation as A

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− descriptor <- liftIO $ UF.descriptor var

25− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank descriptor) [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− forM (Map.toList rankDict) $ \(poolRank, vars) ->

36− mapM (adjustRank youngMark visitedMark poolRank) vars

37−

38− -- For variables that have rank lowerer than youngRank, register them in

39− -- the old pool if they are not redundant.

40− let registerIfNotRedundant var = do

41− isRedundant <- liftIO $ UF.redundant var

42− if isRedundant then return var else TS.register var

43−

44− let rankDict' = Map.delete youngRank rankDict

45− Traversable.traverse (mapM registerIfNotRedundant) rankDict'

46−

47− -- For variables with rank youngRank

48− -- If rank < youngRank: register in oldPool

49− -- otherwise generalize

50− let registerIfLowerRank var = do

51− isRedundant <- liftIO $ UF.redundant var

52− case isRedundant of

53− True -> return ()

54− False -> do

55− desc <- liftIO $ UF.descriptor var

56− case rank desc < youngRank of

57− True -> TS.register var >> return ()

58− False -> do

59− let flex' = case flex desc of { Flexible -> Rigid ; other -> other }

60− liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

61−

62− mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

63−

64−

65−-- adjust the ranks of variables such that ranks never increase as you

66−-- move deeper into a variable.

67−adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

68−adjustRank youngMark visitedMark groupRank var =

69− do descriptor <- liftIO $ UF.descriptor var

70− case () of

71− () | mark descriptor == youngMark ->

72− do -- Set the variable as marked first because it may be cyclic.

73− liftIO $ UF.modifyDescriptor var $ \desc ->

74− desc { mark = visitedMark }

75− rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

76− liftIO $ UF.modifyDescriptor var $ \desc ->

77− desc { rank = rank' }

78− return rank'

79−

80− | mark descriptor /= visitedMark ->

81− do let rank' = min groupRank (rank descriptor)

82− liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

83− return rank'

84−

85− | otherwise -> return (rank descriptor)

86−

87− where

88− adjust = adjustRank youngMark visitedMark groupRank

89−

90− adjustTerm term =

91− case term of

92− App1 a b -> max `liftM` adjust a `ap` adjust b

93− Fun1 a b -> max `liftM` adjust a `ap` adjust b

94− Var1 x -> adjust x

95− EmptyRecord1 -> return outermostRank

96− Record1 fields extension ->

97− do ranks <- mapM adjust (concat (Map.elems fields))

98− rnk <- adjust extension

99− return . maximum $ rnk : ranks

100−

101−

102−solve :: TypeConstraint -> StateT TS.SolverState IO ()

103−solve (A.A region constraint) =

104− case constraint of

105− CTrue -> return ()

106−

107− CSaveEnv -> TS.saveLocalEnv

108−

109− CEqual term1 term2 -> do

110− t1 <- TS.flatten term1

111− t2 <- TS.flatten term2

112− unify region t1 t2

113−

114− CAnd cs -> mapM_ solve cs

115−

116− CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do

117− oldEnv <- TS.getEnv

118− mapM TS.introduce fqs

119− solve constraint'

120− TS.modifyEnv (\_ -> oldEnv)

121−

122− CLet schemes constraint' -> do

123− oldEnv <- TS.getEnv

124− headers <- Map.unions `fmap` mapM (solveScheme region) schemes

125− TS.modifyEnv $ \env -> Map.union headers env

126− solve constraint'

127− mapM Check.occurs $ Map.toList headers

128− TS.modifyEnv (\_ -> oldEnv)

129−

130− CInstance name term -> do

131− env <- TS.getEnv

132− freshCopy <-

133− case Map.lookup name env of

134− Just tipe -> TS.makeInstance tipe

135− Nothing

136− | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

137− | otherwise ->

138− error ("Could not find '" ++ name ++ "' when solving type constraints.")

139−

140− t <- TS.flatten term

141− unify region freshCopy t

142−

143−solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

144−solveScheme region scheme =

145− case scheme of

146− Scheme [] [] constraint header -> do

147− solve constraint

148− Traversable.traverse TS.flatten header

149−

150− Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do

151− let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

152− oldPool <- TS.getPool

153−

154− -- fill in a new pool when working on this scheme's constraints

155− freshPool <- TS.nextRankPool

156− TS.switchToPool freshPool

157− mapM TS.introduce quantifiers

158− header' <- Traversable.traverse TS.flatten header

159− solve constraint

160−

161− allDistinct region rigidQuantifiers

162− youngPool <- TS.getPool

163− TS.switchToPool oldPool

164− generalize youngPool

165− mapM (isGeneric region) rigidQuantifiers

166− return header'

167−

168−

169−-- Checks that all of the given variables belong to distinct equivalence classes.

170−-- Also checks that their structure is Nothing, so they represent a variable, not

171−-- a more complex term.

172−allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()

173−allDistinct region vars = do

174− seen <- TS.uniqueMark

175− let check var = do

176− desc <- liftIO $ UF.descriptor var

177− case structure desc of

178− Just _ -> TS.addError region (Just msg) var var

179− where msg = "Cannot generalize something that is not a type variable."

180−

181− Nothing -> do

182− if mark desc == seen

183− then let msg = "Duplicate variable during generalization."

184− in TS.addError region (Just msg) var var

185− else return ()

186− liftIO $ UF.setDescriptor var (desc { mark = seen })

187− mapM_ check vars

188−

189−-- Check that a variable has rank == noRank, meaning that it can be generalized.

190−isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()

191−isGeneric region var = do

192− desc <- liftIO $ UF.descriptor var

193− if rank desc == noRank

194− then return ()

195− else let msg = "Unable to generalize a type variable. It is not unranked."

196− in TS.addError region (Just msg) var var

compiler/Type/State.hsdeleted−201

@@ -1,201 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.State where

3−

4−import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) )

5−import Control.Monad.State

6−import qualified Data.Map as Map

7−import qualified Data.Traversable as Traversable

8−import qualified Data.UnionFind.IO as UF

9−

10−import qualified AST.Annotation as A

11−import AST.PrettyPrint

12−import Text.PrettyPrint as P

13−import Type.Type

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 :: [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 :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor

50− -> StateT SolverState IO ()

51−addError region hint t1 t2 =

52− do err <- liftIO makeError

53− modify $ \state -> state { sErrors = err : sErrors state }

54− where

55− makeError = do

56− t1' <- pretty <$> toSrcType t1

57− t2' <- pretty <$> toSrcType t2

58− return . P.vcat $

59− [ P.text "Type error" <+> pretty region <> P.colon

60− , maybe P.empty P.text hint

61− , P.text ""

62− , P.nest 8 $ A.getRegionDocs region

63− , P.text ""

64− , P.text " Expected Type:" <+> t1'

65− , P.text " Actual Type:" <+> t2'

66− ]

67−

68−switchToPool pool = modifyPool (\_ -> pool)

69−

70−getPool :: StateT SolverState IO Pool

71−getPool = sPool <$> get

72−

73−getEnv :: StateT SolverState IO Env

74−getEnv = sEnv <$> get

75−

76−saveLocalEnv :: StateT SolverState IO ()

77−saveLocalEnv = do

78− env <- sEnv <$> get

79− modify $ \state -> state { sSavedEnv = env }

80−

81−uniqueMark :: StateT SolverState IO Int

82−uniqueMark = do

83− state <- get

84− let mark = sMark state

85− put $ state { sMark = mark + 1 }

86− return mark

87−

88−nextRankPool :: StateT SolverState IO Pool

89−nextRankPool = do

90− pool <- getPool

91− return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }

92−

93−register :: Variable -> StateT SolverState IO Variable

94−register variable = do

95− modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }

96− return variable

97−

98−introduce :: Variable -> StateT SolverState IO Variable

99−introduce variable = do

100− pool <- getPool

101− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })

102− register variable

103−

104−flatten :: Type -> StateT SolverState IO Variable

105−flatten term =

106− case term of

107− VarN maybeAlias v -> do

108− liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }

109− return v

110− TermN maybeAlias t -> do

111− flatStructure <- traverseTerm flatten t

112− pool <- getPool

113− var <- liftIO . UF.fresh $ Descriptor

114− { structure = Just flatStructure

115− , rank = maxRank pool

116− , flex = Flexible

117− , name = Nothing

118− , copy = Nothing

119− , mark = noMark

120− , alias = maybeAlias

121− }

122− register var

123−

124−makeInstance :: Variable -> StateT SolverState IO Variable

125−makeInstance var = do

126− alreadyCopied <- uniqueMark

127− freshVar <- makeCopy alreadyCopied var

128− restore alreadyCopied var

129− return freshVar

130−

131−makeCopy :: Int -> Variable -> StateT SolverState IO Variable

132−makeCopy alreadyCopied variable = do

133− desc <- liftIO $ UF.descriptor variable

134− case () of

135− () | mark desc == alreadyCopied ->

136− case copy desc of

137− Just v -> return v

138− Nothing -> error $ "Error copying type variable. This should be impossible." ++

139− " Please report an error to the github repo!"

140−

141− | rank desc /= noRank || flex desc == Constant ->

142− return variable

143−

144− | otherwise -> do

145− pool <- getPool

146− newVar <- liftIO $ UF.fresh $ Descriptor

147− { structure = Nothing

148− , rank = maxRank pool

149− , mark = noMark

150− , flex = case flex desc of

151− Is s -> Is s

152− _ -> Flexible

153− , copy = Nothing

154− , name = case flex desc of

155− Rigid -> Nothing

156− _ -> name desc

157− , alias = Nothing

158− }

159− register newVar

160−

161− -- Link the original variable to the new variable. This lets us

162− -- avoid making multiple copies of the variable we are instantiating.

163− --

164− -- Need to do this before recursively copying the structure of

165− -- the variable to avoid looping on cyclic terms.

166− liftIO $ UF.modifyDescriptor variable $ \desc ->

167− desc { mark = alreadyCopied, copy = Just newVar }

168−

169− -- Now we recursively copy the structure of the variable.

170− -- We have already marked the variable as copied, so we

171− -- will not repeat this work or crawl this variable again.

172− case structure desc of

173− Nothing -> return newVar

174− Just term -> do

175− newTerm <- traverseTerm (makeCopy alreadyCopied) term

176− liftIO $ UF.modifyDescriptor newVar $ \desc ->

177− desc { structure = Just newTerm }

178− return newVar

179−

180−restore :: Int -> Variable -> StateT SolverState IO Variable

181−restore alreadyCopied variable = do

182− desc <- liftIO $ UF.descriptor variable

183− if mark desc /= alreadyCopied

184− then return variable

185− else do

186− restoredStructure <-

187− Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)

188− liftIO $ UF.modifyDescriptor variable $ \desc ->

189− desc { mark = noMark, rank = noRank, structure = restoredStructure }

190− return variable

191−

192−traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

193−traverseTerm f term =

194− case term of

195− App1 a b -> App1 <$> f a <*> f b

196− Fun1 a b -> Fun1 <$> f a <*> f b

197− Var1 x -> Var1 <$> f x

198− EmptyRecord1 -> return EmptyRecord1

199− Record1 fields ext ->

200− Record1 <$> Traversable.traverse (mapM f) fields <*> f ext

201−

compiler/Type/Type.hsdeleted−444

@@ -1,444 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.Type where

3−

4−import qualified Data.Char as Char

5−import qualified Data.List as List

6−import qualified Data.Map as Map

7−import qualified Data.UnionFind.IO as UF

8−import Type.PrettyPrint

9−import Text.PrettyPrint as P

10−import System.IO.Unsafe

11−import Control.Applicative ((<$>),(<*>))

12−import Control.Monad.State (StateT, get, put, execStateT, runStateT)

13−import Control.Monad.Error (ErrorT, Error, liftIO)

14−import Data.Traversable (traverse)

15−import AST.Annotation

16−import qualified AST.PrettyPrint as PP

17−import qualified AST.Type as T

18−import qualified AST.Variable as Var

19−

20−data Term1 a

21− = App1 a a

22− | Fun1 a a

23− | Var1 a

24− | EmptyRecord1

25− | Record1 (Map.Map String [a]) a

26− deriving Show

27−

28−data TermN a

29− = VarN (Maybe Var.Canonical) a

30− | TermN (Maybe Var.Canonical) (Term1 (TermN a))

31− deriving Show

32−

33−varN :: a -> TermN a

34−varN = VarN Nothing

35−

36−termN :: (Term1 (TermN a)) -> TermN a

37−termN = TermN Nothing

38−

39−record :: Map.Map String [TermN a] -> TermN a -> TermN a

40−record fs rec = termN (Record1 fs rec)

41−

42−type Type = TermN Variable

43−type Variable = UF.Point Descriptor

44−

45−type SchemeName = String

46−type TypeName = Var.Canonical

47−

48−type Constraint a b = Located (BasicConstraint a b)

49−data BasicConstraint a b

50− = CTrue

51− | CSaveEnv

52− | CEqual a a

53− | CAnd [Constraint a b]

54− | CLet [Scheme a b] (Constraint a b)

55− | CInstance SchemeName a

56− deriving Show

57−

58−data Scheme a b = Scheme {

59− rigidQuantifiers :: [b],

60− flexibleQuantifiers :: [b],

61− constraint :: Constraint a b,

62− header :: Map.Map String a

63−} deriving Show

64−

65−type TypeConstraint = Constraint Type Variable

66−type TypeScheme = Scheme Type Variable

67−

68−monoscheme :: Map.Map String a -> Scheme a b

69−monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

70−

71−infixl 8 /\

72−

73−(/\) :: Constraint a b -> Constraint a b -> Constraint a b

74−a@(A _ c1) /\ b@(A _ c2) =

75− case (c1, c2) of

76− (CTrue, _) -> b

77− (_, CTrue) -> a

78− _ -> mergeOldDocs a b (CAnd [a,b])

79−

80−infixr 9 ==>

81−(==>) :: Type -> Type -> Type

82−a ==> b = termN (Fun1 a b)

83−

84−(<|) :: TermN a -> TermN a -> TermN a

85−f <| a = termN (App1 f a)

86−

87−data Descriptor = Descriptor

88− { structure :: Maybe (Term1 Variable)

89− , rank :: Int

90− , flex :: Flex

91− , name :: Maybe TypeName

92− , copy :: Maybe Variable

93− , mark :: Int

94− , alias :: Maybe Var.Canonical

95− } deriving Show

96−

97−noRank :: Int

98−noRank = -1

99−

100−outermostRank :: Int

101−outermostRank = 0

102−

103−noMark :: Int

104−noMark = 0

105−

106−initialMark :: Int

107−initialMark = 1

108−

109−data Flex = Rigid | Flexible | Constant | Is SuperType

110− deriving (Show, Eq)

111−

112−data SuperType = Number | Comparable | Appendable

113− deriving (Show, Eq)

114−

115−namedVar :: Flex -> Var.Canonical -> IO Variable

116−namedVar flex name = UF.fresh $ Descriptor

117− { structure = Nothing

118− , rank = noRank

119− , flex = flex

120− , name = Just name

121− , copy = Nothing

122− , mark = noMark

123− , alias = Nothing

124− }

125−

126−variable :: Flex -> IO Variable

127−variable flex = UF.fresh $ Descriptor

128− { structure = Nothing

129− , rank = noRank

130− , flex = flex

131− , name = Nothing

132− , copy = Nothing

133− , mark = noMark

134− , alias = Nothing

135− }

136−

137−

138−-- ex qs constraint == exists qs. constraint

139−ex :: [Variable] -> TypeConstraint -> TypeConstraint

140−ex fqs constraint@(A ann _) =

141− A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)

142−

143−-- fl qs constraint == forall qs. constraint

144−fl :: [Variable] -> TypeConstraint -> TypeConstraint

145−fl rqs constraint@(A ann _) =

146− A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)

147−

148−exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

149−exists f = do

150− v <- liftIO $ variable Flexible

151− ex [v] <$> f (varN v)

152−

153−existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

154−existsNumber f = do

155− v <- liftIO $ variable (Is Number)

156− ex [v] <$> f (varN v)

157−

158−

159−instance Show a => Show (UF.Point a) where

160− show point = unsafePerformIO $ fmap show (UF.descriptor point)

161−

162−

163−instance PrettyType a => PrettyType (UF.Point a) where

164− pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

165−

166−

167−instance PrettyType t => PrettyType (Annotated a t) where

168− pretty when (A _ e) = pretty when e

169−

170−

171−instance PrettyType a => PrettyType (Term1 a) where

172− pretty when term =

173− let prty = pretty Never in

174− case term of

175− App1 f x | P.render px == "_List" -> P.brackets (pretty Never x)

176− | otherwise -> parensIf needed (px <+> pretty App x)

177− where

178− px = prty f

179− needed = case when of

180− App -> True

181− _ -> False

182−

183− Fun1 arg body ->

184− parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)

185− where

186− needed = case when of

187− Never -> False

188− _ -> True

189−

190− Var1 x -> prty x

191−

192− EmptyRecord1 -> P.braces P.empty

193−

194− Record1 fields ext -> P.braces (extend <+> commaSep prettyFields)

195− where

196− prettyExt = prty ext

197− extend | P.render prettyExt == "{}" = P.empty

198− | otherwise = prettyExt <+> P.text "|"

199− mkPretty f t = P.text f <+> P.text ":" <+> prty t

200− prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

201−

202−

203−instance PrettyType a => PrettyType (TermN a) where

204− pretty when term =

205− case term of

206− VarN alias x -> either alias (pretty when x)

207− TermN alias t1 -> either alias (pretty when t1)

208− where

209− either maybeAlias doc =

210− case maybeAlias of

211− Just alias -> PP.pretty alias

212− Nothing -> doc

213−

214−instance PrettyType Descriptor where

215− pretty when desc = do

216− case (alias desc, structure desc, name desc) of

217− (Just name, _, _) -> PP.pretty name

218− (_, Just term, _) -> pretty when term

219− (_, _, Just name)

220− | Var.isTuple name ->

221− P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','

222− | otherwise ->

223− P.text (Var.toString name)

224−

225− _ -> P.text "?"

226−

227−

228−instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

229− pretty _ constraint =

230− let prty = pretty Never in

231− case constraint of

232− CTrue -> P.text "True"

233− CSaveEnv -> P.text "SaveTheEnvironment!!!"

234− CEqual a b -> prty a <+> P.text "=" <+> prty b

235− CAnd [] -> P.text "True"

236−

237− CAnd cs ->

238− P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

239−

240− CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->

241− P.sep [ binder, pretty Never c ]

242− where

243− mergeExists vs (A _ c) =

244− case c of

245− CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'

246− _ -> (vs, c)

247−

248− (fqs', c) = mergeExists fqs constraint

249−

250− binder = if null fqs' then P.empty else

251− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."

252−

253− CLet schemes constraint ->

254− P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)

255− , P.text "in", pretty Never constraint ]

256−

257− CInstance name tipe ->

258− P.text name <+> P.text "<" <+> prty tipe

259−

260−instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

261− pretty _ (Scheme rqs fqs (A _ constraint) headers) =

262− P.sep [ forall, cs, headers' ]

263− where

264− prty = pretty Never

265−

266− forall = if null rqs && null fqs then P.empty else

267− P.text "\x2200" <+> frees <+> rigids

268−

269− frees = P.hsep $ map prty fqs

270− rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs

271−

272− cs = case constraint of

273− CTrue -> P.empty

274− CAnd [] -> P.empty

275− _ -> P.brackets (pretty Never constraint)

276−

277− headers' = if Map.size headers > 0 then dict else P.empty

278− dict = P.parens . commaSep . map prettyPair $ Map.toList headers

279− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t

280−

281−

282−extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc

283−extraPretty t = pretty Never <$> addNames t

284−

285−addNames :: (Crawl t) => t -> IO t

286−addNames value = do

287− (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

288− let vars = map head . List.group $ List.sort rawVars

289− suffix s = map (++s) (map (:[]) ['a'..'z'])

290− allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

291− okayVars = filter (`notElem` vars) allVars

292− runStateT (crawl rename value) (okayVars, 0, 0, 0)

293− return value

294− where

295− getNames desc state@(vars, a, b, c) =

296− let name' = name desc in

297− case name' of

298− Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))

299− _ -> (name', state)

300−

301− rename desc state@(vars, a, b, c) =

302− case name desc of

303− Just var -> (Just var, state)

304− Nothing ->

305− case flex desc of

306− Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))

307− Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

308− Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

309− _ -> (local $ head vars, (tail vars, a, b, c))

310− where

311− local v = Just (Var.local v)

312−

313−type CrawlState = ([String], Int, Int, Int)

314−

315−-- Code for traversing all the type data-structures and giving

316−-- names to the variables embedded deep in there.

317−class Crawl t where

318− crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))

319− -> t

320− -> StateT CrawlState IO t

321−

322−instance Crawl e => Crawl (Annotated a e) where

323− crawl nextState (A ann e) = A ann <$> crawl nextState e

324−

325−instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

326− crawl nextState constraint =

327− let rnm = crawl nextState in

328− case constraint of

329− CTrue -> return CTrue

330− CSaveEnv -> return CSaveEnv

331− CEqual a b -> CEqual <$> rnm a <*> rnm b

332− CAnd cs -> CAnd <$> crawl nextState cs

333− CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c

334− CInstance name tipe -> CInstance name <$> rnm tipe

335−

336−instance Crawl a => Crawl [a] where

337− crawl nextState list = mapM (crawl nextState) list

338−

339−instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

340− crawl nextState (Scheme rqs fqs c headers) =

341− let rnm = crawl nextState in

342− Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers

343−

344−instance Crawl t => Crawl (TermN t) where

345− crawl nextState tipe =

346− case tipe of

347− VarN a x -> VarN a <$> crawl nextState x

348− TermN a term -> TermN a <$> crawl nextState term

349−

350−instance Crawl t => Crawl (Term1 t) where

351− crawl nextState term =

352− let rnm = crawl nextState in

353− case term of

354− App1 a b -> App1 <$> rnm a <*> rnm b

355− Fun1 a b -> Fun1 <$> rnm a <*> rnm b

356− Var1 a -> Var1 <$> rnm a

357− EmptyRecord1 -> return EmptyRecord1

358− Record1 fields ext ->

359− Record1 <$> traverse (mapM rnm) fields <*> rnm ext

360−

361−instance Crawl a => Crawl (UF.Point a) where

362− crawl nextState point = do

363− desc <- liftIO $ UF.descriptor point

364− desc' <- crawl nextState desc

365− liftIO $ UF.setDescriptor point desc'

366− return point

367−

368−instance Crawl Descriptor where

369− crawl nextState desc = do

370− state <- get

371− let (name', state') = nextState desc state

372− structure' <- traverse (crawl nextState) (structure desc)

373− put state'

374− return $ desc { name = name', structure = structure' }

375−

376−

377−toSrcType :: Variable -> IO T.CanonicalType

378−toSrcType var =

379− go =<< addNames var

380− where

381− go v = do

382− desc <- UF.descriptor v

383− srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

384− return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)

385−

386− backupSrcType desc =

387− case name desc of

388− Just v@(Var.Canonical _ x@(c:_))

389− | Char.isLower c -> return (T.Var x)

390− | otherwise -> return $ T.Type v

391−

392− _ -> error $ concat

393− [ "Problem converting the following type "

394− , "from a type-checker type to a source-syntax type:"

395− , P.render (pretty Never var) ]

396−

397− termToSrcType term =

398− case term of

399− App1 a b -> do

400− a' <- go a

401− b' <- go b

402− case a' of

403− T.App f args -> return $ T.App f (args ++ [b'])

404− _ -> return $ T.App a' [b']

405−

406− Fun1 a b -> T.Lambda <$> go a <*> go b

407−

408− Var1 a -> go a

409−

410− EmptyRecord1 -> return $ T.Record [] Nothing

411−

412− Record1 tfields extension -> do

413− fields' <- traverse (mapM go) tfields

414− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

415− ext' <- dealias <$> go extension

416− return $ case ext' of

417− T.Record fs ext -> T.Record (fs ++ fields) ext

418− T.Var _ -> T.Record fields (Just ext')

419− _ -> error "Used toSrcType on a type that is not well-formed"

420−

421− dealias :: T.CanonicalType -> T.CanonicalType

422− dealias t =

423− case t of

424− T.Aliased _ t' -> t'

425− _ -> t

426−

427−

428−data AppStructure = List Variable | Tuple [Variable] | Other

429−

430−collectApps :: Variable -> IO AppStructure

431−collectApps var = go [] var

432− where

433− go vars var = do

434− desc <- UF.descriptor var

435− case (structure desc, vars) of

436− (Nothing, [v]) -> case name desc of

437− Just n | Var.isList n -> return (List v)

438− _ -> return Other

439− (Nothing, vs) -> case name desc of

440− Just n | Var.isTuple n -> return (Tuple vs)

441− _ -> return Other

442− (Just term, _) -> case term of

443− App1 a b -> go (vars ++ [b]) a

444− _ -> return Other

compiler/Type/Unify.hsdeleted−233

@@ -1,233 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.Unify (unify) where

3−

4−import Control.Applicative ((<|>))

5−import Control.Monad.State

6−import qualified Data.List as List

7−import qualified Data.Map as Map

8−import qualified Data.Maybe as Maybe

9−import qualified Data.UnionFind.IO as UF

10−import qualified AST.Annotation as A

11−import qualified AST.Variable as Var

12−import qualified Type.State as TS

13−import Type.Type

14−import Type.PrettyPrint

15−import Text.PrettyPrint (render)

16−

17−unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

18−unify region variable1 variable2 = do

19− equivalent <- liftIO $ UF.equivalent variable1 variable2

20− if equivalent then return ()

21− else actuallyUnify region variable1 variable2

22−

23−actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

24−actuallyUnify region variable1 variable2 = do

25− desc1 <- liftIO $ UF.descriptor variable1

26− desc2 <- liftIO $ UF.descriptor variable2

27− let unify' = unify region

28−

29− (name', flex', rank', alias') = combinedDescriptors desc1 desc2

30−

31− merge1 :: StateT TS.SolverState IO ()

32− merge1 = liftIO $ do

33− if rank desc1 < rank desc2 then UF.union variable2 variable1

34− else UF.union variable1 variable2

35− UF.modifyDescriptor variable1 $ \desc ->

36− desc { structure = structure desc1

37− , flex = flex'

38− , name = name'

39− , alias = alias'

40− }

41−

42− merge2 :: StateT TS.SolverState IO ()

43− merge2 = liftIO $ do

44− if rank desc1 < rank desc2 then UF.union variable2 variable1

45− else UF.union variable1 variable2

46− UF.modifyDescriptor variable2 $ \desc ->

47− desc { structure = structure desc2

48− , flex = flex'

49− , name = name'

50− , alias = alias'

51− }

52−

53− merge = if rank desc1 < rank desc2 then merge1 else merge2

54−

55− fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

56− fresh structure = do

57− v <- liftIO . UF.fresh $ Descriptor

58− { structure = structure

59− , rank = rank'

60− , flex = flex'

61− , name = name'

62− , copy = Nothing

63− , mark = noMark

64− , alias = alias'

65− }

66− TS.register v

67−

68− flexAndUnify v = do

69− liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

70− unify' variable1 variable2

71−

72− unifyNumber svar (Var.Canonical home name) =

73− case home of

74− Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

75− Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

76− _ -> let hint = "A number must be an Int or Float."

77− in TS.addError region (Just hint) variable1 variable2

78−

79− comparableError maybe =

80− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

81− where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."

82−

83− appendableError maybe =

84− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

85− where msg = "An appendable must be of type String, List, or Text."

86−

87− unifyComparable v (Var.Canonical home name) =

88− case home of

89− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

90− Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

91− _ -> 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 (variable $ 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] $ \_ -> variable (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− _ -> appendableError Nothing

112−

113− rigidError var = TS.addError region (Just hint) variable1 variable2

114− where

115− var' = "'" ++ render (pretty Never var) ++ "'"

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 name)

136− | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1

137− (_, Is Appendable, Just name, _)

138− | Var.isText name || Var.isPrim "String" name -> 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 region 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 region Nothing variable1 variable2

200−

201−combinedDescriptors :: Descriptor -> Descriptor

202− -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)

203−combinedDescriptors desc1 desc2 =

204− (name', flex', rank', alias')

205− where

206− rank' :: Int

207− rank' = min (rank desc1) (rank desc2)

208−

209− alias' :: Maybe Var.Canonical

210− alias' = alias desc1 <|> alias desc2

211−

212− name' :: Maybe Var.Canonical

213− name' = case (name desc1, name desc2) of

214− (Just name1, Just name2) ->

215− case (flex desc1, flex desc2) of

216− (_, Flexible) -> Just name1

217− (Flexible, _) -> Just name2

218− (Is Number, Is _) -> Just name1

219− (Is _, Is Number) -> Just name2

220− (Is _, Is _) -> Just name1

221− (_, _) -> Nothing

222− (Just name1, _) -> Just name1

223− (_, Just name2) -> Just name2

224− _ -> Nothing

225−

226− flex' :: Flex

227− flex' = case (flex desc1, flex desc2) of

228− (f, Flexible) -> f

229− (Flexible, f) -> f

230− (Is Number, Is _) -> Is Number

231− (Is _, Is Number) -> Is Number

232− (Is super, Is _) -> Is super

233− (_, _) -> Flexible

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

This diff is too big to show here.

compiler/src/Canonicalize/Pattern.hsnew file+181

This diff is too big to show here.

compiler/src/Canonicalize/Type.hsnew file+162

This diff is too big to show here.

compiler/src/Compile.hsnew file+92

This diff is too big to show here.

compiler/src/Data/Bag.hsnew file+110

This diff is too big to show here.

compiler/src/Data/Index.hsnew file+132

This diff is too big to show here.

compiler/src/Data/Map/Utils.hsnew file+43

This diff is too big to show here.

compiler/src/Data/Name.hsnew file+610

This diff is too big to show here.

compiler/src/Data/NonEmptyList.hsnew file+78

This diff is too big to show here.

compiler/src/Data/OneOrMore.hsnew file+99

This diff is too big to show here.

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.md → docs/upgrade-instructions/earlier.mdrenamed+128−26

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/Array.elmdeleted−198

This diff is too big to show here.

libraries/Basics.elmdeleted−419

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−272

This diff is too big to show here.

libraries/Date.elmdeleted−76

This diff is too big to show here.

libraries/Debug.elmdeleted−88

This diff is too big to show here.

libraries/Dict.elmdeleted−419

This diff is too big to show here.

libraries/Either.elmdeleted−91

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−178

This diff is too big to show here.

libraries/Graphics/Input/Field.elmdeleted−170

This diff is too big to show here.

libraries/Http.elmdeleted−54

This diff is too big to show here.

libraries/JavaScript/Experimental.elmdeleted−56

This diff is too big to show here.

libraries/Json.elmdeleted−49

This diff is too big to show here.

libraries/Keyboard.elmdeleted−82

This diff is too big to show here.

libraries/List.elmdeleted−326

This diff is too big to show here.

libraries/Maybe.elmdeleted−61

This diff is too big to show here.

libraries/Mouse.elmdeleted−36

This diff is too big to show here.

libraries/Native/Array.jsdeleted−709

This diff is too big to show here.

libraries/Native/Basics.jsdeleted−111

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−31

This diff is too big to show here.

libraries/Native/Color.jsdeleted−32

This diff is too big to show here.

libraries/Native/Date.jsdeleted−33

This diff is too big to show here.

libraries/Native/Debug.jsdeleted−60

This diff is too big to show here.

libraries/Native/Error.jsdeleted−30

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−410

This diff is too big to show here.

libraries/Native/JavaScript.jsdeleted−68

This diff is too big to show here.

libraries/Native/Json.jsdeleted−85

This diff is too big to show here.

libraries/Native/List.jsdeleted−395

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−103

This diff is too big to show here.

libraries/Native/Show.jsdeleted−132

This diff is too big to show here.

libraries/Native/Signal/Http.jsdeleted−63

This diff is too big to show here.

libraries/Native/Signal/Keyboard.jsdeleted−154

This diff is too big to show here.

libraries/Native/Signal/Mouse.jsdeleted−47

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−227

This diff is too big to show here.

libraries/Native/Signal/Time.jsdeleted−70

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−36

This diff is too big to show here.

libraries/Native/Signal/Window.jsdeleted−57

This diff is too big to show here.

libraries/Native/String.jsdeleted−252

This diff is too big to show here.

libraries/Native/Text.jsdeleted−167

This diff is too big to show here.

libraries/Native/Trampoline.jsdeleted−24

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−267

This diff is too big to show here.

libraries/Random.elmdeleted−30

This diff is too big to show here.

libraries/Regex.elmdeleted−126

This diff is too big to show here.

libraries/Set.elmdeleted−102

This diff is too big to show here.

libraries/Signal.elmdeleted−170

This diff is too big to show here.

libraries/String.elmdeleted−340

This diff is too big to show here.

libraries/Text.elmdeleted−221

This diff is too big to show here.

libraries/Time.elmdeleted−99

This diff is too big to show here.

libraries/Touch.elmdeleted−34

This diff is too big to show here.

libraries/Trampoline.elmdeleted−49

This diff is too big to show here.

libraries/Transform2D.elmdeleted−96

This diff is too big to show here.

libraries/WebSocket.elmdeleted−21

This diff is too big to show here.

libraries/Window.elmdeleted−27

This diff is too big to show here.

libraries/elm_dependencies.jsondeleted−42

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/Debugger.jsdeleted−604

This diff is too big to show here.

runtime/HotSwap.jsdeleted−42

This diff is too big to show here.

runtime/Init.jsdeleted−279

This diff is too big to show here.

runtime/Render/Collage.jsdeleted−355

This diff is too big to show here.

runtime/Render/Element.jsdeleted−469

This diff is too big to show here.

runtime/Render/Utils.jsdeleted−40

This diff is too big to show here.

runtime/Utils.jsdeleted−62

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

This diff is too big to show here.

tests/compiler/Tests/Compiler.hsdeleted−62

This diff is too big to show here.

tests/compiler/Tests/Property.hsdeleted−56

This diff is too big to show here.

tests/compiler/Tests/Property/Arbitrary.hsdeleted−137

This diff is too big to show here.

tests/compiler/test-files/Imports.elmdeleted−22

This diff is too big to show here.

tests/compiler/test-files/bad/BBTArgsdeleted−1

This diff is too big to show here.

tests/compiler/test-files/bad/Imports/UseHiddenValues.elmdeleted−4

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

tests/compiler/test-files/good/Imports/OverlappingImports.elmdeleted−5

This diff is too big to show here.

tests/compiler/test-files/good/Imports/UseHiddenTypes.elmdeleted−4

This diff is too big to show here.

tests/compiler/test-files/good/Imports/UseRecordConstructor.elmdeleted−4

This diff is too big to show here.

tests/compiler/test-files/good/Imports/UseTypeConstructor.elmdeleted−4

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

tests/compiler/test-files/good/Ports.elmdeleted−17

This diff is too big to show here.

tests/compiler/test-files/good/PortsWithTypeAliases.elmdeleted−8

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

tests/libraries/LibraryTest.hsdeleted−55

This diff is too big to show here.

tests/libraries/Test.elmdeleted−42

This diff is too big to show here.

tests/libraries/Test/Array.elmdeleted−78

This diff is too big to show here.

tests/libraries/Test/Basics.elmdeleted−20

This diff is too big to show here.

tests/libraries/Test/Char.elmdeleted−15

This diff is too big to show here.

tests/libraries/Test/CodeGen.elmdeleted−55

This diff is too big to show here.

tests/libraries/Test/Dict.elmdeleted−49

This diff is too big to show here.

tests/libraries/Test/Equality.elmdeleted−24

This diff is too big to show here.

tests/libraries/Test/List.elmdeleted−90

This diff is too big to show here.

tests/libraries/Test/Set.elmdeleted−27

This diff is too big to show here.

tests/libraries/Test/String.elmdeleted−37

This diff is too big to show here.

tests/libraries/Test/Trampoline.elmdeleted−29

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.