3116898...master · elk

.github/CONTRIBUTING.md+18−20

@@ -4,10 +4,15 @@ Thanks helping with the development of Elm! This document describes the basic

44standards for opening pull requests and making the review process as smooth as

55possible.

66

7−## Licensing

87

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

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

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+

1116

1217## Style Guide

1318

@@ -17,27 +22,20 @@ and send it to <info@elm-lang.org> before opening your pull request.

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

1823[js]: https://google.github.io/styleguide/javascriptguide.xml

1924

20−## Branches

2125

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!

26+## Branches

2527

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.

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!

2931

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

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

3233

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.

3734

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.

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+

4241

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

.github/ISSUE_TEMPLATE.md+14−9

@@ -1,13 +1,18 @@

1−BEFORE DELETING THIS:

21

3−- Runtime error? https://github.com/elm-lang/elm-compiler/issues/1591

4−- Type annotations? https://github.com/elm-lang/elm-compiler/issues/1214

5−- Core libraries? https://github.com/elm-lang/core/issues

6−- Bad error message? https://github.com/elm-lang/error-message-catalog/issues

7−- Compiler hangs? https://github.com/elm-lang/elm-compiler/issues/1240

8−- Parser / code gen problem? https://github.com/elm-lang/elm-compiler/labels/meta

2+**Quick Summary:** ???

93

104

11−If none of that applies, write up a report that satisfies this checklist:

5+## SSCCE

126

13− https://github.com/process-bot/contribution-checklist/blob/master/issues.md

7+```elm

8+

9+```

10+

11+- **Elm:** ???

12+- **Browser:** ???

13+- **Operating System:** ???

14+

15+

16+## Additional Details

17+

18+???

.github/PULL_REQUEST_TEMPLATE.mdnew file+18

@@ -0,0 +1,18 @@

1+

2+**Quick Summary:** ???

3+

4+

5+## SSCCE

6+

7+```elm

8+

9+```

10+

11+- **Elm:** ???

12+- **Browser:** ???

13+- **Operating System:** ???

14+

15+

16+## Additional Details

17+

18+???

.github/workflows/set-issue-expectations.ymlnew file+21

@@ -0,0 +1,21 @@

1+name: Set Issue Expectations

2+on:

3+ issues:

4+ types: [opened]

5+jobs:

6+ comment-on-issue:

7+ name: Comment On Issue

8+ runs-on: ubuntu-latest

9+ steps:

10+ - uses: actions/github@v1.0.0

11+ env:

12+ GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}

13+ with:

14+ args: |

15+ comment "Thanks for reporting this! To set expectations:

16+

17+ - Issues are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.

18+ - Ask questions in a [community forum](https://elm-lang.org/community). You will get an answer quicker that way!

19+ - If you experience something similar, open a new issue. [We like duplicates](https://github.com/elm/expectations/blob/master/duplicates.md).

20+

21+ Finally, please be patient with the core team. They are trying their best with limited resources."

.github/workflows/set-pull-expectations.ymlnew file+19

@@ -0,0 +1,19 @@

1+on:

2+ pull_request_target:

3+ types: [opened]

4+

5+jobs:

6+ comment-on-pull:

7+ name: Comment On Pull

8+ runs-on: ubuntu-latest

9+ steps:

10+ - uses: actions/github-script@v3

11+ with:

12+ github-token: ${{secrets.GITHUB_TOKEN}}

13+ script: |

14+ github.issues.createComment({

15+ issue_number: context.issue.number,

16+ owner: context.repo.owner,

17+ repo: context.repo.repo,

18+ body: "Thanks for suggesting these code changes. To set expectations:\n\n- Pull requests are reviewed in [batches](https://github.com/elm/expectations/blob/master/batching.md), so it can take some time to get a response.\n- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).\n- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.\n\nFinally, please be patient with the core team. They are trying their best with limited resources."

19+ })

.gitignore+1

@@ -5,3 +5,4 @@ cabal-dev

55cabal.sandbox.config

66.DS_Store

77*~

8+travis.log

.gitmodulesdeleted

No changes to the content.

.travis.yml+23−20

@@ -1,25 +1,28 @@

1−sudo: false

2−

3−addons:

4− apt:

5− sources:

6− - hvr-ghc

7− packages:

8− - ghc-7.10.1

9− - cabal-install-1.22

10− - happy

11− - alex

1+language: minimal

2+services: docker

123

4+env:

5+ global:

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

137

148before_install:

15−- export PATH=/opt/ghc/7.10.1/bin:/opt/cabal/1.22/bin:$PATH

16−

17−

18−install:

19− - travis_retry cabal update

20− - cabal install --only-dependencies --enable-tests

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

2112

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

2222

23−script:

24− - cabal configure --enable-tests

25− - cabal test

23+notifications:

24+ email:

25+ recipients:

26+ - rlefevre@dmy.fr

27+ on_success: change

28+ on_failure: change

ContributorAgreement.pdfdeleted

Binary file not shown.

How to Request Features.mddeleted−93

@@ -1,93 +0,0 @@

1−# How to make a Feature Request

2−

3−Adding features is hard work and has long term implications for Elm.

4−If you think your particular feature is important, help make it happen

5−by doing some of the background work that goes into actually adding it.

6−

7−### Before making a Request / Formatting:

8−

9− - Make sure your feature has not already been requested. Look through the

10− email list to find similar requests.

11− - Submit feature requests by emailing the list. This allows the broadest

12− discussion and does not clutter up the GitHub repository with speculative

13− issues. I'd prefer to use the GitHub issue tracker for bug tracking and

14− issues with the existing code base.

15− - Label all feature requests with a subject like "Request: _____". For

16− example, if you want to be the umpteenth person to request type classes,

17− you would use the subject "Request: Type Classes".

18−

19−### Body of the Request:

20−

21−Your request should address all of the following issues:

22−

23−**General Problem:** Clearly define the purpose of adding the feature.

24−What general problem do you want to solve? Why is that problem important?

25−Why is it important for a functional GUI language?

26−

27−**Specific Use-Cases:** What are the specific cases when the general problem

28−is actually an issue? How often does this case come up? Why are these cases

29−important to easily designing graphical user interfaces? Why are existing

30−solutions in Elm unsuitable?

31−

32−**Background Materials:** Are there relevant papers on the topic? Are there

33−languages or libraries that already have this feature? Organize this material

34−and provide a concise and helpful overview.

35−

36−**Alternatives:** What are all the ways to address the general problem or a

37−closely related problem? For example, the semantic flexibility of type classes

38−can be largely replicated with a module system in the style of ML.

39−What are the strengths and weakness of each of the alternative solutions?

40−

41−**Suggested Approach:** Outline your specific approach. How does it address

42−the general problem? How does it work? How hard is it going to be to add?

43−What other language features does it depend on that need to be added first?

44−Try to take a look at the relevant code to see if it would require significant

45−changes. If you are suggesting an API or library changes, include an interface

46−(a list of type signatures) for the functions you would like to add (perhaps

47−multiple interfaces if there are many good approaches).

48−

49−**Known Issues:** Search for issues that people have already found. Think of

50−any other possible downside and list them too. For example, one downside of

51−typeclasses is that they are globally defined for each type, so you cannot

52−have multiple `Ord` instances for Strings. This can lead to namespace pollution

53−within a project. In general you can only implement an "interface" once per

54−type, so it is very tricky to get the flexibility of ML's module functors.

55−

56−**Justification:** Why is the added complexity of your feature worth it? Discuss

57−both implementation complexity in the compiler, and conceptual complexity that

58−users must deal with. Why is your feature better than the alternative solutions?

59−Why is it okay to ignore the known issues? Is there any way to overcome the known

60−issues? Will it be difficult or confusing for users coming from JavaScript?

61−

62−### Some final notes:

63−

64−If for some reason you cannot provide details for some of these categories,

65−explain why the category is not applicable.

66−

67−Re-read before posting. Is your request constructive? Is it well organized?

68−Are there any details you forgot? Can anything be clarified or trimmed down?

69−Considering a request takes time, so be considerate about how much work a

70−reader has to do to take it seriously.

71−

72−A feature request is not an opportunity to be sassy or glib. Try to present

73−the information and argument clearly, concisely, thoroughly, and in an unbiased

74−manner.

75−

76−This is likely to be an iterative process. People will have comments and

77−questions. Everyone please be kind. Commenters, if you think you have a

78−concern, raise it as a question: "But what happens when you do blah?" instead

79−of "This will break when you do blah". Assume you have misunderstood their

80−proposal or only have a shallow understanding of it. Seek clarification, not victory.

81−

82−Comments are not a place for flame wars. Discuss specific issues. Vague

83−complaining and unsupported claims should either be forgotten or developed

84−into specific and well-supported concerns.

85−

86−I am always working hard to add cool stuff to Elm, and it is a lot of work.

87−I must prioritize issues to focus on the things that have the highest impact

88−for improving the quality of Elm, addressing the concerns of current users,

89−and making Elm more appealing for new users. I do not have infinite time,

90−so some things must receive more attention than others. I apologize in advance.

91−

92−And to summarize, just be cool! I want Elm to be really fun and easy to use,

93−and I want your projects to be amazing!

LICENSE+6−25

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

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+10−5

@@ -1,17 +1,22 @@

1−# The Elm Compiler [![Build Status](https://travis-ci.org/elm-lang/elm-compiler.svg?branch=master)](https://travis-ci.org/elm-lang/elm-compiler)

1+# Elm

22

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

3+A delightful language for reliable webapps.

44

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>

59

610## Install

711

8−Follow [these instructions][installer]!

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

913

10− [installer]: https://guide.elm-lang.org/install.html

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

1115

16+<br>

1217

1318## Help

1419

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

1621

17−[slack]: http://elmlang.herokuapp.com/

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

Setup.hsdeleted−2

@@ -1,2 +0,0 @@

1−import Distribution.Simple

2−main = defaultMain

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

src/AST/Canonical.hs → compiler/src/AST/Canonical.hsrenamed+99−72

@@ -3,6 +3,7 @@

33module AST.Canonical

44 ( Expr, Expr_(..)

55 , CaseBranch(..)

6+ , FieldUpdate(..)

67 , CtorOpts(..)

78 -- definitions

89 , Def(..)

@@ -14,13 +15,14 @@ module AST.Canonical

1415 , Annotation(..)

1516 , Type(..)

1617 , AliasType(..)

18+ , FieldType(..)

19+ , fieldsToList

1720 -- modules

1821 , Module(..)

1922 , Alias(..)

2023 , Binop(..)

2124 , Union(..)

2225 , Ctor(..)

23− , Docs(..)

2426 , Exports(..)

2527 , Export(..)

2628 , Effects(..)

@@ -30,7 +32,7 @@ module AST.Canonical

3032 where

3133

3234{- Creating a canonical AST means finding the home module for all variables.

33−So if you have L.map, you need to figure out that it is from the elm-lang/core

35+So if you have L.map, you need to figure out that it is from the elm/core

3436package in the List module.

3537

3638In later phases (e.g. type inference, exhaustiveness checking, optimization)

@@ -51,17 +53,18 @@ So it is clear why the data is kept around.

5153

5254import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)

5355import Data.Binary

54−import qualified Data.ByteString as B

56+import qualified Data.List as List

5557import qualified Data.Map as Map

56−import Data.Text (Text)

58+import Data.Name (Name)

5759

60+import qualified AST.Source as Src

5861import qualified AST.Utils.Binop as Binop

59−import qualified AST.Module.Name as ModuleName

6062import qualified AST.Utils.Shader as Shader

6163import qualified Data.Index as Index

62−import qualified Elm.Name as N

64+import qualified Elm.Float as EF

65+import qualified Elm.ModuleName as ModuleName

66+import qualified Elm.String as ES

6367import qualified Reporting.Annotation as A

64−import qualified Reporting.Region as R

6568

6669

6770

@@ -74,20 +77,20 @@ type Expr =

7477

7578-- CACHE Annotations for type inference

7679data Expr_

77− = VarLocal N.Name

78− | VarTopLevel ModuleName.Canonical N.Name

79− | VarKernel N.Name N.Name

80− | VarForeign ModuleName.Canonical N.Name Annotation

81− | VarCtor CtorOpts ModuleName.Canonical N.Name Index.ZeroBased Annotation

82− | VarDebug ModuleName.Canonical N.Name Annotation

83− | VarOperator N.Name ModuleName.Canonical N.Name Annotation -- CACHE real name for optimization

84− | Chr Text

85− | Str Text

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

8689 | Int Int

87− | Float Double

90+ | Float EF.Float

8891 | List [Expr]

8992 | Negate Expr

90− | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr -- CACHE real name for optimization

93+ | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization

9194 | Lambda [Pattern] Expr

9295 | Call Expr [Expr]

9396 | If [(Expr, Expr)] Expr

@@ -95,26 +98,30 @@ data Expr_

9598 | LetRec [Def] Expr

9699 | LetDestruct Pattern Expr Expr

97100 | Case Expr [CaseBranch]

98− | Accessor N.Name

99− | Access Expr N.Name

100− | Update Expr (Map.Map N.Name Expr)

101− | Record (Map.Map N.Name Expr)

101+ | Accessor Name

102+ | Access Expr (A.Located Name)

103+ | Update Name Expr (Map.Map Name FieldUpdate)

104+ | Record (Map.Map Name Expr)

102105 | Unit

103106 | Tuple Expr Expr (Maybe Expr)

104− | Shader Text Text Shader.Shader

107+ | Shader Shader.Source Shader.Types

105108

106109

107110data CaseBranch =

108111 CaseBranch Pattern Expr

109112

110113

114+data FieldUpdate =

115+ FieldUpdate A.Region Expr

116+

117+

111118

112119-- DEFS

113120

114121

115122data Def

116− = Def (A.Located N.Name) [Pattern] Expr

117− | TypedDef (A.Located N.Name) FreeVars [(Pattern, Type)] Expr Type

123+ = Def (A.Located Name) [Pattern] Expr

124+ | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type

118125

119126

120127

@@ -123,7 +130,7 @@ data Def

123130

124131data Decls

125132 = Declare Def Decls

126− | DeclareRec [Def] Decls

133+ | DeclareRec Def [Def] Decls

127134 | SaveTheEnvironment

128135

129136

@@ -137,21 +144,22 @@ type Pattern =

137144

138145data Pattern_

139146 = PAnything

140− | PVar N.Name

141− | PRecord [N.Name]

142− | PAlias Pattern N.Name

147+ | PVar Name

148+ | PRecord [Name]

149+ | PAlias Pattern Name

143150 | PUnit

144151 | PTuple Pattern Pattern (Maybe Pattern)

145152 | PList [Pattern]

146153 | PCons Pattern Pattern

147− | PChr Text

148− | PStr Text

154+ | PBool Union Bool

155+ | PChr ES.String

156+ | PStr ES.String

149157 | PInt Int

150158 | PCtor

151159 { _p_home :: ModuleName.Canonical

152− , _p_type :: N.Name

160+ , _p_type :: Name

153161 , _p_union :: Union

154− , _p_name :: N.Name

162+ , _p_name :: Name

155163 , _p_index :: Index.ZeroBased

156164 , _p_args :: [PatternCtorArg]

157165 }

@@ -174,24 +182,47 @@ data PatternCtorArg =

174182

175183

176184data Annotation = Forall FreeVars Type

185+ deriving (Eq)

177186

178187

179−type FreeVars = Map.Map N.Name ()

188+type FreeVars = Map.Map Name ()

180189

181190

182191data Type

183192 = TLambda Type Type

184− | TVar N.Name

185− | TType ModuleName.Canonical N.Name [Type]

186− | TRecord (Map.Map N.Name Type) (Maybe N.Name)

193+ | TVar Name

194+ | TType ModuleName.Canonical Name [Type]

195+ | TRecord (Map.Map Name FieldType) (Maybe Name)

187196 | TUnit

188197 | TTuple Type Type (Maybe Type)

189− | TAlias ModuleName.Canonical N.Name [(N.Name, Type)] AliasType

198+ | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType

199+ deriving (Eq)

190200

191201

192202data AliasType

193203 = Holey Type

194204 | 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))

195226

196227

197228

@@ -201,27 +232,32 @@ data AliasType

201232data Module =

202233 Module

203234 { _name :: ModuleName.Canonical

204− , _docs :: Docs

205235 , _exports :: Exports

236+ , _docs :: Src.Docs

206237 , _decls :: Decls

207− , _unions :: Map.Map N.Name Union

208− , _aliases :: Map.Map N.Name Alias

209− , _binops :: Map.Map N.Name Binop

238+ , _unions :: Map.Map Name Union

239+ , _aliases :: Map.Map Name Alias

240+ , _binops :: Map.Map Name Binop

210241 , _effects :: Effects

211242 }

212243

213244

214−data Alias = Alias [N.Name] Type (Maybe [(N.Name,Type)])

215−data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name

245+data Alias = Alias [Name] Type

246+ deriving (Eq)

247+

248+

249+data Binop = Binop_ Binop.Associativity Binop.Precedence Name

250+ deriving (Eq)

216251

217252

218253data Union =

219254 Union

220− { _u_vars :: [N.Name]

255+ { _u_vars :: [Name]

221256 , _u_alts :: [Ctor]

222257 , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking

223258 , _u_opts :: CtorOpts -- CACHE which optimizations are available

224259 }

260+ deriving (Eq)

225261

226262

227263data CtorOpts

@@ -231,22 +267,8 @@ data CtorOpts

231267 deriving (Eq, Ord)

232268

233269

234−data Ctor =

235− Ctor N.Name Index.ZeroBased Int [Type] -- CACHE length args

236−

237−

238−

239−-- DOCS

240−

241−

242−data Docs

243− = NoDocs R.Position R.Position

244− | YesDocs

245− { _start :: R.Position

246− , _end :: R.Position

247− , _overview :: B.ByteString

248− , _comments :: Map.Map N.Name Text

249− }

270+data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args

271+ deriving (Eq)

250272

251273

252274

@@ -254,8 +276,8 @@ data Docs

254276

255277

256278data Exports

257− = ExportEverything R.Region

258− | Export (Map.Map N.Name (A.Located Export))

279+ = ExportEverything A.Region

280+ | Export (Map.Map Name (A.Located Export))

259281

260282

261283data Export

@@ -273,8 +295,8 @@ data Export

273295

274296data Effects

275297 = NoEffects

276− | Ports (Map.Map N.Name Port)

277− | Manager R.Region R.Region R.Region Manager

298+ | Ports (Map.Map Name Port)

299+ | Manager A.Region A.Region A.Region Manager

278300

279301

280302data Port

@@ -283,9 +305,9 @@ data Port

283305

284306

285307data Manager

286− = Cmd N.Name

287− | Sub N.Name

288− | Fx N.Name N.Name

308+ = Cmd Name

309+ | Sub Name

310+ | Fx Name Name

289311

290312

291313

@@ -293,8 +315,8 @@ data Manager

293315

294316

295317instance Binary Alias where

296− get = liftM3 Alias get get get

297− put (Alias a b c) = put a >> put b >> put c

318+ get = liftM2 Alias get get

319+ put (Alias a b) = put a >> put b

298320

299321

300322instance Binary Union where

@@ -320,7 +342,7 @@ instance Binary CtorOpts where

320342 0 -> return Normal

321343 1 -> return Enum

322344 2 -> return Unbox

323− _ -> error "binary encoding of CtorOpts was corrupted"

345+ _ -> fail "binary encoding of CtorOpts was corrupted"

324346

325347

326348instance Binary Annotation where

@@ -371,4 +393,9 @@ instance Binary AliasType where

371393 case n of

372394 0 -> liftM Holey get

373395 1 -> liftM Filled get

374− _ -> error "binary encoding of AliasType was corrupted"

396+ _ -> fail "binary encoding of AliasType was corrupted"

397+

398+

399+instance Binary FieldType where

400+ get = liftM2 FieldType get get

401+ put (FieldType a b) = put a >> put b

src/AST/Optimized.hs → compiler/src/AST/Optimized.hsrenamed+150−113

@@ -3,35 +3,41 @@ module AST.Optimized

33 ( Def(..)

44 , Expr(..)

55 , Global(..)

6− , kernel

76 , Path(..)

87 , Destructor(..)

98 , Decider(..)

109 , Choice(..)

11− , Graph(..)

10+ , GlobalGraph(..)

11+ , LocalGraph(..)

1212 , Main(..)

1313 , Node(..)

1414 , EffectsType(..)

15− , KContent(..)

16− , KChunk(..)

15+ , empty

16+ , addGlobalGraph

17+ , addLocalGraph

18+ , addKernel

19+ , toKernelGlobal

1720 )

1821 where

1922

2023

2124import Control.Monad (liftM, liftM2, liftM3, liftM4)

22−import Data.Binary

23−import qualified Data.ByteString as BS

25+import Data.Binary (Binary, get, put, getWord8, putWord8)

2426import qualified Data.Map as Map

27+import qualified Data.Name as Name

28+import Data.Name (Name)

2529import qualified Data.Set as Set

26−import Data.Text (Text)

2730

2831import qualified AST.Canonical as Can

29−import qualified AST.Module.Name as ModuleName

32+import qualified AST.Utils.Shader as Shader

3033import qualified Data.Index as Index

31−import qualified Elm.Name as N

34+import qualified Elm.Float as EF

35+import qualified Elm.Kernel as K

36+import qualified Elm.ModuleName as ModuleName

3237import qualified Elm.Package as Pkg

38+import qualified Elm.String as ES

3339import qualified Optimize.DecisionTree as DT

34−import qualified Reporting.Region as R

40+import qualified Reporting.Annotation as A

3541

3642

3743

@@ -40,43 +46,35 @@ import qualified Reporting.Region as R

4046

4147data Expr

4248 = Bool Bool

43− | Chr Text

44− | Str Text

49+ | Chr ES.String

50+ | Str ES.String

4551 | Int Int

46− | Float Double

47− | VarLocal N.Name

52+ | Float EF.Float

53+ | VarLocal Name

4854 | VarGlobal Global

4955 | VarEnum Global Index.ZeroBased

5056 | VarBox Global

51− | VarCycle ModuleName.Canonical N.Name

52− | VarDebug N.Name ModuleName.Canonical R.Region (Maybe N.Name)

53− | VarKernel N.Name N.Name

57+ | VarCycle ModuleName.Canonical Name

58+ | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)

59+ | VarKernel Name Name

5460 | List [Expr]

55− | Function [N.Name] Expr

61+ | Function [Name] Expr

5662 | Call Expr [Expr]

57− | TailCall N.Name [(N.Name, Expr)]

63+ | TailCall Name [(Name, Expr)]

5864 | If [(Expr, Expr)] Expr

5965 | Let Def Expr

6066 | Destruct Destructor Expr

61− | Case N.Name N.Name (Decider Choice) [(Int, Expr)]

62− | Accessor N.Name

63− | Access Expr N.Name

64− | Update Expr (Map.Map N.Name Expr)

65− | Record (Map.Map N.Name 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)

6672 | Unit

6773 | Tuple Expr Expr (Maybe Expr)

68− | Shader Text

74+ | Shader Shader.Source (Set.Set Name) (Set.Set Name)

6975

7076

71−data Global = Global ModuleName.Canonical N.Name

72− deriving (Eq, Ord)

73−

74−

75−-- Provide "List" not "Elm.Kernel.List"

76−--

77−kernel :: N.Name -> Global

78−kernel home =

79− Global (ModuleName.Canonical Pkg.kernel home) N.dollar

77+data Global = Global ModuleName.Canonical Name

8078

8179

8280

@@ -84,19 +82,19 @@ kernel home =

8482

8583

8684data Def

87− = Def N.Name Expr

88− | TailDef N.Name [N.Name] Expr

85+ = Def Name Expr

86+ | TailDef Name [Name] Expr

8987

9088

9189data Destructor =

92− Destructor N.Name Path

90+ Destructor Name Path

9391

9492

9593data Path

9694 = Index Index.ZeroBased Path

97− | Field N.Name Path

95+ | Field Name Path

9896 | Unbox Path

99− | Root N.Name

97+ | Root Name

10098

10199

102100

@@ -127,11 +125,18 @@ data Choice

127125-- OBJECT GRAPH

128126

129127

130−data Graph =

131− Graph

132− { _mains :: Map.Map ModuleName.Canonical Main

133− , _nodes :: Map.Map Global Node

134− , _fields :: Map.Map N.Name Int

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

135140 }

136141

137142

@@ -145,14 +150,14 @@ data Main

145150

146151data Node

147152 = Define Expr (Set.Set Global)

148− | DefineTailFunc [N.Name] Expr (Set.Set Global)

149− | Ctor N.Name Index.ZeroBased Int

150− | Enum N.Name Index.ZeroBased

151− | Box N.Name

153+ | DefineTailFunc [Name] Expr (Set.Set Global)

154+ | Ctor Index.ZeroBased Int

155+ | Enum Index.ZeroBased

156+ | Box

152157 | Link Global

153− | Cycle [(N.Name, Expr)] (Set.Set Global)

158+ | Cycle [Name] [(Name, Expr)] [Def] (Set.Set Global)

154159 | Manager EffectsType

155− | Kernel KContent (Maybe KContent)

160+ | Kernel [K.Chunk] (Set.Set Global)

156161 | PortIncoming Expr (Set.Set Global)

157162 | PortOutgoing Expr (Set.Set Global)

158163

@@ -160,19 +165,77 @@ data Node

160165data EffectsType = Cmd | Sub | Fx

161166

162167

163−data KContent =

164− KContent [KChunk] (Set.Set Global)

165168

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

166226

167−data KChunk

168− = JS BS.ByteString

169− | ElmVar ModuleName.Canonical N.Name

170− | JsVar N.Name N.Name

171− | ElmField N.Name

172− | JsField Int

173− | JsEnum Int

174− | Debug

175− | Prod

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

176239

177240

178241

@@ -213,7 +276,7 @@ instance Binary Expr where

213276 Record a -> putWord8 23 >> put a

214277 Unit -> putWord8 24

215278 Tuple a b c -> putWord8 25 >> put a >> put b >> put c

216− Shader a -> putWord8 26 >> put a

279+ Shader a b c -> putWord8 26 >> put a >> put b >> put c

217280

218281 get =

219282 do word <- getWord8

@@ -244,8 +307,8 @@ instance Binary Expr where

244307 23 -> liftM Record get

245308 24 -> pure Unit

246309 25 -> liftM3 Tuple get get get

247− 26 -> liftM Shader get

248− _ -> error "problem getting Opt.Expr binary"

310+ 26 -> liftM3 Shader get get get

311+ _ -> fail "problem getting Opt.Expr binary"

249312

250313

251314instance Binary Def where

@@ -259,7 +322,7 @@ instance Binary Def where

259322 case word of

260323 0 -> liftM2 Def get get

261324 1 -> liftM3 TailDef get get get

262− _ -> error "problem getting Opt.Def binary"

325+ _ -> fail "problem getting Opt.Def binary"

263326

264327

265328instance Binary Destructor where

@@ -282,7 +345,7 @@ instance Binary Path where

282345 1 -> liftM2 Field get get

283346 2 -> liftM Unbox get

284347 3 -> liftM Root get

285− _ -> error "problem getting Opt.Path binary"

348+ _ -> fail "problem getting Opt.Path binary"

286349

287350

288351instance (Binary a) => Binary (Decider a) where

@@ -298,7 +361,7 @@ instance (Binary a) => Binary (Decider a) where

298361 0 -> liftM Leaf get

299362 1 -> liftM3 Chain get get get

300363 2 -> liftM3 FanOut get get get

301− _ -> error "problem getting Opt.Decider binary"

364+ _ -> fail "problem getting Opt.Decider binary"

302365

303366

304367instance Binary Choice where

@@ -312,13 +375,18 @@ instance Binary Choice where

312375 case word of

313376 0 -> liftM Inline get

314377 1 -> liftM Jump get

315− _ -> error "problem getting Opt.Choice binary"

378+ _ -> fail "problem getting Opt.Choice binary"

379+

316380

317381

382+instance Binary GlobalGraph where

383+ get = liftM2 GlobalGraph get get

384+ put (GlobalGraph a b) = put a >> put b

318385

319−instance Binary Graph where

320− get = liftM3 Graph get get get

321− put (Graph a b c) = put a >> put b >> put c

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

322390

323391

324392instance Binary Main where

@@ -332,7 +400,7 @@ instance Binary Main where

332400 case word of

333401 0 -> return Static

334402 1 -> liftM2 Dynamic get get

335− _ -> error "problem getting Opt.Main binary"

403+ _ -> fail "problem getting Opt.Main binary"

336404

337405

338406instance Binary Node where

@@ -340,11 +408,11 @@ instance Binary Node where

340408 case node of

341409 Define a b -> putWord8 0 >> put a >> put b

342410 DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c

343− Ctor a b c -> putWord8 2 >> put a >> put b >> put c

344− Enum a b -> putWord8 3 >> put a >> put b

345− Box a -> putWord8 4 >> put a

411+ Ctor a b -> putWord8 2 >> put a >> put b

412+ Enum a -> putWord8 3 >> put a

413+ Box -> putWord8 4

346414 Link a -> putWord8 5 >> put a

347− Cycle a b -> putWord8 6 >> put a >> put b

415+ Cycle a b c d -> putWord8 6 >> put a >> put b >> put c >> put d

348416 Manager a -> putWord8 7 >> put a

349417 Kernel a b -> putWord8 8 >> put a >> put b

350418 PortIncoming a b -> putWord8 9 >> put a >> put b

@@ -355,16 +423,16 @@ instance Binary Node where

355423 case word of

356424 0 -> liftM2 Define get get

357425 1 -> liftM3 DefineTailFunc get get get

358− 2 -> liftM3 Ctor get get get

359− 3 -> liftM2 Enum get get

360− 4 -> liftM Box get

426+ 2 -> liftM2 Ctor get get

427+ 3 -> liftM Enum get

428+ 4 -> return Box

361429 5 -> liftM Link get

362− 6 -> liftM2 Cycle get get

430+ 6 -> liftM4 Cycle get get get get

363431 7 -> liftM Manager get

364432 8 -> liftM2 Kernel get get

365433 9 -> liftM2 PortIncoming get get

366434 10 -> liftM2 PortOutgoing get get

367− _ -> error "problem getting Opt.Node binary"

435+ _ -> fail "problem getting Opt.Node binary"

368436

369437

370438instance Binary EffectsType where

@@ -380,35 +448,4 @@ instance Binary EffectsType where

380448 0 -> return Cmd

381449 1 -> return Sub

382450 2 -> return Fx

383− _ -> error "problem getting Opt.EffectsType binary"

384−

385−

386−instance Binary KContent where

387− get = liftM2 KContent get get

388− put (KContent a b) = put a >> put b

389−

390−

391−instance Binary KChunk where

392− put chunk =

393− case chunk of

394− JS a -> putWord8 0 >> put a

395− ElmVar a b -> putWord8 1 >> put a >> put b

396− JsVar a b -> putWord8 2 >> put a >> put b

397− ElmField a -> putWord8 3 >> put a

398− JsField a -> putWord8 4 >> put a

399− JsEnum a -> putWord8 5 >> put a

400− Debug -> putWord8 6

401− Prod -> putWord8 7

402−

403− get =

404− do word <- getWord8

405− case word of

406− 0 -> liftM JS get

407− 1 -> liftM2 ElmVar get get

408− 2 -> liftM2 JsVar get get

409− 3 -> liftM ElmField get

410− 4 -> liftM JsField get

411− 5 -> liftM JsEnum get

412− 6 -> return Debug

413− 7 -> return Prod

414− _ -> error "problem deserializing AST.Optimized.KChunk"

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

src/AST/Utils/Binop.hs → compiler/src/AST/Utils/Binop.hsrenamed+5−6

@@ -41,12 +41,11 @@ instance Binary Precedence where

4141instance Binary Associativity where

4242 get =

4343 do n <- getWord8

44− return $

45− case n of

46− 0 -> Left

47− 1 -> Non

48− 2 -> Right

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

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"

5049

5150 put assoc =

5251 putWord8 $

compiler/src/AST/Utils/Shader.hsnew file+91

@@ -0,0 +1,91 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE EmptyDataDecls #-}

3+module AST.Utils.Shader

4+ ( Source

5+ , Types(..)

6+ , Type(..)

7+ , fromChars

8+ , toJsStringBuilder

9+ )

10+ where

11+

12+

13+import Control.Monad (liftM)

14+import Data.Binary (Binary, get, put)

15+import qualified Data.ByteString as BS

16+import qualified Data.ByteString.Builder as B

17+import qualified Data.ByteString.UTF8 as BS_UTF8

18+import qualified Data.Map as Map

19+import qualified Data.Name as Name

20+

21+

22+

23+-- SOURCE

24+

25+

26+newtype Source =

27+ Source BS.ByteString

28+

29+

30+

31+-- TYPES

32+

33+

34+data Types =

35+ Types

36+ { _attribute :: Map.Map Name.Name Type

37+ , _uniform :: Map.Map Name.Name Type

38+ , _varying :: Map.Map Name.Name Type

39+ }

40+

41+

42+data Type

43+ = Int

44+ | Float

45+ | V2

46+ | V3

47+ | V4

48+ | M4

49+ | Texture

50+

51+

52+

53+-- TO BUILDER

54+

55+

56+toJsStringBuilder :: Source -> B.Builder

57+toJsStringBuilder (Source src) =

58+ B.byteString src

59+

60+

61+

62+-- FROM CHARS

63+

64+

65+fromChars :: [Char] -> Source

66+fromChars chars =

67+ Source (BS_UTF8.fromString (escape chars))

68+

69+

70+escape :: [Char] -> [Char]

71+escape chars =

72+ case chars of

73+ [] ->

74+ []

75+

76+ c:cs

77+ | c == '\r' -> escape cs

78+ | c == '\n' -> '\\' : 'n' : escape cs

79+ | c == '\"' -> '\\' : '"' : escape cs

80+ | c == '\'' -> '\\' : '\'' : escape cs

81+ | c == '\\' -> '\\' : '\\' : escape cs

82+ | otherwise -> c : escape cs

83+

84+

85+

86+-- BINARY

87+

88+

89+instance Binary Source where

90+ get = liftM Source get

91+ put (Source a) = put a

src/AST/Utils/Type.hs → compiler/src/AST/Utils/Type.hsrenamed+16−7

@@ -1,5 +1,4 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

32module AST.Utils.Type

43 ( delambda

54 , dealias

@@ -10,9 +9,9 @@ module AST.Utils.Type

109

1110

1211import qualified Data.Map as Map

12+import qualified Data.Name as Name

1313

14−import AST.Canonical (Type(..), AliasType(..))

15−import qualified Elm.Name as N

14+import AST.Canonical (Type(..), AliasType(..), FieldType(..))

1615

1716

1817

@@ -33,7 +32,7 @@ delambda tipe =

3332-- DEALIAS

3433

3534

36−dealias :: [(N.Name, Type)] -> AliasType -> Type

35+dealias :: [(Name.Name, Type)] -> AliasType -> Type

3736dealias args aliasType =

3837 case aliasType of

3938 Holey tipe ->

@@ -43,7 +42,7 @@ dealias args aliasType =

4342 tipe

4443

4544

46−dealiasHelp :: Map.Map N.Name Type -> Type -> Type

45+dealiasHelp :: Map.Map Name.Name Type -> Type -> Type

4746dealiasHelp typeTable tipe =

4847 case tipe of

4948 TLambda a b ->

@@ -55,7 +54,7 @@ dealiasHelp typeTable tipe =

5554 Map.findWithDefault tipe x typeTable

5655

5756 TRecord fields ext ->

58− TRecord (Map.map (dealiasHelp typeTable) fields) ext

57+ TRecord (Map.map (dealiasField typeTable) fields) ext

5958

6059 TAlias home name args t' ->

6160 TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'

@@ -73,6 +72,11 @@ dealiasHelp typeTable tipe =

7372 (fmap (dealiasHelp typeTable) maybeC)

7473

7574

75+dealiasField :: Map.Map Name.Name Type -> FieldType -> FieldType

76+dealiasField typeTable (FieldType index tipe) =

77+ FieldType index (dealiasHelp typeTable tipe)

78+

79+

7680

7781-- DEEP DEALIAS

7882

@@ -87,7 +91,7 @@ deepDealias tipe =

8791 tipe

8892

8993 TRecord fields ext ->

90− TRecord (Map.map deepDealias fields) ext

94+ TRecord (Map.map deepDealiasField fields) ext

9195

9296 TAlias _ _ args tipe' ->

9397 deepDealias (dealias args tipe')

@@ -102,6 +106,11 @@ deepDealias tipe =

102106 TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)

103107

104108

109+deepDealiasField :: FieldType -> FieldType

110+deepDealiasField (FieldType index tipe) =

111+ FieldType index (deepDealias tipe)

112+

113+

105114

106115-- ITERATED DEALIAS

107116

src/Canonicalize/Effects.hs → compiler/src/Canonicalize/Effects.hsrenamed+42−38

@@ -8,17 +8,16 @@ module Canonicalize.Effects

88

99import qualified Data.Foldable as F

1010import qualified Data.Map as Map

11+import qualified Data.Name as Name

1112

1213import qualified AST.Canonical as Can

13−import qualified AST.Valid as Valid

14−import qualified AST.Module.Name as ModuleName

14+import qualified AST.Source as Src

1515import qualified AST.Utils.Type as Type

1616import qualified Canonicalize.Environment as Env

1717import qualified Canonicalize.Type as Type

18−import qualified Elm.Name as N

18+import qualified Elm.ModuleName as ModuleName

1919import qualified Reporting.Annotation as A

2020import qualified Reporting.Error.Canonicalize as Error

21−import qualified Reporting.Region as R

2221import qualified Reporting.Result as Result

2322

2423

@@ -36,38 +35,38 @@ type Result i w a =

3635

3736canonicalize

3837 :: Env.Env

39− -> [A.Located Valid.Decl]

40− -> Map.Map N.Name union

41− -> Valid.Effects

38+ -> [A.Located Src.Value]

39+ -> Map.Map Name.Name union

40+ -> Src.Effects

4241 -> Result i w Can.Effects

43−canonicalize env decls unions effects =

42+canonicalize env values unions effects =

4443 case effects of

45− Valid.NoEffects ->

44+ Src.NoEffects ->

4645 Result.ok Can.NoEffects

4746

48− Valid.Ports ports ->

47+ Src.Ports ports ->

4948 do pairs <- traverse (canonicalizePort env) ports

5049 return $ Can.Ports (Map.fromList pairs)

5150

52− Valid.Manager region manager ->

53− let dict = Map.fromList (map toNameRegion decls) in

51+ Src.Manager region manager ->

52+ let dict = Map.fromList (map toNameRegion values) in

5453 Can.Manager

5554 <$> verifyManager region dict "init"

5655 <*> verifyManager region dict "onEffects"

5756 <*> verifyManager region dict "onSelfMsg"

5857 <*>

5958 case manager of

60− Valid.Cmd cmdType ->

59+ Src.Cmd cmdType ->

6160 Can.Cmd

6261 <$> verifyEffectType cmdType unions

6362 <* verifyManager region dict "cmdMap"

6463

65− Valid.Sub subType ->

64+ Src.Sub subType ->

6665 Can.Sub

6766 <$> verifyEffectType subType unions

6867 <* verifyManager region dict "subMap"

6968

70− Valid.Fx cmdType subType ->

69+ Src.Fx cmdType subType ->

7170 Can.Fx

7271 <$> verifyEffectType cmdType unions

7372 <*> verifyEffectType subType unions

@@ -79,12 +78,12 @@ canonicalize env decls unions effects =

7978-- CANONICALIZE PORT

8079

8180

82−canonicalizePort :: Env.Env -> Valid.Port -> Result i w (N.Name, Can.Port)

83−canonicalizePort env (Valid.Port (A.At region portName) tipe) =

81+canonicalizePort :: Env.Env -> Src.Port -> Result i w (Name.Name, Can.Port)

82+canonicalizePort env (Src.Port (A.At region portName) tipe) =

8483 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe

8584 case reverse (Type.delambda (Type.deepDealias ctipe)) of

8685 Can.TType home name [msg] : revArgs

87− | home == ModuleName.cmd && name == N.cmd ->

86+ | home == ModuleName.cmd && name == Name.cmd ->

8887 case revArgs of

8988 [] ->

9089 Result.throw (Error.PortTypeInvalid region portName Error.CmdNoArg)

@@ -105,7 +104,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =

105104 _ ->

106105 Result.throw (Error.PortTypeInvalid region portName (Error.CmdExtraArgs (length revArgs)))

107106

108− | home == ModuleName.sub && name == N.sub ->

107+ | home == ModuleName.sub && name == Name.sub ->

109108 case revArgs of

110109 [Can.TLambda incomingType (Can.TVar msg1)] ->

111110 case msg of

@@ -131,7 +130,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =

131130-- VERIFY MANAGER

132131

133132

134−verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result i w N.Name

133+verifyEffectType :: A.Located Name.Name -> Map.Map Name.Name a -> Result i w Name.Name

135134verifyEffectType (A.At region name) unions =

136135 if Map.member name unions then

137136 Result.ok name

@@ -139,14 +138,14 @@ verifyEffectType (A.At region name) unions =

139138 Result.throw (Error.EffectNotFound region name)

140139

141140

142−toNameRegion :: A.Located Valid.Decl -> (N.Name, R.Region)

143−toNameRegion (A.At _ (Valid.Decl (A.At region name) _ _ _)) =

141+toNameRegion :: A.Located Src.Value -> (Name.Name, A.Region)

142+toNameRegion (A.At _ (Src.Value (A.At region name) _ _ _)) =

144143 (name, region)

145144

146145

147−verifyManager :: R.Region -> Map.Map N.Name R.Region -> N.Name -> Result i w R.Region

148−verifyManager tagRegion decls name =

149− case Map.lookup name decls of

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

150149 Just region ->

151150 Result.ok region

152151

@@ -202,46 +201,51 @@ checkPayload tipe =

202201 Left (tipe, Error.ExtendedRecord)

203202

204203 Can.TRecord fields Nothing ->

205− F.traverse_ checkPayload fields

204+ F.traverse_ checkFieldPayload fields

206205

207206

208−isIntFloatBool :: ModuleName.Canonical -> N.Name -> Bool

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

209213isIntFloatBool home name =

210214 home == ModuleName.basics

211215 &&

212− (name == N.int || name == N.float || name == N.bool)

216+ (name == Name.int || name == Name.float || name == Name.bool)

213217

214218

215−isString :: ModuleName.Canonical -> N.Name -> Bool

219+isString :: ModuleName.Canonical -> Name.Name -> Bool

216220isString home name =

217221 home == ModuleName.string

218222 &&

219− name == N.string

223+ name == Name.string

220224

221225

222−isJson :: ModuleName.Canonical -> N.Name -> Bool

226+isJson :: ModuleName.Canonical -> Name.Name -> Bool

223227isJson home name =

224228 home == ModuleName.jsonEncode

225229 &&

226− name == N.value

230+ name == Name.value

227231

228232

229−isList :: ModuleName.Canonical -> N.Name -> Bool

233+isList :: ModuleName.Canonical -> Name.Name -> Bool

230234isList home name =

231235 home == ModuleName.list

232236 &&

233− name == N.list

237+ name == Name.list

234238

235239

236−isMaybe :: ModuleName.Canonical -> N.Name -> Bool

240+isMaybe :: ModuleName.Canonical -> Name.Name -> Bool

237241isMaybe home name =

238242 home == ModuleName.maybe

239243 &&

240− name == N.maybe

244+ name == Name.maybe

241245

242246

243−isArray :: ModuleName.Canonical -> N.Name -> Bool

247+isArray :: ModuleName.Canonical -> Name.Name -> Bool

244248isArray home name =

245249 home == ModuleName.array

246250 &&

247− name == N.array

251+ name == Name.array

src/Canonicalize/Environment.hs → compiler/src/Canonicalize/Environment.hsrenamed+72−42

@@ -4,6 +4,8 @@ module Canonicalize.Environment

44 ( Env(..)

55 , Exposed

66 , Qualified

7+ , Info(..)

8+ , mergeInfo

79 , Var(..)

810 , Type(..)

911 , Ctor(..)

@@ -20,15 +22,15 @@ module Canonicalize.Environment

2022

2123import qualified Data.Map.Merge.Strict as Map

2224import qualified Data.Map.Strict as Map

23−import qualified Data.Map.Strict.Internal as I

25+import qualified Data.Name as Name

26+import qualified Data.OneOrMore as OneOrMore

2427

2528import qualified AST.Utils.Binop as Binop

2629import qualified AST.Canonical as Can

27−import qualified AST.Module.Name as ModuleName

2830import qualified Data.Index as Index

29−import qualified Elm.Name as N

31+import qualified Elm.ModuleName as ModuleName

32+import qualified Reporting.Annotation as A

3033import qualified Reporting.Error.Canonicalize as Error

31−import qualified Reporting.Region as R

3234import qualified Reporting.Result as Result

3335

3436

@@ -47,7 +49,7 @@ type Result i w a =

4749data Env =

4850 Env

4951 { _home :: ModuleName.Canonical

50− , _vars :: Map.Map N.Name Var

52+ , _vars :: Map.Map Name.Name Var

5153 , _types :: Exposed Type

5254 , _ctors :: Exposed Ctor

5355 , _binops :: Exposed Binop

@@ -58,11 +60,34 @@ data Env =

5860

5961

6062type Exposed a =

61− Map.Map N.Name (Map.Map ModuleName.Canonical a)

63+ Map.Map Name.Name (Info a)

6264

6365

6466type Qualified a =

65− Map.Map N.Name (Map.Map N.Name (Map.Map ModuleName.Canonical a))

67+ Map.Map Name.Name (Map.Map Name.Name (Info a))

68+

69+

70+

71+-- INFO

72+

73+

74+data Info a

75+ = Specific ModuleName.Canonical a

76+ | Ambiguous ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)

77+

78+

79+mergeInfo :: Info a -> Info a -> Info a

80+mergeInfo info1 info2 =

81+ case info1 of

82+ Specific h1 _ ->

83+ case info2 of

84+ Specific h2 _ -> if h1 == h2 then info1 else Ambiguous h1 (OneOrMore.one h2)

85+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more (OneOrMore.one h2) hs2)

86+

87+ Ambiguous h1 hs1 ->

88+ case info2 of

89+ Specific h2 _ -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.one h2))

90+ Ambiguous h2 hs2 -> Ambiguous h1 (OneOrMore.more hs1 (OneOrMore.more (OneOrMore.one h2) hs2))

6691

6792

6893

@@ -70,9 +95,10 @@ type Qualified a =

7095

7196

7297data Var

73− = Local R.Region

74− | TopLevel R.Region

75− | Foreign (Map.Map ModuleName.Canonical Can.Annotation)

98+ = Local A.Region

99+ | TopLevel A.Region

100+ | Foreign ModuleName.Canonical Can.Annotation

101+ | Foreigns ModuleName.Canonical (OneOrMore.OneOrMore ModuleName.Canonical)

76102

77103

78104

@@ -80,7 +106,7 @@ data Var

80106

81107

82108data Type

83− = Alias Int ModuleName.Canonical [N.Name] Can.Type

109+ = Alias Int ModuleName.Canonical [Name.Name] Can.Type

84110 | Union Int ModuleName.Canonical

85111

86112

@@ -89,10 +115,10 @@ data Type

89115

90116

91117data Ctor

92− = RecordCtor ModuleName.Canonical [N.Name] Can.Type

118+ = RecordCtor ModuleName.Canonical [Name.Name] Can.Type

93119 | Ctor

94120 { _c_home :: ModuleName.Canonical

95− , _c_type :: N.Name

121+ , _c_type :: Name.Name

96122 , _c_union :: Can.Union

97123 , _c_index :: Index.ZeroBased

98124 , _c_args :: [Can.Type]

@@ -105,9 +131,9 @@ data Ctor

105131

106132data Binop =

107133 Binop

108− { _op :: N.Name

134+ { _op :: Name.Name

109135 , _op_home :: ModuleName.Canonical

110− , _op_name :: N.Name

136+ , _op_name :: Name.Name

111137 , _op_annotation :: Can.Annotation

112138 , _op_associativity :: Binop.Associativity

113139 , _op_precedence :: Binop.Precedence

@@ -118,7 +144,7 @@ data Binop =

118144-- VARIABLE -- ADD LOCALS

119145

120146

121−addLocals :: Map.Map N.Name R.Region -> Env -> Result i w Env

147+addLocals :: Map.Map Name.Name A.Region -> Env -> Result i w Env

122148addLocals names (Env home vars ts cs bs qvs qts qcs) =

123149 do newVars <-

124150 Map.mergeA

@@ -131,15 +157,18 @@ addLocals names (Env home vars ts cs bs qvs qts qcs) =

131157 Result.ok (Env home newVars ts cs bs qvs qts qcs)

132158

133159

134−addLocalLeft :: N.Name -> R.Region -> Var

160+addLocalLeft :: Name.Name -> A.Region -> Var

135161addLocalLeft _ region =

136162 Local region

137163

138164

139−addLocalBoth :: N.Name -> R.Region -> Var -> Result i w Var

165+addLocalBoth :: Name.Name -> A.Region -> Var -> Result i w Var

140166addLocalBoth name region var =

141167 case var of

142− Foreign _ ->

168+ Foreign _ _ ->

169+ Result.ok (Local region)

170+

171+ Foreigns _ _ ->

143172 Result.ok (Local region)

144173

145174 Local parentRegion ->

@@ -150,32 +179,33 @@ addLocalBoth name region var =

150179

151180

152181

182+

153183-- FIND TYPE

154184

155185

156−findType :: R.Region -> Env -> N.Name -> Result i w Type

186+findType :: A.Region -> Env -> Name.Name -> Result i w Type

157187findType region (Env _ _ ts _ _ _ qts _) name =

158188 case Map.lookup name ts of

159− Just (I.Bin 1 _ tipe _ _) ->

189+ Just (Specific _ tipe) ->

160190 Result.ok tipe

161191

162− Just homes ->

163− Result.throw (Error.AmbiguousType region Nothing name (Map.keys homes))

192+ Just (Ambiguous h hs) ->

193+ Result.throw (Error.AmbiguousType region Nothing name h hs)

164194

165195 Nothing ->

166196 Result.throw (Error.NotFoundType region Nothing name (toPossibleNames ts qts))

167197

168198

169−findTypeQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Type

199+findTypeQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Type

170200findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

171201 case Map.lookup prefix qts of

172202 Just qualified ->

173203 case Map.lookup name qualified of

174− Just (I.Bin 1 _ tipe _ _) ->

204+ Just (Specific _ tipe) ->

175205 Result.ok tipe

176206

177− Just homes ->

178− Result.throw (Error.AmbiguousType region (Just prefix) name (Map.keys homes))

207+ Just (Ambiguous h hs) ->

208+ Result.throw (Error.AmbiguousType region (Just prefix) name h hs)

179209

180210 Nothing ->

181211 Result.throw (Error.NotFoundType region (Just prefix) name (toPossibleNames ts qts))

@@ -188,49 +218,49 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

188218-- FIND CTOR

189219

190220

191−findCtor :: R.Region -> Env -> N.Name -> Result i w Ctor

221+findCtor :: A.Region -> Env -> Name.Name -> Result i w Ctor

192222findCtor region (Env _ _ _ cs _ _ _ qcs) name =

193223 case Map.lookup name cs of

194− Just (I.Bin 1 _ ctor _ _) ->

224+ Just (Specific _ ctor) ->

195225 Result.ok ctor

196226

197− Just homes ->

198− Result.throw (Error.AmbiguousCtor region Nothing name (Map.keys homes))

227+ Just (Ambiguous h hs) ->

228+ Result.throw (Error.AmbiguousVariant region Nothing name h hs)

199229

200230 Nothing ->

201− Result.throw (Error.NotFoundCtor region Nothing name (toPossibleNames cs qcs))

231+ Result.throw (Error.NotFoundVariant region Nothing name (toPossibleNames cs qcs))

202232

203233

204−findCtorQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Ctor

234+findCtorQual :: A.Region -> Env -> Name.Name -> Name.Name -> Result i w Ctor

205235findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

206236 case Map.lookup prefix qcs of

207237 Just qualified ->

208238 case Map.lookup name qualified of

209− Just (I.Bin 1 _ pattern _ _) ->

239+ Just (Specific _ pattern) ->

210240 Result.ok pattern

211241

212− Just homes ->

213− Result.throw (Error.AmbiguousCtor region (Just prefix) name (Map.keys homes))

242+ Just (Ambiguous h hs) ->

243+ Result.throw (Error.AmbiguousVariant region (Just prefix) name h hs)

214244

215245 Nothing ->

216− Result.throw (Error.NotFoundCtor region (Just prefix) name (toPossibleNames cs qcs))

246+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))

217247

218248 Nothing ->

219− Result.throw (Error.NotFoundCtor region (Just prefix) name (toPossibleNames cs qcs))

249+ Result.throw (Error.NotFoundVariant region (Just prefix) name (toPossibleNames cs qcs))

220250

221251

222252

223253-- FIND BINOP

224254

225255

226−findBinop :: R.Region -> Env -> N.Name -> Result i w Binop

256+findBinop :: A.Region -> Env -> Name.Name -> Result i w Binop

227257findBinop region (Env _ _ _ _ binops _ _ _) name =

228258 case Map.lookup name binops of

229− Just (I.Bin 1 _ binop _ _) ->

259+ Just (Specific _ binop) ->

230260 Result.ok binop

231261

232− Just homes ->

233− Result.throw (Error.AmbiguousBinop region name (Map.keys homes))

262+ Just (Ambiguous h hs) ->

263+ Result.throw (Error.AmbiguousBinop region name h hs)

234264

235265 Nothing ->

236266 Result.throw (Error.NotFoundBinop region name (Map.keysSet binops))

src/Canonicalize/Environment/Dups.hs → compiler/src/Canonicalize/Environment/Dups.hsrenamed+27−14

@@ -3,6 +3,7 @@

33module Canonicalize.Environment.Dups

44 ( detect

55 , checkFields

6+ , checkFields'

67 , Dict

78 , none

89 , one

@@ -14,12 +15,11 @@ module Canonicalize.Environment.Dups

1415

1516

1617import qualified Data.Map as Map

18+import qualified Data.Name as Name

1719

1820import qualified Data.OneOrMore as OneOrMore

19−import qualified Elm.Name as N

2021import qualified Reporting.Annotation as A

2122import qualified Reporting.Error.Canonicalize as Error

22−import qualified Reporting.Region as R

2323import qualified Reporting.Result as Result

2424

2525

@@ -28,12 +28,12 @@ import qualified Reporting.Result as Result

2828

2929

3030type Dict value =

31− Map.Map N.Name (OneOrMore.OneOrMore (Info value))

31+ Map.Map Name.Name (OneOrMore.OneOrMore (Info value))

3232

3333

3434data Info value =

3535 Info

36− { _region :: R.Region

36+ { _region :: A.Region

3737 , _value :: value

3838 }

3939

@@ -43,22 +43,25 @@ data Info value =

4343

4444

4545type ToError =

46− N.Name -> R.Region -> R.Region -> Error.Error

46+ Name.Name -> A.Region -> A.Region -> Error.Error

4747

4848

49−detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map N.Name a)

49+detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name a)

5050detect toError dict =

5151 Map.traverseWithKey (detectHelp toError) dict

5252

5353

54−detectHelp :: ToError -> N.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a

54+detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a

5555detectHelp toError name values =

5656 case values of

5757 OneOrMore.One (Info _ value) ->

5858 return value

5959

60− OneOrMore.More _ _ ->

61− let (Info r1 _ : Info r2 _ : _) = OneOrMore.toList values in

60+ OneOrMore.More left right ->

61+ let

62+ (Info r1 _, Info r2 _) =

63+ OneOrMore.getFirstTwo left right

64+ in

6265 Result.throw (toError name r1 r2)

6366

6467

@@ -66,16 +69,26 @@ detectHelp toError name values =

6669-- CHECK FIELDS

6770

6871

69−checkFields :: [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name a)

72+checkFields :: [(A.Located Name.Name, a)] -> Result.Result i w Error.Error (Map.Map Name.Name a)

7073checkFields fields =

7174 detect Error.DuplicateField (foldr addField none fields)

7275

7376

74−addField :: (A.Located N.Name, a) -> Dict a -> Dict a

77+addField :: (A.Located Name.Name, a) -> Dict a -> Dict a

7578addField (A.At region name, value) dups =

7679 Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups

7780

7881

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+

7992

8093-- BUILDING DICTIONARIES

8194

@@ -85,14 +98,14 @@ none =

8598 Map.empty

8699

87100

88−one :: N.Name -> R.Region -> value -> Dict value

101+one :: Name.Name -> A.Region -> value -> Dict value

89102one name region value =

90103 Map.singleton name (OneOrMore.one (Info region value))

91104

92105

93−insert :: N.Name -> R.Region -> a -> Dict a -> Dict a

106+insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a

94107insert name region value dict =

95− Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict

108+ Map.insertWith (\new old -> OneOrMore.more old new) name (OneOrMore.one (Info region value)) dict

96109

97110

98111union :: Dict a -> Dict a -> Dict a

compiler/src/Canonicalize/Environment/Foreign.hsnew file+304

@@ -0,0 +1,304 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+module Canonicalize.Environment.Foreign

5+ ( createInitialEnv

6+ )

7+ where

8+

9+

10+import Control.Monad (foldM)

11+import qualified Data.List as List

12+import qualified Data.Map.Strict as Map

13+import Data.Map.Strict ((!))

14+import qualified Data.Name as Name

15+

16+import qualified AST.Canonical as Can

17+import qualified AST.Source as Src

18+import qualified Canonicalize.Environment as Env

19+import qualified Elm.Interface as I

20+import qualified Elm.ModuleName as ModuleName

21+import qualified Elm.Package as Pkg

22+import qualified Reporting.Annotation as A

23+import qualified Reporting.Error.Canonicalize as Error

24+import qualified Reporting.Result as Result

25+

26+

27+

28+-- RESULT

29+

30+

31+type Result i w a =

32+ Result.Result i w Error.Error a

33+

34+

35+createInitialEnv :: ModuleName.Canonical -> Map.Map ModuleName.Raw I.Interface -> [Src.Import] -> Result i w Env.Env

36+createInitialEnv home ifaces imports =

37+ do (State vs ts cs bs qvs qts qcs) <- foldM (addImport ifaces) emptyState (toSafeImports home imports)

38+ Result.ok (Env.Env home (Map.map infoToVar vs) ts cs bs qvs qts qcs)

39+

40+

41+infoToVar :: Env.Info Can.Annotation -> Env.Var

42+infoToVar info =

43+ case info of

44+ Env.Specific home tipe -> Env.Foreign home tipe

45+ Env.Ambiguous h hs -> Env.Foreigns h hs

46+

47+

48+

49+-- STATE

50+

51+

52+data State =

53+ State

54+ { _vars :: Env.Exposed Can.Annotation

55+ , _types :: Env.Exposed Env.Type

56+ , _ctors :: Env.Exposed Env.Ctor

57+ , _binops :: Env.Exposed Env.Binop

58+ , _q_vars :: Env.Qualified Can.Annotation

59+ , _q_types :: Env.Qualified Env.Type

60+ , _q_ctors :: Env.Qualified Env.Ctor

61+ }

62+

63+

64+emptyState :: State

65+emptyState =

66+ State Map.empty emptyTypes Map.empty Map.empty Map.empty Map.empty Map.empty

67+

68+

69+emptyTypes :: Env.Exposed Env.Type

70+emptyTypes =

71+ Map.singleton "List" (Env.Specific ModuleName.list (Env.Union 1 ModuleName.list))

72+

73+

74+

75+-- TO SAFE IMPORTS

76+

77+

78+toSafeImports :: ModuleName.Canonical -> [Src.Import] -> [Src.Import]

79+toSafeImports (ModuleName.Canonical pkg _) imports =

80+ if Pkg.isKernel pkg

81+ then filter isNormal imports

82+ else imports

83+

84+

85+isNormal :: Src.Import -> Bool

86+isNormal (Src.Import (A.At _ name) maybeAlias _) =

87+ if Name.isKernel name

88+ then

89+ case maybeAlias of

90+ Nothing -> False

91+ Just _ -> error "kernel imports cannot use `as`"

92+ else

93+ True

94+

95+

96+

97+-- ADD IMPORTS

98+

99+

100+addImport :: Map.Map ModuleName.Raw I.Interface -> State -> Src.Import -> Result i w State

101+addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybeAlias exposing) =

102+ let

103+ (I.Interface pkg defs unions aliases binops) = ifaces ! name

104+ !prefix = maybe name id maybeAlias

105+ !home = ModuleName.Canonical pkg name

106+

107+ !rawTypeInfo =

108+ Map.union

109+ (Map.mapMaybeWithKey (unionToType home) unions)

110+ (Map.mapMaybeWithKey (aliasToType home) aliases)

111+

112+ !vars = Map.map (Env.Specific home) defs

113+ !types = Map.map (Env.Specific home . fst) rawTypeInfo

114+ !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo

115+

116+ !qvs2 = addQualified prefix vars qvs

117+ !qts2 = addQualified prefix types qts

118+ !qcs2 = addQualified prefix ctors qcs

119+ in

120+ case exposing of

121+ Src.Open ->

122+ let

123+ !vs2 = addExposed vs vars

124+ !ts2 = addExposed ts types

125+ !cs2 = addExposed cs ctors

126+ !bs2 = addExposed bs (Map.mapWithKey (binopToBinop home) binops)

127+ in

128+ Result.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2)

129+

130+ Src.Explicit exposedList ->

131+ foldM

132+ (addExposedValue home vars rawTypeInfo binops)

133+ (State vs ts cs bs qvs2 qts2 qcs2)

134+ exposedList

135+

136+

137+addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a

138+addExposed =

139+ Map.unionWith Env.mergeInfo

140+

141+

142+addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a

143+addQualified prefix exposed qualified =

144+ Map.insertWith addExposed prefix exposed qualified

145+

146+

147+

148+-- UNION

149+

150+

151+unionToType :: ModuleName.Canonical -> Name.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)

152+unionToType home name union =

153+ unionToTypeHelp home name <$> I.toPublicUnion union

154+

155+

156+unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)

157+unionToTypeHelp home name union@(Can.Union vars ctors _ _) =

158+ let

159+ addCtor dict (Can.Ctor ctor index _ args) =

160+ Map.insert ctor (Env.Specific home (Env.Ctor home name union index args)) dict

161+ in

162+ ( Env.Union (length vars) home

163+ , List.foldl' addCtor Map.empty ctors

164+ )

165+

166+

167+

168+-- ALIAS

169+

170+

171+aliasToType :: ModuleName.Canonical -> Name.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)

172+aliasToType home name alias =

173+ aliasToTypeHelp home name <$> I.toPublicAlias alias

174+

175+

176+aliasToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)

177+aliasToTypeHelp home name (Can.Alias vars tipe) =

178+ (

179+ Env.Alias (length vars) home vars tipe

180+ ,

181+ case tipe of

182+ Can.TRecord fields Nothing ->

183+ let

184+ avars = map (\var -> (var, Can.TVar var)) vars

185+ alias =

186+ foldr

187+ (\(_,t1) t2 -> Can.TLambda t1 t2)

188+ (Can.TAlias home name avars (Can.Filled tipe))

189+ (Can.fieldsToList fields)

190+ in

191+ Map.singleton name (Env.Specific home (Env.RecordCtor home vars alias))

192+

193+ _ ->

194+ Map.empty

195+ )

196+

197+

198+

199+-- BINOP

200+

201+

202+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Env.Info Env.Binop

203+binopToBinop home op (I.Binop name annotation associativity precedence) =

204+ Env.Specific home (Env.Binop op home name annotation associativity precedence)

205+

206+

207+

208+-- ADD EXPOSED VALUE

209+

210+

211+addExposedValue

212+ :: ModuleName.Canonical

213+ -> Env.Exposed Can.Annotation

214+ -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor)

215+ -> Map.Map Name.Name I.Binop

216+ -> State

217+ -> Src.Exposed

218+ -> Result i w State

219+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =

220+ case exposed of

221+ Src.Lower (A.At region name) ->

222+ case Map.lookup name vars of

223+ Just info ->

224+ Result.ok (State (Map.insertWith Env.mergeInfo name info vs) ts cs bs qvs qts qcs)

225+

226+ Nothing ->

227+ Result.throw (Error.ImportExposingNotFound region home name (Map.keys vars))

228+

229+ Src.Upper (A.At region name) privacy ->

230+ case privacy of

231+ Src.Private ->

232+ case Map.lookup name types of

233+ Just (tipe, ctors) ->

234+ case tipe of

235+ Env.Union _ _ ->

236+ let

237+ !ts2 = Map.insert name (Env.Specific home tipe) ts

238+ in

239+ Result.ok (State vs ts2 cs bs qvs qts qcs)

240+

241+ Env.Alias _ _ _ _ ->

242+ let

243+ !ts2 = Map.insert name (Env.Specific home tipe) ts

244+ !cs2 = addExposed cs ctors

245+ in

246+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)

247+

248+ Nothing ->

249+ case checkForCtorMistake name types of

250+ tipe:_ ->

251+ Result.throw $ Error.ImportCtorByName region name tipe

252+

253+ [] ->

254+ Result.throw $ Error.ImportExposingNotFound region home name (Map.keys types)

255+

256+ Src.Public dotDotRegion ->

257+ case Map.lookup name types of

258+ Just (tipe, ctors) ->

259+ case tipe of

260+ Env.Union _ _ ->

261+ let

262+ !ts2 = Map.insert name (Env.Specific home tipe) ts

263+ !cs2 = addExposed cs ctors

264+ in

265+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)

266+

267+ Env.Alias _ _ _ _ ->

268+ Result.throw (Error.ImportOpenAlias dotDotRegion name)

269+

270+ Nothing ->

271+ Result.throw (Error.ImportExposingNotFound region home name (Map.keys types))

272+

273+ Src.Operator region op ->

274+ case Map.lookup op binops of

275+ Just binop ->

276+ let

277+ !bs2 = Map.insert op (binopToBinop home op binop) bs

278+ in

279+ Result.ok (State vs ts cs bs2 qvs qts qcs)

280+

281+ Nothing ->

282+ Result.throw (Error.ImportExposingNotFound region home op (Map.keys binops))

283+

284+

285+checkForCtorMistake :: Name.Name -> Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> [Name.Name]

286+checkForCtorMistake givenName types =

287+ Map.foldr addMatches [] types

288+ where

289+ addMatches (_, exposedCtors) matches =

290+ Map.foldrWithKey addMatch matches exposedCtors

291+

292+ addMatch ctorName info matches =

293+ if ctorName /= givenName

294+ then matches

295+ else

296+ case info of

297+ Env.Specific _ (Env.Ctor _ tipeName _ _ _) ->

298+ tipeName : matches

299+

300+ Env.Specific _ (Env.RecordCtor _ _ _) ->

301+ matches

302+

303+ Env.Ambiguous _ _ ->

304+ matches

src/Canonicalize/Environment/Local.hs → compiler/src/Canonicalize/Environment/Local.hsrenamed+75−77

@@ -6,24 +6,21 @@ module Canonicalize.Environment.Local

66 where

77

88

9−import Control.Arrow (first)

109import Control.Monad (foldM)

1110import qualified Data.Graph as Graph

1211import qualified Data.List as List

1312import qualified Data.Map.Strict as Map

13+import qualified Data.Name as Name

1414

1515import qualified AST.Canonical as Can

1616import qualified AST.Source as Src

17−import qualified AST.Valid as Valid

18−import qualified AST.Module.Name as ModuleName

1917import qualified Canonicalize.Environment as Env

2018import qualified Canonicalize.Environment.Dups as Dups

2119import qualified Canonicalize.Type as Type

2220import qualified Data.Index as Index

23−import qualified Elm.Name as N

21+import qualified Elm.ModuleName as ModuleName

2422import qualified Reporting.Annotation as A

2523import qualified Reporting.Error.Canonicalize as Error

26−import qualified Reporting.Region as R

2724import qualified Reporting.Result as Result

2825

2926

@@ -35,11 +32,11 @@ type Result i w a =

3532 Result.Result i w Error.Error a

3633

3734

38−type Unions = Map.Map N.Name Can.Union

39−type Aliases = Map.Map N.Name Can.Alias

35+type Unions = Map.Map Name.Name Can.Union

36+type Aliases = Map.Map Name.Name Can.Alias

4037

4138

42−add :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)

39+add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)

4340add module_ env =

4441 addCtors module_ =<< addVars module_ =<< addTypes module_ env

4542

@@ -48,7 +45,7 @@ add module_ env =

4845-- ADD VARS

4946

5047

51−addVars :: Valid.Module -> Env.Env -> Result i w Env.Env

48+addVars :: Src.Module -> Env.Env -> Result i w Env.Env

5249addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =

5350 do topLevelVars <- collectVars module_

5451 let vs2 = Map.union topLevelVars vs

@@ -56,38 +53,38 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =

5653 Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs

5754

5855

59−collectVars :: Valid.Module -> Result i w (Map.Map N.Name Env.Var)

60−collectVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =

56+collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)

57+collectVars (Src.Module _ _ _ _ values _ _ _ effects) =

6158 let

62− addDecl dict (A.At _ (Valid.Decl (A.At region name) _ _ _)) =

59+ addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =

6360 Dups.insert name region (Env.TopLevel region) dict

6461 in

6562 Dups.detect Error.DuplicateDecl $

66− List.foldl' addDecl (toEffectDups effects) decls

63+ List.foldl' addDecl (toEffectDups effects) values

6764

6865

69−toEffectDups :: Valid.Effects -> Dups.Dict Env.Var

66+toEffectDups :: Src.Effects -> Dups.Dict Env.Var

7067toEffectDups effects =

7168 case effects of

72− Valid.NoEffects ->

69+ Src.NoEffects ->

7370 Dups.none

7471

75− Valid.Ports ports ->

72+ Src.Ports ports ->

7673 let

77− addPort dict (Valid.Port (A.At region name) _) =

74+ addPort dict (Src.Port (A.At region name) _) =

7875 Dups.insert name region (Env.TopLevel region) dict

7976 in

8077 List.foldl' addPort Dups.none ports

8178

82− Valid.Manager _ manager ->

79+ Src.Manager _ manager ->

8380 case manager of

84− Valid.Cmd (A.At region _) ->

81+ Src.Cmd (A.At region _) ->

8582 Dups.one "command" region (Env.TopLevel region)

8683

87− Valid.Sub (A.At region _) ->

84+ Src.Sub (A.At region _) ->

8885 Dups.one "subscription" region (Env.TopLevel region)

8986

90− Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->

87+ Src.Fx (A.At regionCmd _) (A.At regionSub _) ->

9188 Dups.union

9289 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))

9390 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))

@@ -97,11 +94,11 @@ toEffectDups effects =

9794-- ADD TYPES

9895

9996

100−addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env

101−addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =

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) =

10299 let

103− addAliasDups dups (Valid.Alias _ (A.At region name) _ _) = Dups.insert name region () dups

104− addUnionDups dups (Valid.Union _ (A.At region name) _ _) = Dups.insert name region () dups

100+ addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups

101+ addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups

105102 typeNameDups =

106103 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions

107104 in

@@ -110,10 +107,10 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs

110107 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)

111108

112109

113−addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)

114−addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =

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) _ _)) =

115112 do arity <- checkUnionFreeVars union

116− let one = Map.singleton home (Env.Union arity home)

113+ let one = Env.Specific home (Env.Union arity home)

117114 Result.ok $ Map.insert name one types

118115

119116

@@ -121,7 +118,7 @@ addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =

121118-- ADD TYPE ALIASES

122119

123120

124−addAliases :: [Valid.Alias] -> Env.Env -> Result i w Env.Env

121+addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env

125122addAliases aliases env =

126123 let

127124 nodes = map toNode aliases

@@ -130,22 +127,22 @@ addAliases aliases env =

130127 foldM addAlias env sccs

131128

132129

133−addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env

130+addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env

134131addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =

135132 case scc of

136− Graph.AcyclicSCC alias@(Valid.Alias _ (A.At _ name) _ tipe) ->

133+ Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->

137134 do args <- checkAliasFreeVars alias

138135 ctype <- Type.canonicalize env tipe

139− let one = Map.singleton home (Env.Alias (length args) home args ctype)

136+ let one = Env.Specific home (Env.Alias (length args) home args ctype)

140137 let ts1 = Map.insert name one ts

141138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs

142139

143140 Graph.CyclicSCC [] ->

144141 Result.ok env

145142

146− Graph.CyclicSCC (alias@(Valid.Alias _ (A.At region name1) _ tipe) : others) ->

143+ Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->

147144 do args <- checkAliasFreeVars alias

148− let toName (Valid.Alias _ (A.At _ name) _ _) = name

145+ let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name

149146 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))

150147

151148

@@ -153,12 +150,12 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =

153150-- DETECT TYPE ALIAS CYCLES

154151

155152

156−toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])

157−toNode alias@(Valid.Alias _ (A.At _ name) _ tipe) =

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)) =

158155 ( alias, name, getEdges [] tipe )

159156

160157

161−getEdges :: [N.Name] -> Src.Type -> [N.Name]

158+getEdges :: [Name.Name] -> Src.Type -> [Name.Name]

162159getEdges edges (A.At _ tipe) =

163160 case tipe of

164161 Src.TLambda arg result ->

@@ -187,8 +184,8 @@ getEdges edges (A.At _ tipe) =

187184-- CHECK FREE VARIABLES

188185

189186

190−checkUnionFreeVars :: Valid.Union -> Result i w Int

191−checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =

187+checkUnionFreeVars :: A.Located Src.Union -> Result i w Int

188+checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =

192189 let

193190 addArg (A.At region arg) dict =

194191 Dups.insert arg region region dict

@@ -207,8 +204,8 @@ checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =

207204 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds

208205

209206

210−checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]

211−checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =

207+checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]

208+checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =

212209 let

213210 addArg (A.At region arg) dict =

214211 Dups.insert arg region region dict

@@ -219,15 +216,14 @@ checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =

219216 if Map.size boundVars == overlap && Map.size freeVars == overlap

220217 then Result.ok (map A.toValue args)

221218 else

222− let toLoc (arg, region) = A.At region arg in

223219 Result.throw $

224220 Error.TypeVarsMessedUpInAlias aliasRegion name

225221 (map A.toValue args)

226− (map toLoc (Map.toList (Map.difference boundVars freeVars)))

227− (map toLoc (Map.toList (Map.difference freeVars boundVars)))

222+ (Map.toList (Map.difference boundVars freeVars))

223+ (Map.toList (Map.difference freeVars boundVars))

228224

229225

230−addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region

226+addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region

231227addFreeVars freeVars (A.At region tipe) =

232228 case tipe of

233229 Src.TLambda arg result ->

@@ -265,8 +261,8 @@ addFreeVars freeVars (A.At region tipe) =

265261-- ADD CTORS

266262

267263

268−addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)

269−addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =

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) =

270266 do unionInfo <- traverse (canonicalizeUnion env) unions

271267 aliasInfo <- traverse (canonicalizeAlias env) aliases

272268

@@ -285,45 +281,47 @@ addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts c

285281 )

286282

287283

288−type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)

284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)

289285

290286

291287

292288-- CANONICALIZE ALIAS

293289

294290

295−canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )

296−canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =

297− case tipe of

298− A.At _ (Src.TRecord fields Nothing) ->

299− do cfields <- traverse (traverse (Type.canonicalize env)) fields

300− fieldDict <- Dups.checkFields cfields

301−

302− let recordType = Can.TRecord fieldDict Nothing

303− let ctorType = foldr (Can.TLambda . snd) recordType cfields

304− let vars = map A.toValue args

305− let alias = Can.Alias vars recordType (Just (map (first A.toValue) cfields))

306− let ctor = Env.RecordCtor home vars ctorType

307−

308− Result.ok

309− ( (name, alias)

310− , Dups.one name region (Map.singleton home ctor)

311− )

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+ )

312305

313− _ ->

314− do ctipe <- Type.canonicalize env tipe

315− Result.ok

316− ( (name, Can.Alias (map A.toValue args) ctipe Nothing)

317− , Dups.none

318− )

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

319317

320318

321319

322320-- CANONICALIZE UNION

323321

324322

325−canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )

326−canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name) avars ctors) =

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)) =

327325 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors

328326 let vars = map A.toValue avars

329327 let alts = map A.toValue cctors

@@ -334,14 +332,14 @@ canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name)

334332 )

335333

336334

337−canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)

335+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)

338336canonicalizeCtor env index (A.At region ctor, tipes) =

339337 do ctipes <- traverse (Type.canonicalize env) tipes

340338 Result.ok $ A.At region $

341339 Can.Ctor ctor index (length ctipes) ctipes

342340

343341

344−toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts

342+toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts

345343toOpts ctors =

346344 case ctors of

347345 [ (_,[_]) ] ->

@@ -351,7 +349,7 @@ toOpts ctors =

351349 if all (null . snd) ctors then Can.Enum else Can.Normal

352350

353351

354−toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups

352+toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups

355353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =

356− Dups.one name region $ Map.singleton home $

354+ Dups.one name region $ Env.Specific home $

357355 Env.Ctor home typeName union index args

src/Canonicalize/Expression.hs → compiler/src/Canonicalize/Expression.hsrenamed+78−77

@@ -14,23 +14,21 @@ import Control.Monad (foldM)

1414import qualified Data.Graph as Graph

1515import qualified Data.List as List

1616import qualified Data.Map.Strict as Map

17−import qualified Data.Map.Strict.Internal as I

17+import qualified Data.Name as Name

1818

1919import qualified AST.Canonical as Can

2020import qualified AST.Source as Src

21−import qualified AST.Module.Name as ModuleName

2221import qualified AST.Utils.Binop as Binop

2322import qualified AST.Utils.Type as Type

24−import qualified AST.Valid as Valid

2523import qualified Canonicalize.Environment as Env

2624import qualified Canonicalize.Environment.Dups as Dups

2725import qualified Canonicalize.Pattern as Pattern

2826import qualified Canonicalize.Type as Type

2927import qualified Data.Index as Index

30−import qualified Elm.Name as N

28+import qualified Elm.ModuleName as ModuleName

29+import qualified Elm.Package as Pkg

3130import qualified Reporting.Annotation as A

3231import qualified Reporting.Error.Canonicalize as Error

33−import qualified Reporting.Region as R

3432import qualified Reporting.Result as Result

3533import qualified Reporting.Warning as W

3634

@@ -44,7 +42,7 @@ type Result i w a =

4442

4543

4644type FreeLocals =

47− Map.Map N.Name Uses

45+ Map.Map Name.Name Uses

4846

4947

5048data Uses =

@@ -58,46 +56,46 @@ data Uses =

5856-- CANONICALIZE

5957

6058

61−canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

59+canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr

6260canonicalize env (A.At region expression) =

6361 A.At region <$>

6462 case expression of

65− Valid.Str string ->

63+ Src.Str string ->

6664 Result.ok (Can.Str string)

6765

68− Valid.Chr char ->

66+ Src.Chr char ->

6967 Result.ok (Can.Chr char)

7068

71− Valid.Int int ->

69+ Src.Int int ->

7270 Result.ok (Can.Int int)

7371

74− Valid.Float float ->

72+ Src.Float float ->

7573 Result.ok (Can.Float float)

7674

77− Valid.Var varType name ->

75+ Src.Var varType name ->

7876 case varType of

79− Src.Value -> findVar region env name

80− Src.Ctor -> toVarCtor name <$> Env.findCtor region env name

77+ Src.LowVar -> findVar region env name

78+ Src.CapVar -> toVarCtor name <$> Env.findCtor region env name

8179

82− Valid.VarQual varType prefix name ->

80+ Src.VarQual varType prefix name ->

8381 case varType of

84− Src.Value -> findVarQual region env prefix name

85− Src.Ctor -> toVarCtor name <$> Env.findCtorQual region env prefix name

82+ Src.LowVar -> findVarQual region env prefix name

83+ Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name

8684

87− Valid.List exprs ->

85+ Src.List exprs ->

8886 Can.List <$> traverse (canonicalize env) exprs

8987

90− Valid.Op op ->

88+ Src.Op op ->

9189 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op

9290 return (Can.VarOperator op home name annotation)

9391

94− Valid.Negate expr ->

92+ Src.Negate expr ->

9593 Can.Negate <$> canonicalize env expr

9694

97− Valid.Binops ops final ->

95+ Src.Binops ops final ->

9896 A.toValue <$> canonicalizeBinops region env ops final

9997

100− Valid.Lambda srcArgs body ->

98+ Src.Lambda srcArgs body ->

10199 delayedUsage $

102100 do (args, bindings) <-

103101 Pattern.verify Error.DPLambdaArgs $

@@ -111,60 +109,63 @@ canonicalize env (A.At region expression) =

111109

112110 return (Can.Lambda args cbody, freeLocals)

113111

114− Valid.Call func args ->

112+ Src.Call func args ->

115113 Can.Call

116114 <$> canonicalize env func

117115 <*> traverse (canonicalize env) args

118116

119− Valid.If branches finally ->

117+ Src.If branches finally ->

120118 Can.If

121119 <$> traverse (canonicalizeIfBranch env) branches

122120 <*> canonicalize env finally

123121

124− Valid.Let defs expr ->

122+ Src.Let defs expr ->

125123 A.toValue <$> canonicalizeLet region env defs expr

126124

127− Valid.Case expr branches ->

125+ Src.Case expr branches ->

128126 Can.Case

129127 <$> canonicalize env expr

130128 <*> traverse (canonicalizeCaseBranch env) branches

131129

132− Valid.Accessor field ->

130+ Src.Accessor field ->

133131 Result.ok $ Can.Accessor field

134132

135− Valid.Access record field ->

133+ Src.Access record field ->

136134 Can.Access

137135 <$> canonicalize env record

138136 <*> Result.ok field

139137

140− Valid.Update (A.At reg name) fields ->

141− do fieldDict <- Dups.checkFields fields

142− name_ <- findVar reg env name

143− Can.Update (A.At reg name_)

144− <$> traverse (canonicalize env) fieldDict

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)

145146

146− Valid.Record fields ->

147+ Src.Record fields ->

147148 do fieldDict <- Dups.checkFields fields

148149 Can.Record <$> traverse (canonicalize env) fieldDict

149150

150− Valid.Unit ->

151+ Src.Unit ->

151152 Result.ok Can.Unit

152153

153− Valid.Tuple a b cs ->

154+ Src.Tuple a b cs ->

154155 Can.Tuple

155156 <$> canonicalize env a

156157 <*> canonicalize env b

157158 <*> canonicalizeTupleExtras region env cs

158159

159− Valid.Shader uid src tipe ->

160− Result.ok (Can.Shader uid src tipe)

160+ Src.Shader src tipe ->

161+ Result.ok (Can.Shader src tipe)

161162

162163

163164

164165-- CANONICALIZE TUPLE EXTRAS

165166

166167

167−canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)

168+canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)

168169canonicalizeTupleExtras region env extras =

169170 case extras of

170171 [] ->

@@ -181,7 +182,7 @@ canonicalizeTupleExtras region env extras =

181182-- CANONICALIZE IF BRANCH

182183

183184

184−canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)

185+canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)

185186canonicalizeIfBranch env (condition, branch) =

186187 (,)

187188 <$> canonicalize env condition

@@ -192,7 +193,7 @@ canonicalizeIfBranch env (condition, branch) =

192193-- CANONICALIZE CASE BRANCH

193194

194195

195−canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch

196+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch

196197canonicalizeCaseBranch env (pattern, expr) =

197198 directUsage $

198199 do (cpattern, bindings) <-

@@ -210,7 +211,7 @@ canonicalizeCaseBranch env (pattern, expr) =

210211-- CANONICALIZE BINOPS

211212

212213

213−canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

214+canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr

214215canonicalizeBinops overallRegion env ops final =

215216 let

216217 canonicalizeHelp (expr, A.At region op) =

@@ -231,7 +232,7 @@ data Step

231232 | Error Env.Binop Env.Binop

232233

233234

234−runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr

235+runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr

235236runBinopStepper overallRegion step =

236237 case step of

237238 Done expr ->

@@ -293,7 +294,7 @@ toBinop (Env.Binop op home name annotation _ _) left right =

293294-- CANONICALIZE LET

294295

295296

296−canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

297+canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr

297298canonicalizeLet letRegion env defs body =

298299 directUsage $

299300 do bindings <-

@@ -312,17 +313,17 @@ canonicalizeLet letRegion env defs body =

312313-- ADD BINDINGS

313314

314315

315−addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region

316−addBindings bindings def =

316+addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region

317+addBindings bindings (A.At _ def) =

317318 case def of

318− Valid.Define _ (A.At region name) _ _ _ ->

319+ Src.Define (A.At region name) _ _ _ ->

319320 Dups.insert name region region bindings

320321

321− Valid.Destruct _ pattern _ ->

322+ Src.Destruct pattern _ ->

322323 addBindingsHelp bindings pattern

323324

324325

325−addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region

326+addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region

326327addBindingsHelp bindings (A.At region pattern) =

327328 case pattern of

328329 Src.PAnything ->

@@ -375,19 +376,19 @@ addBindingsHelp bindings (A.At region pattern) =

375376

376377

377378type Node =

378− (Binding, N.Name, [N.Name])

379+ (Binding, Name.Name, [Name.Name])

379380

380381

381382data Binding

382383 = Define Can.Def

383− | Edge (A.Located N.Name)

384+ | Edge (A.Located Name.Name)

384385 | Destruct Can.Pattern Can.Expr

385386

386387

387−addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]

388−addDefNodes env nodes def =

388+addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node]

389+addDefNodes env nodes (A.At _ def) =

389390 case def of

390− Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->

391+ Src.Define aname@(A.At _ name) srcArgs body maybeType ->

391392 case maybeType of

392393 Nothing ->

393394 do (args, argBindings) <-

@@ -420,7 +421,7 @@ addDefNodes env nodes def =

420421 let node = ( Define cdef, name, Map.keys freeLocals )

421422 logLetLocals args freeLocals (node:nodes)

422423

423− Valid.Destruct _ pattern body ->

424+ Src.Destruct pattern body ->

424425 do (cpattern, _bindings) <-

425426 Pattern.verify Error.DPDestruct $

426427 Pattern.canonicalize env pattern

@@ -435,7 +436,7 @@ addDefNodes env nodes def =

435436 (\freeLocals warnings cbody ->

436437 let

437438 names = getPatternNames [] pattern

438− name = N.toCompositeName (map A.toValue names)

439+ name = Name.fromManyNames (map A.toValue names)

439440 node = ( Destruct cpattern cbody, name, Map.keys freeLocals )

440441 in

441442 good

@@ -458,12 +459,12 @@ logLetLocals args letLocals value =

458459 value

459460

460461

461−addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]

462+addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node]

462463addEdge edges nodes aname@(A.At _ name) =

463464 (Edge aname, name, edges) : nodes

464465

465466

466−getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]

467+getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]

467468getPatternNames names (A.At region pattern) =

468469 case pattern of

469470 Src.PAnything -> names

@@ -487,7 +488,7 @@ getPatternNames names (A.At region pattern) =

487488

488489gatherTypedArgs

489490 :: Env.Env

490− -> N.Name

491+ -> Name.Name

491492 -> [Src.Pattern]

492493 -> Can.Type

493494 -> Index.ZeroBased

@@ -508,14 +509,14 @@ gatherTypedArgs env name srcArgs tipe index revTypedArgs =

508509 _ ->

509510 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in

510511 Result.throw $

511− Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)

512+ Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs)

512513

513514

514515

515516-- DETECT CYCLES

516517

517518

518−detectCycles :: R.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr

519+detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr

519520detectCycles letRegion sccs body =

520521 case sccs of

521522 [] ->

@@ -571,7 +572,7 @@ checkCycle bindings defs =

571572 checkCycle otherBindings defs

572573

573574

574−toNames :: [Binding] -> [Can.Def] -> [N.Name]

575+toNames :: [Binding] -> [Can.Def] -> [Name.Name]

575576toNames bindings revDefs =

576577 case bindings of

577578 [] ->

@@ -584,7 +585,7 @@ toNames bindings revDefs =

584585 Destruct _ _ -> toNames otherBindings revDefs

585586

586587

587−getDefName :: Can.Def -> N.Name

588+getDefName :: Can.Def -> Name.Name

588589getDefName def =

589590 case def of

590591 Can.Def (A.At _ name) _ _ ->

@@ -598,7 +599,7 @@ getDefName def =

598599-- LOG VARIABLE USES

599600

600601

601−logVar :: N.Name -> a -> Result FreeLocals w a

602+logVar :: Name.Name -> a -> Result FreeLocals w a

602603logVar name value =

603604 Result.Result $ \freeLocals warnings _ good ->

604605 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value

@@ -653,7 +654,7 @@ verifyBindings context bindings (Result.Result k) =

653654 )

654655

655656

656−addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> R.Region -> [W.Warning]

657+addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning]

657658addUnusedWarning context warnings name region =

658659 W.UnusedVariable region context name : warnings

659660

@@ -683,7 +684,7 @@ delayedUsage (Result.Result k) =

683684-- FIND VARIABLE

684685

685686

686−findVar :: R.Region -> Env.Env -> N.Name -> Result FreeLocals w Can.Expr_

687+findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_

687688findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =

688689 case Map.lookup name vs of

689690 Just var ->

@@ -694,46 +695,46 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =

694695 Env.TopLevel _ ->

695696 logVar name (Can.VarTopLevel localHome name)

696697

697− Env.Foreign (I.Bin 1 home annotation _ _) ->

698+ Env.Foreign home annotation ->

698699 Result.ok $

699700 if home == ModuleName.debug then

700701 Can.VarDebug localHome name annotation

701702 else

702703 Can.VarForeign home name annotation

703704

704− Env.Foreign homes ->

705− Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))

705+ Env.Foreigns h hs ->

706+ Result.throw (Error.AmbiguousVar region Nothing name h hs)

706707

707708 Nothing ->

708709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))

709710

710711

711−findVarQual :: R.Region -> Env.Env -> N.Name -> N.Name -> Result FreeLocals w Can.Expr_

712+findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_

712713findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =

713714 case Map.lookup prefix qvs of

714715 Just qualified ->

715716 case Map.lookup name qualified of

716− Just (I.Bin 1 home annotation _ _) ->

717+ Just (Env.Specific home annotation) ->

717718 Result.ok $

718719 if home == ModuleName.debug then

719720 Can.VarDebug localHome name annotation

720721 else

721722 Can.VarForeign home name annotation

722723

723− Just homes ->

724− Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))

724+ Just (Env.Ambiguous h hs) ->

725+ Result.throw (Error.AmbiguousVar region (Just prefix) name h hs)

725726

726727 Nothing ->

727728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))

728729

729730 Nothing ->

730− if ModuleName.isKernel prefix then

731− Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name

731+ if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then

732+ Result.ok $ Can.VarKernel (Name.getKernel prefix) name

732733 else

733734 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))

734735

735736

736−toPossibleNames :: Map.Map N.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames

737+toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames

737738toPossibleNames exposed qualified =

738739 Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)

739740

@@ -742,7 +743,7 @@ toPossibleNames exposed qualified =

742743-- FIND CTOR

743744

744745

745−toVarCtor :: N.Name -> Env.Ctor -> Can.Expr_

746+toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_

746747toVarCtor name ctor =

747748 case ctor of

748749 Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->

src/Canonicalize/Module.hs → compiler/src/Canonicalize/Module.hsrenamed+65−74

@@ -7,11 +7,10 @@ module Canonicalize.Module

77

88import qualified Data.Graph as Graph

99import qualified Data.Map as Map

10+import qualified Data.Name as Name

1011

1112import qualified AST.Canonical as Can

1213import qualified AST.Source as Src

13−import qualified AST.Valid as Valid

14−import qualified AST.Module.Name as ModuleName

1514import qualified Canonicalize.Effects as Effects

1615import qualified Canonicalize.Environment as Env

1716import qualified Canonicalize.Environment.Dups as Dups

@@ -22,11 +21,10 @@ import qualified Canonicalize.Pattern as Pattern

2221import qualified Canonicalize.Type as Type

2322import qualified Data.Index as Index

2423import qualified Elm.Interface as I

25−import qualified Elm.Name as N

24+import qualified Elm.ModuleName as ModuleName

2625import qualified Elm.Package as Pkg

2726import qualified Reporting.Annotation as A

2827import qualified Reporting.Error.Canonicalize as Error

29−import qualified Reporting.Region as R

3028import qualified Reporting.Result as Result

3129import qualified Reporting.Warning as W

3230

@@ -43,47 +41,28 @@ type Result i w a =

4341-- MODULES

4442

4543

46−canonicalize

47− :: Pkg.Name

48− -> Map.Map N.Name ModuleName.Canonical

49− -> I.Interfaces

50− -> Valid.Module

51− -> Result i [W.Warning] Can.Module

52−canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls _ _ binops effects) =

53− do let home = ModuleName.Canonical pkg name

44+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module

45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =

46+ do let home = ModuleName.Canonical pkg (Src.getName modul)

5447 let cbinops = Map.fromList (map canonicalizeBinop binops)

5548

5649 (env, cunions, caliases) <-

57− Local.add module_ =<<

58− Foreign.createInitialEnv home importDict interfaces imports

50+ Local.add modul =<<

51+ Foreign.createInitialEnv home ifaces imports

5952

60− cdecls <- canonicalizeDecls env decls

61− ceffects <- Effects.canonicalize env decls cunions effects

62− cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports

53+ cvalues <- canonicalizeValues env values

54+ ceffects <- Effects.canonicalize env values cunions effects

55+ cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports

6356

64− return $ Can.Module home (toDocs module_) cexports cdecls cunions caliases cbinops ceffects

65−

66−

67−

68−-- DOCUMENTATION

69−

70−

71−toDocs :: Valid.Module -> Can.Docs

72−toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =

73− case docs of

74− Src.NoDocs start end ->

75− Can.NoDocs start end

76−

77− Src.YesDocs start end overview ->

78− Can.YesDocs start end overview comments

57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects

7958

8059

8160

8261-- CANONICALIZE BINOP

8362

8463

85−canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )

86−canonicalizeBinop (Valid.Binop op associativity precedence func) =

64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )

65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =

8766 ( op, Can.Binop_ associativity precedence func )

8867

8968

@@ -97,9 +76,9 @@ canonicalizeBinop (Valid.Binop op associativity precedence func) =

9776--

9877

9978

100−canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls

101−canonicalizeDecls env decls =

102− do nodes <- traverse (toNodeOne env) decls

79+canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls

80+canonicalizeValues env values =

81+ do nodes <- traverse (toNodeOne env) values

10382 detectCycles (Graph.stronglyConnComp nodes)

10483

10584

@@ -114,13 +93,11 @@ detectCycles sccs =

11493 Graph.AcyclicSCC (def, _, _) ->

11594 Can.Declare def <$> detectCycles otherSccs

11695

117− Graph.CyclicSCC [] ->

118− detectCycles otherSccs

119−

12096 Graph.CyclicSCC subNodes ->

121− Can.DeclareRec

122− <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)

123− <*> detectCycles otherSccs

97+ do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)

98+ case defs of

99+ [] -> detectCycles otherSccs

100+ d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs

124101

125102

126103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def

@@ -129,8 +106,22 @@ detectBadCycles scc =

129106 Graph.AcyclicSCC def ->

130107 Result.ok def

131108

132− Graph.CyclicSCC cyclicValueDefs ->

133− Result.throw (Error.RecursiveDecl cyclicValueDefs)

109+ Graph.CyclicSCC [] ->

110+ error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"

111+

112+ Graph.CyclicSCC (def:defs) ->

113+ let

114+ (A.At region name) = extractDefName def

115+ names = map (A.toValue . extractDefName) defs

116+ in

117+ Result.throw (Error.RecursiveDecl region name names)

118+

119+

120+extractDefName :: Can.Def -> A.Located Name.Name

121+extractDefName def =

122+ case def of

123+ Can.Def name _ _ -> name

124+ Can.TypedDef name _ _ _ _ -> name

134125

135126

136127

@@ -142,17 +133,17 @@ detectBadCycles scc =

142133-- Phase one nodes track ALL dependencies.

143134-- This allows us to find cyclic values for type inference.

144135type NodeOne =

145− (NodeTwo, N.Name, [N.Name])

136+ (NodeTwo, Name.Name, [Name.Name])

146137

147138

148139-- Phase two nodes track DIRECT dependencies.

149140-- This allows us to detect cycles that definitely do not terminate.

150141type NodeTwo =

151− (Can.Def, N.Name, [N.Name])

142+ (Can.Def, Name.Name, [Name.Name])

152143

153144

154−toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne

155−toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =

145+toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne

146+toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =

156147 case maybeType of

157148 Nothing ->

158149 do (args, argBindings) <-

@@ -193,7 +184,7 @@ toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =

193184 )

194185

195186

196−toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo

187+toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo

197188toNodeTwo name args def freeLocals =

198189 case args of

199190 [] ->

@@ -203,7 +194,7 @@ toNodeTwo name args def freeLocals =

203194 (def, name, [])

204195

205196

206−addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]

197+addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]

207198addDirects name (Expr.Uses directUses _) directDeps =

208199 if directUses > 0 then

209200 name:directDeps

@@ -216,41 +207,41 @@ addDirects name (Expr.Uses directUses _) directDeps =

216207

217208

218209canonicalizeExports

219− :: [A.Located Valid.Decl]

220− -> Map.Map N.Name union

221− -> Map.Map N.Name alias

222− -> Map.Map N.Name binop

210+ :: [A.Located Src.Value]

211+ -> Map.Map Name.Name union

212+ -> Map.Map Name.Name alias

213+ -> Map.Map Name.Name binop

223214 -> Can.Effects

224215 -> A.Located Src.Exposing

225216 -> Result i w Can.Exports

226−canonicalizeExports decls unions aliases binops effects (A.At region exposing) =

217+canonicalizeExports values unions aliases binops effects (A.At region exposing) =

227218 case exposing of

228219 Src.Open ->

229220 Result.ok (Can.ExportEverything region)

230221

231222 Src.Explicit exposeds ->

232− do let names = Map.fromList (map declToName decls)

223+ do let names = Map.fromList (map valueToName values)

233224 infos <- traverse (checkExposed names unions aliases binops effects) exposeds

234225 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)

235226

236227

237−declToName :: A.Located Valid.Decl -> ( N.Name, () )

238−declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =

228+valueToName :: A.Located Src.Value -> ( Name.Name, () )

229+valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =

239230 ( name, () )

240231

241232

242233checkExposed

243− :: Map.Map N.Name decl

244− -> Map.Map N.Name union

245− -> Map.Map N.Name alias

246− -> Map.Map N.Name binop

234+ :: Map.Map Name.Name value

235+ -> Map.Map Name.Name union

236+ -> Map.Map Name.Name alias

237+ -> Map.Map Name.Name binop

247238 -> Can.Effects

248− -> A.Located Src.Exposed

239+ -> Src.Exposed

249240 -> Result i w (Dups.Dict (A.Located Can.Export))

250−checkExposed decls unions aliases binops effects (A.At region exposed) =

241+checkExposed values unions aliases binops effects exposed =

251242 case exposed of

252− Src.Lower name ->

253− if Map.member name decls then

243+ Src.Lower (A.At region name) ->

244+ if Map.member name values then

254245 ok name region Can.ExportValue

255246 else

256247 case checkPorts effects name of

@@ -259,25 +250,25 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =

259250

260251 Just ports ->

261252 Result.throw $ Error.ExportNotFound region Error.BadVar name $

262− ports ++ Map.keys decls

253+ ports ++ Map.keys values

263254

264− Src.Operator name ->

255+ Src.Operator region name ->

265256 if Map.member name binops then

266257 ok name region Can.ExportBinop

267258 else

268259 Result.throw $ Error.ExportNotFound region Error.BadOp name $

269260 Map.keys binops

270261

271− Src.Upper name Src.Public ->

262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->

272263 if Map.member name unions then

273264 ok name region Can.ExportUnionOpen

274265 else if Map.member name aliases then

275− Result.throw $ Error.ExportOpenAlias region name

266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name

276267 else

277268 Result.throw $ Error.ExportNotFound region Error.BadType name $

278269 Map.keys unions ++ Map.keys aliases

279270

280− Src.Upper name Src.Private ->

271+ Src.Upper (A.At region name) Src.Private ->

281272 if Map.member name unions then

282273 ok name region Can.ExportUnionClosed

283274 else if Map.member name aliases then

@@ -287,7 +278,7 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =

287278 Map.keys unions ++ Map.keys aliases

288279

289280

290−checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]

281+checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]

291282checkPorts effects name =

292283 case effects of

293284 Can.NoEffects ->

@@ -300,6 +291,6 @@ checkPorts effects name =

300291 Just []

301292

302293

303−ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))

294+ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))

304295ok name region export =

305296 Result.ok $ Dups.one name region (A.At region export)

src/Canonicalize/Pattern.hs → compiler/src/Canonicalize/Pattern.hsrenamed+16−12

@@ -8,17 +8,18 @@ module Canonicalize.Pattern

88 where

99

1010

11+import qualified Data.List as List

1112import qualified Data.Map.Strict as Map

13+import qualified Data.Name as Name

1214

1315import qualified AST.Canonical as Can

1416import qualified AST.Source as Src

1517import qualified Canonicalize.Environment as Env

1618import qualified Canonicalize.Environment.Dups as Dups

1719import qualified Data.Index as Index

18−import qualified Elm.Name as N

20+import qualified Elm.ModuleName as ModuleName

1921import qualified Reporting.Annotation as A

2022import qualified Reporting.Error.Canonicalize as Error

21−import qualified Reporting.Region as R

2223import qualified Reporting.Result as Result

2324

2425

@@ -31,7 +32,7 @@ type Result i w a =

3132

3233

3334type Bindings =

34− Map.Map N.Name R.Region

35+ Map.Map Name.Name A.Region

3536

3637

3738

@@ -59,7 +60,7 @@ verify context (Result.Result k) =

5960

6061

6162type DupsDict =

62− Dups.Dict R.Region

63+ Dups.Dict A.Region

6364

6465

6566canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern

@@ -112,7 +113,7 @@ canonicalize env (A.At region pattern) =

112113 Result.ok (Can.PInt int)

113114

114115

115−canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_

116+canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_

116117canonicalizeCtor env region name patterns ctor =

117118 case ctor of

118119 Env.Ctor home tipe union index args ->

@@ -123,16 +124,19 @@ canonicalizeCtor env region name patterns ctor =

123124 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

124125 case verifiedList of

125126 Index.LengthMatch cargs ->

126− Result.ok (Can.PCtor home tipe union name index cargs)

127+ if tipe == Name.bool && home == ModuleName.basics then

128+ Result.ok (Can.PBool union (name == Name.true))

129+ else

130+ Result.ok (Can.PCtor home tipe union name index cargs)

127131

128132 Index.LengthMismatch actualLength expectedLength ->

129− Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)

133+ Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)

130134

131135 Env.RecordCtor _ _ _ ->

132136 Result.throw (Error.PatternHasRecordCtor region name)

133137

134138

135−canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)

139+canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)

136140canonicalizeTuple tupleRegion env extras =

137141 case extras of

138142 [] ->

@@ -161,17 +165,17 @@ canonicalizeList env list =

161165-- LOG BINDINGS

162166

163167

164−logVar :: N.Name -> R.Region -> a -> Result DupsDict w a

168+logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a

165169logVar name region value =

166170 Result.Result $ \bindings warnings _ ok ->

167171 ok (Dups.insert name region region bindings) warnings value

168172

169173

170−logFields :: [A.Located N.Name] -> a -> Result DupsDict w a

174+logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a

171175logFields fields value =

172176 let

173− addField (A.At region name) dict =

177+ addField dict (A.At region name) =

174178 Dups.insert name region region dict

175179 in

176180 Result.Result $ \bindings warnings _ ok ->

177− ok (foldr addField bindings fields) warnings value

181+ ok (List.foldl' addField bindings fields) warnings value

src/Canonicalize/Type.hs → compiler/src/Canonicalize/Type.hsrenamed+22−9

@@ -9,15 +9,14 @@ module Canonicalize.Type

99

1010import qualified Data.List as List

1111import qualified Data.Map as Map

12+import qualified Data.Name as Name

1213

1314import qualified AST.Canonical as Can

1415import qualified AST.Source as Src

1516import qualified Canonicalize.Environment as Env

1617import qualified Canonicalize.Environment.Dups as Dups

17−import qualified Elm.Name as N

1818import qualified Reporting.Annotation as A

1919import qualified Reporting.Error.Canonicalize as Error

20−import qualified Reporting.Region as R

2120import qualified Reporting.Result as Result

2221

2322

@@ -63,8 +62,7 @@ canonicalize env (A.At typeRegion tipe) =

6362 <*> canonicalize env b

6463

6564 Src.TRecord fields ext ->

66− do fieldDict <- Dups.checkFields fields

67− cfields <- traverse (canonicalize env) fieldDict

65+ do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields)

6866 return $ Can.TRecord cfields (fmap A.toValue ext)

6967

7068 Src.TUnit ->

@@ -86,11 +84,21 @@ canonicalize env (A.At typeRegion tipe) =

8684 Result.throw $ Error.TupleLargerThanThree typeRegion

8785

8886

87+canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)]

88+canonicalizeFields env fields =

89+ let

90+ len = fromIntegral (length fields)

91+ canonicalizeField index (name, srcType) =

92+ (name, Can.FieldType index <$> canonicalize env srcType)

93+ in

94+ zipWith canonicalizeField [0..len] fields

95+

96+

8997

9098-- CANONICALIZE TYPE

9199

92100

93−canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type

101+canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type

94102canonicalizeType env region name args info =

95103 do cargs <- traverse (canonicalize env) args

96104 case info of

@@ -103,7 +111,7 @@ canonicalizeType env region name args info =

103111 Can.TType home name cargs

104112

105113

106−checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer

114+checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer

107115checkArity expected region name args answer =

108116 let actual = length args in

109117 if expected == actual then

@@ -116,7 +124,7 @@ checkArity expected region name args answer =

116124-- ADD FREE VARS

117125

118126

119−addFreeVars :: Map.Map N.Name () -> Can.Type -> Map.Map N.Name ()

127+addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name ()

120128addFreeVars freeVars tipe =

121129 case tipe of

122130 Can.TLambda arg result ->

@@ -129,10 +137,10 @@ addFreeVars freeVars tipe =

129137 List.foldl' addFreeVars freeVars args

130138

131139 Can.TRecord fields Nothing ->

132− Map.foldl addFreeVars freeVars fields

140+ Map.foldl addFieldFreeVars freeVars fields

133141

134142 Can.TRecord fields (Just ext) ->

135− Map.foldl addFreeVars (Map.insert ext () freeVars) fields

143+ Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields

136144

137145 Can.TUnit ->

138146 freeVars

@@ -147,3 +155,8 @@ addFreeVars freeVars tipe =

147155

148156 Can.TAlias _ _ args _ ->

149157 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args

158+

159+

160+addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name ()

161+addFieldFreeVars freeVars (Can.FieldType _ tipe) =

162+ addFreeVars freeVars tipe

compiler/src/Compile.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2+module Compile

3+ ( Artifacts(..)

4+ , compile

5+ )

6+ where

7+

8+

9+import qualified Data.Map as Map

10+import qualified Data.Name as Name

11+

12+import qualified AST.Source as Src

13+import qualified AST.Canonical as Can

14+import qualified AST.Optimized as Opt

15+import qualified Canonicalize.Module as Canonicalize

16+import qualified Elm.Interface as I

17+import qualified Elm.ModuleName as ModuleName

18+import qualified Elm.Package as Pkg

19+import qualified Nitpick.PatternMatches as PatternMatches

20+import qualified Optimize.Module as Optimize

21+import qualified Reporting.Error as E

22+import qualified Reporting.Result as R

23+import qualified Reporting.Render.Type.Localizer as Localizer

24+import qualified Type.Constrain.Module as Type

25+import qualified Type.Solve as Type

26+

27+import System.IO.Unsafe (unsafePerformIO)

28+

29+

30+

31+-- COMPILE

32+

33+

34+data Artifacts =

35+ Artifacts

36+ { _modul :: Can.Module

37+ , _types :: Map.Map Name.Name Can.Annotation

38+ , _graph :: Opt.LocalGraph

39+ }

40+

41+

42+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts

43+compile pkg ifaces modul =

44+ do canonical <- canonicalize pkg ifaces modul

45+ annotations <- typeCheck modul canonical

46+ () <- nitpick canonical

47+ objects <- optimize modul annotations canonical

48+ return (Artifacts canonical annotations objects)

49+

50+

51+

52+-- PHASES

53+

54+

55+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module

56+canonicalize pkg ifaces modul =

57+ case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of

58+ Right canonical ->

59+ Right canonical

60+

61+ Left errors ->

62+ Left $ E.BadNames errors

63+

64+

65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)

66+typeCheck modul canonical =

67+ case unsafePerformIO (Type.run =<< Type.constrain canonical) of

68+ Right annotations ->

69+ Right annotations

70+

71+ Left errors ->

72+ Left (E.BadTypes (Localizer.fromModule modul) errors)

73+

74+

75+nitpick :: Can.Module -> Either E.Error ()

76+nitpick canonical =

77+ case PatternMatches.check canonical of

78+ Right () ->

79+ Right ()

80+

81+ Left errors ->

82+ Left (E.BadPatterns errors)

83+

84+

85+optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph

86+optimize modul annotations canonical =

87+ case snd $ R.run $ Optimize.optimize annotations canonical of

88+ Right localGraph ->

89+ Right localGraph

90+

91+ Left errors ->

92+ Left (E.BadMains (Localizer.fromModule modul) errors)

src/Data/Bag.hs → compiler/src/Data/Bag.hsrenamed−11

@@ -108,14 +108,3 @@ fromList func list =

108108add :: (a -> b) -> Bag b -> a -> Bag b

109109add func bag value =

110110 Two (One (func value)) bag

111−

112−

113−

114−-- MONOID

115−

116−

117−instance Monoid (Bag a) where

118− {-# INLINE mempty #-}

119− mempty = Empty

120− {-# INLINE mappend #-}

121− mappend = Two

src/Data/Index.hs → compiler/src/Data/Index.hsrenamed

The content is the same.

compiler/src/Data/Map/Utils.hsnew file+43

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

1+module Data.Map.Utils

2+ ( fromKeys

3+ , fromKeysA

4+ , fromValues

5+ , any

6+ )

7+ where

8+

9+

10+import Prelude hiding (any)

11+import qualified Data.Map as Map

12+import Data.Map.Internal (Map(..))

13+

14+

15+

16+-- FROM KEYS

17+

18+

19+fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v

20+fromKeys toValue keys =

21+ Map.fromList $ map (\k -> (k, toValue k)) keys

22+

23+

24+fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v)

25+fromKeysA toValue keys =

26+ Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys

27+

28+

29+fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v

30+fromValues toKey values =

31+ Map.fromList $ map (\v -> (toKey v, v)) values

32+

33+

34+

35+-- ANY

36+

37+

38+{-# INLINE any #-}

39+any :: (v -> Bool) -> Map.Map k v -> Bool

40+any isGood = go

41+ where

42+ go Tip = False

43+ go (Bin _ _ v l r) = isGood v || go l || go r

compiler/src/Data/Name.hsnew file+610

@@ -0,0 +1,610 @@

1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

3+module Data.Name

4+ ( Name

5+ --

6+ , toChars

7+ , toElmString

8+ , toBuilder

9+ --

10+ , fromPtr

11+ , fromChars

12+ --

13+ , getKernel

14+ , hasDot

15+ , splitDots

16+ , isKernel

17+ , isNumberType

18+ , isComparableType

19+ , isAppendableType

20+ , isCompappendType

21+ , fromVarIndex

22+ , fromWords

23+ , fromManyNames

24+ , fromTypeVariable

25+ , fromTypeVariableScheme

26+ , sepBy

27+ --

28+ , int, float, bool, char, string

29+ , maybe, result, list, array, dict, tuple, jsArray

30+ , task, router, cmd, sub, platform, virtualDom

31+ , shader, debug, debugger, bitwise, basics

32+ , utils, negate, true, false, value

33+ , node, program, _main, _Main, dollar, identity

34+ , replModule, replValueToPrint

35+ )

36+ where

37+

38+

39+import Prelude hiding (length, maybe, negate)

40+import Control.Exception (assert)

41+import qualified Data.Binary as Binary

42+import qualified Data.ByteString.Builder.Internal as B

43+import qualified Data.Coerce as Coerce

44+import qualified Data.List as List

45+import qualified Data.String as Chars

46+import qualified Data.Utf8 as Utf8

47+import GHC.Exts

48+ ( Int(I#), Ptr

49+ , MutableByteArray#

50+ , isTrue#

51+ , newByteArray#

52+ , sizeofByteArray#

53+ , unsafeFreezeByteArray#

54+ )

55+import GHC.ST (ST(ST), runST)

56+import GHC.Prim

57+import GHC.Word (Word8(W8#))

58+

59+import qualified Elm.String as ES

60+

61+

62+

63+-- NAME

64+

65+

66+type Name =

67+ Utf8.Utf8 ELM_NAME

68+

69+

70+data ELM_NAME

71+

72+

73+

74+-- INSTANCES

75+

76+

77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where

78+ fromString = Utf8.fromChars

79+

80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where

81+ get = Utf8.getUnder256

82+ put = Utf8.putUnder256

83+

84+

85+

86+-- TO

87+

88+

89+toChars :: Name -> [Char]

90+toChars =

91+ Utf8.toChars

92+

93+

94+toElmString :: Name -> ES.String

95+toElmString =

96+ Coerce.coerce

97+

98+

99+{-# INLINE toBuilder #-}

100+toBuilder :: Name -> B.Builder

101+toBuilder =

102+ Utf8.toBuilder

103+

104+

105+

106+-- FROM

107+

108+

109+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name

110+fromPtr =

111+ Utf8.fromPtr

112+

113+

114+fromChars :: [Char] -> Name

115+fromChars =

116+ Utf8.fromChars

117+

118+

119+

120+-- HAS DOT

121+

122+

123+hasDot :: Name -> Bool

124+hasDot name =

125+ Utf8.contains 0x2E {- . -} name

126+

127+

128+splitDots :: Name -> [Name]

129+splitDots name =

130+ Utf8.split 0x2E {- . -} name

131+

132+

133+

134+-- GET KERNEL

135+

136+

137+getKernel :: Name -> Name

138+getKernel name@(Utf8.Utf8 ba#) =

139+ assert (isKernel name)

140+ (

141+ runST

142+ (

143+ let

144+ !size# = sizeofByteArray# ba# -# 11#

145+ in

146+ ST $ \s ->

147+ case newByteArray# size# s of

148+ (# s, mba# #) ->

149+ case copyByteArray# ba# 11# mba# 0# size# s of

150+ s ->

151+ case unsafeFreezeByteArray# mba# s of

152+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

153+ )

154+ )

155+

156+

157+

158+-- STARTS WITH

159+

160+

161+isKernel :: Name -> Bool

162+isKernel = Utf8.startsWith prefix_kernel

163+

164+isNumberType :: Name -> Bool

165+isNumberType = Utf8.startsWith prefix_number

166+

167+isComparableType :: Name -> Bool

168+isComparableType = Utf8.startsWith prefix_comparable

169+

170+isAppendableType :: Name -> Bool

171+isAppendableType = Utf8.startsWith prefix_appendable

172+

173+isCompappendType :: Name -> Bool

174+isCompappendType = Utf8.startsWith prefix_compappend

175+

176+{-# NOINLINE prefix_kernel #-}

177+prefix_kernel :: Name

178+prefix_kernel = fromChars "Elm.Kernel."

179+

180+{-# NOINLINE prefix_number #-}

181+prefix_number :: Name

182+prefix_number = fromChars "number"

183+

184+{-# NOINLINE prefix_comparable #-}

185+prefix_comparable :: Name

186+prefix_comparable = fromChars "comparable"

187+

188+{-# NOINLINE prefix_appendable #-}

189+prefix_appendable :: Name

190+prefix_appendable = fromChars "appendable"

191+

192+{-# NOINLINE prefix_compappend #-}

193+prefix_compappend :: Name

194+prefix_compappend = fromChars "compappend"

195+

196+

197+

198+-- FROM VAR INDEX

199+

200+

201+fromVarIndex :: Int -> Name

202+fromVarIndex n =

203+ runST

204+ (

205+ do let !size = 2 + getIndexSize n

206+ mba <- newByteArray size

207+ writeWord8 mba 0 0x5F {- _ -}

208+ writeWord8 mba 1 0x76 {- v -}

209+ writeDigitsAtEnd mba size n

210+ freeze mba

211+ )

212+

213+

214+{-# INLINE getIndexSize #-}

215+getIndexSize :: Int -> Int

216+getIndexSize n

217+ | n < 10 = 1

218+ | n < 100 = 2

219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

220+

221+

222+

223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()

224+writeDigitsAtEnd !mba !oldOffset !n =

225+ do let (q,r) = quotRem n 10

226+ let !newOffset = oldOffset - 1

227+ writeWord8 mba newOffset (0x30 + fromIntegral r)

228+ if q <= 0

229+ then return ()

230+ else writeDigitsAtEnd mba newOffset q

231+

232+

233+

234+-- FROM TYPE VARIABLE

235+

236+

237+fromTypeVariable :: Name -> Int -> Name

238+fromTypeVariable name@(Utf8.Utf8 ba#) index =

239+ if index <= 0 then

240+ name

241+ else

242+ let

243+ len# = sizeofByteArray# ba#

244+ end# = indexWord8Array# ba# (len# -# 1#)

245+ in

246+ if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then

247+ runST

248+ (

249+ do let !size = I# len# + 1 + getIndexSize index

250+ mba <- newByteArray size

251+ copyToMBA name mba

252+ writeWord8 mba (I# len#) 0x5F {- _ -}

253+ writeDigitsAtEnd mba size index

254+ freeze mba

255+ )

256+ else

257+ runST

258+ (

259+ do let !size = I# len# + getIndexSize index

260+ mba <- newByteArray size

261+ copyToMBA name mba

262+ writeDigitsAtEnd mba size index

263+ freeze mba

264+ )

265+

266+

267+

268+-- FROM TYPE VARIABLE SCHEME

269+

270+

271+fromTypeVariableScheme :: Int -> Name

272+fromTypeVariableScheme scheme =

273+ runST

274+ (

275+ if scheme < 26 then

276+ do mba <- newByteArray 1

277+ writeWord8 mba 0 (0x61 + fromIntegral scheme)

278+ freeze mba

279+ else

280+ do let (extra, letter) = quotRem scheme 26

281+ let !size = 1 + getIndexSize extra

282+ mba <- newByteArray size

283+ writeWord8 mba 0 (0x61 + fromIntegral letter)

284+ writeDigitsAtEnd mba size extra

285+ freeze mba

286+ )

287+

288+

289+

290+-- FROM MANY NAMES

291+--

292+-- Creating a unique name by combining all the subnames can create names

293+-- longer than 256 bytes relatively easily. So instead, the first given name

294+-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)

295+--

296+-- This should be a unique name since 0.19 disallows shadowing. It would not

297+-- be possible for multiple top-level cycles to include values with the same

298+-- name, so the important thing is to make the cycle name distinct from the

299+-- normal name. Same logic for destructuring patterns like (x,y)

300+

301+

302+fromManyNames :: [Name] -> Name

303+fromManyNames names =

304+ case names of

305+ [] ->

306+ blank

307+ -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)

308+ -- but maybe unused patterns should be stripped out instead

309+

310+ Utf8.Utf8 ba# : _ ->

311+ let

312+ len# = sizeofByteArray# ba#

313+ in

314+ runST

315+ (

316+ ST $ \s ->

317+ case newByteArray# (len# +# 3#) s of

318+ (# s, mba# #) ->

319+ case writeWord8Array# mba# 0# 0x5F## {-_-} s of

320+ s ->

321+ case writeWord8Array# mba# 1# 0x4D## {-M-} s of

322+ s ->

323+ case writeWord8Array# mba# 2# 0x24## {-$-} s of

324+ s ->

325+ case copyByteArray# ba# 0# mba# 3# len# s of

326+ s ->

327+ case unsafeFreezeByteArray# mba# s of

328+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

329+ )

330+

331+

332+{-# NOINLINE blank #-}

333+blank :: Name

334+blank =

335+ fromWords [0x5F,0x4D,0x24] {-_M$-}

336+

337+

338+

339+-- FROM WORDS

340+

341+

342+fromWords :: [Word8] -> Name

343+fromWords words =

344+ runST

345+ (

346+ do mba <- newByteArray (List.length words)

347+ writeWords mba 0 words

348+ freeze mba

349+ )

350+

351+

352+writeWords :: MBA s -> Int -> [Word8] -> ST s ()

353+writeWords !mba !i words =

354+ case words of

355+ [] ->

356+ return ()

357+

358+ w:ws ->

359+ do writeWord8 mba i w

360+ writeWords mba (i+1) ws

361+

362+

363+

364+-- SEP BY

365+

366+

367+sepBy :: Word8 -> Name -> Name -> Name

368+sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =

369+ let

370+ !len1# = sizeofByteArray# ba1#

371+ !len2# = sizeofByteArray# ba2#

372+ in

373+ runST

374+ (

375+ ST $ \s ->

376+ case newByteArray# (len1# +# len2# +# 1#) s of

377+ (# s, mba# #) ->

378+ case copyByteArray# ba1# 0# mba# 0# len1# s of

379+ s ->

380+ case writeWord8Array# mba# len1# sep# s of

381+ s ->

382+ case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of

383+ s ->

384+ case unsafeFreezeByteArray# mba# s of

385+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

386+ )

387+

388+

389+

390+-- PRIMITIVES

391+

392+

393+data MBA s =

394+ MBA# (MutableByteArray# s)

395+

396+

397+{-# INLINE newByteArray #-}

398+newByteArray :: Int -> ST s (MBA s)

399+newByteArray (I# len#) =

400+ ST $ \s ->

401+ case newByteArray# len# s of

402+ (# s, mba# #) -> (# s, MBA# mba# #)

403+

404+

405+{-# INLINE freeze #-}

406+freeze :: MBA s -> ST s Name

407+freeze (MBA# mba#) =

408+ ST $ \s ->

409+ case unsafeFreezeByteArray# mba# s of

410+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

411+

412+

413+{-# INLINE writeWord8 #-}

414+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()

415+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

416+ ST $ \s ->

417+ case writeWord8Array# mba# offset# w# s of

418+ s -> (# s, () #)

419+

420+

421+{-# INLINE copyToMBA #-}

422+copyToMBA :: Name -> MBA s -> ST s ()

423+copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

424+ ST $ \s ->

425+ case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of

426+ s -> (# s, () #)

427+

428+

429+

430+-- COMMON NAMES

431+

432+

433+{-# NOINLINE int #-}

434+int :: Name

435+int = fromChars "Int"

436+

437+

438+{-# NOINLINE float #-}

439+float :: Name

440+float = fromChars "Float"

441+

442+

443+{-# NOINLINE bool #-}

444+bool :: Name

445+bool = fromChars "Bool"

446+

447+

448+{-# NOINLINE char #-}

449+char :: Name

450+char = fromChars "Char"

451+

452+

453+{-# NOINLINE string #-}

454+string :: Name

455+string = fromChars "String"

456+

457+

458+{-# NOINLINE maybe #-}

459+maybe :: Name

460+maybe = fromChars "Maybe"

461+

462+

463+{-# NOINLINE result #-}

464+result :: Name

465+result = fromChars "Result"

466+

467+

468+{-# NOINLINE list #-}

469+list :: Name

470+list = fromChars "List"

471+

472+

473+{-# NOINLINE array #-}

474+array :: Name

475+array = fromChars "Array"

476+

477+

478+{-# NOINLINE dict #-}

479+dict :: Name

480+dict = fromChars "Dict"

481+

482+

483+{-# NOINLINE tuple #-}

484+tuple :: Name

485+tuple = fromChars "Tuple"

486+

487+

488+{-# NOINLINE jsArray #-}

489+jsArray :: Name

490+jsArray = fromChars "JsArray"

491+

492+

493+{-# NOINLINE task #-}

494+task :: Name

495+task = fromChars "Task"

496+

497+

498+{-# NOINLINE router #-}

499+router :: Name

500+router = fromChars "Router"

501+

502+

503+{-# NOINLINE cmd #-}

504+cmd :: Name

505+cmd = fromChars "Cmd"

506+

507+

508+{-# NOINLINE sub #-}

509+sub :: Name

510+sub = fromChars "Sub"

511+

512+

513+{-# NOINLINE platform #-}

514+platform :: Name

515+platform = fromChars "Platform"

516+

517+

518+{-# NOINLINE virtualDom #-}

519+virtualDom :: Name

520+virtualDom = fromChars "VirtualDom"

521+

522+

523+{-# NOINLINE shader #-}

524+shader :: Name

525+shader = fromChars "Shader"

526+

527+

528+{-# NOINLINE debug #-}

529+debug :: Name

530+debug = fromChars "Debug"

531+

532+

533+{-# NOINLINE debugger #-}

534+debugger :: Name

535+debugger = fromChars "Debugger"

536+

537+

538+{-# NOINLINE bitwise #-}

539+bitwise :: Name

540+bitwise = fromChars "Bitwise"

541+

542+

543+{-# NOINLINE basics #-}

544+basics :: Name

545+basics = fromChars "Basics"

546+

547+

548+{-# NOINLINE utils #-}

549+utils :: Name

550+utils = fromChars "Utils"

551+

552+

553+{-# NOINLINE negate #-}

554+negate :: Name

555+negate = fromChars "negate"

556+

557+

558+{-# NOINLINE true #-}

559+true :: Name

560+true = fromChars "True"

561+

562+

563+{-# NOINLINE false #-}

564+false :: Name

565+false = fromChars "False"

566+

567+

568+{-# NOINLINE value #-}

569+value :: Name

570+value = fromChars "Value"

571+

572+

573+{-# NOINLINE node #-}

574+node :: Name

575+node = fromChars "Node"

576+

577+

578+{-# NOINLINE program #-}

579+program :: Name

580+program = fromChars "Program"

581+

582+

583+{-# NOINLINE _main #-}

584+_main :: Name

585+_main = fromChars "main"

586+

587+

588+{-# NOINLINE _Main #-}

589+_Main :: Name

590+_Main = fromChars "Main"

591+

592+

593+{-# NOINLINE dollar #-}

594+dollar :: Name

595+dollar = fromChars "$"

596+

597+

598+{-# NOINLINE identity #-}

599+identity :: Name

600+identity = fromChars "identity"

601+

602+

603+{-# NOINLINE replModule #-}

604+replModule :: Name

605+replModule = fromChars "Elm_Repl"

606+

607+

608+{-# NOINLINE replValueToPrint #-}

609+replValueToPrint :: Name

610+replValueToPrint = fromChars "repl_input_value_"

compiler/src/Data/NonEmptyList.hsnew file+78

@@ -0,0 +1,78 @@

1+module Data.NonEmptyList

2+ ( List(..)

3+ , singleton

4+ , toList

5+ , sortBy

6+ )

7+ where

8+

9+

10+import Control.Monad (liftM2)

11+import Data.Binary (Binary, get, put)

12+import qualified Data.List as List

13+

14+

15+

16+-- LIST

17+

18+

19+data List a =

20+ List a [a]

21+

22+

23+singleton :: a -> List a

24+singleton a =

25+ List a []

26+

27+

28+toList :: List a -> [a]

29+toList (List x xs) =

30+ x:xs

31+

32+

33+

34+-- INSTANCES

35+

36+

37+instance Functor List where

38+ fmap func (List x xs) = List (func x) (map func xs)

39+

40+

41+instance Traversable List where

42+ traverse func (List x xs) = List <$> func x <*> traverse func xs

43+

44+

45+instance Foldable List where

46+ foldr step state (List x xs) = step x (foldr step state xs)

47+ foldl step state (List x xs) = foldl step (step state x) xs

48+ foldl1 step (List x xs) = foldl step x xs

49+

50+

51+

52+-- SORT BY

53+

54+

55+sortBy :: (Ord b) => (a -> b) -> List a -> List a

56+sortBy toRank (List x xs) =

57+ let

58+ comparison a b =

59+ compare (toRank a) (toRank b)

60+ in

61+ case List.sortBy comparison xs of

62+ [] ->

63+ List x []

64+

65+ y:ys ->

66+ case comparison x y of

67+ LT -> List x (y:ys)

68+ EQ -> List x (y:ys)

69+ GT -> List y (List.insertBy comparison x ys)

70+

71+

72+

73+-- BINARY

74+

75+

76+instance (Binary a) => Binary (List a) where

77+ put (List x xs) = put x >> put xs

78+ get = liftM2 List get get

compiler/src/Data/OneOrMore.hsnew file+99

@@ -0,0 +1,99 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Data.OneOrMore

3+ ( OneOrMore(..)

4+ , one

5+ , more

6+ , map

7+ , destruct

8+ , getFirstTwo

9+ )

10+ where

11+

12+

13+import Prelude hiding (map)

14+

15+

16+

17+-- ONE OR MORE

18+

19+

20+data OneOrMore a

21+ = One a

22+ | More (OneOrMore a) (OneOrMore a)

23+

24+

25+one :: a -> OneOrMore a

26+one =

27+ One

28+

29+

30+more :: OneOrMore a -> OneOrMore a -> OneOrMore a

31+more =

32+ More

33+

34+

35+

36+-- MAP

37+

38+

39+map :: (a -> b) -> OneOrMore a -> OneOrMore b

40+map func oneOrMore =

41+ case oneOrMore of

42+ One value ->

43+ One (func value)

44+

45+ More left right ->

46+ More (map func left) (map func right)

47+

48+

49+

50+-- DESTRUCT

51+

52+

53+destruct :: (a -> [a] -> b) -> OneOrMore a -> b

54+destruct func oneOrMore =

55+ destructLeft func oneOrMore []

56+

57+

58+destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

59+destructLeft func oneOrMore xs =

60+ case oneOrMore of

61+ One x ->

62+ func x xs

63+

64+ More a b ->

65+ destructLeft func a (destructRight b xs)

66+

67+

68+destructRight :: OneOrMore a -> [a] -> [a]

69+destructRight oneOrMore xs =

70+ case oneOrMore of

71+ One x ->

72+ x : xs

73+

74+ More a b ->

75+ destructRight a (destructRight b xs)

76+

77+

78+

79+-- GET FIRST TWO

80+

81+

82+getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)

83+getFirstTwo left right =

84+ case left of

85+ One x ->

86+ (x, getFirstOne right)

87+

88+ More lleft lright ->

89+ getFirstTwo lleft lright

90+

91+

92+getFirstOne :: OneOrMore a -> a

93+getFirstOne oneOrMore =

94+ case oneOrMore of

95+ One x ->

96+ x

97+

98+ More left _ ->

99+ getFirstOne left

compiler/src/Data/Utf8.hsnew file+618

@@ -0,0 +1,618 @@

1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}

3+module Data.Utf8

4+ ( Utf8(..)

5+ , isEmpty

6+ , empty

7+ , size

8+ , contains

9+ , startsWith

10+ , startsWithChar

11+ , endsWithWord8

12+ , split

13+ , join

14+ --

15+ , getUnder256

16+ , putUnder256

17+ --

18+ , getVeryLong

19+ , putVeryLong

20+ --

21+ , toChars

22+ , toBuilder

23+ , toEscapedBuilder

24+ --

25+ , fromPtr

26+ , fromSnippet

27+ , fromChars

28+ --

29+ , MBA

30+ , newByteArray

31+ , copyFromPtr

32+ , writeWord8

33+ , freeze

34+ )

35+ where

36+

37+

38+import Prelude hiding (String, all, any, concat)

39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)

40+import Data.Binary.Put (putBuilder)

41+import Data.Binary.Get.Internal (readN)

42+import Data.Bits ((.&.), shiftR)

43+import qualified Data.ByteString.Internal as B

44+import qualified Data.ByteString.Builder.Internal as B

45+import qualified Data.Char as Char

46+import qualified Data.List as List

47+import Foreign.ForeignPtr (touchForeignPtr)

48+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

49+import Foreign.Ptr (minusPtr, plusPtr)

50+import GHC.Exts

51+ ( Int(I#), Ptr(Ptr), Char(C#)

52+ , RealWorld

53+ , ByteArray#, MutableByteArray#

54+ , isTrue#

55+ , newByteArray#

56+ , unsafeFreezeByteArray#

57+ , sizeofByteArray#

58+ , copyByteArray#

59+ , copyAddrToByteArray#

60+ , copyByteArrayToAddr#

61+ , writeWord8Array#

62+ )

63+import GHC.IO

64+import GHC.ST (ST(ST), runST)

65+import GHC.Prim

66+import GHC.Word (Word8(W8#))

67+

68+import qualified Parse.Primitives as P

69+

70+

71+

72+-- UTF-8

73+

74+

75+data Utf8 tipe =

76+ Utf8 ByteArray#

77+

78+

79+

80+-- EMPTY

81+

82+

83+{-# NOINLINE empty #-}

84+empty :: Utf8 t

85+empty =

86+ runST (freeze =<< newByteArray 0)

87+

88+

89+isEmpty :: Utf8 t -> Bool

90+isEmpty (Utf8 ba#) =

91+ isTrue# (sizeofByteArray# ba# ==# 0#)

92+

93+

94+

95+-- SIZE

96+

97+

98+size :: Utf8 t -> Int

99+size (Utf8 ba#) =

100+ I# (sizeofByteArray# ba#)

101+

102+

103+

104+-- CONTAINS

105+

106+

107+contains :: Word8 -> Utf8 t -> Bool

108+contains (W8# word#) (Utf8 ba#) =

109+ containsHelp word# ba# 0# (sizeofByteArray# ba#)

110+

111+

112+containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool

113+containsHelp word# ba# !offset# len# =

114+ if isTrue# (offset# <# len#) then

115+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset#))

116+ then True

117+ else containsHelp word# ba# (offset# +# 1#) len#

118+ else

119+ False

120+

121+

122+

123+-- STARTS WITH

124+

125+

126+{-# INLINE startsWith #-}

127+startsWith :: Utf8 t -> Utf8 t -> Bool

128+startsWith (Utf8 ba1#) (Utf8 ba2#) =

129+ let

130+ !len1# = sizeofByteArray# ba1#

131+ !len2# = sizeofByteArray# ba2#

132+ in

133+ isTrue# (len1# <=# len2#)

134+ &&

135+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)

136+

137+

138+

139+-- STARTS WITH CHAR

140+

141+

142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool

143+startsWithChar isGood bytes@(Utf8 ba#) =

144+ if isEmpty bytes then

145+ False

146+ else

147+ let

148+ !w# = indexWord8Array# ba# 0#

149+ !char

150+ | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#))

151+ | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w#

152+ | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w#

153+ | True = chr4 ba# 0# w#

154+ in

155+ isGood char

156+

157+

158+

159+-- ENDS WITH WORD

160+

161+

162+endsWithWord8 :: Word8 -> Utf8 t -> Bool

163+endsWithWord8 (W8# w#) (Utf8 ba#) =

164+ let len# = sizeofByteArray# ba# in

165+ isTrue# (len# ># 0#)

166+ &&

167+ isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#)))

168+

169+

170+

171+-- SPLIT

172+

173+

174+split :: Word8 -> Utf8 t -> [Utf8 t]

175+split (W8# divider#) str@(Utf8 ba#) =

176+ splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

177+

178+

179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]

180+splitHelp str start offsets =

181+ case offsets of

182+ [] ->

183+ [ unsafeSlice str start (size str) ]

184+

185+ offset : offsets ->

186+ unsafeSlice str start offset : splitHelp str (offset + 1) offsets

187+

188+

189+findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int]

190+findDividers divider# ba# !offset# len# revOffsets =

191+ if isTrue# (offset# <# len#) then

192+ findDividers divider# ba# (offset# +# 1#) len# $

193+ if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#))

194+ then I# offset# : revOffsets

195+ else revOffsets

196+ else

197+ reverse revOffsets

198+

199+

200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t

201+unsafeSlice str start end =

202+ let !len = end - start in

203+ if len == 0 then

204+ empty

205+ else

206+ runST $

207+ do mba <- newByteArray len

208+ copy str start mba 0 len

209+ freeze mba

210+

211+

212+

213+-- JOIN

214+

215+

216+join :: Word8 -> [Utf8 t] -> Utf8 t

217+join sep strings =

218+ case strings of

219+ [] ->

220+ empty

221+

222+ str:strs ->

223+ runST $

224+ do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs

225+ mba <- newByteArray len

226+ joinHelp sep mba 0 str strs

227+ freeze mba

228+

229+

230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()

231+joinHelp sep mba offset str strings =

232+ let

233+ !len = size str

234+ in

235+ case strings of

236+ [] ->

237+ copy str 0 mba offset len

238+

239+ s:ss ->

240+ do copy str 0 mba offset len

241+ let !dotOffset = offset + len

242+ writeWord8 mba dotOffset sep

243+ let !newOffset = dotOffset + 1

244+ joinHelp sep mba newOffset s ss

245+

246+

247+

248+-- EQUAL

249+

250+

251+instance Eq (Utf8 t) where

252+ (==) (Utf8 ba1#) (Utf8 ba2#) =

253+ let

254+ !len1# = sizeofByteArray# ba1#

255+ !len2# = sizeofByteArray# ba2#

256+ in

257+ isTrue# (len1# ==# len2#)

258+ &&

259+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)

260+

261+

262+

263+-- COMPARE

264+--

265+-- TODO: is it fine to sort by length and only compare bytes on length ties?

266+--

267+

268+instance Ord (Utf8 t) where

269+ compare (Utf8 ba1#) (Utf8 ba2#) =

270+ let

271+ !len1# = sizeofByteArray# ba1#

272+ !len2# = sizeofByteArray# ba2#

273+ !len# = if isTrue# (len1# <# len2#) then len1# else len2#

274+ !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#

275+ in

276+ case () of

277+ _ | isTrue# (cmp# <# 0#) -> LT

278+ | isTrue# (cmp# ># 0#) -> GT

279+ | isTrue# (len1# <# len2#) -> LT

280+ | isTrue# (len1# ># len2#) -> GT

281+ | True -> EQ

282+

283+

284+

285+-- FROM STRING

286+

287+

288+fromChars :: [Char] -> Utf8 t

289+fromChars chars =

290+ runST

291+ (

292+ do mba <- newByteArray (sum (map getWidth chars))

293+ writeChars mba 0 chars

294+ )

295+

296+

297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)

298+writeChars !mba !offset chars =

299+ case chars of

300+ [] ->

301+ freeze mba

302+

303+ char : chars

304+ | n < 0x80 ->

305+ do writeWord8 mba (offset ) (fromIntegral n)

306+ writeChars mba (offset + 1) chars

307+

308+ | n < 0x800 ->

309+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

310+ writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

311+ writeChars mba (offset + 2) chars

312+

313+ | n < 0x10000 ->

314+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

315+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

316+ writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

317+ writeChars mba (offset + 3) chars

318+

319+ | otherwise ->

320+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

321+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

322+ writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

323+ writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

324+ writeChars mba (offset + 4) chars

325+

326+ where

327+ n = Char.ord char

328+

329+

330+{-# INLINE getWidth #-}

331+getWidth :: Char -> Int

332+getWidth char

333+ | code < 0x80 = 1

334+ | code < 0x800 = 2

335+ | code < 0x10000 = 3

336+ | otherwise = 4

337+ where

338+ code = Char.ord char

339+

340+

341+

342+-- TO CHARS

343+

344+

345+toChars :: Utf8 t -> [Char]

346+toChars (Utf8 ba#) =

347+ toCharsHelp ba# 0# (sizeofByteArray# ba#)

348+

349+

350+toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char]

351+toCharsHelp ba# offset# len# =

352+ if isTrue# (offset# >=# len#) then

353+ []

354+ else

355+ let

356+ !w# = indexWord8Array# ba# offset#

357+ !(# char, width# #)

358+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)

359+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)

360+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)

361+ | True = (# chr4 ba# offset# w#, 4# #)

362+

363+ !newOffset# = offset# +# width#

364+ in

365+ char : toCharsHelp ba# newOffset# len#

366+

367+

368+{-# INLINE chr2 #-}

369+chr2 :: ByteArray# -> Int# -> Word# -> Char

370+chr2 ba# offset# firstWord# =

371+ let

372+ !i1# = word2Int# firstWord#

373+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))

374+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#

375+ !c2# = i2# -# 0x80#

376+ in

377+ C# (chr# (c1# +# c2#))

378+

379+

380+{-# INLINE chr3 #-}

381+chr3 :: ByteArray# -> Int# -> Word# -> Char

382+chr3 ba# offset# firstWord# =

383+ let

384+ !i1# = word2Int# firstWord#

385+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))

386+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))

387+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#

388+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#

389+ !c3# = i3# -# 0x80#

390+ in

391+ C# (chr# (c1# +# c2# +# c3#))

392+

393+

394+{-# INLINE chr4 #-}

395+chr4 :: ByteArray# -> Int# -> Word# -> Char

396+chr4 ba# offset# firstWord# =

397+ let

398+ !i1# = word2Int# firstWord#

399+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))

400+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))

401+ !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))

402+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#

403+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#

404+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#

405+ !c4# = i4# -# 0x80#

406+ in

407+ C# (chr# (c1# +# c2# +# c3# +# c4#))

408+

409+

410+

411+-- TO BUILDER

412+

413+

414+{-# INLINE toBuilder #-}

415+toBuilder :: Utf8 t -> B.Builder

416+toBuilder =

417+ \bytes -> B.builder (toBuilderHelp bytes)

418+

419+

420+{-# INLINE toBuilderHelp #-}

421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a

422+toBuilderHelp !bytes@(Utf8 ba#) k =

423+ go 0 (I# (sizeofByteArray# ba#))

424+ where

425+ go !offset !end !(B.BufferRange bOffset bEnd) =

426+ let

427+ !bLen = minusPtr bEnd bOffset

428+ !len = end - offset

429+ in

430+ if len <= bLen then

431+ do copyToPtr bytes offset bOffset len

432+ let !br' = B.BufferRange (plusPtr bOffset len) bEnd

433+ k br'

434+ else

435+ do copyToPtr bytes offset bOffset bLen

436+ let !offset' = offset + bLen

437+ return $ B.bufferFull 1 bEnd (go offset' end)

438+

439+

440+

441+-- TO ESCAPED BUILDER

442+

443+

444+{-# INLINE toEscapedBuilder #-}

445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder

446+toEscapedBuilder before after =

447+ \name -> B.builder (toEscapedBuilderHelp before after name)

448+

449+

450+{-# INLINE toEscapedBuilderHelp #-}

451+toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a

452+toEscapedBuilderHelp before after !name@(Utf8 ba#) k =

453+ go 0 (I# (sizeofByteArray# ba#))

454+ where

455+ go !offset !len !(B.BufferRange bOffset bEnd) =

456+ let

457+ !bLen = minusPtr bEnd bOffset

458+ in

459+ if len <= bLen then

460+ do -- PERF test if writing word-by-word is faster

461+ copyToPtr name offset bOffset len

462+ escape before after bOffset name offset len 0

463+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd

464+ k newBufferRange

465+ else

466+ do copyToPtr name offset bOffset bLen

467+ escape before after bOffset name offset bLen 0

468+ let !newOffset = offset + bLen

469+ let !newLength = len - bLen

470+ return $ B.bufferFull 1 bEnd (go newOffset newLength)

471+

472+

473+escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()

474+escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =

475+ if isTrue# (i# <# len#) then

476+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))

477+ then

478+ do writeWordToPtr ptr i after

479+ escape before after ptr name offset len (i + 1)

480+ else

481+ do escape before after ptr name offset len (i + 1)

482+

483+ else

484+ return ()

485+

486+

487+

488+-- FROM PTR

489+

490+

491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t

492+fromPtr pos end =

493+ unsafeDupablePerformIO (stToIO (

494+ do let !len = minusPtr end pos

495+ mba <- newByteArray len

496+ copyFromPtr pos mba 0 len

497+ freeze mba

498+ ))

499+

500+

501+

502+-- FROM SNIPPET

503+

504+

505+fromSnippet :: P.Snippet -> Utf8 t

506+fromSnippet (P.Snippet fptr off len _ _) =

507+ unsafeDupablePerformIO (stToIO (

508+ do mba <- newByteArray len

509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off

510+ copyFromPtr pos mba 0 len

511+ freeze mba

512+ ))

513+

514+

515+

516+-- BINARY

517+

518+

519+putUnder256 :: Utf8 t -> Put

520+putUnder256 bytes =

521+ do putWord8 (fromIntegral (size bytes))

522+ putBuilder (toBuilder bytes)

523+

524+

525+getUnder256 :: Get (Utf8 t)

526+getUnder256 =

527+ do word <- getWord8

528+ let !n = fromIntegral word

529+ readN n (copyFromByteString n)

530+

531+

532+putVeryLong :: Utf8 t -> Put

533+putVeryLong bytes =

534+ do put (size bytes)

535+ putBuilder (toBuilder bytes)

536+

537+

538+getVeryLong :: Get (Utf8 t)

539+getVeryLong =

540+ do n <- get

541+ if n > 0

542+ then readN n (copyFromByteString n)

543+ else return empty

544+

545+

546+

547+-- COPY FROM BYTESTRING

548+

549+

550+{-# INLINE copyFromByteString #-}

551+copyFromByteString :: Int -> B.ByteString -> Utf8 t

552+copyFromByteString len (B.PS fptr offset _) =

553+ unsafeDupablePerformIO

554+ (

555+ do mba <- stToIO (newByteArray len)

556+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)

557+ touchForeignPtr fptr

558+ stToIO (freeze mba)

559+ )

560+

561+

562+

563+-- PRIMITIVES

564+

565+

566+data MBA s =

567+ MBA# (MutableByteArray# s)

568+

569+

570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive

571+newByteArray (I# len#) =

572+ ST $ \s ->

573+ case newByteArray# len# s of

574+ (# s, mba# #) -> (# s, MBA# mba# #)

575+

576+

577+freeze :: MBA s -> ST s (Utf8 t)

578+freeze (MBA# mba#) =

579+ ST $ \s ->

580+ case unsafeFreezeByteArray# mba# s of

581+ (# s, ba# #) -> (# s, Utf8 ba# #)

582+

583+

584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()

585+copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

586+ ST $ \s ->

587+ case copyByteArray# ba# offset# mba# i# len# s of

588+ s -> (# s, () #)

589+

590+

591+copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()

592+copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =

593+ ST $ \s ->

594+ case copyAddrToByteArray# src# mba# offset# len# s of

595+ s -> (# s, () #)

596+

597+

598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()

599+copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

600+ IO $ \s ->

601+ case copyByteArrayToAddr# ba# offset# mba# len# s of

602+ s -> (# s, () #)

603+

604+

605+{-# INLINE writeWord8 #-}

606+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()

607+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

608+ ST $ \s ->

609+ case writeWord8Array# mba# offset# w# s of

610+ s -> (# s, () #)

611+

612+

613+{-# INLINE writeWordToPtr #-}

614+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()

615+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =

616+ IO $ \s ->

617+ case writeWord8OffAddr# addr# offset# word# s of

618+ s -> (# s, () #)

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

@@ -0,0 +1,62 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Elm.Compiler.Imports

4+ ( defaults

5+ )

6+ where

7+

8+

9+import qualified Data.Name as Name

10+

11+import qualified AST.Source as Src

12+import qualified Elm.ModuleName as ModuleName

13+import qualified Reporting.Annotation as A

14+

15+

16+

17+-- DEFAULTS

18+

19+

20+defaults :: [Src.Import]

21+defaults =

22+ [ import_ ModuleName.basics Nothing Src.Open

23+ , import_ ModuleName.debug Nothing closed

24+ , import_ ModuleName.list Nothing (operator "::")

25+ , import_ ModuleName.maybe Nothing (typeOpen Name.maybe)

26+ , import_ ModuleName.result Nothing (typeOpen Name.result)

27+ , import_ ModuleName.string Nothing (typeClosed Name.string)

28+ , import_ ModuleName.char Nothing (typeClosed Name.char)

29+ , import_ ModuleName.tuple Nothing closed

30+ , import_ ModuleName.platform Nothing (typeClosed Name.program)

31+ , import_ ModuleName.cmd (Just Name.cmd) (typeClosed Name.cmd)

32+ , import_ ModuleName.sub (Just Name.sub) (typeClosed Name.sub)

33+ ]

34+

35+

36+import_ :: ModuleName.Canonical -> Maybe Name.Name -> Src.Exposing -> Src.Import

37+import_ (ModuleName.Canonical _ name) maybeAlias exposing =

38+ Src.Import (A.At A.zero name) maybeAlias exposing

39+

40+

41+

42+-- EXPOSING

43+

44+

45+closed :: Src.Exposing

46+closed =

47+ Src.Explicit []

48+

49+

50+typeOpen :: Name.Name -> Src.Exposing

51+typeOpen name =

52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]

53+

54+

55+typeClosed :: Name.Name -> Src.Exposing

56+typeClosed name =

57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]

58+

59+

60+operator :: Name.Name -> Src.Exposing

61+operator op =

62+ Src.Explicit [ Src.Operator A.zero op ]

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

@@ -0,0 +1,194 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Elm.Compiler.Type

4+ ( Type(..)

5+ , RT.Context(..)

6+ , toDoc

7+ , DebugMetadata(..)

8+ , Alias(..)

9+ , Union(..)

10+ , encode

11+ , decoder

12+ , encodeMetadata

13+ )

14+ where

15+

16+

17+import qualified Data.Name as Name

18+

19+import qualified AST.Source as Src

20+import qualified Json.Decode as D

21+import qualified Json.Encode as E

22+import Json.Encode ((==>))

23+import qualified Json.String as Json

24+import qualified Parse.Primitives as P

25+import qualified Parse.Type as Type

26+import qualified Reporting.Annotation as A

27+import qualified Reporting.Doc as D

28+import qualified Reporting.Render.Type as RT

29+import qualified Reporting.Render.Type.Localizer as L

30+

31+

32+

33+-- TYPES

34+

35+

36+data Type

37+ = Lambda Type Type

38+ | Var Name.Name

39+ | Type Name.Name [Type]

40+ | Record [(Name.Name, Type)] (Maybe Name.Name)

41+ | Unit

42+ | Tuple Type Type [Type]

43+

44+

45+data DebugMetadata =

46+ DebugMetadata

47+ { _message :: Type

48+ , _aliases :: [Alias]

49+ , _unions :: [Union]

50+ }

51+

52+

53+data Alias = Alias Name.Name [Name.Name] Type

54+data Union = Union Name.Name [Name.Name] [(Name.Name, [Type])]

55+

56+

57+

58+-- TO DOC

59+

60+

61+toDoc :: L.Localizer -> RT.Context -> Type -> D.Doc

62+toDoc localizer context tipe =

63+ case tipe of

64+ Lambda _ _ ->

65+ let

66+ a:b:cs =

67+ map (toDoc localizer RT.Func) (collectLambdas tipe)

68+ in

69+ RT.lambda context a b cs

70+

71+ Var name ->

72+ D.fromName name

73+

74+ Unit ->

75+ "()"

76+

77+ Tuple a b cs ->

78+ RT.tuple

79+ (toDoc localizer RT.None a)

80+ (toDoc localizer RT.None b)

81+ (map (toDoc localizer RT.None) cs)

82+

83+ Type name args ->

84+ RT.apply

85+ context

86+ (D.fromName name)

87+ (map (toDoc localizer RT.App) args)

88+

89+ Record fields ext ->

90+ RT.record

91+ (map (entryToDoc localizer) fields)

92+ (fmap D.fromName ext)

93+

94+

95+entryToDoc :: L.Localizer -> (Name.Name, Type) -> (D.Doc, D.Doc)

96+entryToDoc localizer (field, fieldType) =

97+ ( D.fromName field, toDoc localizer RT.None fieldType )

98+

99+

100+collectLambdas :: Type -> [Type]

101+collectLambdas tipe =

102+ case tipe of

103+ Lambda arg body ->

104+ arg : collectLambdas body

105+

106+ _ ->

107+ [tipe]

108+

109+

110+

111+-- JSON for TYPE

112+

113+

114+encode :: Type -> E.Value

115+encode tipe =

116+ E.chars $ D.toLine (toDoc L.empty RT.None tipe)

117+

118+

119+decoder :: D.Decoder () Type

120+decoder =

121+ let

122+ parser =

123+ P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)

124+ in

125+ D.customString parser (\_ _ -> ())

126+

127+

128+fromRawType :: Src.Type -> Type

129+fromRawType (A.At _ astType) =

130+ case astType of

131+ Src.TLambda t1 t2 ->

132+ Lambda (fromRawType t1) (fromRawType t2)

133+

134+ Src.TVar x ->

135+ Var x

136+

137+ Src.TUnit ->

138+ Unit

139+

140+ Src.TTuple a b cs ->

141+ Tuple

142+ (fromRawType a)

143+ (fromRawType b)

144+ (map fromRawType cs)

145+

146+ Src.TType _ name args ->

147+ Type name (map fromRawType args)

148+

149+ Src.TTypeQual _ _ name args ->

150+ Type name (map fromRawType args)

151+

152+ Src.TRecord fields ext ->

153+ let fromField (A.At _ field, tipe) = (field, fromRawType tipe) in

154+ Record

155+ (map fromField fields)

156+ (fmap A.toValue ext)

157+

158+

159+

160+-- JSON for PROGRAM

161+

162+

163+encodeMetadata :: DebugMetadata -> E.Value

164+encodeMetadata (DebugMetadata msg aliases unions) =

165+ E.object

166+ [ "message" ==> encode msg

167+ , "aliases" ==> E.object (map toTypeAliasField aliases)

168+ , "unions" ==> E.object (map toCustomTypeField unions)

169+ ]

170+

171+

172+toTypeAliasField :: Alias -> ( Json.String, E.Value )

173+toTypeAliasField (Alias name args tipe) =

174+ ( Json.fromName name

175+ , E.object

176+ [ "args" ==> E.list E.name args

177+ , "type" ==> encode tipe

178+ ]

179+ )

180+

181+

182+toCustomTypeField :: Union -> ( Json.String, E.Value )

183+toCustomTypeField (Union name args constructors) =

184+ ( Json.fromName name

185+ , E.object

186+ [ "args" ==> E.list E.name args

187+ , "tags" ==> E.object (map toVariantObject constructors)

188+ ]

189+ )

190+

191+

192+toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )

193+toVariantObject (name, args) =

194+ ( Json.fromName name, E.list encode args )

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

@@ -1,9 +1,13 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}

43module Elm.Compiler.Type.Extract

54 ( fromAnnotation

65 , fromType

6+ , Types(..)

7+ , mergeMany

8+ , merge

9+ , fromInterface

10+ , fromDependencyInterface

711 , fromMsg

812 )

913 where

@@ -12,15 +16,15 @@ module Elm.Compiler.Type.Extract

1216import Data.Map ((!))

1317import qualified Data.Map as Map

1418import qualified Data.Maybe as Maybe

19+import qualified Data.Name as Name

1520import qualified Data.Set as Set

1621

1722import qualified AST.Canonical as Can

1823import qualified AST.Optimized as Opt

19−import qualified AST.Module.Name as ModuleName

2024import qualified AST.Utils.Type as Type

2125import qualified Elm.Compiler.Type as T

2226import qualified Elm.Interface as I

23−import qualified Elm.Name as N

27+import qualified Elm.ModuleName as ModuleName

2428

2529

2630

@@ -53,7 +57,7 @@ extract astType =

5357 <*> traverse extract args

5458

5559 Can.TRecord fields ext ->

56− do efields <- fmap Map.toList (traverse extract fields)

60+ do efields <- traverse (traverse extract) (Can.fieldsToList fields)

5761 pure (T.Record efields ext)

5862

5963 Can.TUnit ->

@@ -72,29 +76,76 @@ extract astType =

7276 <$> traverse (extract . snd) args

7377

7478

75−toPublicName :: ModuleName.Canonical -> N.Name -> N.Name

79+toPublicName :: ModuleName.Canonical -> Name.Name -> Name.Name

7680toPublicName (ModuleName.Canonical _ home) name =

77− N.sepBy 0x2E {- . -} home name

81+ Name.sepBy 0x2E {- . -} home name

82+

83+

84+

85+-- TRANSITIVELY AVAILABLE TYPES

86+

87+

88+newtype Types =

89+ Types (Map.Map ModuleName.Canonical Types_)

90+ -- PERF profile Opt.Global representation

91+ -- current representation needs less allocation

92+ -- but maybe the lookup is much worse

93+

94+

95+data Types_ =

96+ Types_

97+ { _union_info :: Map.Map Name.Name Can.Union

98+ , _alias_info :: Map.Map Name.Name Can.Alias

99+ }

100+

101+

102+mergeMany :: [Types] -> Types

103+mergeMany listOfTypes =

104+ case listOfTypes of

105+ [] -> Types Map.empty

106+ t:ts -> foldr merge t ts

107+

108+

109+merge :: Types -> Types -> Types

110+merge (Types types1) (Types types2) =

111+ Types (Map.union types1 types2)

112+

113+

114+fromInterface :: ModuleName.Raw -> I.Interface -> Types

115+fromInterface name (I.Interface pkg _ unions aliases _) =

116+ Types $ Map.singleton (ModuleName.Canonical pkg name) $

117+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)

118+

119+

120+fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types

121+fromDependencyInterface home di =

122+ Types $ Map.singleton home $

123+ case di of

124+ I.Public (I.Interface _ _ unions aliases _) ->

125+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)

126+

127+ I.Private _ unions aliases ->

128+ Types_ unions aliases

78129

79130

80131

81132-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES

82133

83134

84−fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata

85−fromMsg interfaces message =

135+fromMsg :: Types -> Can.Type -> T.DebugMetadata

136+fromMsg types message =

86137 let

87138 (msgDeps, msgType) =

88139 run (extract message)

89140

90141 (aliases, unions) =

91− extractTransitive interfaces noDeps msgDeps

142+ extractTransitive types noDeps msgDeps

92143 in

93144 T.DebugMetadata msgType aliases unions

94145

95146

96−extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )

97−extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =

147+extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )

148+extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =

98149 let

99150 aliases = Set.difference nextAliases seenAliases

100151 unions = Set.difference nextUnions seenUnions

@@ -107,39 +158,39 @@ extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nex

107158 (newDeps, result) =

108159 run $

109160 (,)

110− <$> traverse (extractAlias interfaces) (Set.toList aliases)

111− <*> traverse (extractUnion interfaces) (Set.toList unions)

161+ <$> traverse (extractAlias types) (Set.toList aliases)

162+ <*> traverse (extractUnion types) (Set.toList unions)

112163

113164 oldDeps =

114165 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)

115166

116167 remainingResult =

117− extractTransitive interfaces oldDeps newDeps

168+ extractTransitive types oldDeps newDeps

118169 in

119170 mappend result remainingResult

120171

121172

122−extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias

123−extractAlias interfaces (Opt.Global home name) =

173+extractAlias :: Types -> Opt.Global -> Extractor T.Alias

174+extractAlias (Types dict) (Opt.Global home name) =

124175 let

125− (I.Interface _ _ aliases _) = interfaces ! home

126− (Can.Alias args aliasType _) = aliases ! name

176+ (Can.Alias args aliasType) = _alias_info (dict ! home) ! name

127177 in

128178 T.Alias (toPublicName home name) args <$> extract aliasType

129179

130180

131−extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union

132−extractUnion interfaces (Opt.Global home name) =

133− let

134− pname = toPublicName home name

135− unions = I._unions (interfaces ! home)

136− in

137− case unions ! name of

138− Can.Union vars ctors _ _ ->

181+extractUnion :: Types -> Opt.Global -> Extractor T.Union

182+extractUnion (Types dict) (Opt.Global home name) =

183+ if name == Name.list && home == ModuleName.list

184+ then return $ T.Union (toPublicName home name) ["a"] []

185+ else

186+ let

187+ pname = toPublicName home name

188+ (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name

189+ in

139190 T.Union pname vars <$> traverse extractCtor ctors

140191

141192

142−extractCtor :: Can.Ctor -> Extractor (N.Name, [T.Type])

193+extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])

143194extractCtor (Can.Ctor ctor _ _ args) =

144195 (,) ctor <$> traverse extract args

145196

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

@@ -0,0 +1,260 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Elm.Constraint

4+ ( Constraint

5+ , exactly

6+ , anything

7+ , toChars

8+ , satisfies

9+ , check

10+ , intersect

11+ , goodElm

12+ , defaultElm

13+ , untilNextMajor

14+ , untilNextMinor

15+ , expand

16+ --

17+ , Error(..)

18+ , decoder

19+ , encode

20+ )

21+ where

22+

23+

24+import Control.Monad (liftM4)

25+import Data.Binary (Binary, get, put, getWord8, putWord8)

26+

27+import qualified Elm.Version as V

28+import qualified Json.Decode as D

29+import qualified Json.Encode as E

30+import qualified Parse.Primitives as P

31+import Parse.Primitives (Row, Col)

32+

33+

34+

35+-- CONSTRAINTS

36+

37+

38+data Constraint

39+ = Range V.Version Op Op V.Version

40+ deriving (Eq)

41+

42+

43+data Op

44+ = Less

45+ | LessOrEqual

46+ deriving (Eq)

47+

48+

49+

50+-- COMMON CONSTRAINTS

51+

52+

53+exactly :: V.Version -> Constraint

54+exactly version =

55+ Range version LessOrEqual LessOrEqual version

56+

57+

58+anything :: Constraint

59+anything =

60+ Range V.one LessOrEqual LessOrEqual V.max

61+

62+

63+

64+-- TO CHARS

65+

66+

67+toChars :: Constraint -> [Char]

68+toChars constraint =

69+ case constraint of

70+ Range lower lowerOp upperOp upper ->

71+ V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper

72+

73+

74+opToChars :: Op -> [Char]

75+opToChars op =

76+ case op of

77+ Less -> " < "

78+ LessOrEqual -> " <= "

79+

80+

81+

82+-- IS SATISFIED

83+

84+

85+satisfies :: Constraint -> V.Version -> Bool

86+satisfies constraint version =

87+ case constraint of

88+ Range lower lowerOp upperOp upper ->

89+ isLess lowerOp lower version

90+ &&

91+ isLess upperOp version upper

92+

93+

94+isLess :: (Ord a) => Op -> (a -> a -> Bool)

95+isLess op =

96+ case op of

97+ Less ->

98+ (<)

99+

100+ LessOrEqual ->

101+ (<=)

102+

103+

104+check :: Constraint -> V.Version -> Ordering

105+check constraint version =

106+ case constraint of

107+ Range lower lowerOp upperOp upper ->

108+ if not (isLess lowerOp lower version) then

109+ LT

110+

111+ else if not (isLess upperOp version upper) then

112+ GT

113+

114+ else

115+ EQ

116+

117+

118+

119+-- INTERSECT

120+

121+

122+intersect :: Constraint -> Constraint -> Maybe Constraint

123+intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) =

124+ let

125+ (newLo, newLop) =

126+ case compare lo lo_ of

127+ LT -> (lo_, lop_)

128+ EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual)

129+ GT -> (lo, lop)

130+

131+ (newHi, newHop) =

132+ case compare hi hi_ of

133+ LT -> (hi, hop)

134+ EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual)

135+ GT -> (hi_, hop_)

136+ in

137+ if newLo <= newHi then

138+ Just (Range newLo newLop newHop newHi)

139+ else

140+ Nothing

141+

142+

143+

144+-- ELM CONSTRAINT

145+

146+

147+goodElm :: Constraint -> Bool

148+goodElm constraint =

149+ satisfies constraint V.compiler

150+

151+

152+defaultElm :: Constraint

153+defaultElm =

154+ if V._major V.compiler > 0

155+ then untilNextMajor V.compiler

156+ else untilNextMinor V.compiler

157+

158+

159+

160+-- CREATE CONSTRAINTS

161+

162+

163+untilNextMajor :: V.Version -> Constraint

164+untilNextMajor version =

165+ Range version LessOrEqual Less (V.bumpMajor version)

166+

167+

168+untilNextMinor :: V.Version -> Constraint

169+untilNextMinor version =

170+ Range version LessOrEqual Less (V.bumpMinor version)

171+

172+

173+expand :: Constraint -> V.Version -> Constraint

174+expand constraint@(Range lower lowerOp upperOp upper) version

175+ | version < lower =

176+ Range version LessOrEqual upperOp upper

177+

178+ | version > upper =

179+ Range lower lowerOp Less (V.bumpMajor version)

180+

181+ | otherwise =

182+ constraint

183+

184+

185+

186+-- JSON

187+

188+

189+encode :: Constraint -> E.Value

190+encode constraint =

191+ E.chars (toChars constraint)

192+

193+

194+decoder :: D.Decoder Error Constraint

195+decoder =

196+ D.customString parser BadFormat

197+

198+

199+

200+-- BINARY

201+

202+

203+instance Binary Constraint where

204+ get = liftM4 Range get get get get

205+ put (Range a b c d) = put a >> put b >> put c >> put d

206+

207+

208+instance Binary Op where

209+ put op =

210+ case op of

211+ Less -> putWord8 0

212+ LessOrEqual -> putWord8 1

213+

214+ get =

215+ do n <- getWord8

216+ case n of

217+ 0 -> return Less

218+ 1 -> return LessOrEqual

219+ _ -> fail "binary encoding of Op was corrupted"

220+

221+

222+

223+-- PARSER

224+

225+

226+data Error

227+ = BadFormat Row Col

228+ | InvalidRange V.Version V.Version

229+

230+

231+parser :: P.Parser Error Constraint

232+parser =

233+ do lower <- parseVersion

234+ P.word1 0x20 {- -} BadFormat

235+ loOp <- parseOp

236+ P.word1 0x20 {- -} BadFormat

237+ P.word1 0x76 {-v-} BadFormat

238+ P.word1 0x20 {- -} BadFormat

239+ hiOp <- parseOp

240+ P.word1 0x20 {- -} BadFormat

241+ higher <- parseVersion

242+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->

243+ if lower < higher

244+ then eok (Range lower loOp hiOp higher) state

245+ else eerr row col (\_ _ -> InvalidRange lower higher)

246+

247+

248+parseVersion :: P.Parser Error V.Version

249+parseVersion =

250+ P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser

251+

252+

253+parseOp :: P.Parser Error Op

254+parseOp =

255+ do P.word1 0x3C {-<-} BadFormat

256+ P.oneOfWithFallback

257+ [ do P.word1 0x3D {-=-} BadFormat

258+ return LessOrEqual

259+ ]

260+ Less

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

@@ -0,0 +1,587 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}

3+module Elm.Docs

4+ ( Documentation

5+ , Module(..)

6+ , fromModule

7+ , Union(..)

8+ , Alias(..)

9+ , Value(..)

10+ , Binop(..)

11+ , Binop.Associativity(..)

12+ , Binop.Precedence(..)

13+ , Error(..)

14+ , decoder

15+ , encode

16+ )

17+ where

18+

19+

20+import qualified Data.Coerce as Coerce

21+import qualified Data.List as List

22+import Data.Map ((!))

23+import qualified Data.Map as Map

24+import qualified Data.Map.Merge.Strict as Map

25+import qualified Data.Name as Name

26+import qualified Data.NonEmptyList as NE

27+import qualified Data.OneOrMore as OneOrMore

28+import Data.Word (Word8)

29+import Foreign.Ptr (Ptr, plusPtr)

30+

31+import qualified AST.Canonical as Can

32+import qualified AST.Source as Src

33+import qualified AST.Utils.Binop as Binop

34+import qualified Elm.Compiler.Type as Type

35+import qualified Elm.Compiler.Type.Extract as Extract

36+import qualified Elm.ModuleName as ModuleName

37+import qualified Json.Decode as D

38+import qualified Json.Encode as E

39+import Json.Encode ((==>))

40+import qualified Json.String as Json

41+import Parse.Primitives (Row, Col, word1)

42+import qualified Parse.Primitives as P

43+import qualified Parse.Space as Space

44+import qualified Parse.Symbol as Symbol

45+import qualified Parse.Variable as Var

46+import qualified Reporting.Annotation as A

47+import qualified Reporting.Error.Docs as E

48+import qualified Reporting.Result as Result

49+

50+

51+

52+-- DOCUMENTATION

53+

54+

55+type Documentation =

56+ Map.Map Name.Name Module

57+

58+

59+data Module =

60+ Module

61+ { _name :: Name.Name

62+ , _comment :: Comment

63+ , _unions :: Map.Map Name.Name Union

64+ , _aliases :: Map.Map Name.Name Alias

65+ , _values :: Map.Map Name.Name Value

66+ , _binops :: Map.Map Name.Name Binop

67+ }

68+

69+type Comment = Json.String

70+

71+data Alias = Alias Comment [Name.Name] Type.Type

72+data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]

73+data Value = Value Comment Type.Type

74+data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence

75+

76+

77+

78+-- JSON

79+

80+

81+encode :: Documentation -> E.Value

82+encode docs =

83+ E.list encodeModule (Map.elems docs)

84+

85+

86+encodeModule :: Module -> E.Value

87+encodeModule (Module name comment unions aliases values binops) =

88+ E.object $

89+ [ "name" ==> ModuleName.encode name

90+ , "comment" ==> E.string comment

91+ , "unions" ==> E.list encodeUnion (Map.toList unions)

92+ , "aliases" ==> E.list encodeAlias (Map.toList aliases)

93+ , "values" ==> E.list encodeValue (Map.toList values)

94+ , "binops" ==> E.list encodeBinop (Map.toList binops)

95+ ]

96+

97+

98+data Error

99+ = BadAssociativity

100+ | BadModuleName

101+ | BadType

102+

103+

104+decoder :: D.Decoder Error Documentation

105+decoder =

106+ toDict <$> D.list moduleDecoder

107+

108+

109+toDict :: [Module] -> Documentation

110+toDict modules =

111+ Map.fromList (map toDictHelp modules)

112+

113+

114+toDictHelp :: Module -> (Name.Name, Module)

115+toDictHelp modul@(Module name _ _ _ _ _) =

116+ (name, modul)

117+

118+

119+moduleDecoder :: D.Decoder Error Module

120+moduleDecoder =

121+ Module

122+ <$> D.field "name" moduleNameDecoder

123+ <*> D.field "comment" D.string

124+ <*> D.field "unions" (dictDecoder union)

125+ <*> D.field "aliases" (dictDecoder alias)

126+ <*> D.field "values" (dictDecoder value)

127+ <*> D.field "binops" (dictDecoder binop)

128+

129+

130+dictDecoder :: D.Decoder Error a -> D.Decoder Error (Map.Map Name.Name a)

131+dictDecoder entryDecoder =

132+ Map.fromList <$> D.list (named entryDecoder)

133+

134+

135+named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)

136+named entryDecoder =

137+ (,)

138+ <$> D.field "name" nameDecoder

139+ <*> entryDecoder

140+

141+

142+nameDecoder :: D.Decoder e Name.Name

143+nameDecoder =

144+ fmap Coerce.coerce D.string

145+

146+

147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw

148+moduleNameDecoder =

149+ D.mapError (const BadModuleName) ModuleName.decoder

150+

151+

152+typeDecoder :: D.Decoder Error Type.Type

153+typeDecoder =

154+ D.mapError (const BadType) Type.decoder

155+

156+

157+

158+-- UNION JSON

159+

160+

161+encodeUnion :: (Name.Name, Union) -> E.Value

162+encodeUnion (name, Union comment args cases) =

163+ E.object

164+ [ "name" ==> E.name name

165+ , "comment" ==> E.string comment

166+ , "args" ==> E.list E.name args

167+ , "cases" ==> E.list encodeCase cases

168+ ]

169+

170+

171+union :: D.Decoder Error Union

172+union =

173+ Union

174+ <$> D.field "comment" D.string

175+ <*> D.field "args" (D.list nameDecoder)

176+ <*> D.field "cases" (D.list caseDecoder)

177+

178+

179+encodeCase :: ( Name.Name, [Type.Type] ) -> E.Value

180+encodeCase ( tag, args ) =

181+ E.list id [ E.name tag, E.list Type.encode args ]

182+

183+

184+caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )

185+caseDecoder =

186+ D.pair nameDecoder (D.list typeDecoder)

187+

188+

189+

190+-- ALIAS JSON

191+

192+

193+encodeAlias :: (Name.Name, Alias) -> E.Value

194+encodeAlias ( name, Alias comment args tipe) =

195+ E.object

196+ [ "name" ==> E.name name

197+ , "comment" ==> E.string comment

198+ , "args" ==> E.list E.name args

199+ , "type" ==> Type.encode tipe

200+ ]

201+

202+

203+alias :: D.Decoder Error Alias

204+alias =

205+ Alias

206+ <$> D.field "comment" D.string

207+ <*> D.field "args" (D.list nameDecoder)

208+ <*> D.field "type" typeDecoder

209+

210+

211+

212+-- VALUE JSON

213+

214+

215+encodeValue :: (Name.Name, Value) -> E.Value

216+encodeValue (name, Value comment tipe) =

217+ E.object

218+ [ "name" ==> E.name name

219+ , "comment" ==> E.string comment

220+ , "type" ==> Type.encode tipe

221+ ]

222+

223+

224+value :: D.Decoder Error Value

225+value =

226+ Value

227+ <$> D.field "comment" D.string

228+ <*> D.field "type" typeDecoder

229+

230+

231+

232+-- BINOP JSON

233+

234+

235+encodeBinop :: (Name.Name, Binop) -> E.Value

236+encodeBinop (name, Binop comment tipe assoc prec) =

237+ E.object

238+ [ "name" ==> E.name name

239+ , "comment" ==> E.string comment

240+ , "type" ==> Type.encode tipe

241+ , "associativity" ==> encodeAssoc assoc

242+ , "precedence" ==> encodePrec prec

243+ ]

244+

245+

246+binop :: D.Decoder Error Binop

247+binop =

248+ Binop

249+ <$> D.field "comment" D.string

250+ <*> D.field "type" typeDecoder

251+ <*> D.field "associativity" assocDecoder

252+ <*> D.field "precedence" precDecoder

253+

254+

255+

256+-- ASSOCIATIVITY JSON

257+

258+

259+encodeAssoc :: Binop.Associativity -> E.Value

260+encodeAssoc assoc =

261+ case assoc of

262+ Binop.Left -> E.chars "left"

263+ Binop.Non -> E.chars "non"

264+ Binop.Right -> E.chars "right"

265+

266+

267+assocDecoder :: D.Decoder Error Binop.Associativity

268+assocDecoder =

269+ let

270+ left = Json.fromChars "left"

271+ non = Json.fromChars "non"

272+ right = Json.fromChars "right"

273+ in

274+ do str <- D.string

275+ if | str == left -> return Binop.Left

276+ | str == non -> return Binop.Non

277+ | str == right -> return Binop.Right

278+ | otherwise -> D.failure BadAssociativity

279+

280+

281+

282+-- PRECEDENCE JSON

283+

284+

285+encodePrec :: Binop.Precedence -> E.Value

286+encodePrec (Binop.Precedence n) =

287+ E.int n

288+

289+

290+precDecoder :: D.Decoder Error Binop.Precedence

291+precDecoder =

292+ Binop.Precedence <$> D.int

293+

294+

295+

296+-- FROM MODULE

297+

298+

299+fromModule :: Can.Module -> Either E.Error Module

300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =

301+ case exports of

302+ Can.ExportEverything region ->

303+ Left (E.ImplicitExposing region)

304+

305+ Can.Export exportDict ->

306+ case docs of

307+ Src.NoDocs region ->

308+ Left (E.NoDocs region)

309+

310+ Src.YesDocs overview comments ->

311+ do names <- parseOverview overview

312+ checkNames exportDict names

313+ checkDefs exportDict overview (Map.fromList comments) modul

314+

315+

316+

317+-- PARSE OVERVIEW

318+

319+

320+parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]

321+parseOverview (Src.Comment snippet) =

322+ case P.fromSnippet (chompOverview []) E.BadEnd snippet of

323+ Left err ->

324+ Left (E.SyntaxProblem err)

325+

326+ Right names ->

327+ Right names

328+

329+

330+type Parser a =

331+ P.Parser E.SyntaxProblem a

332+

333+

334+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

335+chompOverview names =

336+ do isDocs <- chompUntilDocs

337+ if isDocs

338+ then

339+ do Space.chomp E.Space

340+ chompOverview =<< chompDocs names

341+ else

342+ return names

343+

344+

345+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

346+chompDocs names =

347+ do name <-

348+ P.addLocation $

349+ P.oneOf E.Name

350+ [ Var.lower E.Name

351+ , Var.upper E.Name

352+ , chompOperator

353+ ]

354+

355+ Space.chomp E.Space

356+

357+ P.oneOfWithFallback

358+ [ do pos <- P.getPosition

359+ Space.checkIndent pos E.Comma

360+ word1 0x2C {-,-} E.Comma

361+ Space.chomp E.Space

362+ chompDocs (name:names)

363+ ]

364+ (name:names)

365+

366+

367+chompOperator :: Parser Name.Name

368+chompOperator =

369+ do word1 0x28 {-(-} E.Op

370+ op <- Symbol.operator E.Op E.OpBad

371+ word1 0x29 {-)-} E.Op

372+ return op

373+

374+

375+-- TODO add rule that @docs must be after newline in 0.20

376+--

377+chompUntilDocs :: Parser Bool

378+chompUntilDocs =

379+ P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->

380+ let

381+ (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col

382+ !newState = P.State src newPos end indent newRow newCol

383+ in

384+ cok isDocs newState

385+

386+

387+untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)

388+untilDocs pos end row col =

389+ if pos >= end then

390+ (# False, pos, row, col #)

391+ else

392+ let !word = P.unsafeIndex pos in

393+ if word == 0x0A {-\n-} then

394+ untilDocs (plusPtr pos 1) end (row + 1) 1

395+ else

396+ let !pos5 = plusPtr pos 5 in

397+ if pos5 <= end

398+ && P.unsafeIndex ( pos ) == 0x40 {-@-}

399+ && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}

400+ && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}

401+ && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}

402+ && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}

403+ && Var.getInnerWidth pos5 end == 0

404+ then

405+ (# True, pos5, row, col + 5 #)

406+ else

407+ let !newPos = plusPtr pos (P.getCharWidth word) in

408+ untilDocs newPos end row (col + 1)

409+

410+

411+

412+-- CHECK NAMES

413+

414+

415+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()

416+checkNames exports names =

417+ let

418+ docs = List.foldl' addName Map.empty names

419+ loneDoc = Map.traverseMissing onlyInDocs

420+ loneExport = Map.traverseMissing onlyInExports

421+ checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)

422+ in

423+ case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of

424+ (_, Right _) -> Right ()

425+ (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))

426+

427+

428+type DocNameRegions =

429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)

430+

431+

432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions

433+addName dict (A.At region name) =

434+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

435+

436+

437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region

438+isUnique name regions =

439+ case regions of

440+ OneOrMore.One region ->

441+ Result.ok region

442+

443+ OneOrMore.More left right ->

444+ let (r1, r2) = OneOrMore.getFirstTwo left right in

445+ Result.throw (E.NameDuplicate name r1 r2)

446+

447+

448+onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a

449+onlyInDocs name regions =

450+ do region <- isUnique name regions

451+ Result.throw $ E.NameOnlyInDocs name region

452+

453+

454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a

455+onlyInExports name (A.At region _) =

456+ Result.throw $ E.NameOnlyInExports name region

457+

458+

459+

460+-- CHECK DEFS

461+

462+

463+checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module

464+checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =

465+ let

466+ types = gatherTypes decls Map.empty

467+ info = Info comments types unions aliases infixes effects

468+ in

469+ case Result.run (Map.traverseWithKey (checkExport info) exportDict) of

470+ (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)

471+ (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters

472+

473+

474+emptyModule :: ModuleName.Canonical -> Src.Comment -> Module

475+emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =

476+ Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty

477+

478+

479+data Info =

480+ Info

481+ { _iComments :: Map.Map Name.Name Src.Comment

482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)

483+ , _iUnions :: Map.Map Name.Name Can.Union

484+ , _iAliases :: Map.Map Name.Name Can.Alias

485+ , _iBinops :: Map.Map Name.Name Can.Binop

486+ , _iEffects :: Can.Effects

487+ }

488+

489+

490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)

491+checkExport info name (A.At region export) =

492+ case export of

493+ Can.ExportValue ->

494+ do tipe <- getType name info

495+ comment <- getComment region name info

496+ Result.ok $ \m ->

497+ m { _values = Map.insert name (Value comment tipe) (_values m) }

498+

499+ Can.ExportBinop ->

500+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name

501+ tipe <- getType realName info

502+ comment <- getComment region realName info

503+ Result.ok $ \m ->

504+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }

505+

506+ Can.ExportAlias ->

507+ do let (Can.Alias tvars tipe) = _iAliases info ! name

508+ comment <- getComment region name info

509+ Result.ok $ \m ->

510+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }

511+

512+ Can.ExportUnionOpen ->

513+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name

514+ comment <- getComment region name info

515+ Result.ok $ \m ->

516+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }

517+

518+ Can.ExportUnionClosed ->

519+ do let (Can.Union tvars _ _ _) = _iUnions info ! name

520+ comment <- getComment region name info

521+ Result.ok $ \m ->

522+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }

523+

524+ Can.ExportPort ->

525+ do tipe <- getType name info

526+ comment <- getComment region name info

527+ Result.ok $ \m ->

528+ m { _values = Map.insert name (Value comment tipe) (_values m) }

529+

530+

531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment

532+getComment region name info =

533+ case Map.lookup name (_iComments info) of

534+ Nothing ->

535+ Result.throw (E.NoComment name region)

536+

537+ Just (Src.Comment snippet) ->

538+ Result.ok (Json.fromComment snippet)

539+

540+

541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type

542+getType name info =

543+ case _iValues info ! name of

544+ Left region ->

545+ Result.throw (E.NoAnnotation name region)

546+

547+ Right tipe ->

548+ Result.ok (Extract.fromType tipe)

549+

550+

551+dector :: Can.Ctor -> (Name.Name, [Type.Type])

552+dector (Can.Ctor name _ _ args) =

553+ ( name, map Extract.fromType args )

554+

555+

556+

557+-- GATHER TYPES

558+

559+

560+type Types =

561+ Map.Map Name.Name (Either A.Region Can.Type)

562+

563+

564+gatherTypes :: Can.Decls -> Types -> Types

565+gatherTypes decls types =

566+ case decls of

567+ Can.Declare def subDecls ->

568+ gatherTypes subDecls (addDef types def)

569+

570+ Can.DeclareRec def defs subDecls ->

571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)

572+

573+ Can.SaveTheEnvironment ->

574+ types

575+

576+

577+addDef :: Types -> Can.Def -> Types

578+addDef types def =

579+ case def of

580+ Can.Def (A.At region name) _ _ ->

581+ Map.insert name (Left region) types

582+

583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->

584+ let

585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)

586+ in

587+ Map.insert name (Right tipe) types

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

@@ -0,0 +1,51 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}

3+module Elm.Float

4+ ( Float

5+ , fromPtr

6+ , toBuilder

7+ )

8+ where

9+

10+

11+import Prelude hiding (Float)

12+import Data.Binary (Binary, get, put)

13+import qualified Data.ByteString.Builder as B

14+import qualified Data.Utf8 as Utf8

15+import Data.Word (Word8)

16+import Foreign.Ptr (Ptr)

17+

18+

19+

20+-- FLOATS

21+

22+

23+type Float =

24+ Utf8.Utf8 ELM_FLOAT

25+

26+

27+data ELM_FLOAT

28+

29+

30+

31+-- HELPERS

32+

33+

34+fromPtr :: Ptr Word8 -> Ptr Word8 -> Float

35+fromPtr =

36+ Utf8.fromPtr

37+

38+

39+{-# INLINE toBuilder #-}

40+toBuilder :: Float -> B.Builder

41+toBuilder =

42+ Utf8.toBuilder

43+

44+

45+

46+-- BINARY

47+

48+

49+instance Binary (Utf8.Utf8 ELM_FLOAT) where

50+ get = Utf8.getUnder256

51+ put = Utf8.putUnder256

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

@@ -0,0 +1,254 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Elm.Interface

3+ ( Interface(..)

4+ , Union(..)

5+ , Alias(..)

6+ , Binop(..)

7+ , fromModule

8+ , toPublicUnion

9+ , toPublicAlias

10+ , DependencyInterface(..)

11+ , public

12+ , private

13+ , privatize

14+ , extractUnion

15+ , extractAlias

16+ )

17+ where

18+

19+

20+import Control.Monad (liftM, liftM3, liftM4, liftM5)

21+import Data.Binary

22+import Data.Map.Strict ((!))

23+import qualified Data.Map.Strict as Map

24+import qualified Data.Map.Merge.Strict as Map

25+import qualified Data.Name as Name

26+

27+import qualified AST.Canonical as Can

28+import qualified AST.Utils.Binop as Binop

29+import qualified Elm.Package as Pkg

30+import qualified Reporting.Annotation as A

31+

32+

33+

34+-- INTERFACE

35+

36+

37+data Interface =

38+ Interface

39+ { _home :: Pkg.Name

40+ , _values :: Map.Map Name.Name Can.Annotation

41+ , _unions :: Map.Map Name.Name Union

42+ , _aliases :: Map.Map Name.Name Alias

43+ , _binops :: Map.Map Name.Name Binop

44+ }

45+ deriving (Eq)

46+

47+

48+data Union

49+ = OpenUnion Can.Union

50+ | ClosedUnion Can.Union

51+ | PrivateUnion Can.Union

52+ deriving (Eq)

53+

54+

55+data Alias

56+ = PublicAlias Can.Alias

57+ | PrivateAlias Can.Alias

58+ deriving (Eq)

59+

60+

61+data Binop =

62+ Binop

63+ { _op_name :: Name.Name

64+ , _op_annotation :: Can.Annotation

65+ , _op_associativity :: Binop.Associativity

66+ , _op_precedence :: Binop.Precedence

67+ }

68+ deriving (Eq)

69+

70+

71+

72+-- FROM MODULE

73+

74+

75+fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface

76+fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =

77+ Interface

78+ { _home = home

79+ , _values = restrict exports annotations

80+ , _unions = restrictUnions exports unions

81+ , _aliases = restrictAliases exports aliases

82+ , _binops = restrict exports (Map.map (toOp annotations) binops)

83+ }

84+

85+

86+restrict :: Can.Exports -> Map.Map Name.Name a -> Map.Map Name.Name a

87+restrict exports dict =

88+ case exports of

89+ Can.ExportEverything _ ->

90+ dict

91+

92+ Can.Export explicitExports ->

93+ Map.intersection dict explicitExports

94+

95+

96+toOp :: Map.Map Name.Name Can.Annotation -> Can.Binop -> Binop

97+toOp types (Can.Binop_ associativity precedence name) =

98+ Binop name (types ! name) associativity precedence

99+

100+

101+restrictUnions :: Can.Exports -> Map.Map Name.Name Can.Union -> Map.Map Name.Name Union

102+restrictUnions exports unions =

103+ case exports of

104+ Can.ExportEverything _ ->

105+ Map.map OpenUnion unions

106+

107+ Can.Export explicitExports ->

108+ Map.merge onLeft onRight onBoth explicitExports unions

109+ where

110+ onLeft = Map.dropMissing

111+ onRight = Map.mapMissing (\_ union -> PrivateUnion union)

112+ onBoth = Map.zipWithMatched $ \_ (A.At _ export) union ->

113+ case export of

114+ Can.ExportUnionOpen -> OpenUnion union

115+ Can.ExportUnionClosed -> ClosedUnion union

116+ _ -> error "impossible exports discovered in restrictUnions"

117+

118+

119+restrictAliases :: Can.Exports -> Map.Map Name.Name Can.Alias -> Map.Map Name.Name Alias

120+restrictAliases exports aliases =

121+ case exports of

122+ Can.ExportEverything _ ->

123+ Map.map PublicAlias aliases

124+

125+ Can.Export explicitExports ->

126+ Map.merge onLeft onRight onBoth explicitExports aliases

127+ where

128+ onLeft = Map.dropMissing

129+ onRight = Map.mapMissing (\_ a -> PrivateAlias a)

130+ onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a)

131+

132+

133+

134+-- TO PUBLIC

135+

136+

137+toPublicUnion :: Union -> Maybe Can.Union

138+toPublicUnion iUnion =

139+ case iUnion of

140+ OpenUnion union -> Just union

141+ ClosedUnion (Can.Union vars _ _ opts) -> Just (Can.Union vars [] 0 opts)

142+ PrivateUnion _ -> Nothing

143+

144+

145+toPublicAlias :: Alias -> Maybe Can.Alias

146+toPublicAlias iAlias =

147+ case iAlias of

148+ PublicAlias alias -> Just alias

149+ PrivateAlias _ -> Nothing

150+

151+

152+

153+-- DEPENDENCY INTERFACE

154+

155+

156+data DependencyInterface

157+ = Public Interface

158+ | Private

159+ Pkg.Name

160+ (Map.Map Name.Name Can.Union)

161+ (Map.Map Name.Name Can.Alias)

162+

163+

164+public :: Interface -> DependencyInterface

165+public =

166+ Public

167+

168+

169+private :: Interface -> DependencyInterface

170+private (Interface pkg _ unions aliases _) =

171+ Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases)

172+

173+

174+extractUnion :: Union -> Can.Union

175+extractUnion iUnion =

176+ case iUnion of

177+ OpenUnion union -> union

178+ ClosedUnion union -> union

179+ PrivateUnion union -> union

180+

181+

182+extractAlias :: Alias -> Can.Alias

183+extractAlias iAlias =

184+ case iAlias of

185+ PublicAlias alias -> alias

186+ PrivateAlias alias -> alias

187+

188+

189+privatize :: DependencyInterface -> DependencyInterface

190+privatize di =

191+ case di of

192+ Public i -> private i

193+ Private _ _ _ -> di

194+

195+

196+

197+-- BINARY

198+

199+

200+instance Binary Interface where

201+ get = liftM5 Interface get get get get get

202+ put (Interface a b c d e) = put a >> put b >> put c >> put d >> put e

203+

204+

205+instance Binary Union where

206+ put union =

207+ case union of

208+ OpenUnion u -> putWord8 0 >> put u

209+ ClosedUnion u -> putWord8 1 >> put u

210+ PrivateUnion u -> putWord8 2 >> put u

211+

212+ get =

213+ do n <- getWord8

214+ case n of

215+ 0 -> liftM OpenUnion get

216+ 1 -> liftM ClosedUnion get

217+ 2 -> liftM PrivateUnion get

218+ _ -> fail "binary encoding of Union was corrupted"

219+

220+

221+instance Binary Alias where

222+ put union =

223+ case union of

224+ PublicAlias a -> putWord8 0 >> put a

225+ PrivateAlias a -> putWord8 1 >> put a

226+

227+ get =

228+ do n <- getWord8

229+ case n of

230+ 0 -> liftM PublicAlias get

231+ 1 -> liftM PrivateAlias get

232+ _ -> fail "binary encoding of Alias was corrupted"

233+

234+

235+instance Binary Binop where

236+ get =

237+ liftM4 Binop get get get get

238+

239+ put (Binop a b c d) =

240+ put a >> put b >> put c >> put d

241+

242+

243+instance Binary DependencyInterface where

244+ put union =

245+ case union of

246+ Public a -> putWord8 0 >> put a

247+ Private a b c -> putWord8 1 >> put a >> put b >> put c

248+

249+ get =

250+ do n <- getWord8

251+ case n of

252+ 0 -> liftM Public get

253+ 1 -> liftM3 Private get get get

254+ _ -> fail "binary encoding of DependencyInterface was corrupted"

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

@@ -0,0 +1,365 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, OverloadedStrings, UnboxedTuples #-}

3+module Elm.Kernel

4+ ( Content(..)

5+ , Chunk(..)

6+ , fromByteString

7+ , countFields

8+ )

9+ where

10+

11+

12+import Control.Monad (liftM, liftM2)

13+import Data.Binary (Binary, get, put, getWord8, putWord8)

14+import qualified Data.ByteString.Internal as B

15+import qualified Data.List as List

16+import qualified Data.Map as Map

17+import qualified Data.Name as Name

18+import Data.Word (Word8)

19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

20+import Foreign.ForeignPtr (ForeignPtr)

21+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

22+

23+import qualified AST.Source as Src

24+import qualified Elm.ModuleName as ModuleName

25+import qualified Elm.Package as Pkg

26+import qualified Parse.Module as Module

27+import qualified Parse.Space as Space

28+import qualified Parse.Variable as Var

29+import Parse.Primitives hiding (fromByteString)

30+import qualified Parse.Primitives as P

31+import qualified Reporting.Annotation as A

32+

33+

34+

35+-- CHUNK

36+

37+

38+data Chunk

39+ = JS B.ByteString

40+ | ElmVar ModuleName.Canonical Name.Name

41+ | JsVar Name.Name Name.Name

42+ | ElmField Name.Name

43+ | JsField Int

44+ | JsEnum Int

45+ | Debug

46+ | Prod

47+

48+

49+

50+-- COUNT FIELDS

51+

52+

53+countFields :: [Chunk] -> Map.Map Name.Name Int

54+countFields chunks =

55+ foldr addField Map.empty chunks

56+

57+

58+addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int

59+addField chunk fields =

60+ case chunk of

61+ JS _ -> fields

62+ ElmVar _ _ -> fields

63+ JsVar _ _ -> fields

64+ ElmField f -> Map.insertWith (+) f 1 fields

65+ JsField _ -> fields

66+ JsEnum _ -> fields

67+ Debug -> fields

68+ Prod -> fields

69+

70+

71+

72+-- FROM FILE

73+

74+

75+data Content =

76+ Content [Src.Import] [Chunk]

77+

78+

79+type Foreigns =

80+ Map.Map ModuleName.Raw Pkg.Name

81+

82+

83+fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content

84+fromByteString pkg foreigns bytes =

85+ case P.fromByteString (parser pkg foreigns) toError bytes of

86+ Right content ->

87+ Just content

88+

89+ Left () ->

90+ Nothing

91+

92+

93+parser :: Pkg.Name -> Foreigns -> Parser () Content

94+parser pkg foreigns =

95+ do word2 0x2F 0x2A {-/*-} toError

96+ Space.chomp ignoreError

97+ Space.checkFreshLine toError

98+ imports <- specialize ignoreError (Module.chompImports [])

99+ word2 0x2A 0x2F {-*/-} toError

100+ chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty

101+ return (Content imports chunks)

102+

103+

104+toError :: Row -> Col -> ()

105+toError _ _ =

106+ ()

107+

108+

109+ignoreError :: a -> Row -> Col -> ()

110+ignoreError _ _ _ =

111+ ()

112+

113+

114+

115+-- PARSE CHUNKS

116+

117+

118+parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]

119+parseChunks vtable enums fields =

120+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->

121+ let

122+ (# chunks, newPos, newRow, newCol #) =

123+ chompChunks vtable enums fields src pos end row col pos []

124+ in

125+ if newPos == end then

126+ cok chunks (P.State src newPos end indent newRow newCol)

127+ else

128+ cerr row col toError

129+

130+

131+chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)

132+chompChunks vs es fs src pos end row col lastPos revChunks =

133+ if pos >= end then

134+ let !js = toByteString src lastPos end in

135+ (# reverse (JS js : revChunks), pos, row, col #)

136+

137+ else

138+ let !word = unsafeIndex pos in

139+ if word == 0x5F {-_-} then

140+ let

141+ !pos1 = plusPtr pos 1

142+ !pos3 = plusPtr pos 3

143+ in

144+ if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then

145+ let !js = toByteString src lastPos pos in

146+ chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)

147+ else

148+ chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks

149+

150+ else if word == 0x0A {-\n-} then

151+ chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks

152+

153+ else

154+ let

155+ !newPos = plusPtr pos (getCharWidth word)

156+ in

157+ chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks

158+

159+

160+toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString

161+toByteString src pos end =

162+ let

163+ !off = minusPtr pos (unsafeForeignPtrToPtr src)

164+ !len = minusPtr end pos

165+ in

166+ B.PS src off len

167+

168+

169+

170+-- relies on external checks in chompChunks

171+chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)

172+chompTag vs es fs src pos end row col revChunks =

173+ let

174+ (# newPos, newCol #) = Var.chompInnerChars pos end col

175+ !tagPos = plusPtr pos (-1)

176+ !word = unsafeIndex tagPos

177+ in

178+ if word == 0x24 {-$-} then

179+ let

180+ !name = Name.fromPtr pos newPos

181+ in

182+ chompChunks vs es fs src newPos end row newCol newPos $

183+ ElmField name : revChunks

184+ else

185+ let

186+ !name = Name.fromPtr tagPos newPos

187+ in

188+ if 0x30 {-0-} <= word && word <= 0x39 {-9-} then

189+ let

190+ (enum, newEnums) =

191+ lookupEnum (word - 0x30) name es

192+ in

193+ chompChunks vs newEnums fs src newPos end row newCol newPos $

194+ JsEnum enum : revChunks

195+

196+ else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then

197+ let

198+ (field, newFields) =

199+ lookupField name fs

200+ in

201+ chompChunks vs es newFields src newPos end row newCol newPos $

202+ JsField field : revChunks

203+

204+ else if name == "DEBUG" then

205+ chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)

206+

207+ else if name == "PROD" then

208+ chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)

209+

210+ else

211+ case Map.lookup name vs of

212+ Just chunk ->

213+ chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)

214+

215+ Nothing ->

216+ (# revChunks, pos, row, col #)

217+

218+

219+

220+-- FIELDS

221+

222+

223+type Fields =

224+ Map.Map Name.Name Int

225+

226+

227+lookupField :: Name.Name -> Fields -> (Int, Fields)

228+lookupField name fields =

229+ case Map.lookup name fields of

230+ Just n ->

231+ ( n, fields )

232+

233+ Nothing ->

234+ let n = Map.size fields in

235+ ( n, Map.insert name n fields )

236+

237+

238+

239+-- ENUMS

240+

241+

242+type Enums =

243+ Map.Map Word8 (Map.Map Name.Name Int)

244+

245+

246+lookupEnum :: Word8 -> Name.Name -> Enums -> (Int, Enums)

247+lookupEnum word var allEnums =

248+ let

249+ enums =

250+ Map.findWithDefault Map.empty word allEnums

251+ in

252+ case Map.lookup var enums of

253+ Just n ->

254+ ( n, allEnums )

255+

256+ Nothing ->

257+ let n = Map.size enums in

258+ ( n, Map.insert word (Map.insert var n enums) allEnums )

259+

260+

261+

262+-- PROCESS IMPORTS

263+

264+

265+type VarTable =

266+ Map.Map Name.Name Chunk

267+

268+

269+toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable

270+toVarTable pkg foreigns imports =

271+ List.foldl' (addImport pkg foreigns) Map.empty imports

272+

273+

274+addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable

275+addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) =

276+ if Name.isKernel importName then

277+ case maybeAlias of

278+ Just _ ->

279+ error ("cannot use `as` with kernel import of: " ++ Name.toChars importName)

280+

281+ Nothing ->

282+ let

283+ home = Name.getKernel importName

284+ add table name =

285+ Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table

286+ in

287+ List.foldl' add vtable (toNames exposing)

288+

289+ else

290+ let

291+ home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName

292+ prefix = toPrefix importName maybeAlias

293+ add table name =

294+ Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table

295+ in

296+ List.foldl' add vtable (toNames exposing)

297+

298+

299+toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name

300+toPrefix home maybeAlias =

301+ case maybeAlias of

302+ Just alias ->

303+ alias

304+

305+ Nothing ->

306+ if Name.hasDot home then

307+ error ("kernel imports with dots need an alias: " ++ show (Name.toChars home))

308+ else

309+ home

310+

311+

312+toNames :: Src.Exposing -> [Name.Name]

313+toNames exposing =

314+ case exposing of

315+ Src.Open ->

316+ error "cannot have `exposing (..)` in kernel code."

317+

318+ Src.Explicit exposedList ->

319+ map toName exposedList

320+

321+

322+toName :: Src.Exposed -> Name.Name

323+toName exposed =

324+ case exposed of

325+ Src.Lower (A.At _ name) ->

326+ name

327+

328+ Src.Upper (A.At _ name) Src.Private ->

329+ name

330+

331+ Src.Upper _ (Src.Public _) ->

332+ error "cannot have Maybe(..) syntax in kernel code header"

333+

334+ Src.Operator _ _ ->

335+ error "cannot use binops in kernel code"

336+

337+

338+

339+-- BINARY

340+

341+

342+instance Binary Chunk where

343+ put chunk =

344+ case chunk of

345+ JS a -> putWord8 0 >> put a

346+ ElmVar a b -> putWord8 1 >> put a >> put b

347+ JsVar a b -> putWord8 2 >> put a >> put b

348+ ElmField a -> putWord8 3 >> put a

349+ JsField a -> putWord8 4 >> put a

350+ JsEnum a -> putWord8 5 >> put a

351+ Debug -> putWord8 6

352+ Prod -> putWord8 7

353+

354+ get =

355+ do word <- getWord8

356+ case word of

357+ 0 -> liftM JS get

358+ 1 -> liftM2 ElmVar get get

359+ 2 -> liftM2 JsVar get get

360+ 3 -> liftM ElmField get

361+ 4 -> liftM JsField get

362+ 5 -> liftM JsEnum get

363+ 6 -> return Debug

364+ 7 -> return Prod

365+ _ -> error "problem deserializing Elm.Kernel.Chunk"

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

@@ -0,0 +1,185 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Elm.Licenses

4+ ( License

5+ , bsd3

6+ , encode

7+ , decoder

8+ )

9+ where

10+

11+

12+import qualified Data.Map as Map

13+import qualified Data.Utf8 as Utf8

14+

15+import qualified Json.Decode as D

16+import qualified Json.Encode as E

17+import qualified Json.String as Json

18+import qualified Reporting.Suggest as Suggest

19+

20+

21+

22+-- LICENCES

23+

24+

25+newtype License =

26+ License Json.String

27+

28+

29+bsd3 :: License

30+bsd3 =

31+ License (Json.fromChars "BSD-3-Clause")

32+

33+

34+encode :: License -> E.Value

35+encode (License code) =

36+ E.string code

37+

38+

39+decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License

40+decoder toError =

41+ do str <- D.string

42+ case check str of

43+ Right license ->

44+ return license

45+

46+ Left suggestions ->

47+ D.failure (toError str suggestions)

48+

49+

50+

51+-- CHECK

52+

53+

54+check :: Json.String -> Either [Json.String] License

55+check givenCode =

56+ if Map.member givenCode osiApprovedSpdxLicenses then

57+ Right (License givenCode)

58+

59+ else

60+ let

61+ pairs =

62+ map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)

63+ ++

64+ Map.toList osiApprovedSpdxLicenses

65+ in

66+ Left $ map fst $ take 4 $

67+ Suggest.sort (Utf8.toChars givenCode) snd pairs

68+

69+

70+

71+-- LIST OF LICENCES

72+

73+

74+(==>) :: [Char] -> [Char] -> (Json.String, [Char])

75+(==>) code fullName =

76+ ( Json.fromChars code, fullName )

77+

78+

79+--

80+-- OSI approved licenses in SPDX format.

81+-- <https://spdx.org/licenses/>

82+--

83+osiApprovedSpdxLicenses :: Map.Map Json.String [Char]

84+osiApprovedSpdxLicenses =

85+ Map.fromList

86+ [ "0BSD" ==> "BSD Zero Clause License"

87+ , "AAL" ==> "Attribution Assurance License"

88+ , "AFL-1.1" ==> "Academic Free License v1.1"

89+ , "AFL-1.2" ==> "Academic Free License v1.2"

90+ , "AFL-2.0" ==> "Academic Free License v2.0"

91+ , "AFL-2.1" ==> "Academic Free License v2.1"

92+ , "AFL-3.0" ==> "Academic Free License v3.0"

93+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"

94+ , "Apache-1.1" ==> "Apache License 1.1"

95+ , "Apache-2.0" ==> "Apache License 2.0"

96+ , "APL-1.0" ==> "Adaptive Public License 1.0"

97+ , "APSL-1.0" ==> "Apple Public Source License 1.0"

98+ , "APSL-1.1" ==> "Apple Public Source License 1.1"

99+ , "APSL-1.2" ==> "Apple Public Source License 1.2"

100+ , "APSL-2.0" ==> "Apple Public Source License 2.0"

101+ , "Artistic-1.0" ==> "Artistic License 1.0"

102+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"

103+ , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"

104+ , "Artistic-2.0" ==> "Artistic License 2.0"

105+ , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"

106+ , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"

107+ , "BSL-1.0" ==> "Boost Software License 1.0"

108+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"

109+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"

110+ , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"

111+ , "CNRI-Python" ==> "CNRI Python License"

112+ , "CPAL-1.0" ==> "Common Public Attribution License 1.0"

113+ , "CPL-1.0" ==> "Common Public License 1.0"

114+ , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"

115+ , "ECL-1.0" ==> "Educational Community License v1.0"

116+ , "ECL-2.0" ==> "Educational Community License v2.0"

117+ , "EFL-1.0" ==> "Eiffel Forum License v1.0"

118+ , "EFL-2.0" ==> "Eiffel Forum License v2.0"

119+ , "Entessa" ==> "Entessa Public License v1.0"

120+ , "EPL-1.0" ==> "Eclipse Public License 1.0"

121+ , "EUDatagrid" ==> "EU DataGrid Software License"

122+ , "EUPL-1.1" ==> "European Union Public License 1.1"

123+ , "Fair" ==> "Fair License"

124+ , "Frameworx-1.0" ==> "Frameworx Open License 1.0"

125+ , "GPL-2.0" ==> "GNU General Public License v2.0 only"

126+ , "GPL-3.0" ==> "GNU General Public License v3.0 only"

127+ , "HPND" ==> "Historic Permission Notice and Disclaimer"

128+ , "Intel" ==> "Intel Open Source License"

129+ , "IPA" ==> "IPA Font License"

130+ , "IPL-1.0" ==> "IBM Public License v1.0"

131+ , "ISC" ==> "ISC License"

132+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"

133+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"

134+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"

135+ , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"

136+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"

137+ , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"

138+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"

139+ , "LPL-1.02" ==> "Lucent Public License v1.02"

140+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

141+ , "MirOS" ==> "MirOS Licence"

142+ , "MIT" ==> "MIT License"

143+ , "Motosoto" ==> "Motosoto License"

144+ , "MPL-1.0" ==> "Mozilla Public License 1.0"

145+ , "MPL-1.1" ==> "Mozilla Public License 1.1"

146+ , "MPL-2.0" ==> "Mozilla Public License 2.0"

147+ , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"

148+ , "MS-PL" ==> "Microsoft Public License"

149+ , "MS-RL" ==> "Microsoft Reciprocal License"

150+ , "Multics" ==> "Multics License"

151+ , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"

152+ , "Naumen" ==> "Naumen Public License"

153+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"

154+ , "NGPL" ==> "Nethack General Public License"

155+ , "Nokia" ==> "Nokia Open Source License"

156+ , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"

157+ , "NTP" ==> "NTP License"

158+ , "OCLC-2.0" ==> "OCLC Research Public License 2.0"

159+ , "OFL-1.1" ==> "SIL Open Font License 1.1"

160+ , "OGTSL" ==> "Open Group Test Suite License"

161+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

162+ , "OSL-1.0" ==> "Open Software License 1.0"

163+ , "OSL-2.0" ==> "Open Software License 2.0"

164+ , "OSL-2.1" ==> "Open Software License 2.1"

165+ , "OSL-3.0" ==> "Open Software License 3.0"

166+ , "PHP-3.0" ==> "PHP License v3.0"

167+ , "PostgreSQL" ==> "PostgreSQL License"

168+ , "Python-2.0" ==> "Python License 2.0"

169+ , "QPL-1.0" ==> "Q Public License 1.0"

170+ , "RPL-1.1" ==> "Reciprocal Public License 1.1"

171+ , "RPL-1.5" ==> "Reciprocal Public License 1.5"

172+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

173+ , "RSCPL" ==> "Ricoh Source Code Public License"

174+ , "SimPL-2.0" ==> "Simple Public License 2.0"

175+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"

176+ , "Sleepycat" ==> "Sleepycat License"

177+ , "SPL-1.0" ==> "Sun Public License v1.0"

178+ , "UPL-1.0" ==> "Universal Permissive License v1.0"

179+ , "VSL-1.0" ==> "Vovida Software License v1.0"

180+ , "W3C" ==> "W3C Software Notice and License (2002-12-31)"

181+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

182+ , "Xnet" ==> "X.Net License"

183+ , "Zlib" ==> "zlib License"

184+ , "ZPL-2.0" ==> "Zope Public License 2.0"

185+ ]

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

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

1+module Elm.Magnitude

2+ ( Magnitude(..)

3+ , toChars

4+ )

5+ where

6+

7+

8+

9+-- MAGNITUDE

10+

11+

12+data Magnitude

13+ = PATCH

14+ | MINOR

15+ | MAJOR

16+ deriving (Eq, Ord)

17+

18+

19+toChars :: Magnitude -> String

20+toChars magnitude =

21+ case magnitude of

22+ PATCH -> "PATCH"

23+ MINOR -> "MINOR"

24+ MAJOR -> "MAJOR"

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

@@ -0,0 +1,283 @@

1+{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}

2+module Elm.ModuleName

3+ ( Raw

4+ , toChars

5+ , toFilePath

6+ , toHyphenPath

7+ --

8+ , encode

9+ , decoder

10+ , parser

11+ --

12+ , Canonical(..)

13+ , basics, char, string

14+ , maybe, result, list, array, dict, tuple

15+ , platform, cmd, sub

16+ , debug

17+ , virtualDom

18+ , jsonDecode, jsonEncode

19+ , webgl, texture, vector2, vector3, vector4, matrix4

20+ )

21+ where

22+

23+

24+import Control.Monad (liftM2)

25+import Data.Binary (Binary(..))

26+import qualified Data.Name as Name

27+import qualified Data.Utf8 as Utf8

28+import Data.Word (Word8)

29+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

30+import Prelude hiding (maybe)

31+import qualified System.FilePath as FP

32+

33+import qualified Elm.Package as Pkg

34+import qualified Json.Decode as D

35+import qualified Json.Encode as E

36+import qualified Parse.Variable as Var

37+import qualified Parse.Primitives as P

38+import Parse.Primitives (Row, Col)

39+

40+

41+

42+-- RAW

43+

44+

45+type Raw = Name.Name

46+

47+

48+toChars :: Raw -> String

49+toChars =

50+ Name.toChars

51+

52+

53+toFilePath :: Raw -> FilePath

54+toFilePath name =

55+ map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)

56+

57+

58+toHyphenPath :: Raw -> FilePath

59+toHyphenPath name =

60+ map (\c -> if c == '.' then '-' else c) (Name.toChars name)

61+

62+

63+

64+-- JSON

65+

66+

67+encode :: Raw -> E.Value

68+encode =

69+ E.name

70+

71+

72+decoder :: D.Decoder (Row, Col) Raw

73+decoder =

74+ D.customString parser (,)

75+

76+

77+

78+-- PARSER

79+

80+

81+parser :: P.Parser (Row, Col) Raw

82+parser =

83+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

84+ let

85+ (# isGood, newPos, newCol #) = chompStart pos end col

86+ in

87+ if isGood && minusPtr newPos pos < 256 then

88+ let !newState = P.State src newPos end indent row newCol in

89+ cok (Utf8.fromPtr pos newPos) newState

90+

91+ else if col == newCol then

92+ eerr row newCol (,)

93+

94+ else

95+ cerr row newCol (,)

96+

97+

98+chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)

99+chompStart pos end col =

100+ let

101+ !width = Var.getUpperWidth pos end

102+ in

103+ if width == 0 then

104+ (# False, pos, col #)

105+ else

106+ chompInner (plusPtr pos width) end (col + 1)

107+

108+

109+chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)

110+chompInner pos end col =

111+ if pos >= end then

112+ (# True, pos, col #)

113+ else

114+ let

115+ !word = P.unsafeIndex pos

116+ !width = Var.getInnerWidthHelp pos end word

117+ in

118+ if width == 0 then

119+ if word == 0x2E {-.-} then

120+ chompStart (plusPtr pos 1) end (col + 1)

121+ else

122+ (# True, pos, col #)

123+ else

124+ chompInner (plusPtr pos width) end (col + 1)

125+

126+

127+

128+-- CANONICAL

129+

130+

131+data Canonical =

132+ Canonical

133+ { _package :: !Pkg.Name

134+ , _module :: !Name.Name

135+ }

136+

137+

138+

139+-- INSTANCES

140+

141+

142+instance Eq Canonical where

143+ (==) (Canonical pkg1 name1) (Canonical pkg2 name2) =

144+ name1 == name2 && pkg1 == pkg2

145+

146+

147+instance Ord Canonical where

148+ compare (Canonical pkg1 name1) (Canonical pkg2 name2) =

149+ case compare name1 name2 of

150+ LT -> LT

151+ EQ -> compare pkg1 pkg2

152+ GT -> GT

153+

154+

155+instance Binary Canonical where

156+ put (Canonical a b) = put a >> put b

157+ get = liftM2 Canonical get get

158+

159+

160+

161+-- CORE

162+

163+

164+{-# NOINLINE basics #-}

165+basics :: Canonical

166+basics = Canonical Pkg.core Name.basics

167+

168+

169+{-# NOINLINE char #-}

170+char :: Canonical

171+char = Canonical Pkg.core Name.char

172+

173+

174+{-# NOINLINE string #-}

175+string :: Canonical

176+string = Canonical Pkg.core Name.string

177+

178+

179+{-# NOINLINE maybe #-}

180+maybe :: Canonical

181+maybe = Canonical Pkg.core Name.maybe

182+

183+

184+{-# NOINLINE result #-}

185+result :: Canonical

186+result = Canonical Pkg.core Name.result

187+

188+

189+{-# NOINLINE list #-}

190+list :: Canonical

191+list = Canonical Pkg.core Name.list

192+

193+

194+{-# NOINLINE array #-}

195+array :: Canonical

196+array = Canonical Pkg.core Name.array

197+

198+

199+{-# NOINLINE dict #-}

200+dict :: Canonical

201+dict = Canonical Pkg.core Name.dict

202+

203+

204+{-# NOINLINE tuple #-}

205+tuple :: Canonical

206+tuple = Canonical Pkg.core Name.tuple

207+

208+

209+{-# NOINLINE platform #-}

210+platform :: Canonical

211+platform = Canonical Pkg.core Name.platform

212+

213+

214+{-# NOINLINE cmd #-}

215+cmd :: Canonical

216+cmd = Canonical Pkg.core "Platform.Cmd"

217+

218+

219+{-# NOINLINE sub #-}

220+sub :: Canonical

221+sub = Canonical Pkg.core "Platform.Sub"

222+

223+

224+{-# NOINLINE debug #-}

225+debug :: Canonical

226+debug = Canonical Pkg.core Name.debug

227+

228+

229+

230+-- HTML

231+

232+

233+{-# NOINLINE virtualDom #-}

234+virtualDom :: Canonical

235+virtualDom = Canonical Pkg.virtualDom Name.virtualDom

236+

237+

238+

239+-- JSON

240+

241+

242+{-# NOINLINE jsonDecode #-}

243+jsonDecode :: Canonical

244+jsonDecode = Canonical Pkg.json "Json.Decode"

245+

246+

247+{-# NOINLINE jsonEncode #-}

248+jsonEncode :: Canonical

249+jsonEncode = Canonical Pkg.json "Json.Encode"

250+

251+

252+

253+-- WEBGL

254+

255+

256+{-# NOINLINE webgl #-}

257+webgl :: Canonical

258+webgl = Canonical Pkg.webgl "WebGL"

259+

260+

261+{-# NOINLINE texture #-}

262+texture :: Canonical

263+texture = Canonical Pkg.webgl "WebGL.Texture"

264+

265+

266+{-# NOINLINE vector2 #-}

267+vector2 :: Canonical

268+vector2 = Canonical Pkg.linearAlgebra "Math.Vector2"

269+

270+

271+{-# NOINLINE vector3 #-}

272+vector3 :: Canonical

273+vector3 = Canonical Pkg.linearAlgebra "Math.Vector3"

274+

275+

276+{-# NOINLINE vector4 #-}

277+vector4 :: Canonical

278+vector4 = Canonical Pkg.linearAlgebra "Math.Vector4"

279+

280+

281+{-# NOINLINE matrix4 #-}

282+matrix4 :: Canonical

283+matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4"

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

@@ -0,0 +1,374 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}

3+module Elm.Package

4+ ( Name(..)

5+ , Author

6+ , Project

7+ , Canonical(..)

8+ , isKernel

9+ , toChars

10+ , toUrl

11+ , toFilePath

12+ , toJsonString

13+ --

14+ , dummyName, kernel, core

15+ , browser, virtualDom, html

16+ , json, http, url

17+ , webgl, linearAlgebra

18+ --

19+ , suggestions

20+ , nearbyNames

21+ --

22+ , decoder

23+ , encode

24+ , keyDecoder

25+ --

26+ , parser

27+ )

28+ where

29+

30+

31+import Control.Monad (liftM2)

32+import Data.Binary (Binary, get, put)

33+import qualified Data.Coerce as Coerce

34+import qualified Data.List as List

35+import qualified Data.Map as Map

36+import qualified Data.Name as Name

37+import Data.Monoid ((<>))

38+import qualified Data.Utf8 as Utf8

39+import Data.Word (Word8)

40+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

41+import System.FilePath ((</>))

42+

43+import qualified Elm.Version as V

44+import qualified Json.Decode as D

45+import qualified Json.Encode as E

46+import qualified Json.String as Json

47+import qualified Parse.Primitives as P

48+import Parse.Primitives (Row, Col)

49+import qualified Reporting.Suggest as Suggest

50+

51+

52+

53+-- PACKGE NAMES

54+

55+

56+data Name =

57+ Name

58+ { _author :: !Author

59+ , _project :: !Project

60+ }

61+ deriving (Ord)

62+

63+

64+type Author = Utf8.Utf8 AUTHOR

65+type Project = Utf8.Utf8 PROJECT

66+

67+data AUTHOR

68+data PROJECT

69+

70+

71+data Canonical =

72+ Canonical

73+ { _name :: !Name

74+ , _version :: !V.Version

75+ }

76+ deriving (Ord)

77+

78+

79+

80+-- HELPERS

81+

82+

83+isKernel :: Name -> Bool

84+isKernel (Name author _) =

85+ author == elm || author == elm_explorations

86+

87+

88+toChars :: Name -> String

89+toChars (Name author project) =

90+ Utf8.toChars author <> "/" <> Utf8.toChars project

91+

92+

93+toUrl :: Name -> String

94+toUrl (Name author project) =

95+ Utf8.toChars author ++ "/" ++ Utf8.toChars project

96+

97+

98+toFilePath :: Name -> FilePath

99+toFilePath (Name author project) =

100+ Utf8.toChars author </> Utf8.toChars project

101+

102+

103+toJsonString :: Name -> Json.String

104+toJsonString (Name author project) =

105+ Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]

106+

107+

108+

109+-- COMMON PACKAGE NAMES

110+

111+

112+toName :: Author -> [Char] -> Name

113+toName author project =

114+ Name author (Utf8.fromChars project)

115+

116+

117+{-# NOINLINE dummyName #-}

118+dummyName :: Name

119+dummyName =

120+ toName (Utf8.fromChars "author") "project"

121+

122+

123+{-# NOINLINE kernel #-}

124+kernel :: Name

125+kernel =

126+ toName elm "kernel"

127+

128+

129+{-# NOINLINE core #-}

130+core :: Name

131+core =

132+ toName elm "core"

133+

134+

135+{-# NOINLINE browser #-}

136+browser :: Name

137+browser =

138+ toName elm "browser"

139+

140+

141+{-# NOINLINE virtualDom #-}

142+virtualDom :: Name

143+virtualDom =

144+ toName elm "virtual-dom"

145+

146+

147+{-# NOINLINE html #-}

148+html :: Name

149+html =

150+ toName elm "html"

151+

152+

153+{-# NOINLINE json #-}

154+json :: Name

155+json =

156+ toName elm "json"

157+

158+

159+{-# NOINLINE http #-}

160+http :: Name

161+http =

162+ toName elm "http"

163+

164+

165+{-# NOINLINE url #-}

166+url :: Name

167+url =

168+ toName elm "url"

169+

170+

171+{-# NOINLINE webgl #-}

172+webgl :: Name

173+webgl =

174+ toName elm_explorations "webgl"

175+

176+

177+{-# NOINLINE linearAlgebra #-}

178+linearAlgebra :: Name

179+linearAlgebra =

180+ toName elm_explorations "linear-algebra"

181+

182+

183+{-# NOINLINE elm #-}

184+elm :: Author

185+elm =

186+ Utf8.fromChars "elm"

187+

188+

189+{-# NOINLINE elm_explorations #-}

190+elm_explorations :: Author

191+elm_explorations =

192+ Utf8.fromChars "elm-explorations"

193+

194+

195+

196+-- PACKAGE SUGGESTIONS

197+

198+

199+suggestions :: Map.Map Name.Name Name

200+suggestions =

201+ let

202+ random = toName elm "random"

203+ time = toName elm "time"

204+ file = toName elm "file"

205+ in

206+ Map.fromList

207+ [ "Browser" ==> browser

208+ , "File" ==> file

209+ , "File.Download" ==> file

210+ , "File.Select" ==> file

211+ , "Html" ==> html

212+ , "Html.Attributes" ==> html

213+ , "Html.Events" ==> html

214+ , "Http" ==> http

215+ , "Json.Decode" ==> json

216+ , "Json.Encode" ==> json

217+ , "Random" ==> random

218+ , "Time" ==> time

219+ , "Url.Parser" ==> url

220+ , "Url" ==> url

221+ ]

222+

223+

224+(==>) :: [Char] -> Name -> (Name.Name, Name)

225+(==>) moduleName package =

226+ ( Utf8.fromChars moduleName, package )

227+

228+

229+

230+-- NEARBY NAMES

231+

232+

233+nearbyNames :: Name -> [Name] -> [Name]

234+nearbyNames (Name author1 project1) possibleNames =

235+ let

236+ authorDist = authorDistance (Utf8.toChars author1)

237+ projectDist = projectDistance (Utf8.toChars project1)

238+

239+ nameDistance (Name author2 project2) =

240+ authorDist author2 + projectDist project2

241+ in

242+ take 4 $ List.sortOn nameDistance possibleNames

243+

244+

245+authorDistance :: [Char] -> Author -> Int

246+authorDistance given possibility =

247+ if possibility == elm || possibility == elm_explorations

248+ then 0

249+ else abs (Suggest.distance given (Utf8.toChars possibility))

250+

251+

252+projectDistance :: [Char] -> Project -> Int

253+projectDistance given possibility =

254+ abs (Suggest.distance given (Utf8.toChars possibility))

255+

256+

257+

258+-- INSTANCES

259+

260+

261+instance Eq Name where

262+ (==) (Name author1 project1) (Name author2 project2) =

263+ project1 == project2 && author1 == author2

264+

265+

266+instance Eq Canonical where

267+ (==) (Canonical package1 version1) (Canonical package2 version2) =

268+ version1 == version2 && package1 == package2

269+

270+

271+

272+-- BINARY

273+

274+

275+instance Binary Name where -- PERF try storing as a Word16

276+ get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256

277+ put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b

278+

279+

280+instance Binary Canonical where

281+ get = liftM2 Canonical get get

282+ put (Canonical a b) = put a >> put b

283+

284+

285+

286+-- JSON

287+

288+

289+decoder :: D.Decoder (Row, Col) Name

290+decoder =

291+ D.customString parser (,)

292+

293+

294+encode :: Name -> E.Value

295+encode name =

296+ E.chars (toChars name)

297+

298+

299+keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name

300+keyDecoder toError =

301+ let

302+ keyParser =

303+ P.specialize (\(r,c) _ _ -> toError r c) parser

304+ in

305+ D.KeyDecoder keyParser toError

306+

307+

308+

309+-- PARSER

310+

311+

312+parser :: P.Parser (Row, Col) Name

313+parser =

314+ do author <- parseName isAlphaOrDigit isAlphaOrDigit

315+ P.word1 0x2F {-/-} (,)

316+ project <- parseName isLower isLowerOrDigit

317+ return (Name author project)

318+

319+

320+parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)

321+parseName isGoodStart isGoodInner =

322+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

323+ if pos >= end then

324+ eerr row col (,)

325+ else

326+ let !word = P.unsafeIndex pos in

327+ if not (isGoodStart word) then

328+ eerr row col (,)

329+ else

330+ let

331+ (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False

332+ !len = fromIntegral (minusPtr newPos pos)

333+ !newCol = col + len

334+ in

335+ if isGood && len < 256 then

336+ let !newState = P.State src newPos end indent row newCol in

337+ cok (Utf8.fromPtr pos newPos) newState

338+ else

339+ cerr row newCol (,)

340+

341+

342+isLower :: Word8 -> Bool

343+isLower word =

344+ 0x61 {-a-} <= word && word <= 0x7A {-z-}

345+

346+

347+isLowerOrDigit :: Word8 -> Bool

348+isLowerOrDigit word =

349+ 0x61 {-a-} <= word && word <= 0x7A {-z-}

350+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}

351+

352+

353+isAlphaOrDigit :: Word8 -> Bool

354+isAlphaOrDigit word =

355+ 0x61 {-a-} <= word && word <= 0x7A {-z-}

356+ || 0x41 {-A-} <= word && word <= 0x5A {-Z-}

357+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}

358+

359+

360+chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)

361+chompName isGoodChar pos end prevWasDash =

362+ if pos >= end then

363+ (# not prevWasDash, pos #)

364+ else

365+ let !word = P.unsafeIndex pos in

366+ if isGoodChar word then

367+ chompName isGoodChar (plusPtr pos 1) end False

368+ else if word == 0x2D {---} then

369+ if prevWasDash then

370+ (# False, pos #)

371+ else

372+ chompName isGoodChar (plusPtr pos 1) end True

373+ else

374+ (# True, pos #)

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

@@ -0,0 +1,133 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}

3+module Elm.String

4+ ( String

5+ , toChars

6+ , toBuilder

7+ , Chunk(..)

8+ , fromChunks

9+ )

10+ where

11+

12+

13+import Prelude hiding (String)

14+import Data.Binary (Binary, get, put)

15+import Data.Bits ((.&.), shiftR)

16+import qualified Data.ByteString.Builder as B

17+import qualified Data.Utf8 as Utf8

18+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

19+import GHC.Exts (RealWorld, Ptr)

20+import GHC.IO (stToIO, unsafeDupablePerformIO)

21+import GHC.ST (ST)

22+import GHC.Word (Word8)

23+

24+

25+

26+-- STRINGS

27+

28+

29+type String =

30+ Utf8.Utf8 ELM_STRING

31+

32+

33+data ELM_STRING

34+

35+

36+

37+-- HELPERS

38+

39+

40+toChars :: String -> [Char]

41+toChars =

42+ Utf8.toChars

43+

44+

45+{-# INLINE toBuilder #-}

46+toBuilder :: String -> B.Builder

47+toBuilder =

48+ Utf8.toBuilder

49+

50+

51+

52+-- FROM CHUNKS

53+

54+

55+data Chunk

56+ = Slice (Ptr Word8) Int

57+ | Escape Word8

58+ | CodePoint Int

59+

60+

61+fromChunks :: [Chunk] -> String

62+fromChunks chunks =

63+ unsafeDupablePerformIO (stToIO (

64+ do let !len = sum (map chunkToWidth chunks)

65+ mba <- newByteArray len

66+ writeChunks mba 0 chunks

67+ freeze mba

68+ ))

69+

70+

71+chunkToWidth :: Chunk -> Int

72+chunkToWidth chunk =

73+ case chunk of

74+ Slice _ len -> len

75+ Escape _ -> 2

76+ CodePoint c -> if c < 0xFFFF then 6 else 12

77+

78+

79+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

80+writeChunks mba offset chunks =

81+ case chunks of

82+ [] ->

83+ return ()

84+

85+ chunk : chunks ->

86+ case chunk of

87+ Slice ptr len ->

88+ do copyFromPtr ptr mba offset len

89+ let !newOffset = offset + len

90+ writeChunks mba newOffset chunks

91+

92+ Escape word ->

93+ do writeWord8 mba offset 0x5C {- \ -}

94+ writeWord8 mba (offset + 1) word

95+ let !newOffset = offset + 2

96+ writeChunks mba newOffset chunks

97+

98+ CodePoint code ->

99+ if code < 0xFFFF then

100+ do writeCode mba offset code

101+ let !newOffset = offset + 6

102+ writeChunks mba newOffset chunks

103+ else

104+ do let (hi,lo) = divMod (code - 0x10000) 0x400

105+ writeCode mba (offset ) (hi + 0xD800)

106+ writeCode mba (offset + 6) (lo + 0xDC00)

107+ let !newOffset = offset + 12

108+ writeChunks mba newOffset chunks

109+

110+

111+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

112+writeCode mba offset code =

113+ do writeWord8 mba offset 0x5C {- \ -}

114+ writeWord8 mba (offset + 1) 0x75 {- u -}

115+ writeHex mba (offset + 2) (shiftR code 12)

116+ writeHex mba (offset + 3) (shiftR code 8)

117+ writeHex mba (offset + 4) (shiftR code 4)

118+ writeHex mba (offset + 5) code

119+

120+

121+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

122+writeHex mba !offset !bits =

123+ do let !n = fromIntegral bits .&. 0x0F

124+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)

125+

126+

127+

128+-- BINARY

129+

130+

131+instance Binary (Utf8.Utf8 ELM_STRING) where

132+ get = Utf8.getVeryLong

133+ put = Utf8.putVeryLong

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

@@ -0,0 +1,196 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}

3+module Elm.Version

4+ ( Version(..)

5+ , one

6+ , max

7+ , compiler

8+ , bumpPatch

9+ , bumpMinor

10+ , bumpMajor

11+ , toChars

12+ --

13+ , decoder

14+ , encode

15+ --

16+ , parser

17+ )

18+ where

19+

20+

21+import Prelude hiding (max)

22+import Control.Monad (liftM3)

23+import Data.Binary (Binary, get, put, getWord8, putWord8)

24+import qualified Data.Version as Version

25+import Data.Word (Word8, Word16)

26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

27+import qualified Paths_elm

28+

29+import qualified Json.Decode as D

30+import qualified Json.Encode as E

31+import qualified Parse.Primitives as P

32+import Parse.Primitives (Row, Col)

33+

34+

35+

36+-- VERSION

37+

38+

39+data Version =

40+ Version

41+ { _major :: {-# UNPACK #-} !Word16

42+ , _minor :: {-# UNPACK #-} !Word16

43+ , _patch :: {-# UNPACK #-} !Word16

44+ }

45+ deriving (Eq, Ord)

46+

47+

48+one :: Version

49+one =

50+ Version 1 0 0

51+

52+

53+max :: Version

54+max =

55+ Version maxBound 0 0

56+

57+

58+compiler :: Version

59+compiler =

60+ case map fromIntegral (Version.versionBranch Paths_elm.version) of

61+ major : minor : patch : _ ->

62+ Version major minor patch

63+

64+ [major, minor] ->

65+ Version major minor 0

66+

67+ [major] ->

68+ Version major 0 0

69+

70+ [] ->

71+ error "could not detect version of elm-compiler you are using"

72+

73+

74+

75+-- BUMP

76+

77+

78+bumpPatch :: Version -> Version

79+bumpPatch (Version major minor patch) =

80+ Version major minor (patch + 1)

81+

82+

83+bumpMinor :: Version -> Version

84+bumpMinor (Version major minor _patch) =

85+ Version major (minor + 1) 0

86+

87+

88+bumpMajor :: Version -> Version

89+bumpMajor (Version major _minor _patch) =

90+ Version (major + 1) 0 0

91+

92+

93+

94+-- TO CHARS

95+

96+

97+toChars :: Version -> [Char]

98+toChars (Version major minor patch) =

99+ show major ++ '.' : show minor ++ '.' : show patch

100+

101+

102+

103+-- JSON

104+

105+

106+decoder :: D.Decoder (Row, Col) Version

107+decoder =

108+ D.customString parser (,)

109+

110+

111+encode :: Version -> E.Value

112+encode version =

113+ E.chars (toChars version)

114+

115+

116+

117+-- BINARY

118+

119+

120+instance Binary Version where

121+ get =

122+ do word <- getWord8

123+ if word == 255

124+ then liftM3 Version get get get

125+ else

126+ do minor <- getWord8

127+ patch <- getWord8

128+ return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch))

129+

130+ put (Version major minor patch) =

131+ if major < 255 && minor < 256 && patch < 256 then

132+ do putWord8 (fromIntegral major)

133+ putWord8 (fromIntegral minor)

134+ putWord8 (fromIntegral patch)

135+ else

136+ do putWord8 255

137+ put major

138+ put minor

139+ put patch

140+

141+

142+

143+-- PARSER

144+

145+

146+parser :: P.Parser (Row, Col) Version

147+parser =

148+ do major <- numberParser

149+ P.word1 0x2E {-.-} (,)

150+ minor <- numberParser

151+ P.word1 0x2E {-.-} (,)

152+ patch <- numberParser

153+ return (Version major minor patch)

154+

155+

156+numberParser :: P.Parser (Row, Col) Word16

157+numberParser =

158+ P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

159+ if pos >= end then

160+ eerr row col (,)

161+ else

162+ let !word = P.unsafeIndex pos in

163+ if word == 0x30 {-0-} then

164+

165+ let

166+ !newState = P.State src (plusPtr pos 1) end indent row (col + 1)

167+ in

168+ cok 0 newState

169+

170+ else if isDigit word then

171+

172+ let

173+ (# total, newPos #) = chompWord16 (plusPtr pos 1) end (fromIntegral (word - 0x30))

174+ !newState = P.State src newPos end indent row (col + fromIntegral (minusPtr newPos pos))

175+ in

176+ cok total newState

177+

178+ else

179+ eerr row col (,)

180+

181+

182+chompWord16 :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Word16, Ptr Word8 #)

183+chompWord16 pos end total =

184+ if pos >= end then

185+ (# total, pos #)

186+ else

187+ let !word = P.unsafeIndex pos in

188+ if isDigit word then

189+ chompWord16 (plusPtr pos 1) end (10 * total + fromIntegral (word - 0x30))

190+ else

191+ (# total, pos #)

192+

193+

194+isDigit :: Word8 -> Bool

195+isDigit word =

196+ 0x30 {-0-} <= word && word <= 0x39 {-9-}

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

@@ -0,0 +1,54 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE QuasiQuotes #-}

3+module Generate.Html

4+ ( sandwich

5+ )

6+ where

7+

8+

9+import qualified Data.ByteString.Builder as B

10+import Data.Monoid ((<>))

11+import qualified Data.Name as Name

12+import Text.RawString.QQ (r)

13+

14+

15+

16+-- SANDWICH

17+

18+

19+sandwich :: Name.Name -> B.Builder -> B.Builder

20+sandwich moduleName javascript =

21+ let name = Name.toBuilder moduleName in

22+ [r|<!DOCTYPE HTML>

23+<html>

24+<head>

25+ <meta charset="UTF-8">

26+ <title>|] <> name <> [r|</title>

27+ <style>body { padding: 0; margin: 0; }</style>

28+</head>

29+

30+<body>

31+

32+<pre id="elm"></pre>

33+

34+<script>

35+try {

36+|] <> javascript <> [r|

37+

38+ var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });

39+}

40+catch (e)

41+{

42+ // display initialization errors (e.g. bad flags, infinite recursion)

43+ var header = document.createElement("h1");

44+ header.style.fontFamily = "monospace";

45+ header.innerText = "Initialization Error";

46+ var pre = document.getElementById("elm");

47+ document.body.insertBefore(header, pre);

48+ pre.innerText = e;

49+ throw e;

50+}

51+</script>

52+

53+</body>

54+</html>|]

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

@@ -0,0 +1,590 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Generate.JavaScript

3+ ( generate

4+ , generateForRepl

5+ , generateForReplEndpoint

6+ )

7+ where

8+

9+

10+import Prelude hiding (cycle, print)

11+import qualified Data.ByteString.Builder as B

12+import Data.Monoid ((<>))

13+import qualified Data.List as List

14+import Data.Map ((!))

15+import qualified Data.Map as Map

16+import qualified Data.Name as Name

17+import qualified Data.Set as Set

18+import qualified Data.Utf8 as Utf8

19+

20+import qualified AST.Canonical as Can

21+import qualified AST.Optimized as Opt

22+import qualified Data.Index as Index

23+import qualified Elm.Kernel as K

24+import qualified Elm.ModuleName as ModuleName

25+import qualified Generate.JavaScript.Builder as JS

26+import qualified Generate.JavaScript.Expression as Expr

27+import qualified Generate.JavaScript.Functions as Functions

28+import qualified Generate.JavaScript.Name as JsName

29+import qualified Generate.Mode as Mode

30+import qualified Reporting.Doc as D

31+import qualified Reporting.Render.Type as RT

32+import qualified Reporting.Render.Type.Localizer as L

33+

34+

35+

36+-- GENERATE

37+

38+

39+type Graph = Map.Map Opt.Global Opt.Node

40+type Mains = Map.Map ModuleName.Canonical Opt.Main

41+

42+

43+generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder

44+generate mode (Opt.GlobalGraph graph _) mains =

45+ let

46+ state = Map.foldrWithKey (addMain mode graph) emptyState mains

47+ in

48+ "(function(scope){\n'use strict';"

49+ <> Functions.functions

50+ <> perfNote mode

51+ <> stateToBuilder state

52+ <> toMainExports mode mains

53+ <> "}(this));"

54+

55+

56+addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State

57+addMain mode graph home _ state =

58+ addGlobal mode graph state (Opt.Global home "main")

59+

60+

61+perfNote :: Mode.Mode -> B.Builder

62+perfNote mode =

63+ case mode of

64+ Mode.Prod _ ->

65+ ""

66+

67+ Mode.Dev Nothing ->

68+ "console.warn('Compiled in DEV mode. Follow the advice at "

69+ <> B.stringUtf8 (D.makeNakedLink "optimize")

70+ <> " for better performance and smaller assets.');"

71+

72+ Mode.Dev (Just _) ->

73+ "console.warn('Compiled in DEBUG mode. Follow the advice at "

74+ <> B.stringUtf8 (D.makeNakedLink "optimize")

75+ <> " for better performance and smaller assets.');"

76+

77+

78+

79+-- GENERATE FOR REPL

80+

81+

82+generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder

83+generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =

84+ let

85+ mode = Mode.Dev Nothing

86+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

87+ evalState = addGlobal mode graph debugState (Opt.Global home name)

88+ in

89+ "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"

90+ <> Functions.functions

91+ <> stateToBuilder evalState

92+ <> print ansi localizer home name tipe

93+

94+

95+print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder

96+print ansi localizer home name tipe =

97+ let

98+ value = JsName.toBuilder (JsName.fromGlobal home name)

99+ toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")

100+ tipeDoc = RT.canToDoc localizer RT.None tipe

101+ bool = if ansi then "true" else "false"

102+ in

103+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\

104+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\

105+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\

106+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\

107+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\

108+ \} else {\n\

109+ \ _print(' : ' + _type);\n\

110+ \}\n"

111+

112+

113+

114+-- GENERATE FOR REPL ENDPOINT

115+

116+

117+generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder

118+generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =

119+ let

120+ name = maybe Name.replValueToPrint id maybeName

121+ mode = Mode.Dev Nothing

122+ debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

123+ evalState = addGlobal mode graph debugState (Opt.Global home name)

124+ in

125+ Functions.functions

126+ <> stateToBuilder evalState

127+ <> postMessage localizer home maybeName tipe

128+

129+

130+postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder

131+postMessage localizer home maybeName tipe =

132+ let

133+ name = maybe Name.replValueToPrint id maybeName

134+ value = JsName.toBuilder (JsName.fromGlobal home name)

135+ toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")

136+ tipeDoc = RT.canToDoc localizer RT.None tipe

137+ toName n = "\"" <> Name.toBuilder n <> "\""

138+ in

139+ "self.postMessage({\n\

140+ \ name: " <> maybe "null" toName maybeName <> ",\n\

141+ \ value: " <> toString <> "(true, " <> value <> "),\n\

142+ \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\

143+ \});\n"

144+

145+

146+

147+-- GRAPH TRAVERSAL STATE

148+

149+

150+data State =

151+ State

152+ { _revKernels :: [B.Builder]

153+ , _revBuilders :: [B.Builder]

154+ , _seenGlobals :: Set.Set Opt.Global

155+ }

156+

157+

158+emptyState :: State

159+emptyState =

160+ State mempty [] Set.empty

161+

162+

163+stateToBuilder :: State -> B.Builder

164+stateToBuilder (State revKernels revBuilders _) =

165+ prependBuilders revKernels (prependBuilders revBuilders mempty)

166+

167+

168+prependBuilders :: [B.Builder] -> B.Builder -> B.Builder

169+prependBuilders revBuilders monolith =

170+ List.foldl' (\m b -> b <> m) monolith revBuilders

171+

172+

173+

174+-- ADD DEPENDENCIES

175+

176+

177+addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State

178+addGlobal mode graph state@(State revKernels builders seen) global =

179+ if Set.member global seen then

180+ state

181+ else

182+ addGlobalHelp mode graph global $

183+ State revKernels builders (Set.insert global seen)

184+

185+

186+addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State

187+addGlobalHelp mode graph global state =

188+ let

189+ addDeps deps someState =

190+ Set.foldl' (addGlobal mode graph) someState deps

191+ in

192+ case graph ! global of

193+ Opt.Define expr deps ->

194+ addStmt (addDeps deps state) (

195+ var global (Expr.generate mode expr)

196+ )

197+

198+ Opt.DefineTailFunc argNames body deps ->

199+ addStmt (addDeps deps state) (

200+ let (Opt.Global _ name) = global in

201+ var global (Expr.generateTailDef mode name argNames body)

202+ )

203+

204+ Opt.Ctor index arity ->

205+ addStmt state (

206+ var global (Expr.generateCtor mode global index arity)

207+ )

208+

209+ Opt.Link linkedGlobal ->

210+ addGlobal mode graph state linkedGlobal

211+

212+ Opt.Cycle names values functions deps ->

213+ addStmt (addDeps deps state) (

214+ generateCycle mode global names values functions

215+ )

216+

217+ Opt.Manager effectsType ->

218+ generateManager mode graph global effectsType state

219+

220+ Opt.Kernel chunks deps ->

221+ if isDebugger global && not (Mode.isDebug mode) then

222+ state

223+ else

224+ addKernel (addDeps deps state) (generateKernel mode chunks)

225+

226+ Opt.Enum index ->

227+ addStmt state (

228+ generateEnum mode global index

229+ )

230+

231+ Opt.Box ->

232+ addStmt (addGlobal mode graph state identity) (

233+ generateBox mode global

234+ )

235+

236+ Opt.PortIncoming decoder deps ->

237+ addStmt (addDeps deps state) (

238+ generatePort mode global "incomingPort" decoder

239+ )

240+

241+ Opt.PortOutgoing encoder deps ->

242+ addStmt (addDeps deps state) (

243+ generatePort mode global "outgoingPort" encoder

244+ )

245+

246+

247+addStmt :: State -> JS.Stmt -> State

248+addStmt state stmt =

249+ addBuilder state (JS.stmtToBuilder stmt)

250+

251+

252+addBuilder :: State -> B.Builder -> State

253+addBuilder (State revKernels revBuilders seen) builder =

254+ State revKernels (builder:revBuilders) seen

255+

256+

257+addKernel :: State -> B.Builder -> State

258+addKernel (State revKernels revBuilders seen) kernel =

259+ State (kernel:revKernels) revBuilders seen

260+

261+

262+var :: Opt.Global -> Expr.Code -> JS.Stmt

263+var (Opt.Global home name) code =

264+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)

265+

266+

267+isDebugger :: Opt.Global -> Bool

268+isDebugger (Opt.Global (ModuleName.Canonical _ home) _) =

269+ home == Name.debugger

270+

271+

272+

273+-- GENERATE CYCLES

274+

275+

276+generateCycle :: Mode.Mode -> Opt.Global -> [Name.Name] -> [(Name.Name, Opt.Expr)] -> [Opt.Def] -> JS.Stmt

277+generateCycle mode (Opt.Global home _) names values functions =

278+ JS.Block

279+ [ JS.Block $ map (generateCycleFunc mode home) functions

280+ , JS.Block $ map (generateSafeCycle mode home) values

281+ , case map (generateRealCycle home) values of

282+ [] ->

283+ JS.EmptyStmt

284+

285+ realBlock@(_:_) ->

286+ case mode of

287+ Mode.Prod _ ->

288+ JS.Block realBlock

289+

290+ Mode.Dev _ ->

291+ JS.Try (JS.Block realBlock) JsName.dollar $ JS.Throw $ JS.String $

292+ "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"

293+ <> drawCycle names

294+ <> "\\n\\nThese errors are very tricky, so read "

295+ <> B.stringUtf8 (D.makeNakedLink "bad-recursion")

296+ <> " to learn how to fix it!"

297+ ]

298+

299+

300+generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt

301+generateCycleFunc mode home def =

302+ case def of

303+ Opt.Def name expr ->

304+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))

305+

306+ Opt.TailDef name args expr ->

307+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))

308+

309+

310+generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt

311+generateSafeCycle mode home (name, expr) =

312+ JS.FunctionStmt (JsName.fromCycle home name) [] $

313+ Expr.codeToStmtList (Expr.generate mode expr)

314+

315+

316+generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt

317+generateRealCycle home (name, _) =

318+ let

319+ safeName = JsName.fromCycle home name

320+ realName = JsName.fromGlobal home name

321+ in

322+ JS.Block

323+ [ JS.Var realName (JS.Call (JS.Ref safeName) [])

324+ , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $

325+ JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]

326+ ]

327+

328+

329+drawCycle :: [Name.Name] -> B.Builder

330+drawCycle names =

331+ let

332+ topLine = "\\n ┌─────┐"

333+ nameLine name = "\\n │ " <> Name.toBuilder name

334+ midLine = "\\n │ ↓"

335+ bottomLine = "\\n └─────┘"

336+ in

337+ mconcat (topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ])

338+

339+

340+

341+-- GENERATE KERNEL

342+

343+

344+generateKernel :: Mode.Mode -> [K.Chunk] -> B.Builder

345+generateKernel mode chunks =

346+ List.foldr (addChunk mode) mempty chunks

347+

348+

349+addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder

350+addChunk mode chunk builder =

351+ case chunk of

352+ K.JS javascript ->

353+ B.byteString javascript <> builder

354+

355+ K.ElmVar home name ->

356+ JsName.toBuilder (JsName.fromGlobal home name) <> builder

357+

358+ K.JsVar home name ->

359+ JsName.toBuilder (JsName.fromKernel home name) <> builder

360+

361+ K.ElmField name ->

362+ JsName.toBuilder (Expr.generateField mode name) <> builder

363+

364+ K.JsField int ->

365+ JsName.toBuilder (JsName.fromInt int) <> builder

366+

367+ K.JsEnum int ->

368+ B.intDec int <> builder

369+

370+ K.Debug ->

371+ case mode of

372+ Mode.Dev _ ->

373+ builder

374+

375+ Mode.Prod _ ->

376+ "_UNUSED" <> builder

377+

378+ K.Prod ->

379+ case mode of

380+ Mode.Dev _ ->

381+ "_UNUSED" <> builder

382+

383+ Mode.Prod _ ->

384+ builder

385+

386+

387+

388+-- GENERATE ENUM

389+

390+

391+generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt

392+generateEnum mode global@(Opt.Global home name) index =

393+ JS.Var (JsName.fromGlobal home name) $

394+ case mode of

395+ Mode.Dev _ ->

396+ Expr.codeToExpr (Expr.generateCtor mode global index 0)

397+

398+ Mode.Prod _ ->

399+ JS.Int (Index.toMachine index)

400+

401+

402+

403+-- GENERATE BOX

404+

405+

406+generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt

407+generateBox mode global@(Opt.Global home name) =

408+ JS.Var (JsName.fromGlobal home name) $

409+ case mode of

410+ Mode.Dev _ ->

411+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

412+

413+ Mode.Prod _ ->

414+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

415+

416+

417+{-# NOINLINE identity #-}

418+identity :: Opt.Global

419+identity =

420+ Opt.Global ModuleName.basics Name.identity

421+

422+

423+

424+-- GENERATE PORTS

425+

426+

427+generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt

428+generatePort mode (Opt.Global home name) makePort converter =

429+ JS.Var (JsName.fromGlobal home name) $

430+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))

431+ [ JS.String (Name.toBuilder name)

432+ , Expr.codeToExpr (Expr.generate mode converter)

433+ ]

434+

435+

436+

437+-- GENERATE MANAGER

438+

439+

440+generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State

441+generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =

442+ let

443+ managerLVar =

444+ JS.LBracket

445+ (JS.Ref (JsName.fromKernel Name.platform "effectManagers"))

446+ (JS.String (Name.toBuilder moduleName))

447+

448+ (deps, args, stmts) =

449+ generateManagerHelp home effectsType

450+

451+ createManager =

452+ JS.ExprStmt $ JS.Assign managerLVar $

453+ JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args

454+ in

455+ addStmt (List.foldl' (addGlobal mode graph) state deps) $

456+ JS.Block (createManager : stmts)

457+

458+

459+generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt

460+generateLeaf home@(ModuleName.Canonical _ moduleName) name =

461+ JS.Var (JsName.fromGlobal home name) $

462+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

463+

464+

465+

466+{-# NOINLINE leaf #-}

467+leaf :: JS.Expr

468+leaf =

469+ JS.Ref (JsName.fromKernel Name.platform "leaf")

470+

471+

472+generateManagerHelp :: ModuleName.Canonical -> Opt.EffectsType -> ([Opt.Global], [JS.Expr], [JS.Stmt])

473+generateManagerHelp home effectsType =

474+ let

475+ dep name = Opt.Global home name

476+ ref name = JS.Ref (JsName.fromGlobal home name)

477+ in

478+ case effectsType of

479+ Opt.Cmd ->

480+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap" ]

481+ , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap" ]

482+ , [ generateLeaf home "command" ]

483+ )

484+

485+ Opt.Sub ->

486+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "subMap" ]

487+ , [ ref "init", ref "onEffects", ref "onSelfMsg", JS.Int 0, ref "subMap" ]

488+ , [ generateLeaf home "subscription" ]

489+ )

490+

491+ Opt.Fx ->

492+ ( [ dep "init", dep "onEffects", dep "onSelfMsg", dep "cmdMap", dep "subMap" ]

493+ , [ ref "init", ref "onEffects", ref "onSelfMsg", ref "cmdMap", ref "subMap" ]

494+ , [ generateLeaf home "command"

495+ , generateLeaf home "subscription"

496+ ]

497+ )

498+

499+

500+

501+-- MAIN EXPORTS

502+

503+

504+toMainExports :: Mode.Mode -> Mains -> B.Builder

505+toMainExports mode mains =

506+ let

507+ export = JsName.fromKernel Name.platform "export"

508+ exports = generateExports mode (Map.foldrWithKey addToTrie emptyTrie mains)

509+ in

510+ JsName.toBuilder export <> "(" <> exports <> ");"

511+

512+

513+generateExports :: Mode.Mode -> Trie -> B.Builder

514+generateExports mode (Trie maybeMain subs) =

515+ let

516+ starter end =

517+ case maybeMain of

518+ Nothing ->

519+ "{"

520+

521+ Just (home, main) ->

522+ "{'init':"

523+ <> JS.exprToBuilder (Expr.generateMain mode home main)

524+ <> end

525+ in

526+ case Map.toList subs of

527+ [] ->

528+ starter "" <> "}"

529+

530+ (name, subTrie) : otherSubTries ->

531+ starter "," <>

532+ "'" <> Utf8.toBuilder name <> "':"

533+ <> generateExports mode subTrie

534+ <> List.foldl' (addSubTrie mode) "}" otherSubTries

535+

536+

537+addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder

538+addSubTrie mode end (name, trie) =

539+ ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end

540+

541+

542+

543+-- BUILD TRIES

544+

545+

546+data Trie =

547+ Trie

548+ { _main :: Maybe (ModuleName.Canonical, Opt.Main)

549+ , _subs :: Map.Map Name.Name Trie

550+ }

551+

552+

553+emptyTrie :: Trie

554+emptyTrie =

555+ Trie Nothing Map.empty

556+

557+

558+addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie

559+addToTrie home@(ModuleName.Canonical _ moduleName) main trie =

560+ merge trie $ segmentsToTrie home (Name.splitDots moduleName) main

561+

562+

563+segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie

564+segmentsToTrie home segments main =

565+ case segments of

566+ [] ->

567+ Trie (Just (home, main)) Map.empty

568+

569+ segment : otherSegments ->

570+ Trie Nothing (Map.singleton segment (segmentsToTrie home otherSegments main))

571+

572+

573+merge :: Trie -> Trie -> Trie

574+merge (Trie main1 subs1) (Trie main2 subs2) =

575+ Trie

576+ (checkedMerge main1 main2)

577+ (Map.unionWith merge subs1 subs2)

578+

579+

580+checkedMerge :: Maybe a -> Maybe a -> Maybe a

581+checkedMerge a b =

582+ case (a, b) of

583+ (Nothing, main) ->

584+ main

585+

586+ (main, Nothing) ->

587+ main

588+

589+ (Just _, Just _) ->

590+ error "cannot have two modules with the same name"

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

@@ -0,0 +1,530 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Generate.JavaScript.Builder

4+ ( stmtToBuilder

5+ , exprToBuilder

6+ , Expr(..), LValue(..)

7+ , Stmt(..), Case(..)

8+ , InfixOp(..), PrefixOp(..)

9+ )

10+ where

11+

12+-- Based on the language-ecmascript package.

13+-- https://hackage.haskell.org/package/language-ecmascript

14+-- They did the hard work of reading the spec to figure out

15+-- how all the types should fit together.

16+

17+import Prelude hiding (lines)

18+import qualified Data.List as List

19+import qualified Data.ByteString as BS

20+import Data.ByteString.Builder as B

21+import Data.Monoid ((<>))

22+import qualified Generate.JavaScript.Name as Name

23+import Generate.JavaScript.Name (Name)

24+import qualified Json.Encode as Json

25+

26+

27+

28+-- EXPRESSIONS

29+

30+

31+-- NOTE: I tried making this create a B.Builder directly.

32+--

33+-- The hope was that it'd allocate less and speed things up, but it seemed

34+-- to be neutral for perf.

35+--

36+-- The downside is that Generate.JavaScript.Expression inspects the

37+-- structure of Expr and Stmt on some occassions to try to strip out

38+-- unnecessary closures. I think these closures are already avoided

39+-- by other logic in code gen these days, but I am not 100% certain.

40+--

41+-- For this to be worth it, I think it would be necessary to avoid

42+-- returning tuples when generating expressions.

43+--

44+data Expr

45+ = String Builder

46+ | Float Builder

47+ | Int Int

48+ | Bool Bool

49+ | Null

50+ | Json Json.Value

51+ | Array [Expr]

52+ | Object [(Name, Expr)]

53+ | Ref Name

54+ | Access Expr Name -- foo.bar

55+ | Index Expr Expr -- foo[bar]

56+ | Prefix PrefixOp Expr

57+ | Infix InfixOp Expr Expr

58+ | If Expr Expr Expr

59+ | Assign LValue Expr

60+ | Call Expr [Expr]

61+ | Function (Maybe Name) [Name] [Stmt]

62+

63+

64+data LValue

65+ = LRef Name

66+ | LDot Expr Name

67+ | LBracket Expr Expr

68+

69+

70+

71+-- STATEMENTS

72+

73+

74+data Stmt

75+ = Block [Stmt]

76+ | EmptyStmt

77+ | ExprStmt Expr

78+ | IfStmt Expr Stmt Stmt

79+ | Switch Expr [Case]

80+ | While Expr Stmt

81+ | Break (Maybe Name)

82+ | Continue (Maybe Name)

83+ | Labelled Name Stmt

84+ | Try Stmt Name Stmt

85+ | Throw Expr

86+ | Return Expr

87+ | Var Name Expr

88+ | Vars [(Name, Expr)]

89+ | FunctionStmt Name [Name] [Stmt]

90+

91+

92+data Case

93+ = Case Expr [Stmt]

94+ | Default [Stmt]

95+

96+

97+

98+-- OPERATORS

99+

100+

101+data InfixOp

102+ = OpAdd -- +

103+ | OpSub -- -

104+ | OpMul -- *

105+ | OpDiv -- /

106+ | OpMod -- %

107+ | OpEq -- ===

108+ | OpNe -- !==

109+ | OpLt -- <

110+ | OpLe -- <=

111+ | OpGt -- >

112+ | OpGe -- >=

113+ | OpAnd -- &&

114+ | OpOr -- ||

115+ | OpBitwiseAnd -- &

116+ | OpBitwiseXor -- ^

117+ | OpBitwiseOr -- |

118+ | OpLShift -- <<

119+ | OpSpRShift -- >>

120+ | OpZfRShift -- >>>

121+

122+

123+data PrefixOp

124+ = PrefixNot -- !

125+ | PrefixNegate -- -

126+ | PrefixComplement -- ~

127+

128+

129+

130+-- ENCODE

131+

132+

133+stmtToBuilder :: Stmt -> Builder

134+stmtToBuilder stmts =

135+ fromStmt levelZero stmts

136+

137+

138+exprToBuilder :: Expr -> Builder

139+exprToBuilder expr =

140+ snd $ fromExpr levelZero Whatever expr

141+

142+

143+

144+-- INDENT LEVEL

145+

146+

147+data Level =

148+ Level Builder Level

149+

150+

151+levelZero :: Level

152+levelZero =

153+ Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))

154+

155+

156+makeLevel :: Int -> BS.ByteString -> Level

157+makeLevel level oldTabs =

158+ let

159+ tabs =

160+ if level <= BS.length oldTabs

161+ then oldTabs

162+ else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}

163+ in

164+ Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)

165+

166+

167+

168+-- HELPERS

169+

170+

171+commaSep :: [Builder] -> Builder

172+commaSep builders =

173+ mconcat (List.intersperse ", " builders)

174+

175+

176+commaNewlineSep :: Level -> [Builder] -> Builder

177+commaNewlineSep (Level _ (Level deeperIndent _)) builders =

178+ mconcat (List.intersperse (",\n" <> deeperIndent) builders)

179+

180+

181+

182+-- STATEMENTS

183+

184+

185+fromStmtBlock :: Level -> [Stmt] -> Builder

186+fromStmtBlock level stmts =

187+ mconcat (map (fromStmt level) stmts)

188+

189+

190+fromStmt :: Level -> Stmt -> Builder

191+fromStmt level@(Level indent nextLevel) statement =

192+ case statement of

193+ Block stmts ->

194+ fromStmtBlock level stmts

195+

196+ EmptyStmt ->

197+ mempty

198+

199+ ExprStmt expr ->

200+ indent <> snd (fromExpr level Whatever expr) <> ";\n"

201+

202+ IfStmt condition thenStmt elseStmt ->

203+ mconcat

204+ [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"

205+ , fromStmt nextLevel thenStmt

206+ , indent, "} else {\n"

207+ , fromStmt nextLevel elseStmt

208+ , indent, "}\n"

209+ ]

210+

211+ Switch expr clauses ->

212+ mconcat

213+ [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"

214+ , mconcat (map (fromClause nextLevel) clauses)

215+ , indent, "}\n"

216+ ]

217+

218+ While expr stmt ->

219+ mconcat

220+ [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"

221+ , fromStmt nextLevel stmt

222+ , indent, "}\n"

223+ ]

224+

225+ Break Nothing ->

226+ indent <> "break;\n"

227+

228+ Break (Just label) ->

229+ indent <> "break " <> Name.toBuilder label <> ";\n"

230+

231+ Continue Nothing ->

232+ indent <> "continue;\n"

233+

234+ Continue (Just label) ->

235+ indent <> "continue " <> Name.toBuilder label <> ";\n"

236+

237+ Labelled label stmt ->

238+ mconcat

239+ [ indent, Name.toBuilder label, ":\n"

240+ , fromStmt level stmt

241+ ]

242+

243+ Try tryStmt errorName catchStmt ->

244+ mconcat

245+ [ indent, "try {\n"

246+ , fromStmt nextLevel tryStmt

247+ , indent, "} catch (", Name.toBuilder errorName, ") {\n"

248+ , fromStmt nextLevel catchStmt

249+ , indent, "}\n"

250+ ]

251+

252+ Throw expr ->

253+ indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"

254+

255+ Return expr ->

256+ indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"

257+

258+ Var name expr ->

259+ indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"

260+

261+ Vars [] ->

262+ mempty

263+

264+ Vars vars ->

265+ indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"

266+

267+ FunctionStmt name args stmts ->

268+ indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

269+ <>

270+ fromStmtBlock nextLevel stmts

271+ <>

272+ indent <> "}\n"

273+

274+

275+

276+-- SWITCH CLAUSES

277+

278+

279+fromClause :: Level -> Case -> Builder

280+fromClause level@(Level indent nextLevel) clause =

281+ case clause of

282+ Case expr stmts ->

283+ indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"

284+ <> fromStmtBlock nextLevel stmts

285+

286+ Default stmts ->

287+ indent <> "default:\n"

288+ <> fromStmtBlock nextLevel stmts

289+

290+

291+

292+-- VAR DECLS

293+

294+

295+varToBuilder :: Level -> (Name, Expr) -> Builder

296+varToBuilder level (name, expr) =

297+ Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)

298+

299+

300+

301+-- EXPRESSIONS

302+

303+

304+data Lines = One | Many deriving (Eq)

305+

306+

307+merge :: Lines -> Lines -> Lines

308+merge a b =

309+ if a == Many || b == Many then Many else One

310+

311+

312+linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])

313+linesMap func xs =

314+ let

315+ pairs = map func xs

316+ in

317+ ( any ((==) Many . fst) pairs

318+ , map snd pairs

319+ )

320+

321+

322+data Grouping = Atomic | Whatever

323+

324+

325+parensFor :: Grouping -> Builder -> Builder

326+parensFor grouping builder =

327+ case grouping of

328+ Atomic ->

329+ "(" <> builder <> ")"

330+

331+ Whatever ->

332+ builder

333+

334+

335+fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)

336+fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =

337+ case expression of

338+ String string ->

339+ ( One, "'" <> string <> "'" )

340+

341+ Float float ->

342+ ( One, float )

343+

344+ Int n ->

345+ ( One, B.intDec n )

346+

347+ Bool bool ->

348+ ( One, if bool then "true" else "false" )

349+

350+ Null ->

351+ ( One, "null" )

352+

353+ Json json ->

354+ ( One, Json.encodeUgly json )

355+

356+ Array exprs ->

357+ (,) Many $

358+ let

359+ (anyMany, builders) = linesMap (fromExpr level Whatever) exprs

360+ in

361+ if anyMany then

362+ "[\n"

363+ <> deeperIndent

364+ <> commaNewlineSep level builders

365+ <> "\n" <> indent <> "]"

366+ else

367+ "[" <> commaSep builders <> "]"

368+

369+ Object fields ->

370+ (,) Many $

371+ let

372+ (anyMany, builders) = linesMap (fromField nextLevel) fields

373+ in

374+ if anyMany then

375+ "{\n"

376+ <> deeperIndent

377+ <> commaNewlineSep level builders

378+ <> "\n" <> indent <> "}"

379+ else

380+ "{" <> commaSep builders <> "}"

381+

382+ Ref name ->

383+ ( One, Name.toBuilder name )

384+

385+ Access expr field ->

386+ makeDot level expr field

387+

388+ Index expr bracketedExpr ->

389+ makeBracketed level expr bracketedExpr

390+

391+ Prefix op expr ->

392+ let

393+ (lines, builder) = fromExpr level Atomic expr

394+ in

395+ ( lines

396+ , parensFor grouping (fromPrefix op <> builder)

397+ )

398+

399+ Infix op leftExpr rightExpr ->

400+ let

401+ (leftLines , left ) = fromExpr level Atomic leftExpr

402+ (rightLines, right) = fromExpr level Atomic rightExpr

403+ in

404+ ( merge leftLines rightLines

405+ , parensFor grouping (left <> fromInfix op <> right)

406+ )

407+

408+ If condExpr thenExpr elseExpr ->

409+ let

410+ condB = snd (fromExpr level Atomic condExpr)

411+ thenB = snd (fromExpr level Atomic thenExpr)

412+ elseB = snd (fromExpr level Atomic elseExpr)

413+ in

414+ ( Many

415+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

416+ )

417+

418+ Assign lValue expr ->

419+ let

420+ (leftLines , left ) = fromLValue level lValue

421+ (rightLines, right) = fromExpr level Whatever expr

422+ in

423+ ( merge leftLines rightLines

424+ , parensFor grouping (left <> " = " <> right)

425+ )

426+

427+ Call function args ->

428+ (,) Many $

429+ let

430+ (_ , funcB) = fromExpr level Atomic function

431+ (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args

432+ in

433+ if anyMany then

434+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"

435+ else

436+ funcB <> "(" <> commaSep argsB <> ")"

437+

438+ Function maybeName args stmts ->

439+ (,) Many $

440+ "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

441+ <>

442+ fromStmtBlock nextLevel stmts

443+ <>

444+ indent <> "}"

445+

446+

447+

448+-- FIELDS

449+

450+

451+fromField :: Level -> (Name, Expr) -> (Lines, Builder)

452+fromField level (field, expr) =

453+ let

454+ (lines, builder) = fromExpr level Whatever expr

455+ in

456+ ( lines

457+ , Name.toBuilder field <> ": " <> builder

458+ )

459+

460+

461+

462+-- VALUES

463+

464+

465+fromLValue :: Level -> LValue -> (Lines, Builder)

466+fromLValue level lValue =

467+ case lValue of

468+ LRef name ->

469+ (One, Name.toBuilder name)

470+

471+ LDot expr field ->

472+ makeDot level expr field

473+

474+ LBracket expr bracketedExpr ->

475+ makeBracketed level expr bracketedExpr

476+

477+

478+makeDot :: Level -> Expr -> Name -> (Lines, Builder)

479+makeDot level expr field =

480+ let

481+ (lines, builder) = fromExpr level Atomic expr

482+ in

483+ (lines, builder <> "." <> Name.toBuilder field)

484+

485+

486+makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)

487+makeBracketed level expr bracketedExpr =

488+ let

489+ (lines , builder ) = fromExpr level Atomic expr

490+ (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr

491+ in

492+ ( merge lines bracketedLines

493+ , builder <> "[" <> bracketedBuilder <> "]"

494+ )

495+

496+

497+

498+-- OPERATORS

499+

500+

501+fromPrefix :: PrefixOp -> Builder

502+fromPrefix op =

503+ case op of

504+ PrefixNot -> "!"

505+ PrefixNegate -> "-"

506+ PrefixComplement -> "~"

507+

508+

509+fromInfix :: InfixOp -> Builder

510+fromInfix op =

511+ case op of

512+ OpAdd -> " + "

513+ OpSub -> " - "

514+ OpMul -> " * "

515+ OpDiv -> " / "

516+ OpMod -> " % "

517+ OpEq -> " === "

518+ OpNe -> " !== "

519+ OpLt -> " < "

520+ OpLe -> " <= "

521+ OpGt -> " > "

522+ OpGe -> " >= "

523+ OpAnd -> " && "

524+ OpOr -> " || "

525+ OpBitwiseAnd -> " & "

526+ OpBitwiseXor -> " ^ "

527+ OpBitwiseOr -> " | "

528+ OpLShift -> " << "

529+ OpSpRShift -> " >> "

530+ OpZfRShift -> " >>> "

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

@@ -2,6 +2,7 @@

22module Generate.JavaScript.Expression

33 ( generate

44 , generateCtor

5+ , generateField

56 , generateTailDef

67 , generateMain

78 , Code

@@ -13,43 +14,40 @@ module Generate.JavaScript.Expression

1314

1415import qualified Data.IntMap as IntMap

1516import qualified Data.List as List

17+import Data.Map ((!))

1618import qualified Data.Map as Map

17−import qualified Data.Text.Encoding as Text

19+import qualified Data.Name as Name

20+import qualified Data.Set as Set

21+import qualified Data.Utf8 as Utf8

1822

1923import qualified AST.Canonical as Can

2024import qualified AST.Optimized as Opt

21−import qualified AST.Module.Name as ModuleName

25+import qualified AST.Utils.Shader as Shader

2226import qualified Data.Index as Index

2327import qualified Elm.Compiler.Type as Type

2428import qualified Elm.Compiler.Type.Extract as Extract

25−import qualified Elm.Interface as I

26−import qualified Elm.Name as N

29+import qualified Elm.Version as V

30+import qualified Elm.ModuleName as ModuleName

2731import qualified Elm.Package as Pkg

28−import qualified Elm.Compiler.Version as Version

2932import qualified Generate.JavaScript.Builder as JS

30−import qualified Generate.JavaScript.Name as Name

33+import qualified Generate.JavaScript.Name as JsName

34+import qualified Generate.Mode as Mode

3135import qualified Json.Encode as Encode

36+import Json.Encode ((==>))

3237import qualified Optimize.DecisionTree as DT

33−import qualified Reporting.Region as R

34−

35−

36−

37−-- ENVIRONMENT

38−

39−

40−type Mode = Name.Mode

38+import qualified Reporting.Annotation as A

4139

4240

4341

4442-- EXPRESSIONS

4543

4644

47−generateJsExpr :: Mode -> Opt.Expr -> JS.Expr

45+generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr

4846generateJsExpr mode expression =

4947 codeToExpr (generate mode expression)

5048

5149

52−generate :: Mode -> Opt.Expr -> Code

50+generate :: Mode.Mode -> Opt.Expr -> Code

5351generate mode expression =

5452 case expression of

5553 Opt.Bool bool ->

@@ -58,64 +56,64 @@ generate mode expression =

5856 Opt.Chr char ->

5957 JsExpr $

6058 case mode of

61− Name.Debug _ ->

62− JS.Call toChar [ JS.String (Text.encodeUtf8Builder char) ]

59+ Mode.Dev _ ->

60+ JS.Call toChar [ JS.String (Utf8.toBuilder char) ]

6361

64− Name.Prod _ _ ->

65− JS.String (Text.encodeUtf8Builder char)

62+ Mode.Prod _ ->

63+ JS.String (Utf8.toBuilder char)

6664

6765 Opt.Str string ->

68− JsExpr $ JS.String (Text.encodeUtf8Builder string)

66+ JsExpr $ JS.String (Utf8.toBuilder string)

6967

7068 Opt.Int int ->

7169 JsExpr $ JS.Int int

7270

7371 Opt.Float float ->

74− JsExpr $ JS.Float float

72+ JsExpr $ JS.Float (Utf8.toBuilder float)

7573

7674 Opt.VarLocal name ->

77− JsExpr $ JS.Ref (Name.fromLocal name)

75+ JsExpr $ JS.Ref (JsName.fromLocal name)

7876

7977 Opt.VarGlobal (Opt.Global home name) ->

80− JsExpr $ JS.Ref (Name.fromGlobal home name)

78+ JsExpr $ JS.Ref (JsName.fromGlobal home name)

8179

8280 Opt.VarEnum (Opt.Global home name) index ->

8381 case mode of

84− Name.Debug _ ->

85− JsExpr $ JS.Ref (Name.fromGlobal home name)

82+ Mode.Dev _ ->

83+ JsExpr $ JS.Ref (JsName.fromGlobal home name)

8684

87− Name.Prod _ _ ->

85+ Mode.Prod _ ->

8886 JsExpr $ JS.Int (Index.toMachine index)

8987

9088 Opt.VarBox (Opt.Global home name) ->

9189 JsExpr $ JS.Ref $

9290 case mode of

93− Name.Debug _ -> Name.fromGlobal home name

94− Name.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity

91+ Mode.Dev _ -> JsName.fromGlobal home name

92+ Mode.Prod _ -> JsName.fromGlobal ModuleName.basics Name.identity

9593

9694 Opt.VarCycle home name ->

97− JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []

95+ JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) []

9896

9997 Opt.VarDebug name home region unhandledValueName ->

10098 JsExpr $ generateDebug name home region unhandledValueName

10199

102100 Opt.VarKernel home name ->

103− JsExpr $ JS.Ref (Name.fromKernel home name)

101+ JsExpr $ JS.Ref (JsName.fromKernel home name)

104102

105103 Opt.List entries ->

106104 case entries of

107105 [] ->

108− JsExpr $ JS.Ref (Name.fromKernel N.list "Nil")

106+ JsExpr $ JS.Ref (JsName.fromKernel Name.list "Nil")

109107

110108 _ ->

111109 JsExpr $

112110 JS.Call

113− (JS.Ref (Name.fromKernel N.list "fromArray"))

111+ (JS.Ref (JsName.fromKernel Name.list "fromArray"))

114112 [ JS.Array $ map (generateJsExpr mode) entries

115113 ]

116114

117115 Opt.Function args body ->

118− generateFunction (map Name.fromLocal args) (generate mode body)

116+ generateFunction (map JsName.fromLocal args) (generate mode body)

119117

120118 Opt.Call func args ->

121119 JsExpr $ generateCall mode func args

@@ -132,8 +130,7 @@ generate mode expression =

132130

133131 Opt.Destruct (Opt.Destructor name path) body ->

134132 let

135− pathExpr = generatePath mode path

136− pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]

133+ pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)

137134 in

138135 JsBlock $ pathDef : codeToStmtList (generate mode body)

139136

@@ -141,17 +138,17 @@ generate mode expression =

141138 JsBlock $ generateCase mode label root decider jumps

142139

143140 Opt.Accessor field ->

144− JsExpr $ JS.Function Nothing [Name.dollar]

145− [ JS.Return $ Just $

146− JS.Access (JS.Ref Name.dollar) (Name.fromField mode field)

141+ JsExpr $ JS.Function Nothing [JsName.dollar]

142+ [ JS.Return $

143+ JS.Access (JS.Ref JsName.dollar) (generateField mode field)

147144 ]

148145

149146 Opt.Access record field ->

150− JsExpr $ JS.Access (generateJsExpr mode record) (Name.fromField mode field)

147+ JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field)

151148

152149 Opt.Update record fields ->

153150 JsExpr $

154− JS.Call (JS.Ref (Name.fromKernel N.utils "update"))

151+ JS.Call (JS.Ref (JsName.fromKernel Name.utils "update"))

155152 [ generateJsExpr mode record

156153 , generateRecord mode fields

157154 ]

@@ -161,31 +158,43 @@ generate mode expression =

161158

162159 Opt.Unit ->

163160 case mode of

164− Name.Debug _ ->

165− JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")

161+ Mode.Dev _ ->

162+ JsExpr $ JS.Ref (JsName.fromKernel Name.utils "Tuple0")

166163

167− Name.Prod _ _ ->

164+ Mode.Prod _ ->

168165 JsExpr $ JS.Int 0

169166

170167 Opt.Tuple a b maybeC ->

171168 JsExpr $

172169 case maybeC of

173170 Nothing ->

174− JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple2"))

171+ JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple2"))

175172 [ generateJsExpr mode a

176173 , generateJsExpr mode b

177174 ]

178175

179176 Just c ->

180− JS.Call (JS.Ref (Name.fromKernel N.utils "Tuple3"))

177+ JS.Call (JS.Ref (JsName.fromKernel Name.utils "Tuple3"))

181178 [ generateJsExpr mode a

182179 , generateJsExpr mode b

183180 , generateJsExpr mode c

184181 ]

185182

186− Opt.Shader src ->

187− let string = JS.String (Text.encodeUtf8Builder src) in

188− JsExpr $ JS.Object [ ( Name.fromLocal "src", string ) ]

183+ Opt.Shader src attributes uniforms ->

184+ let

185+ toTranlation field =

186+ ( JsName.fromLocal field

187+ , JS.String (JsName.toBuilder (generateField mode field))

188+ )

189+

190+ toTranslationObject fields =

191+ JS.Object (map toTranlation (Set.toList fields))

192+ in

193+ JsExpr $ JS.Object $

194+ [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )

195+ , ( JsName.fromLocal "attributes", toTranslationObject attributes )

196+ , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )

197+ ]

189198

190199

191200

@@ -203,7 +212,7 @@ codeToExpr code =

203212 JsExpr expr ->

204213 expr

205214

206− JsBlock [ JS.Return (Just expr) ] ->

215+ JsBlock [ JS.Return expr ] ->

207216 expr

208217

209218 JsBlock stmts ->

@@ -217,7 +226,7 @@ codeToStmtList code =

217226 stmts

218227

219228 JsExpr expr ->

220− [ JS.Return (Just expr) ]

229+ [ JS.Return expr ]

221230

222231 JsBlock stmts ->

223232 stmts

@@ -230,7 +239,7 @@ codeToStmt code =

230239 JS.Block stmts

231240

232241 JsExpr expr ->

233− JS.Return (Just expr)

242+ JS.Return expr

234243

235244 JsBlock [stmt] ->

236245 stmt

@@ -246,78 +255,97 @@ codeToStmt code =

246255{-# NOINLINE toChar #-}

247256toChar :: JS.Expr

248257toChar =

249− JS.Ref (Name.fromKernel N.utils "chr")

258+ JS.Ref (JsName.fromKernel Name.utils "chr")

250259

251260

252261

253262-- CTOR

254263

255264

256−generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code

257−generateCtor mode name index arity =

265+generateCtor :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> Int -> Code

266+generateCtor mode (Opt.Global home name) index arity =

258267 let

259268 argNames =

260− Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]

269+ Index.indexedMap (\i _ -> JsName.fromIndex i) [1 .. arity]

261270

262271 ctorTag =

263272 case mode of

264− Name.Debug _ -> JS.String (N.toBuilder name)

265− Name.Prod _ _ -> JS.Int (Index.toMachine index)

273+ Mode.Dev _ -> JS.String (Name.toBuilder name)

274+ Mode.Prod _ -> JS.Int (ctorToInt home name index)

266275 in

267276 generateFunction argNames $ JsExpr $ JS.Object $

268− (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames

277+ (JsName.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames

278+

279+

280+ctorToInt :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Int

281+ctorToInt home name index =

282+ if home == ModuleName.dict && name == "RBNode_elm_builtin" || name == "RBEmpty_elm_builtin" then

283+ 0 - Index.toHuman index

284+ else

285+ Index.toMachine index

269286

270287

271288

272289-- RECORDS

273290

274291

275−generateRecord :: Mode -> Map.Map N.Name Opt.Expr -> JS.Expr

292+generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr

276293generateRecord mode fields =

277294 let

278295 toPair (field, value) =

279− (Name.fromField mode field, generateJsExpr mode value)

296+ (generateField mode field, generateJsExpr mode value)

280297 in

281298 JS.Object (map toPair (Map.toList fields))

282299

283300

301+generateField :: Mode.Mode -> Name.Name -> JsName.Name

302+generateField mode name =

303+ case mode of

304+ Mode.Dev _ ->

305+ JsName.fromLocal name

306+

307+ Mode.Prod fields ->

308+ fields ! name

309+

310+

311+

284312

285313-- DEBUG

286314

287315

288−generateDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Maybe N.Name -> JS.Expr

316+generateDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Maybe Name.Name -> JS.Expr

289317generateDebug name (ModuleName.Canonical _ home) region unhandledValueName =

290− if name /= "crash" then

291− JS.Ref (Name.fromGlobal ModuleName.debug name)

318+ if name /= "todo" then

319+ JS.Ref (JsName.fromGlobal ModuleName.debug name)

292320 else

293321 case unhandledValueName of

294322 Nothing ->

295− JS.Call (JS.Ref (Name.fromKernel N.utils "crash")) $

296− [ JS.String (N.toBuilder home)

323+ JS.Call (JS.Ref (JsName.fromKernel Name.debug "todo")) $

324+ [ JS.String (Name.toBuilder home)

297325 , regionToJsExpr region

298326 ]

299327

300328 Just valueName ->

301− JS.Call (JS.Ref (Name.fromKernel N.utils "crashCase")) $

302− [ JS.String (N.toBuilder home)

329+ JS.Call (JS.Ref (JsName.fromKernel Name.debug "todoCase")) $

330+ [ JS.String (Name.toBuilder home)

303331 , regionToJsExpr region

304− , JS.Ref (Name.fromLocal valueName)

332+ , JS.Ref (JsName.fromLocal valueName)

305333 ]

306334

307335

308−regionToJsExpr :: R.Region -> JS.Expr

309−regionToJsExpr (R.Region start end) =

336+regionToJsExpr :: A.Region -> JS.Expr

337+regionToJsExpr (A.Region start end) =

310338 JS.Object

311− [ ( Name.fromLocal "start", positionToJsExpr start )

312− , ( Name.fromLocal "end", positionToJsExpr end )

339+ [ ( JsName.fromLocal "start", positionToJsExpr start )

340+ , ( JsName.fromLocal "end", positionToJsExpr end )

313341 ]

314342

315343

316−positionToJsExpr :: R.Position -> JS.Expr

317−positionToJsExpr (R.Position line column) =

344+positionToJsExpr :: A.Position -> JS.Expr

345+positionToJsExpr (A.Position line column) =

318346 JS.Object

319− [ ( Name.fromLocal "line", JS.Int line )

320− , ( Name.fromLocal "column", JS.Int column )

347+ [ ( JsName.fromLocal "line", JS.Int (fromIntegral line) )

348+ , ( JsName.fromLocal "column", JS.Int (fromIntegral column) )

321349 ]

322350

323351

@@ -325,7 +353,7 @@ positionToJsExpr (R.Position line column) =

325353-- FUNCTION

326354

327355

328−generateFunction :: [Name.Name] -> Code -> Code

356+generateFunction :: [JsName.Name] -> Code -> Code

329357generateFunction args body =

330358 case IntMap.lookup (length args) funcHelpers of

331359 Just helper ->

@@ -348,14 +376,14 @@ generateFunction args body =

348376funcHelpers :: IntMap.IntMap JS.Expr

349377funcHelpers =

350378 IntMap.fromList $

351− map (\n -> (n, JS.Ref (Name.makeF n))) [2..9]

379+ map (\n -> (n, JS.Ref (JsName.makeF n))) [2..9]

352380

353381

354382

355383-- CALLS

356384

357385

358−generateCall :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

386+generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

359387generateCall mode func args =

360388 case func of

361389 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->

@@ -363,10 +391,10 @@ generateCall mode func args =

363391

364392 Opt.VarBox _ ->

365393 case mode of

366− Name.Debug _ ->

394+ Mode.Dev _ ->

367395 generateCallHelp mode func args

368396

369− Name.Prod _ _ ->

397+ Mode.Prod _ ->

370398 case args of

371399 [arg] ->

372400 generateJsExpr mode arg

@@ -378,16 +406,16 @@ generateCall mode func args =

378406 generateCallHelp mode func args

379407

380408

381−generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

409+generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

382410generateCallHelp mode func args =

383411 generateNormalCall

384412 (generateJsExpr mode func)

385413 (map (generateJsExpr mode) args)

386414

387415

388−generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

416+generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr

389417generateGlobalCall home name args =

390− generateNormalCall (JS.Ref (Name.fromGlobal home name)) args

418+ generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args

391419

392420

393421generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr

@@ -404,45 +432,45 @@ generateNormalCall func args =

404432callHelpers :: IntMap.IntMap JS.Expr

405433callHelpers =

406434 IntMap.fromList $

407− map (\n -> (n, JS.Ref (Name.makeA n))) [2..9]

435+ map (\n -> (n, JS.Ref (JsName.makeA n))) [2..9]

408436

409437

410438

411439-- CORE CALLS

412440

413441

414−generateCoreCall :: Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr

442+generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr

415443generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args =

416− if moduleName == N.basics then

444+ if moduleName == Name.basics then

417445 generateBasicsCall mode home name args

418446

419− else if moduleName == N.bitwise then

447+ else if moduleName == Name.bitwise then

420448 generateBitwiseCall home name (map (generateJsExpr mode) args)

421449

422− else if moduleName == N.tuple then

450+ else if moduleName == Name.tuple then

423451 generateTupleCall home name (map (generateJsExpr mode) args)

424452

425− else if moduleName == N.jsArray then

453+ else if moduleName == Name.jsArray then

426454 generateJsArrayCall home name (map (generateJsExpr mode) args)

427455

428456 else

429457 generateGlobalCall home name (map (generateJsExpr mode) args)

430458

431459

432−generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

460+generateTupleCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr

433461generateTupleCall home name args =

434462 case args of

435463 [value] ->

436464 case name of

437− "first" -> JS.Access value (Name.fromLocal "a")

438− "second" -> JS.Access value (Name.fromLocal "b")

465+ "first" -> JS.Access value (JsName.fromLocal "a")

466+ "second" -> JS.Access value (JsName.fromLocal "b")

439467 _ -> generateGlobalCall home name args

440468

441469 _ ->

442470 generateGlobalCall home name args

443471

444472

445−generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

473+generateJsArrayCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr

446474generateJsArrayCall home name args =

447475 case args of

448476 [entry] | name == "singleton" -> JS.Array [entry]

@@ -450,44 +478,44 @@ generateJsArrayCall home name args =

450478 _ -> generateGlobalCall home name args

451479

452480

453−generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

481+generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr

454482generateBitwiseCall home name args =

455483 case args of

456484 [arg] ->

457485 case name of

458− "complement" -> JS.Prefix JS.PrefixBNot arg

486+ "complement" -> JS.Prefix JS.PrefixComplement arg

459487 _ -> generateGlobalCall home name args

460488

461489 [left,right] ->

462490 case name of

463− "and" -> JS.Infix JS.OpBAnd left right

464− "or" -> JS.Infix JS.OpBOr left right

465− "xor" -> JS.Infix JS.OpBXor left right

466− "shiftLeftBy" -> JS.Infix JS.OpLShift right left

467− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

468− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

491+ "and" -> JS.Infix JS.OpBitwiseAnd left right

492+ "or" -> JS.Infix JS.OpBitwiseOr left right

493+ "xor" -> JS.Infix JS.OpBitwiseXor left right

494+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left

495+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

496+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

469497 _ -> generateGlobalCall home name args

470498

471499 _ ->

472500 generateGlobalCall home name args

473501

474502

475−generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr

503+generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr

476504generateBasicsCall mode home name args =

477505 case args of

478506 [elmArg] ->

479507 let arg = generateJsExpr mode elmArg in

480508 case name of

481− "not" -> JS.Prefix JS.PrefixLNot arg

482− "negate" -> JS.Prefix JS.PrefixMinus arg

509+ "not" -> JS.Prefix JS.PrefixNot arg

510+ "negate" -> JS.Prefix JS.PrefixNegate arg

483511 "toFloat" -> arg

484− "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)

512+ "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)

485513 _ -> generateGlobalCall home name [arg]

486514

487515 [elmLeft, elmRight] ->

488516 case name of

489− "composeL" -> decomposeL mode elmLeft [elmRight]

490− "composeR" -> decomposeR mode [elmLeft] elmRight

517+ -- NOTE: removed "composeL" and "composeR" because of this issue:

518+ -- https://github.com/elm/compiler/issues/1722

491519 "append" -> append mode elmLeft elmRight

492520 "apL" -> generateJsExpr mode $ apply elmLeft elmRight

493521 "apR" -> generateJsExpr mode $ apply elmRight elmLeft

@@ -501,16 +529,17 @@ generateBasicsCall mode home name args =

501529 "sub" -> JS.Infix JS.OpSub left right

502530 "mul" -> JS.Infix JS.OpMul left right

503531 "fdiv" -> JS.Infix JS.OpDiv left right

504− "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

532+ "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

505533 "eq" -> equal left right

506534 "neq" -> notEqual left right

507− "lt" -> cmp JS.OpLT JS.OpLT 0 left right

508− "gt" -> cmp JS.OpGT JS.OpGT 0 left right

509− "le" -> cmp JS.OpLEq JS.OpLT 1 left right

510− "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right

511− "or" -> JS.Infix JS.OpLOr left right

512− "and" -> JS.Infix JS.OpLAnd left right

513− "xor" -> JS.Infix JS.OpStrictNEq left right

535+ "lt" -> cmp JS.OpLt JS.OpLt 0 left right

536+ "gt" -> cmp JS.OpGt JS.OpGt 0 left right

537+ "le" -> cmp JS.OpLe JS.OpLt 1 left right

538+ "ge" -> cmp JS.OpGe JS.OpGt (-1) left right

539+ "or" -> JS.Infix JS.OpOr left right

540+ "and" -> JS.Infix JS.OpAnd left right

541+ "xor" -> JS.Infix JS.OpNe left right

542+ "remainderBy" -> JS.Infix JS.OpMod right left

514543 _ -> generateGlobalCall home name [left, right]

515544

516545 _ ->

@@ -522,7 +551,7 @@ equal left right =

522551 if isLiteral left || isLiteral right then

523552 strictEq left right

524553 else

525− JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]

554+ JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]

526555

527556

528557notEqual :: JS.Expr -> JS.Expr -> JS.Expr

@@ -530,8 +559,8 @@ notEqual left right =

530559 if isLiteral left || isLiteral right then

531560 strictNEq left right

532561 else

533− JS.Prefix JS.PrefixLNot $

534− JS.Call (JS.Ref (Name.fromKernel N.utils "eq")) [left, right]

562+ JS.Prefix JS.PrefixNot $

563+ JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]

535564

536565

537566cmp :: JS.InfixOp -> JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr

@@ -540,7 +569,7 @@ cmp idealOp backupOp backupInt left right =

540569 JS.Infix idealOp left right

541570 else

542571 JS.Infix backupOp

543− (JS.Call (JS.Ref (Name.fromKernel N.utils "cmp")) [left, right])

572+ (JS.Call (JS.Ref (JsName.fromKernel Name.utils "cmp")) [left, right])

544573 (JS.Int backupInt)

545574

546575

@@ -563,30 +592,6 @@ isLiteral expr =

563592 False

564593

565594

566−decomposeL :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

567−decomposeL mode expr funcs =

568− case expr of

569− Opt.Call (Opt.VarGlobal (Opt.Global home "composeL")) [left, func]

570− | home == ModuleName.basics ->

571− decomposeL mode left (func:funcs)

572−

573− _ ->

574− generateJsExpr mode $

575− Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))

576−

577−

578−decomposeR :: Mode -> [Opt.Expr] -> Opt.Expr -> JS.Expr

579−decomposeR mode funcs expr =

580− case expr of

581− Opt.Call (Opt.VarGlobal (Opt.Global home "composeR")) [func, right]

582− | home == ModuleName.basics ->

583− decomposeR mode (func:funcs) right

584−

585− _ ->

586− generateJsExpr mode $

587− Opt.Function [N.dollar] (foldr apply (Opt.VarLocal N.dollar) (expr:funcs))

588−

589−

590595apply :: Opt.Expr -> Opt.Expr -> Opt.Expr

591596apply func value =

592597 case func of

@@ -600,7 +605,7 @@ apply func value =

600605 Opt.Call func [value]

601606

602607

603−append :: Mode -> Opt.Expr -> Opt.Expr -> JS.Expr

608+append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr

604609append mode left right =

605610 let seqs = generateJsExpr mode left : toSeqs mode right in

606611 if any isStringLiteral seqs then

@@ -611,10 +616,10 @@ append mode left right =

611616

612617jsAppend :: JS.Expr -> JS.Expr -> JS.Expr

613618jsAppend a b =

614− JS.Call (JS.Ref (Name.fromKernel N.utils "ap")) [a, b]

619+ JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b]

615620

616621

617−toSeqs :: Mode -> Opt.Expr -> [JS.Expr]

622+toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr]

618623toSeqs mode expr =

619624 case expr of

620625 Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right]

@@ -643,42 +648,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr

643648strictEq left right =

644649 case left of

645650 JS.Int 0 ->

646− JS.Prefix JS.PrefixLNot right

651+ JS.Prefix JS.PrefixNot right

647652

648653 JS.Bool bool ->

649− if bool then right else JS.Prefix JS.PrefixLNot right

654+ if bool then right else JS.Prefix JS.PrefixNot right

650655

651656 _ ->

652657 case right of

653658 JS.Int 0 ->

654− JS.Prefix JS.PrefixLNot left

659+ JS.Prefix JS.PrefixNot left

655660

656661 JS.Bool bool ->

657− if bool then left else JS.Prefix JS.PrefixLNot left

662+ if bool then left else JS.Prefix JS.PrefixNot left

658663

659664 _ ->

660− JS.Infix JS.OpStrictEq left right

665+ JS.Infix JS.OpEq left right

661666

662667

663668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr

664669strictNEq left right =

665670 case left of

666671 JS.Int 0 ->

667− right

672+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)

668673

669674 JS.Bool bool ->

670− if bool then JS.Prefix JS.PrefixLNot right else right

675+ if bool then JS.Prefix JS.PrefixNot right else right

671676

672677 _ ->

673678 case right of

674679 JS.Int 0 ->

675− left

680+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)

676681

677682 JS.Bool bool ->

678− if bool then JS.Prefix JS.PrefixLNot left else left

683+ if bool then JS.Prefix JS.PrefixNot left else left

679684

680685 _ ->

681− JS.Infix JS.OpStrictNEq left right

686+ JS.Infix JS.OpNe left right

682687

683688

684689

@@ -687,39 +692,39 @@ strictNEq left right =

687692

688693-- TODO check if JS minifiers collapse unnecessary temporary variables

689694--

690−generateTailCall :: Mode -> N.Name -> [(N.Name, Opt.Expr)] -> [JS.Stmt]

695+generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt]

691696generateTailCall mode name args =

692697 let

693698 toTempVars (argName, arg) =

694− ( Name.makeTemp argName, Just (generateJsExpr mode arg) )

699+ ( JsName.makeTemp argName, generateJsExpr mode arg )

695700

696701 toRealVars (argName, _) =

697702 JS.ExprStmt $

698− JS.Assign (JS.LRef (Name.fromLocal argName)) (JS.Ref (Name.makeTemp argName))

703+ JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))

699704 in

700− JS.Var (map toTempVars args)

705+ JS.Vars (map toTempVars args)

701706 : map toRealVars args

702− ++ [ JS.Continue (Just (Name.fromLocal name)) ]

707+ ++ [ JS.Continue (Just (JsName.fromLocal name)) ]

703708

704709

705710

706711-- DEFINITIONS

707712

708713

709−generateDef :: Mode -> Opt.Def -> JS.Stmt

714+generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt

710715generateDef mode def =

711716 case def of

712717 Opt.Def name body ->

713− JS.Var [ (Name.fromLocal name, Just (generateJsExpr mode body)) ]

718+ JS.Var (JsName.fromLocal name) (generateJsExpr mode body)

714719

715720 Opt.TailDef name argNames body ->

716− JS.Var [ (Name.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]

721+ JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))

717722

718723

719−generateTailDef :: Mode -> N.Name -> [N.Name] -> Opt.Expr -> Code

724+generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code

720725generateTailDef mode name argNames body =

721− generateFunction (map Name.fromLocal argNames) $ JsBlock $

722− [ JS.Labelled (Name.fromLocal name) $

726+ generateFunction (map JsName.fromLocal argNames) $ JsBlock $

727+ [ JS.Labelled (JsName.fromLocal name) $

723728 JS.While (JS.Bool True) $

724729 codeToStmt $ generate mode body

725730 ]

@@ -729,24 +734,24 @@ generateTailDef mode name argNames body =

729734-- PATHS

730735

731736

732−generatePath :: Mode -> Opt.Path -> JS.Expr

737+generatePath :: Mode.Mode -> Opt.Path -> JS.Expr

733738generatePath mode path =

734739 case path of

735740 Opt.Index index subPath ->

736− JS.Access (generatePath mode subPath) (Name.fromIndex index)

741+ JS.Access (generatePath mode subPath) (JsName.fromIndex index)

737742

738743 Opt.Root name ->

739− JS.Ref (Name.fromLocal name)

744+ JS.Ref (JsName.fromLocal name)

740745

741746 Opt.Field field subPath ->

742− JS.Access (generatePath mode subPath) (Name.fromField mode field)

747+ JS.Access (generatePath mode subPath) (generateField mode field)

743748

744749 Opt.Unbox subPath ->

745750 case mode of

746− Name.Debug _ ->

747− JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)

751+ Mode.Dev _ ->

752+ JS.Access (generatePath mode subPath) (JsName.fromIndex Index.first)

748753

749− Name.Prod _ _ ->

754+ Mode.Prod _ ->

750755 generatePath mode subPath

751756

752757

@@ -754,7 +759,7 @@ generatePath mode path =

754759-- GENERATE IFS

755760

756761

757−generateIf :: Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code

762+generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code

758763generateIf mode givenBranches givenFinal =

759764 let

760765 (branches, final) =

@@ -819,34 +824,34 @@ crushIfsHelp visitedBranches unvisitedBranches final =

819824-- CASE EXPRESSIONS

820825

821826

822−generateCase :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]

827+generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt]

823828generateCase mode label root decider jumps =

824829 foldr (goto mode label) (generateDecider mode label root decider) jumps

825830

826831

827−goto :: Mode -> N.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]

832+goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt]

828833goto mode label (index, branch) stmts =

829834 let

830835 labeledDeciderStmt =

831836 JS.Labelled

832− (Name.makeLabel label index)

837+ (JsName.makeLabel label index)

833838 (JS.While (JS.Bool True) (JS.Block stmts))

834839 in

835840 labeledDeciderStmt : codeToStmtList (generate mode branch)

836841

837842

838−generateDecider :: Mode -> N.Name -> N.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]

843+generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt]

839844generateDecider mode label root decisionTree =

840845 case decisionTree of

841846 Opt.Leaf (Opt.Inline branch) ->

842847 codeToStmtList (generate mode branch)

843848

844849 Opt.Leaf (Opt.Jump index) ->

845− [ JS.Break (Just (Name.makeLabel label index)) ]

850+ [ JS.Break (Just (JsName.makeLabel label index)) ]

846851

847852 Opt.Chain testChain success failure ->

848853 [ JS.IfStmt

849− (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))

854+ (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))

850855 (JS.Block $ generateDecider mode label root success)

851856 (JS.Block $ generateDecider mode label root failure)

852857 ]

@@ -862,65 +867,84 @@ generateDecider mode label root decisionTree =

862867 ]

863868

864869

865−generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr

870+generateIfTest :: Mode.Mode -> Name.Name -> (DT.Path, DT.Test) -> JS.Expr

866871generateIfTest mode root (path, test) =

867872 let

868873 value = pathToJsExpr mode root path

869874 in

870875 case test of

871− DT.IsCtor name index _ _ ->

872− strictEq (JS.Access value Name.dollar) $

876+ DT.IsCtor home name index _ opts ->

877+ let

878+ tag =

879+ case mode of

880+ Mode.Dev _ -> JS.Access value JsName.dollar

881+ Mode.Prod _ ->

882+ case opts of

883+ Can.Normal -> JS.Access value JsName.dollar

884+ Can.Enum -> value

885+ Can.Unbox -> value

886+ in

887+ strictEq tag $

873888 case mode of

874− Name.Debug _ -> JS.String (N.toBuilder name)

875− Name.Prod _ _ -> JS.Int (Index.toMachine index)

889+ Mode.Dev _ -> JS.String (Name.toBuilder name)

890+ Mode.Prod _ -> JS.Int (ctorToInt home name index)

891+

892+ DT.IsBool True ->

893+ value

894+

895+ DT.IsBool False ->

896+ JS.Prefix JS.PrefixNot value

876897

877898 DT.IsInt int ->

878899 strictEq value (JS.Int int)

879900

880901 DT.IsChr char ->

881− strictEq (JS.String (Text.encodeUtf8Builder char)) $

902+ strictEq (JS.String (Utf8.toBuilder char)) $

882903 case mode of

883− Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []

884− Name.Prod _ _ -> value

904+ Mode.Dev _ -> JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []

905+ Mode.Prod _ -> value

885906

886907 DT.IsStr string ->

887− strictEq value (JS.String (Text.encodeUtf8Builder string))

908+ strictEq value (JS.String (Utf8.toBuilder string))

888909

889910 DT.IsCons ->

890− JS.Access value (Name.fromLocal "b")

911+ JS.Access value (JsName.fromLocal "b")

891912

892913 DT.IsNil ->

893− JS.Prefix JS.PrefixLNot $

894− JS.Access value (Name.fromLocal "b")

914+ JS.Prefix JS.PrefixNot $

915+ JS.Access value (JsName.fromLocal "b")

895916

896917 DT.IsTuple ->

897918 error "COMPILER BUG - there should never be tests on a tuple"

898919

899920

900921

901−generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case

922+generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case

902923generateCaseBranch mode label root (test, subTree) =

903924 JS.Case

904925 (generateCaseValue mode test)

905926 (generateDecider mode label root subTree)

906927

907928

908−generateCaseValue :: Mode -> DT.Test -> JS.Expr

929+generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr

909930generateCaseValue mode test =

910931 case test of

911− DT.IsCtor name index _ _ ->

932+ DT.IsCtor home name index _ _ ->

912933 case mode of

913− Name.Debug _ -> JS.String (N.toBuilder name)

914− Name.Prod _ _ -> JS.Int (Index.toMachine index)

934+ Mode.Dev _ -> JS.String (Name.toBuilder name)

935+ Mode.Prod _ -> JS.Int (ctorToInt home name index)

915936

916937 DT.IsInt int ->

917938 JS.Int int

918939

919940 DT.IsChr char ->

920− JS.String (Text.encodeUtf8Builder char)

941+ JS.String (Utf8.toBuilder char)

921942

922943 DT.IsStr string ->

923− JS.String (Text.encodeUtf8Builder string)

944+ JS.String (Utf8.toBuilder string)

945+

946+ DT.IsBool _ ->

947+ error "COMPILER BUG - there should never be three tests on a boolean"

924948

925949 DT.IsCons ->

926950 error "COMPILER BUG - there should never be three tests on a list"

@@ -932,27 +956,30 @@ generateCaseValue mode test =

932956 error "COMPILER BUG - there should never be three tests on a tuple"

933957

934958

935−generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr

959+generateCaseTest :: Mode.Mode -> Name.Name -> DT.Path -> DT.Test -> JS.Expr

936960generateCaseTest mode root path exampleTest =

937961 let

938962 value = pathToJsExpr mode root path

939963 in

940964 case exampleTest of

941− DT.IsCtor _ _ _ opts ->

942− case mode of

943− Name.Debug _ ->

944− JS.Access value Name.dollar

965+ DT.IsCtor home name _ _ opts ->

966+ if name == Name.bool && home == ModuleName.basics then

967+ value

968+ else

969+ case mode of

970+ Mode.Dev _ ->

971+ JS.Access value JsName.dollar

945972

946− Name.Prod _ _ ->

947− case opts of

948− Can.Normal ->

949− JS.Access value Name.dollar

973+ Mode.Prod _ ->

974+ case opts of

975+ Can.Normal ->

976+ JS.Access value JsName.dollar

950977

951− Can.Enum ->

952− value

978+ Can.Enum ->

979+ value

953980

954− Can.Unbox ->

955− value

981+ Can.Unbox ->

982+ value

956983

957984 DT.IsInt _ ->

958985 value

@@ -962,12 +989,15 @@ generateCaseTest mode root path exampleTest =

962989

963990 DT.IsChr _ ->

964991 case mode of

965− Name.Debug _ ->

966− JS.Call (JS.Access value (Name.fromLocal "valueOf")) []

992+ Mode.Dev _ ->

993+ JS.Call (JS.Access value (JsName.fromLocal "valueOf")) []

967994

968− Name.Prod _ _ ->

995+ Mode.Prod _ ->

969996 value

970997

998+ DT.IsBool _ ->

999+ error "COMPILER BUG - there should never be three tests on a list"

1000+

9711001 DT.IsCons ->

9721002 error "COMPILER BUG - there should never be three tests on a list"

9731003

@@ -982,41 +1012,41 @@ generateCaseTest mode root path exampleTest =

9821012-- PATTERN PATHS

9831013

9841014

985−pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr

1015+pathToJsExpr :: Mode.Mode -> Name.Name -> DT.Path -> JS.Expr

9861016pathToJsExpr mode root path =

9871017 case path of

9881018 DT.Index index subPath ->

989− JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)

1019+ JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex index)

9901020

9911021 DT.Unbox subPath ->

9921022 case mode of

993− Name.Debug _ ->

994− JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)

1023+ Mode.Dev _ ->

1024+ JS.Access (pathToJsExpr mode root subPath) (JsName.fromIndex Index.first)

9951025

996− Name.Prod _ _ ->

1026+ Mode.Prod _ ->

9971027 pathToJsExpr mode root subPath

9981028

9991029 DT.Empty ->

1000− JS.Ref (Name.fromLocal root)

1030+ JS.Ref (JsName.fromLocal root)

10011031

10021032

10031033

10041034-- GENERATE MAIN

10051035

10061036

1007−generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> JS.Expr

1008−generateMain mode interfaces home main =

1037+generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr

1038+generateMain mode home main =

10091039 case main of

10101040 Opt.Static ->

1011− JS.Ref (Name.fromKernel N.browser "staticPage")

1012− # JS.Ref (Name.fromGlobal home "main")

1041+ JS.Ref (JsName.fromKernel Name.virtualDom "init")

1042+ # JS.Ref (JsName.fromGlobal home "main")

10131043 # JS.Int 0

10141044 # JS.Int 0

10151045

10161046 Opt.Dynamic msgType decoder ->

1017− JS.Ref (Name.fromGlobal home "main")

1047+ JS.Ref (JsName.fromGlobal home "main")

10181048 # generateJsExpr mode decoder

1019− # toDebugMetadata mode interfaces msgType

1049+ # toDebugMetadata mode msgType

10201050

10211051

10221052(#) :: JS.Expr -> JS.Expr -> JS.Expr

@@ -1024,14 +1054,17 @@ generateMain mode interfaces home main =

10241054 JS.Call func [arg]

10251055

10261056

1027−toDebugMetadata :: Mode -> I.Interfaces -> Can.Type -> JS.Expr

1028−toDebugMetadata mode interfaces msgType =

1057+toDebugMetadata :: Mode.Mode -> Can.Type -> JS.Expr

1058+toDebugMetadata mode msgType =

10291059 case mode of

1030− Name.Prod _ _ ->

1060+ Mode.Prod _ ->

1061+ JS.Int 0

1062+

1063+ Mode.Dev Nothing ->

10311064 JS.Int 0

10321065

1033− Name.Debug _ ->

1066+ Mode.Dev (Just interfaces) ->

10341067 JS.Json $ Encode.object $

1035− [ ("versions", Encode.object [ ("elm", Pkg.encodeVersion Version.version) ])

1036− , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))

1068+ [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]

1069+ , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)

10371070 ]

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

@@ -0,0 +1,95 @@

1+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}

2+module Generate.JavaScript.Functions

3+ ( functions

4+ )

5+ where

6+

7+

8+import qualified Data.ByteString.Builder as B

9+import Text.RawString.QQ (r)

10+

11+

12+

13+-- FUNCTIONS

14+

15+

16+functions :: B.Builder

17+functions = [r|

18+

19+function F(arity, fun, wrapper) {

20+ wrapper.a = arity;

21+ wrapper.f = fun;

22+ return wrapper;

23+}

24+

25+function F2(fun) {

26+ return F(2, fun, function(a) { return function(b) { return fun(a,b); }; })

27+}

28+function F3(fun) {

29+ return F(3, fun, function(a) {

30+ return function(b) { return function(c) { return fun(a, b, c); }; };

31+ });

32+}

33+function F4(fun) {

34+ return F(4, fun, function(a) { return function(b) { return function(c) {

35+ return function(d) { return fun(a, b, c, d); }; }; };

36+ });

37+}

38+function F5(fun) {

39+ return F(5, fun, function(a) { return function(b) { return function(c) {

40+ return function(d) { return function(e) { return fun(a, b, c, d, e); }; }; }; };

41+ });

42+}

43+function F6(fun) {

44+ return F(6, fun, function(a) { return function(b) { return function(c) {

45+ return function(d) { return function(e) { return function(f) {

46+ return fun(a, b, c, d, e, f); }; }; }; }; };

47+ });

48+}

49+function F7(fun) {

50+ return F(7, fun, function(a) { return function(b) { return function(c) {

51+ return function(d) { return function(e) { return function(f) {

52+ return function(g) { return fun(a, b, c, d, e, f, g); }; }; }; }; }; };

53+ });

54+}

55+function F8(fun) {

56+ return F(8, fun, function(a) { return function(b) { return function(c) {

57+ return function(d) { return function(e) { return function(f) {

58+ return function(g) { return function(h) {

59+ return fun(a, b, c, d, e, f, g, h); }; }; }; }; }; }; };

60+ });

61+}

62+function F9(fun) {

63+ return F(9, fun, function(a) { return function(b) { return function(c) {

64+ return function(d) { return function(e) { return function(f) {

65+ return function(g) { return function(h) { return function(i) {

66+ return fun(a, b, c, d, e, f, g, h, i); }; }; }; }; }; }; }; };

67+ });

68+}

69+

70+function A2(fun, a, b) {

71+ return fun.a === 2 ? fun.f(a, b) : fun(a)(b);

72+}

73+function A3(fun, a, b, c) {

74+ return fun.a === 3 ? fun.f(a, b, c) : fun(a)(b)(c);

75+}

76+function A4(fun, a, b, c, d) {

77+ return fun.a === 4 ? fun.f(a, b, c, d) : fun(a)(b)(c)(d);

78+}

79+function A5(fun, a, b, c, d, e) {

80+ return fun.a === 5 ? fun.f(a, b, c, d, e) : fun(a)(b)(c)(d)(e);

81+}

82+function A6(fun, a, b, c, d, e, f) {

83+ return fun.a === 6 ? fun.f(a, b, c, d, e, f) : fun(a)(b)(c)(d)(e)(f);

84+}

85+function A7(fun, a, b, c, d, e, f, g) {

86+ return fun.a === 7 ? fun.f(a, b, c, d, e, f, g) : fun(a)(b)(c)(d)(e)(f)(g);

87+}

88+function A8(fun, a, b, c, d, e, f, g, h) {

89+ return fun.a === 8 ? fun.f(a, b, c, d, e, f, g, h) : fun(a)(b)(c)(d)(e)(f)(g)(h);

90+}

91+function A9(fun, a, b, c, d, e, f, g, h, i) {

92+ return fun.a === 9 ? fun.f(a, b, c, d, e, f, g, h, i) : fun(a)(b)(c)(d)(e)(f)(g)(h)(i);

93+}

94+

95+|]

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

@@ -2,9 +2,6 @@

22{-# LANGUAGE OverloadedStrings #-}

33module Generate.JavaScript.Name

44 ( Name

5− , Mode(..)

6− , Target(..)

7− , isServer

85 , toBuilder

96 , fromIndex

107 , fromInt

@@ -12,31 +9,25 @@ module Generate.JavaScript.Name

129 , fromGlobal

1310 , fromCycle

1411 , fromKernel

15− , fromField

1612 , makeF

1713 , makeA

1814 , makeLabel

1915 , makeTemp

2016 , dollar

21− , shortenFieldNames

2217 )

2318 where

2419

2520

2621import qualified Data.ByteString.Builder as B

27−import qualified Data.ByteString.Short as S

28−import qualified Data.List as List

2922import Data.Monoid ((<>))

30−import Data.Map ((!))

3123import qualified Data.Map as Map

24+import qualified Data.Name as Name

3225import qualified Data.Set as Set

33−import qualified Data.Text as Text

34−import qualified Data.Text.Encoding as Text

26+import qualified Data.Utf8 as Utf8

3527import Data.Word (Word8)

3628

37−import qualified AST.Module.Name as ModuleName

3829import qualified Data.Index as Index

39−import qualified Elm.Name as N

30+import qualified Elm.ModuleName as ModuleName

4031import qualified Elm.Package as Pkg

4132

4233

@@ -49,34 +40,6 @@ newtype Name =

4940

5041

5142

52−-- MODE

53−

54−

55−data Mode

56− = Debug Target

57− | Prod Target ShortFieldNames

58−

59−

60−data Target = Client | Server

61−

62−

63−type ShortFieldNames =

64− Map.Map N.Name Name

65−

66−

67−isServer :: Mode -> Bool

68−isServer mode =

69− case mode of

70− Debug target -> isServerHelp target

71− Prod target _ -> isServerHelp target

72−

73−

74−isServerHelp :: Target -> Bool

75−isServerHelp target =

76− case target of { Client -> False ; Server -> True }

77−

78−

79−

8043-- CONSTRUCTORS

8144

8245

@@ -87,48 +50,41 @@ fromIndex index =

8750

8851fromInt :: Int -> Name

8952fromInt n =

90− Name (B.shortByteString (intToAscii n))

53+ Name (Name.toBuilder (intToAscii n))

9154

9255

93−fromLocal :: N.Name -> Name

56+fromLocal :: Name.Name -> Name

9457fromLocal name =

9558 if Set.member name reservedNames then

96− Name ("_" <> N.toBuilder name)

59+ Name ("_" <> Name.toBuilder name)

9760 else

98− Name (N.toBuilder name)

61+ Name (Name.toBuilder name)

9962

10063

101−fromGlobal :: ModuleName.Canonical -> N.Name -> Name

102−fromGlobal (ModuleName.Canonical (Pkg.Name user project) home) name =

103− Name $

104− Text.encodeUtf8Builder (Text.replace "-" "_" user)

105− <> "$" <> Text.encodeUtf8Builder (Text.replace "-" "_" project) -- TODO store this in a better way

106− <> "$" <> N.toDotlessBuilder home

107− <> "$" <> N.toBuilder name

64+fromGlobal :: ModuleName.Canonical -> Name.Name -> Name

65+fromGlobal home name =

66+ Name $ homeToBuilder home <> usd <> Name.toBuilder name

10867

10968

110−fromCycle :: ModuleName.Canonical -> N.Name -> Name

111−fromCycle (ModuleName.Canonical (Pkg.Name user project) home) name =

112− Name $

113− Text.encodeUtf8Builder (Text.replace "-" "_" user)

114− <> "$" <> Text.encodeUtf8Builder (Text.replace "-" "_" project) -- TODO store this in a better way

115− <> "$" <> N.toDotlessBuilder home

116− <> "$cyclic$" <> N.toBuilder name

69+fromCycle :: ModuleName.Canonical -> Name.Name -> Name

70+fromCycle home name =

71+ Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name

11772

11873

119−fromKernel :: N.Name -> N.Name -> Name

74+fromKernel :: Name.Name -> Name.Name -> Name

12075fromKernel home name =

121− Name ("_" <> N.toBuilder home <> "_" <> N.toBuilder name)

122−

76+ Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)

12377

124−fromField :: Mode -> N.Name -> Name

125−fromField mode name =

126− case mode of

127− Debug _ ->

128− Name (N.toBuilder name)

12978

130− Prod _ fields ->

131− fields ! name

79+{-# INLINE homeToBuilder #-}

80+homeToBuilder :: ModuleName.Canonical -> B.Builder

81+homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =

82+ usd <>

83+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author

84+ <> usd <>

85+ Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project

86+ <> usd <>

87+ Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home

13288

13389

13490

@@ -145,46 +101,24 @@ makeA n =

145101 Name ("A" <> B.intDec n)

146102

147103

148−makeLabel :: N.Name -> Int -> Name

104+makeLabel :: Name.Name -> Int -> Name

149105makeLabel name index =

150− Name (N.toBuilder name <> "$" <> B.intDec index)

106+ Name (Name.toBuilder name <> usd <> B.intDec index)

151107

152108

153−makeTemp :: N.Name -> Name

109+makeTemp :: Name.Name -> Name

154110makeTemp name =

155− Name ("$temp$" <> N.toBuilder name)

111+ Name ("$temp$" <> Name.toBuilder name)

156112

157113

158114dollar :: Name

159115dollar =

160− Name (N.toBuilder N.dollar)

161−

162−

163−

164−-- SHORTEN FIELD NAMES

165−

166−

167−shortenFieldNames :: Map.Map N.Name Int -> ShortFieldNames

168−shortenFieldNames frequencies =

169− Map.foldr addToShortNames Map.empty $

170− Map.foldrWithKey addToBuckets Map.empty frequencies

171−

172−

173−addToBuckets :: N.Name -> Int -> Map.Map Int [N.Name] -> Map.Map Int [N.Name]

174−addToBuckets field frequency buckets =

175− -- TODO try using an IntMap for buckets

176− Map.insertWith (++) frequency [field] buckets

177−

178−

179−addToShortNames :: [N.Name] -> ShortFieldNames -> ShortFieldNames

180−addToShortNames fields shortNames =

181− List.foldl' addField shortNames fields

116+ Name usd

182117

183118

184−addField :: ShortFieldNames -> N.Name -> ShortFieldNames

185−addField shortNames field =

186− let rename = fromInt (Map.size shortNames) in

187− Map.insert field rename shortNames

119+usd :: B.Builder

120+usd =

121+ Name.toBuilder Name.dollar

188122

189123

190124

@@ -192,12 +126,12 @@ addField shortNames field =

192126

193127

194128{-# NOINLINE reservedNames #-}

195−reservedNames :: Set.Set N.Name

129+reservedNames :: Set.Set Name.Name

196130reservedNames =

197131 Set.union jsReservedWords elmReservedWords

198132

199133

200−jsReservedWords :: Set.Set N.Name

134+jsReservedWords :: Set.Set Name.Name

201135jsReservedWords =

202136 Set.fromList

203137 [ "do", "if", "in"

@@ -213,7 +147,7 @@ jsReservedWords =

213147 ]

214148

215149

216−elmReservedWords :: Set.Set N.Name

150+elmReservedWords :: Set.Set Name.Name

217151elmReservedWords =

218152 Set.fromList

219153 [ "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

@@ -225,16 +159,16 @@ elmReservedWords =

225159-- INT TO ASCII

226160

227161

228−intToAscii :: Int -> S.ShortByteString

162+intToAscii :: Int -> Name.Name

229163intToAscii n =

230164 if n < 53 then -- skip $ as a standalone name

231− S.pack [toByte n]

165+ Name.fromWords [toByte n]

232166

233167 else

234168 intToAsciiHelp 2 (numStartBytes * numInnerBytes) allBadFields (n - 53)

235169

236170

237−intToAsciiHelp :: Int -> Int -> [BadFields] -> Int -> S.ShortByteString

171+intToAsciiHelp :: Int -> Int -> [BadFields] -> Int -> Name.Name

238172intToAsciiHelp width blockSize badFields n =

239173 case badFields of

240174 [] ->

@@ -256,10 +190,10 @@ intToAsciiHelp width blockSize badFields n =

256190-- UNSAFE INT TO ASCII

257191

258192

259−unsafeIntToAscii :: Int -> [Word8] -> Int -> S.ShortByteString

193+unsafeIntToAscii :: Int -> [Word8] -> Int -> Name.Name

260194unsafeIntToAscii width bytes n =

261195 if width <= 1 then

262− S.pack (toByte n : bytes)

196+ Name.fromWords (toByte n : bytes)

263197 else

264198 let

265199 (quotient, remainder) =

@@ -301,27 +235,27 @@ newtype BadFields =

301235

302236

303237type Renamings =

304− Map.Map S.ShortByteString S.ShortByteString

238+ Map.Map Name.Name Name.Name

305239

306240

307241allBadFields :: [BadFields]

308242allBadFields =

309243 let

310244 add keyword dict =

311− Map.alter (Just . addRenaming keyword) (N.length keyword) dict

245+ Map.alter (Just . addRenaming keyword) (Utf8.size keyword) dict

312246 in

313247 Map.elems $ Set.foldr add Map.empty jsReservedWords

314248

315249

316−addRenaming :: N.Name -> Maybe BadFields -> BadFields

250+addRenaming :: Name.Name -> Maybe BadFields -> BadFields

317251addRenaming keyword maybeBadFields =

318252 let

319− width = N.length keyword

253+ width = Utf8.size keyword

320254 maxName = numStartBytes * numInnerBytes ^ (width - 1) - 1

321255 in

322256 case maybeBadFields of

323257 Nothing ->

324− BadFields $ Map.singleton (N.toShort keyword) (unsafeIntToAscii width [] maxName)

258+ BadFields $ Map.singleton keyword (unsafeIntToAscii width [] maxName)

325259

326260 Just (BadFields renamings) ->

327− BadFields $ Map.insert (N.toShort keyword) (unsafeIntToAscii width [] (maxName - Map.size renamings)) renamings

261+ BadFields $ Map.insert keyword (unsafeIntToAscii width [] (maxName - Map.size renamings)) renamings

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

@@ -0,0 +1,63 @@

1+module Generate.Mode

2+ ( Mode(..)

3+ , isDebug

4+ , ShortFieldNames

5+ , shortenFieldNames

6+ )

7+ where

8+

9+

10+import qualified Data.List as List

11+import qualified Data.Map as Map

12+import qualified Data.Maybe as Maybe

13+import qualified Data.Name as Name

14+

15+import qualified AST.Optimized as Opt

16+import qualified Elm.Compiler.Type.Extract as Extract

17+import qualified Generate.JavaScript.Name as JsName

18+

19+

20+

21+-- MODE

22+

23+

24+data Mode

25+ = Dev (Maybe Extract.Types)

26+ | Prod ShortFieldNames

27+

28+

29+isDebug :: Mode -> Bool

30+isDebug mode =

31+ case mode of

32+ Dev mi -> Maybe.isJust mi

33+ Prod _ -> False

34+

35+

36+

37+-- SHORTEN FIELD NAMES

38+

39+

40+type ShortFieldNames =

41+ Map.Map Name.Name JsName.Name

42+

43+

44+shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames

45+shortenFieldNames (Opt.GlobalGraph _ frequencies) =

46+ Map.foldr addToShortNames Map.empty $

47+ Map.foldrWithKey addToBuckets Map.empty frequencies

48+

49+

50+addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]

51+addToBuckets field frequency buckets =

52+ Map.insertWith (++) frequency [field] buckets

53+

54+

55+addToShortNames :: [Name.Name] -> ShortFieldNames -> ShortFieldNames

56+addToShortNames fields shortNames =

57+ List.foldl' addField shortNames fields

58+

59+

60+addField :: ShortFieldNames -> Name.Name -> ShortFieldNames

61+addField shortNames field =

62+ let rename = JsName.fromInt (Map.size shortNames) in

63+ Map.insert field rename shortNames

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

@@ -0,0 +1,799 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}

3+module Json.Decode

4+ ( fromByteString

5+ , Decoder

6+ , string

7+ , customString

8+ , bool

9+ , int

10+ , list

11+ , nonEmptyList

12+ , pair

13+ --

14+ , KeyDecoder(..)

15+ , dict

16+ , pairs

17+ , field

18+ --

19+ , oneOf

20+ , failure

21+ , mapError

22+ --

23+ , Error(..)

24+ , Problem(..)

25+ , DecodeExpectation(..)

26+ , ParseError(..)

27+ , StringProblem(..)

28+ )

29+ where

30+

31+

32+import qualified Data.ByteString.Internal as B

33+import qualified Data.Map as Map

34+import qualified Data.NonEmptyList as NE

35+import Data.Word (Word8)

36+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

37+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

38+

39+import qualified Json.String as Json

40+import qualified Parse.Keyword as K

41+import qualified Parse.Primitives as P

42+import Parse.Primitives (Row, Col)

43+import qualified Reporting.Annotation as A

44+

45+

46+

47+-- RUNNERS

48+

49+

50+fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a

51+fromByteString (Decoder decode) src =

52+ case P.fromByteString pFile BadEnd src of

53+ Right ast ->

54+ decode ast Right (Left . DecodeProblem src)

55+

56+ Left problem ->

57+ Left (ParseProblem src problem)

58+

59+

60+

61+-- DECODERS

62+

63+

64+newtype Decoder x a =

65+ Decoder

66+ (

67+ forall b.

68+ AST

69+ -> (a -> b)

70+ -> (Problem x -> b)

71+ -> b

72+ )

73+

74+

75+

76+-- ERRORS

77+

78+

79+data Error x

80+ = DecodeProblem B.ByteString (Problem x)

81+ | ParseProblem B.ByteString ParseError

82+

83+

84+

85+-- DECODE PROBLEMS

86+

87+

88+data Problem x

89+ = Field B.ByteString (Problem x)

90+ | Index Int (Problem x)

91+ | OneOf (Problem x) [Problem x]

92+ | Failure A.Region x

93+ | Expecting A.Region DecodeExpectation

94+

95+

96+data DecodeExpectation

97+ = TObject

98+ | TArray

99+ | TString

100+ | TBool

101+ | TInt

102+ | TObjectWith B.ByteString

103+ | TArrayPair Int

104+

105+

106+

107+-- INSTANCES

108+

109+

110+instance Functor (Decoder x) where

111+ {-# INLINE fmap #-}

112+ fmap func (Decoder decodeA) =

113+ Decoder $ \ast ok err ->

114+ let

115+ ok' a = ok (func a)

116+ in

117+ decodeA ast ok' err

118+

119+

120+instance Applicative (Decoder x) where

121+ {-# INLINE pure #-}

122+ pure = return

123+

124+ {-# INLINE (<*>) #-}

125+ (<*>) (Decoder decodeFunc) (Decoder decodeArg) =

126+ Decoder $ \ast ok err ->

127+ let

128+ okF func =

129+ let

130+ okA arg = ok (func arg)

131+ in

132+ decodeArg ast okA err

133+ in

134+ decodeFunc ast okF err

135+

136+

137+instance Monad (Decoder x) where

138+ {-# INLINE return #-}

139+ return a =

140+ Decoder $ \_ ok _ ->

141+ ok a

142+

143+ {-# INLINE (>>=) #-}

144+ (>>=) (Decoder decodeA) callback =

145+ Decoder $ \ast ok err ->

146+ let

147+ ok' a =

148+ case callback a of

149+ Decoder decodeB -> decodeB ast ok err

150+ in

151+ decodeA ast ok' err

152+

153+

154+

155+-- STRINGS

156+

157+

158+string :: Decoder x Json.String

159+string =

160+ Decoder $ \(A.At region ast) ok err ->

161+ case ast of

162+ String snippet ->

163+ ok (Json.fromSnippet snippet)

164+

165+ _ ->

166+ err (Expecting region TString)

167+

168+

169+customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a

170+customString parser toBadEnd =

171+ Decoder $ \(A.At region ast) ok err ->

172+ case ast of

173+ String snippet ->

174+ case P.fromSnippet parser toBadEnd snippet of

175+ Right a -> ok a

176+ Left x -> err (Failure region x)

177+

178+ _ ->

179+ err (Expecting region TString)

180+

181+

182+

183+-- BOOL

184+

185+

186+bool :: Decoder x Bool

187+bool =

188+ Decoder $ \(A.At region ast) ok err ->

189+ case ast of

190+ TRUE ->

191+ ok True

192+

193+ FALSE ->

194+ ok False

195+

196+ _ ->

197+ err (Expecting region TBool)

198+

199+

200+

201+-- INT

202+

203+

204+int :: Decoder x Int

205+int =

206+ Decoder $ \(A.At region ast) ok err ->

207+ case ast of

208+ Int n ->

209+ ok n

210+

211+ _ ->

212+ err (Expecting region TInt)

213+

214+

215+

216+-- LISTS

217+

218+

219+list :: Decoder x a -> Decoder x [a]

220+list decoder =

221+ Decoder $ \(A.At region ast) ok err ->

222+ case ast of

223+ Array asts ->

224+ listHelp decoder ok err 0 asts []

225+

226+ _ ->

227+ err (Expecting region TArray)

228+

229+

230+listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b

231+listHelp decoder@(Decoder decodeA) ok err !i asts revs =

232+ case asts of

233+ [] ->

234+ ok (reverse revs)

235+

236+ ast:asts ->

237+ let

238+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)

239+ err' prob = err (Index i prob)

240+ in

241+ decodeA ast ok' err'

242+

243+

244+

245+-- NON-EMPTY LISTS

246+

247+

248+nonEmptyList :: Decoder x a -> x -> Decoder x (NE.List a)

249+nonEmptyList decoder x =

250+ do values <- list decoder

251+ case values of

252+ v:vs -> return (NE.List v vs)

253+ [] -> failure x

254+

255+

256+

257+-- PAIR

258+

259+

260+pair :: Decoder x a -> Decoder x b -> Decoder x (a,b)

261+pair (Decoder decodeA) (Decoder decodeB) =

262+ Decoder $ \(A.At region ast) ok err ->

263+ case ast of

264+ Array vs ->

265+ case vs of

266+ [astA,astB] ->

267+ let

268+ err0 e = err (Index 0 e)

269+ ok0 a =

270+ let

271+ err1 e = err (Index 1 e)

272+ ok1 b = ok (a,b)

273+ in

274+ decodeB astB ok1 err1

275+ in

276+ decodeA astA ok0 err0

277+

278+ _ ->

279+ err (Expecting region (TArrayPair (length vs)))

280+

281+ _ ->

282+ err (Expecting region TArray)

283+

284+

285+

286+-- OBJECTS

287+

288+

289+data KeyDecoder x a =

290+ KeyDecoder (P.Parser x a) (Row -> Col -> x)

291+

292+

293+dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)

294+dict keyDecoder valueDecoder =

295+ Map.fromList <$> pairs keyDecoder valueDecoder

296+

297+

298+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]

299+pairs keyDecoder valueDecoder =

300+ Decoder $ \(A.At region ast) ok err ->

301+ case ast of

302+ Object kvs ->

303+ pairsHelp keyDecoder valueDecoder ok err kvs []

304+

305+ _ ->

306+ err (Expecting region TObject)

307+

308+

309+pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b

310+pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =

311+ case kvs of

312+ [] ->

313+ ok (reverse revs)

314+

315+ (snippet, ast) : kvs ->

316+ case P.fromSnippet keyParser toBadEnd snippet of

317+ Left x ->

318+ err (Failure (snippetToRegion snippet) x)

319+

320+ Right key ->

321+ let

322+ ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)

323+ err' prob =

324+ let (P.Snippet fptr off len _ _) = snippet in

325+ err (Field (B.PS fptr off len) prob)

326+ in

327+ decodeA ast ok' err'

328+

329+

330+snippetToRegion :: P.Snippet -> A.Region

331+snippetToRegion (P.Snippet _ _ len row col) =

332+ A.Region (A.Position row col) (A.Position row (col + fromIntegral len))

333+

334+

335+

336+-- FIELDS

337+

338+

339+field :: B.ByteString -> Decoder x a -> Decoder x a

340+field key (Decoder decodeA) =

341+ Decoder $ \(A.At region ast) ok err ->

342+ case ast of

343+ Object kvs ->

344+ case findField key kvs of

345+ Just value ->

346+ let

347+ err' prob =

348+ err (Field key prob)

349+ in

350+ decodeA value ok err'

351+

352+ Nothing ->

353+ err (Expecting region (TObjectWith key))

354+

355+ _ ->

356+ err (Expecting region TObject)

357+

358+

359+findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST

360+findField key pairs =

361+ case pairs of

362+ [] ->

363+ Nothing

364+

365+ (P.Snippet fptr off len _ _, value) : remainingPairs ->

366+ if key == B.PS fptr off len

367+ then Just value

368+ else findField key remainingPairs

369+

370+

371+

372+-- ONE OF

373+

374+

375+oneOf :: [Decoder x a] -> Decoder x a

376+oneOf decoders =

377+ Decoder $ \ast ok err ->

378+ case decoders of

379+ Decoder decodeA : decoders ->

380+ let

381+ err' e =

382+ oneOfHelp ast ok err decoders e []

383+ in

384+ decodeA ast ok err'

385+

386+ [] ->

387+ error "Ran into (Json.Decode.oneOf [])"

388+

389+

390+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b

391+oneOfHelp ast ok err decoders p ps =

392+ case decoders of

393+ Decoder decodeA : decoders ->

394+ let

395+ err' p' =

396+ oneOfHelp ast ok err decoders p' (p:ps)

397+ in

398+ decodeA ast ok err'

399+

400+ [] ->

401+ err (oneOfError [] p ps)

402+

403+

404+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x

405+oneOfError problems prob ps =

406+ case ps of

407+ [] ->

408+ OneOf prob problems

409+

410+ p:ps ->

411+ oneOfError (prob:problems) p ps

412+

413+

414+

415+-- FAILURE

416+

417+

418+failure :: x -> Decoder x a

419+failure x =

420+ Decoder $ \(A.At region _) _ err ->

421+ err (Failure region x)

422+

423+

424+

425+-- ERRORS

426+

427+

428+mapError :: (x -> y) -> Decoder x a -> Decoder y a

429+mapError func (Decoder decodeA) =

430+ Decoder $ \ast ok err ->

431+ let

432+ err' prob = err (mapErrorHelp func prob)

433+ in

434+ decodeA ast ok err'

435+

436+

437+mapErrorHelp :: (x -> y) -> Problem x -> Problem y

438+mapErrorHelp func problem =

439+ case problem of

440+ Field k p -> Field k (mapErrorHelp func p)

441+ Index i p -> Index i (mapErrorHelp func p)

442+ OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)

443+ Failure r x -> Failure r (func x)

444+ Expecting r e -> Expecting r e

445+

446+

447+

448+-- AST

449+

450+

451+type AST =

452+ A.Located AST_

453+

454+

455+data AST_

456+ = Array [AST]

457+ | Object [(P.Snippet, AST)]

458+ | String P.Snippet

459+ | Int Int

460+ | TRUE

461+ | FALSE

462+ | NULL

463+

464+

465+

466+-- PARSE

467+

468+

469+type Parser a =

470+ P.Parser ParseError a

471+

472+

473+data ParseError

474+ = Start Row Col

475+ | ObjectField Row Col

476+ | ObjectColon Row Col

477+ | ObjectEnd Row Col

478+ | ArrayEnd Row Col

479+ | StringProblem StringProblem Row Col

480+ | NoLeadingZeros Row Col

481+ | NoFloats Row Col

482+ | BadEnd Row Col

483+

484+-- PIndex Int ParseError Row Col

485+-- PField Json.String ParseError Row Col

486+

487+

488+data StringProblem

489+ = BadStringEnd

490+ | BadStringControlChar

491+ | BadStringEscapeChar

492+ | BadStringEscapeHex

493+

494+

495+

496+-- PARSE AST

497+

498+

499+pFile :: Parser AST

500+pFile =

501+ do spaces

502+ value <- pValue

503+ spaces

504+ return value

505+

506+

507+pValue :: Parser AST

508+pValue =

509+ P.addLocation $

510+ P.oneOf Start

511+ [ String <$> pString Start

512+ , pObject

513+ , pArray

514+ , pInt

515+ , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE

516+ , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE

517+ , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL

518+ ]

519+

520+

521+

522+-- OBJECT

523+

524+

525+pObject :: Parser AST_

526+pObject =

527+ do P.word1 0x7B {- { -} Start

528+ spaces

529+ P.oneOf ObjectField

530+ [ do entry <- pField

531+ spaces

532+ pObjectHelp [entry]

533+ , do P.word1 0x7D {-}-} ObjectEnd

534+ return (Object [])

535+ ]

536+

537+

538+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_

539+pObjectHelp revEntries =

540+ P.oneOf ObjectEnd

541+ [

542+ do P.word1 0x2C {-,-} ObjectEnd

543+ spaces

544+ entry <- pField

545+ spaces

546+ pObjectHelp (entry:revEntries)

547+ ,

548+ do P.word1 0x7D {-}-} ObjectEnd

549+ return (Object (reverse revEntries))

550+ ]

551+

552+

553+pField :: Parser (P.Snippet, AST)

554+pField =

555+ do key <- pString ObjectField

556+ spaces

557+ P.word1 0x3A {-:-} ObjectColon

558+ spaces

559+ value <- pValue

560+ return (key, value)

561+

562+

563+

564+-- ARRAY

565+

566+

567+pArray :: Parser AST_

568+pArray =

569+ do P.word1 0x5B {-[-} Start

570+ spaces

571+ P.oneOf Start

572+ [ do entry <- pValue

573+ spaces

574+ pArrayHelp 1 [entry]

575+ , do P.word1 0x5D {-]-} ArrayEnd

576+ return (Array [])

577+ ]

578+

579+

580+pArrayHelp :: Int -> [AST] -> Parser AST_

581+pArrayHelp !len revEntries =

582+ P.oneOf ArrayEnd

583+ [

584+ do P.word1 0x2C {-,-} ArrayEnd

585+ spaces

586+ entry <- pValue

587+ spaces

588+ pArrayHelp (len + 1) (entry:revEntries)

589+ ,

590+ do P.word1 0x5D {-]-} ArrayEnd

591+ return (Array (reverse revEntries))

592+ ]

593+

594+

595+

596+-- STRING

597+

598+

599+pString :: (Row -> Col -> ParseError) -> Parser P.Snippet

600+pString start =

601+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

602+ if pos < end && P.unsafeIndex pos == 0x22 {-"-} then

603+

604+ let

605+ !pos1 = plusPtr pos 1

606+ !col1 = col + 1

607+

608+ (# status, newPos, newRow, newCol #) =

609+ pStringHelp pos1 end row col1

610+ in

611+ case status of

612+ GoodString ->

613+ let

614+ !off = minusPtr pos1 (unsafeForeignPtrToPtr src)

615+ !len = minusPtr newPos pos1 - 1

616+ !snp = P.Snippet src off len row col1

617+ !newState = P.State src newPos end indent newRow newCol

618+ in

619+ cok snp newState

620+

621+ BadString problem ->

622+ cerr newRow newCol (StringProblem problem)

623+

624+ else

625+ eerr row col start

626+

627+

628+data StringStatus

629+ = GoodString

630+ | BadString StringProblem

631+

632+

633+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)

634+pStringHelp pos end row col =

635+ if pos >= end then

636+ (# BadString BadStringEnd, pos, row, col #)

637+

638+ else

639+ case P.unsafeIndex pos of

640+ 0x22 {-"-} ->

641+ (# GoodString, plusPtr pos 1, row, col + 1 #)

642+

643+ 0x0A {-\n-} ->

644+ (# BadString BadStringEnd, pos, row, col #)

645+

646+ 0x5C {-\-} ->

647+ let !pos1 = plusPtr pos 1 in

648+ if pos1 >= end then

649+ (# BadString BadStringEnd, pos1, row + 1, col #)

650+ else

651+ case P.unsafeIndex pos1 of

652+ 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

653+ 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

654+ 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

655+ 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

656+ 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

657+ 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

658+ 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

659+ 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

660+ 0x75 {-u-} ->

661+ let !pos6 = plusPtr pos 6 in

662+ if pos6 <= end

663+ && isHex (P.unsafeIndex (plusPtr pos 2))

664+ && isHex (P.unsafeIndex (plusPtr pos 3))

665+ && isHex (P.unsafeIndex (plusPtr pos 4))

666+ && isHex (P.unsafeIndex (plusPtr pos 5))

667+ then

668+ pStringHelp pos6 end row (col + 6)

669+ else

670+ (# BadString BadStringEscapeHex, pos, row, col #)

671+

672+ _ ->

673+ (# BadString BadStringEscapeChar, pos, row, col #)

674+

675+ word ->

676+ if word < 0x20 then

677+ (# BadString BadStringControlChar, pos, row, col #)

678+ else

679+ let !newPos = plusPtr pos (P.getCharWidth word) in

680+ pStringHelp newPos end row (col + 1)

681+

682+

683+isHex :: Word8 -> Bool

684+isHex word =

685+ 0x30 {-0-} <= word && word <= 0x39 {-9-}

686+ || 0x61 {-a-} <= word && word <= 0x66 {-f-}

687+ || 0x41 {-A-} <= word && word <= 0x46 {-F-}

688+

689+

690+

691+-- SPACES

692+

693+

694+spaces :: Parser ()

695+spaces =

696+ P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->

697+ let

698+ (# newPos, newRow, newCol #) =

699+ eatSpaces pos end row col

700+ in

701+ if pos == newPos then

702+ eok () state

703+ else

704+ let

705+ !newState =

706+ P.State src newPos end indent newRow newCol

707+ in

708+ cok () newState

709+

710+

711+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)

712+eatSpaces pos end row col =

713+ if pos >= end then

714+ (# pos, row, col #)

715+

716+ else

717+ case P.unsafeIndex pos of

718+ 0x20 {- -} -> eatSpaces (plusPtr pos 1) end row (col + 1)

719+ 0x09 {-\t-} -> eatSpaces (plusPtr pos 1) end row (col + 1)

720+ 0x0A {-\n-} -> eatSpaces (plusPtr pos 1) end (row + 1) 1

721+ 0x0D {-\r-} -> eatSpaces (plusPtr pos 1) end row col

722+ _ ->

723+ (# pos, row, col #)

724+

725+

726+

727+-- INTS

728+

729+

730+pInt :: Parser AST_

731+pInt =

732+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

733+ if pos >= end then

734+ eerr row col Start

735+

736+ else

737+ let !word = P.unsafeIndex pos in

738+ if not (isDecimalDigit word) then

739+ eerr row col Start

740+

741+ else if word == 0x30 {-0-} then

742+

743+ let

744+ !pos1 = plusPtr pos 1

745+ !newState = P.State src pos1 end indent row (col + 1)

746+ in

747+ if pos1 < end then

748+ let !word1 = P.unsafeIndex pos1 in

749+ if isDecimalDigit word1 then

750+ cerr row (col + 1) NoLeadingZeros

751+ else if word1 == 0x2E {-.-} then

752+ cerr row (col + 1) NoFloats

753+ else

754+ cok (Int 0) newState

755+ else

756+ cok (Int 0) newState

757+

758+ else

759+ let

760+ (# status, n, newPos #) =

761+ chompInt (plusPtr pos 1) end (fromIntegral (word - 0x30 {-0-}))

762+

763+ !len = fromIntegral (minusPtr newPos pos)

764+ in

765+ case status of

766+ GoodInt ->

767+ let

768+ !newState =

769+ P.State src newPos end indent row (col + len)

770+ in

771+ cok (Int n) newState

772+

773+ BadIntEnd ->

774+ cerr row (col + len) NoFloats

775+

776+

777+data IntStatus = GoodInt | BadIntEnd

778+

779+

780+chompInt :: Ptr Word8 -> Ptr Word8 -> Int -> (# IntStatus, Int, Ptr Word8 #)

781+chompInt pos end n =

782+ if pos < end then

783+ let !word = P.unsafeIndex pos in

784+ if isDecimalDigit word then

785+ let !m = 10 * n + fromIntegral (word - 0x30 {-0-}) in

786+ chompInt (plusPtr pos 1) end m

787+ else if word == 0x2E {-.-} || word == 0x65 {-e-} || word == 0x45 {-E-} then

788+ (# BadIntEnd, n, pos #)

789+ else

790+ (# GoodInt, n, pos #)

791+

792+ else

793+ (# GoodInt, n, pos #)

794+

795+

796+{-# INLINE isDecimalDigit #-}

797+isDecimalDigit :: Word8 -> Bool

798+isDecimalDigit word =

799+ word <= 0x39 {-9-} && word >= 0x30 {-0-}

src/Json/Encode.hs → compiler/src/Json/Encode.hsrenamed+47−59

@@ -5,11 +5,12 @@ module Json.Encode

55 , encode

66 , writeUgly

77 , encodeUgly

8− , Value

8+ , Value(..)

99 , array

1010 , object

11− , text

11+ , string

1212 , name

13+ , chars

1314 , bool

1415 , int

1516 , number

@@ -25,17 +26,14 @@ import Prelude hiding (null)

2526import Control.Arrow ((***))

2627import qualified Data.ByteString.Char8 as BSC

2728import qualified Data.ByteString.Builder as B

28−import qualified Data.ByteString.Builder.Prim as BP

29−import Data.ByteString.Builder.Prim ((>*<))

3029import qualified Data.Map as Map

3130import qualified Data.Scientific as Sci

3231import Data.Monoid ((<>))

33−import qualified Data.Text as Text

34−import qualified Data.Text.Encoding as Text

35−import qualified Data.Word as W

36−import System.IO (IOMode(WriteMode), withBinaryFile)

32+import qualified Data.Name as Name

33+import qualified Data.Utf8 as Utf8

3734

38−import qualified Elm.Name as N

35+import qualified File

36+import qualified Json.String as Json

3937

4038

4139

@@ -44,7 +42,7 @@ import qualified Elm.Name as N

4442

4543data Value

4644 = Array [Value]

47− | Object [(Text.Text, Value)]

45+ | Object [(Json.String, Value)]

4846 | String B.Builder

4947 | Boolean Bool

5048 | Integer Int

@@ -57,19 +55,19 @@ array =

5755 Array

5856

5957

60−object :: [(Text.Text,Value)] -> Value

58+object :: [(Json.String, Value)] -> Value

6159object =

6260 Object

6361

6462

65−text :: Text.Text -> Value

66−text txt =

67− String (encodeText txt)

63+string :: Json.String -> Value

64+string str =

65+ String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')

6866

6967

70−name :: N.Name -> Value

68+name :: Name.Name -> Value

7169name nm =

72− String ("\"" <> N.toBuilder nm <> "\"")

70+ String (B.char7 '"' <> Name.toBuilder nm <> B.char7 '"')

7371

7472

7573bool :: Bool -> Value

@@ -92,7 +90,7 @@ null =

9290 Null

9391

9492

95−dict :: (k -> Text.Text) -> (v -> Value) -> Map.Map k v -> Value

93+dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value

9694dict encodeKey encodeValue pairs =

9795 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)

9896

@@ -103,12 +101,35 @@ list encodeEntry entries =

103101

104102

105103

104+-- CHARS

105+

106+

107+chars :: [Char] -> Value -- PERF can this be done better? Look for examples.

108+chars chrs =

109+ String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')

110+

111+

112+escape :: [Char] -> [Char]

113+escape chrs =

114+ case chrs of

115+ [] ->

116+ []

117+

118+ c:cs

119+ | c == '\r' -> '\\' : 'r' : escape cs

120+ | c == '\n' -> '\\' : 'n' : escape cs

121+ | c == '\"' -> '\\' : '"' : escape cs

122+ | c == '\\' -> '\\' : '\\' : escape cs

123+ | otherwise -> c : escape cs

124+

125+

126+

106127-- HELPERS

107128

108129

109−(==>) :: a -> b -> (a, b)

110−(==>) a b =

111− (a, b)

130+(==>) :: [Char] -> value -> (Json.String, value)

131+(==>) key value =

132+ (Json.fromChars key, value)

112133

113134

114135

@@ -117,14 +138,12 @@ list encodeEntry entries =

117138

118139write :: FilePath -> Value -> IO ()

119140write path value =

120− withBinaryFile path WriteMode $ \handle ->

121− B.hPutBuilder handle (encode value)

141+ File.writeBuilder path (encode value <> "\n")

122142

123143

124144writeUgly :: FilePath -> Value -> IO ()

125145writeUgly path value =

126− withBinaryFile path WriteMode $ \handle ->

127− B.hPutBuilder handle (encodeUgly value)

146+ File.writeBuilder path (encodeUgly value)

128147

129148

130149

@@ -150,7 +169,7 @@ encodeUgly value =

150169 Object (first : rest) ->

151170 let

152171 encodeEntry char (key, entry) =

153− B.char7 char <> encodeText key <> B.char7 ':' <> encodeUgly entry

172+ B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry

154173 in

155174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'

156175

@@ -233,7 +252,7 @@ arrayClose =

233252-- ENCODE OBJECT

234253

235254

236−encodeObject :: BSC.ByteString -> (Text.Text, Value) -> [(Text.Text, Value)] -> B.Builder

255+encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder

237256encodeObject =

238257 encodeSequence objectOpen objectClose encodeField

239258

@@ -248,9 +267,9 @@ objectClose =

248267 B.char7 '}'

249268

250269

251−encodeField :: BSC.ByteString -> (Text.Text, Value) -> B.Builder

270+encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder

252271encodeField indent (key, value) =

253− encodeText key <> B.string7 ": " <> encodeHelp indent value

272+ B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value

254273

255274

256275

@@ -289,34 +308,3 @@ commaNewline =

289308newline :: B.Builder

290309newline =

291310 B.char7 '\n'

292−

293−

294−

295−-- ENCODE TEXT

296−

297−

298−encodeText :: Text.Text -> B.Builder

299−encodeText txt =

300− B.char7 '"' <> Text.encodeUtf8BuilderEscaped escapeAscii txt <> B.char7 '"'

301−

302−

303−{-# INLINE escapeAscii #-}

304−escapeAscii :: BP.BoundedPrim W.Word8

305−escapeAscii =

306− BP.condB (== 0x5C {- \\ -}) (ascii2 ('\\','\\')) $

307− BP.condB (== 0x22 {- \" -}) (ascii2 ('\\','"' )) $

308− BP.condB (>= 0x20 ) (BP.liftFixedToBounded BP.word8) $

309− BP.condB (== 0x0A {- \n -}) (ascii2 ('\\','n' )) $

310− BP.condB (== 0x0D {- \r -}) (ascii2 ('\\','r' )) $

311− BP.condB (== 0x09 {- \t -}) (ascii2 ('\\','t' )) $

312− BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20

313− where

314− hexEscape :: BP.FixedPrim W.Word8

315− hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<

316− BP.char8 >*< BP.char8 >*< BP.word16HexFixed

317−

318−

319−{-# INLINE ascii2 #-}

320−ascii2 :: (Char, Char) -> BP.BoundedPrim a

321−ascii2 cs =

322− BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7

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

@@ -0,0 +1,192 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls #-}

3+module Json.String

4+ ( String

5+ , isEmpty

6+ --

7+ , fromPtr

8+ , fromName

9+ , fromChars

10+ , fromSnippet

11+ , fromComment

12+ --

13+ , toChars

14+ , toBuilder

15+ )

16+ where

17+

18+

19+import Prelude hiding (String)

20+import qualified Data.ByteString.Builder as B

21+import qualified Data.Coerce as Coerce

22+import qualified Data.Name as Name

23+import qualified Data.Utf8 as Utf8

24+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

25+import Data.Word (Word8)

26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

27+import Foreign.ForeignPtr (withForeignPtr)

28+import GHC.Exts (RealWorld)

29+import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)

30+import GHC.ST (ST)

31+

32+import qualified Parse.Primitives as P

33+

34+

35+

36+-- JSON STRINGS

37+

38+

39+-- INVARIANT: any Json.String is appropriately escaped already

40+-- PERF: is this the right representation for Json.String? Maybe ByteString instead?

41+--

42+type String =

43+ Utf8.Utf8 JSON_STRING

44+

45+

46+data JSON_STRING

47+

48+

49+isEmpty :: String -> Bool

50+isEmpty =

51+ Utf8.isEmpty

52+

53+

54+

55+-- FROM

56+

57+

58+fromPtr :: Ptr Word8 -> Ptr Word8 -> String

59+fromPtr =

60+ Utf8.fromPtr

61+

62+

63+fromChars :: [Char] -> String

64+fromChars =

65+ Utf8.fromChars

66+

67+

68+fromSnippet :: P.Snippet -> String

69+fromSnippet =

70+ Utf8.fromSnippet

71+

72+

73+fromName :: Name.Name -> String

74+fromName =

75+ Coerce.coerce

76+

77+

78+

79+-- TO

80+

81+

82+toChars :: String -> [Char]

83+toChars =

84+ Utf8.toChars

85+

86+

87+{-# INLINE toBuilder #-}

88+toBuilder :: String -> B.Builder

89+toBuilder =

90+ Utf8.toBuilder

91+

92+

93+

94+-- FROM COMMENT

95+

96+

97+fromComment :: P.Snippet -> String

98+fromComment (P.Snippet fptr off len _ _) =

99+ unsafePerformIO $ withForeignPtr fptr $ \ptr ->

100+ let

101+ !pos = plusPtr ptr off

102+ !end = plusPtr pos len

103+ !str = fromChunks (chompChunks pos end pos [])

104+ in

105+ return str

106+

107+

108+chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

109+chompChunks pos end start revChunks =

110+ if pos >= end then

111+ reverse (addSlice start end revChunks)

112+ else

113+ let

114+ !word = P.unsafeIndex pos

115+ in

116+ case word of

117+ 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks

118+ 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks

119+ 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks

120+ 0x0D {-\r-} ->

121+ let

122+ !newPos = plusPtr pos 1

123+ in

124+ chompChunks newPos end newPos (addSlice start pos revChunks)

125+

126+ _ ->

127+ let

128+ !width = P.getCharWidth word

129+ !newPos = plusPtr pos width

130+ in

131+ chompChunks newPos end start revChunks

132+

133+

134+chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

135+chompEscape escape pos end start revChunks =

136+ let

137+ !pos1 = plusPtr pos 1

138+ in

139+ chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)

140+

141+

142+addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

143+addSlice start end revChunks =

144+ if start == end

145+ then revChunks

146+ else Slice start (minusPtr end start) : revChunks

147+

148+

149+

150+-- FROM CHUNKS

151+

152+

153+data Chunk

154+ = Slice (Ptr Word8) Int

155+ | Escape Word8

156+

157+

158+fromChunks :: [Chunk] -> String

159+fromChunks chunks =

160+ unsafeDupablePerformIO (stToIO (

161+ do let !len = sum (map chunkToWidth chunks)

162+ mba <- newByteArray len

163+ writeChunks mba 0 chunks

164+ freeze mba

165+ ))

166+

167+

168+chunkToWidth :: Chunk -> Int

169+chunkToWidth chunk =

170+ case chunk of

171+ Slice _ len -> len

172+ Escape _ -> 2

173+

174+

175+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

176+writeChunks mba offset chunks =

177+ case chunks of

178+ [] ->

179+ return ()

180+

181+ chunk : chunks ->

182+ case chunk of

183+ Slice ptr len ->

184+ do copyFromPtr ptr mba offset len

185+ let !newOffset = offset + len

186+ writeChunks mba newOffset chunks

187+

188+ Escape word ->

189+ do writeWord8 mba offset 0x5C {- \ -}

190+ writeWord8 mba (offset + 1) word

191+ let !newOffset = offset + 2

192+ writeChunks mba newOffset chunks

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

@@ -0,0 +1,87 @@

1+module Nitpick.Debug

2+ ( hasDebugUses

3+ )

4+ where

5+

6+

7+import qualified Data.Map.Utils as Map

8+

9+import qualified AST.Optimized as Opt

10+

11+

12+

13+-- HAS DEBUG USES

14+

15+

16+hasDebugUses :: Opt.LocalGraph -> Bool

17+hasDebugUses (Opt.LocalGraph _ graph _) =

18+ Map.any nodeHasDebug graph

19+

20+

21+nodeHasDebug :: Opt.Node -> Bool

22+nodeHasDebug node =

23+ case node of

24+ Opt.Define expr _ -> hasDebug expr

25+ Opt.DefineTailFunc _ expr _ -> hasDebug expr

26+ Opt.Ctor _ _ -> False

27+ Opt.Enum _ -> False

28+ Opt.Box -> False

29+ Opt.Link _ -> False

30+ Opt.Cycle _ vs fs _ -> any (hasDebug . snd) vs || any defHasDebug fs

31+ Opt.Manager _ -> False

32+ Opt.Kernel _ _ -> False

33+ Opt.PortIncoming expr _ -> hasDebug expr

34+ Opt.PortOutgoing expr _ -> hasDebug expr

35+

36+

37+hasDebug :: Opt.Expr -> Bool

38+hasDebug expression =

39+ case expression of

40+ Opt.Bool _ -> False

41+ Opt.Chr _ -> False

42+ Opt.Str _ -> False

43+ Opt.Int _ -> False

44+ Opt.Float _ -> False

45+ Opt.VarLocal _ -> False

46+ Opt.VarGlobal _ -> False

47+ Opt.VarEnum _ _ -> False

48+ Opt.VarBox _ -> False

49+ Opt.VarCycle _ _ -> False

50+ Opt.VarDebug _ _ _ _ -> True

51+ Opt.VarKernel _ _ -> False

52+ Opt.List exprs -> any hasDebug exprs

53+ Opt.Function _ expr -> hasDebug expr

54+ Opt.Call e es -> hasDebug e || any hasDebug es

55+ Opt.TailCall _ args -> any (hasDebug . snd) args

56+ Opt.If conds finally -> any (\(c,e) -> hasDebug c || hasDebug e) conds || hasDebug finally

57+ Opt.Let def body -> defHasDebug def || hasDebug body

58+ Opt.Destruct _ expr -> hasDebug expr

59+ Opt.Case _ _ d jumps -> deciderHasDebug d || any (hasDebug . snd) jumps

60+ Opt.Accessor _ -> False

61+ Opt.Access r _ -> hasDebug r

62+ Opt.Update r fs -> hasDebug r || any hasDebug fs

63+ Opt.Record fs -> any hasDebug fs

64+ Opt.Unit -> False

65+ Opt.Tuple a b c -> hasDebug a || hasDebug b || maybe False hasDebug c

66+ Opt.Shader _ _ _ -> False

67+

68+

69+defHasDebug :: Opt.Def -> Bool

70+defHasDebug def =

71+ case def of

72+ Opt.Def _ expr -> hasDebug expr

73+ Opt.TailDef _ _ expr -> hasDebug expr

74+

75+

76+deciderHasDebug :: Opt.Decider Opt.Choice -> Bool

77+deciderHasDebug decider =

78+ case decider of

79+ Opt.Leaf (Opt.Inline expr) -> hasDebug expr

80+ Opt.Leaf (Opt.Jump _) -> False

81+ Opt.Chain _ success failure -> deciderHasDebug success || deciderHasDebug failure

82+ Opt.FanOut _ tests fallback -> any (deciderHasDebug . snd) tests || deciderHasDebug fallback

83+

84+

85+

86+-- TODO: FIND GLOBALLY UNUSED DEFINITIONS?

87+-- TODO: FIND PACKAGE USAGE STATS? (e.g. elm/core = 142, author/project = 2, etc.)

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

@@ -20,14 +20,14 @@ http://moscova.inria.fr/~maranget/papers/warn/warn.pdf

2020import qualified Data.List as List

2121import qualified Data.Map as Map

2222import qualified Data.Maybe as Maybe

23−import qualified Data.Text as Text

23+import qualified Data.Name as Name

24+import qualified Data.NonEmptyList as NE

2425

2526import qualified AST.Canonical as Can

26−import qualified AST.Module.Name as ModuleName

2727import qualified Data.Index as Index

28−import qualified Elm.Name as N

28+import qualified Elm.ModuleName as ModuleName

29+import qualified Elm.String as ES

2930import qualified Reporting.Annotation as A

30−import qualified Reporting.Region as R

3131

3232

3333

@@ -37,12 +37,12 @@ import qualified Reporting.Region as R

3737data Pattern

3838 = Anything

3939 | Literal Literal

40− | Ctor Can.Union N.Name [Pattern]

40+ | Ctor Can.Union Name.Name [Pattern]

4141

4242

4343data Literal

44− = Chr Text.Text

45− | Str Text.Text

44+ = Chr ES.String

45+ | Str ES.String

4646 | Int Int

4747 deriving (Eq)

4848

@@ -94,6 +94,9 @@ simplify (A.At _ pattern) =

9494 Can.PChr chr ->

9595 Literal (Chr chr)

9696

97+ Can.PBool union bool ->

98+ Ctor union (if bool then Name.true else Name.false) []

99+

97100

98101cons :: Can.Pattern -> Pattern -> Pattern

99102cons hd tl =

@@ -150,34 +153,34 @@ list =

150153 consCtor =

151154 Can.Ctor consName Index.second 2

152155 [ Can.TVar "a"

153− , Can.TType ModuleName.list N.list [Can.TVar "a"]

156+ , Can.TType ModuleName.list Name.list [Can.TVar "a"]

154157 ]

155158 in

156159 Can.Union ["a"] [ nilCtor, consCtor ] 2 Can.Normal

157160

158161

159162{-# NOINLINE unitName #-}

160−unitName :: N.Name

163+unitName :: Name.Name

161164unitName = "#0"

162165

163166

164167{-# NOINLINE pairName #-}

165−pairName :: N.Name

168+pairName :: Name.Name

166169pairName = "#2"

167170

168171

169172{-# NOINLINE tripleName #-}

170−tripleName :: N.Name

173+tripleName :: Name.Name

171174tripleName = "#3"

172175

173176

174177{-# NOINLINE consName #-}

175−consName :: N.Name

178+consName :: Name.Name

176179consName = "::"

177180

178181

179182{-# NOINLINE nilName #-}

180−nilName :: N.Name

183+nilName :: Name.Name

181184nilName = "[]"

182185

183186

@@ -186,8 +189,8 @@ nilName = "[]"

186189

187190

188191data Error

189− = Incomplete R.Region Context [Pattern]

190− | Redundant R.Region R.Region Int

192+ = Incomplete A.Region Context [Pattern]

193+ | Redundant A.Region A.Region Int

191194

192195

193196data Context

@@ -200,14 +203,14 @@ data Context

200203-- CHECK

201204

202205

203−check :: Can.Module -> Either [Error] ()

206+check :: Can.Module -> Either (NE.List Error) ()

204207check (Can.Module _ _ _ decls _ _ _ _) =

205208 case checkDecls decls [] of

206209 [] ->

207210 Right ()

208211

209− errors ->

210− Left errors

212+ e:es ->

213+ Left (NE.List e es)

211214

212215

213216

@@ -220,8 +223,8 @@ checkDecls decls errors =

220223 Can.Declare def subDecls ->

221224 checkDef def $ checkDecls subDecls errors

222225

223− Can.DeclareRec defs subDecls ->

224− foldr checkDef (checkDecls subDecls errors) defs

226+ Can.DeclareRec def defs subDecls ->

227+ checkDef def (foldr checkDef (checkDecls subDecls errors) defs)

225228

226229 Can.SaveTheEnvironment ->

227230 errors

@@ -329,8 +332,8 @@ checkExpr (A.At region expression) errors =

329332 Can.Access record _ ->

330333 checkExpr record errors

331334

332− Can.Update record fields ->

333− checkExpr record $ Map.foldr checkExpr errors fields

335+ Can.Update _ record fields ->

336+ checkExpr record $ Map.foldr checkField errors fields

334337

335338 Can.Record fields ->

336339 Map.foldr checkExpr errors fields

@@ -348,11 +351,20 @@ checkExpr (A.At region expression) errors =

348351 Just c ->

349352 checkExpr c errors

350353

351− Can.Shader _ _ _ ->

354+ Can.Shader _ _ ->

352355 errors

353356

354357

355358

359+-- CHECK FIELD

360+

361+

362+checkField :: Can.FieldUpdate -> [Error] -> [Error]

363+checkField (Can.FieldUpdate _ expr) errors =

364+ checkExpr expr errors

365+

366+

367+

356368-- CHECK IF BRANCH

357369

358370

@@ -365,7 +377,7 @@ checkIfBranch (condition, branch) errs =

365377-- CHECK CASE EXPRESSION

366378

367379

368−checkCases :: R.Region -> [Can.CaseBranch] -> [Error] -> [Error]

380+checkCases :: A.Region -> [Can.CaseBranch] -> [Error] -> [Error]

369381checkCases region branches errors =

370382 let

371383 (patterns, newErrors) =

@@ -385,7 +397,7 @@ checkCaseBranch (Can.CaseBranch pattern expr) (patterns, errors) =

385397-- CHECK PATTERNS

386398

387399

388−checkPatterns :: R.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]

400+checkPatterns :: A.Region -> Context -> [Can.Pattern] -> [Error] -> [Error]

389401checkPatterns region context patterns errors =

390402 case toNonRedundantRows region patterns of

391403 Left err ->

@@ -446,7 +458,7 @@ isExhaustive matrix n =

446458 concatMap isAltExhaustive altList

447459

448460

449−isMissing :: Can.Union -> Map.Map N.Name a -> Can.Ctor -> Maybe Pattern

461+isMissing :: Can.Union -> Map.Map Name.Name a -> Can.Ctor -> Maybe Pattern

450462isMissing union ctors (Can.Ctor name _ arity _) =

451463 if Map.member name ctors then

452464 Nothing

@@ -454,7 +466,7 @@ isMissing union ctors (Can.Ctor name _ arity _) =

454466 Just (Ctor union name (replicate arity Anything))

455467

456468

457−recoverCtor :: Can.Union -> N.Name -> Int -> [Pattern] -> [Pattern]

469+recoverCtor :: Can.Union -> Name.Name -> Int -> [Pattern] -> [Pattern]

458470recoverCtor union name arity patterns =

459471 let

460472 (args, rest) =

@@ -468,13 +480,13 @@ recoverCtor union name arity patterns =

468480

469481

470482-- INVARIANT: Produces a list of rows where (forall row. length row == 1)

471−toNonRedundantRows :: R.Region -> [Can.Pattern] -> Either Error [[Pattern]]

483+toNonRedundantRows :: A.Region -> [Can.Pattern] -> Either Error [[Pattern]]

472484toNonRedundantRows region patterns =

473485 toSimplifiedUsefulRows region [] patterns

474486

475487

476488-- INVARIANT: Produces a list of rows where (forall row. length row == 1)

477−toSimplifiedUsefulRows :: R.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]

489+toSimplifiedUsefulRows :: A.Region -> [[Pattern]] -> [Can.Pattern] -> Either Error [[Pattern]]

478490toSimplifiedUsefulRows overallRegion checkedRows uncheckedPatterns =

479491 case uncheckedPatterns of

480492 [] ->

@@ -540,7 +552,7 @@ isUseful matrix vector =

540552

541553

542554-- INVARIANT: (length row == N) ==> (length result == arity + N - 1)

543−specializeRowByCtor :: N.Name -> Int -> [Pattern] -> Maybe [Pattern]

555+specializeRowByCtor :: Name.Name -> Int -> [Pattern] -> Maybe [Pattern]

544556specializeRowByCtor ctorName arity row =

545557 case row of

546558 Ctor _ name args : patterns ->

@@ -626,12 +638,12 @@ isComplete matrix =

626638-- COLLECT CTORS

627639

628640

629−collectCtors :: [[Pattern]] -> Map.Map N.Name Can.Union

641+collectCtors :: [[Pattern]] -> Map.Map Name.Name Can.Union

630642collectCtors matrix =

631643 List.foldl' collectCtorsHelp Map.empty matrix

632644

633645

634−collectCtorsHelp :: Map.Map N.Name Can.Union -> [Pattern] -> Map.Map N.Name Can.Union

646+collectCtorsHelp :: Map.Map Name.Name Can.Union -> [Pattern] -> Map.Map Name.Name Can.Union

635647collectCtorsHelp ctors row =

636648 case row of

637649 Ctor union name _ : _ ->

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

@@ -9,10 +9,10 @@ import Control.Arrow (second)

99import qualified Data.Map as Map

1010import Data.Map ((!))

1111import qualified Data.Maybe as Maybe

12+import qualified Data.Name as Name

1213

1314import qualified AST.Canonical as Can

1415import qualified AST.Optimized as Opt

15−import qualified Elm.Name as N

1616import qualified Optimize.DecisionTree as DT

1717

1818

@@ -20,7 +20,7 @@ import qualified Optimize.DecisionTree as DT

2020-- OPTIMIZE A CASE EXPRESSION

2121

2222

23−optimize :: N.Name -> N.Name -> [(Can.Pattern, Opt.Expr)] -> Opt.Expr

23+optimize :: Name.Name -> Name.Name -> [(Can.Pattern, Opt.Expr)] -> Opt.Expr

2424optimize temp root optBranches =

2525 let

2626 (patterns, indexedBranches) =

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

@@ -21,16 +21,17 @@ as SML/NJ to get nice trees.

2121-}

2222

2323import Control.Arrow (second)

24−import Control.Monad (liftM, liftM2, liftM4)

24+import Control.Monad (liftM, liftM2, liftM5)

2525import Data.Binary

2626import qualified Data.List as List

2727import qualified Data.Maybe as Maybe

28+import qualified Data.Name as Name

2829import qualified Data.Set as Set

29−import Data.Text (Text)

3030

3131import qualified AST.Canonical as Can

3232import qualified Data.Index as Index

33−import qualified Elm.Name as N

33+import qualified Elm.ModuleName as ModuleName

34+import qualified Elm.String as ES

3435import qualified Reporting.Annotation as A

3536

3637

@@ -71,13 +72,14 @@ data DecisionTree

7172

7273

7374data Test

74− = IsCtor N.Name Index.ZeroBased Int Can.CtorOpts

75+ = IsCtor ModuleName.Canonical Name.Name Index.ZeroBased Int Can.CtorOpts

7576 | IsCons

7677 | IsNil

7778 | IsTuple

7879 | IsInt Int

79− | IsChr Text

80− | IsStr Text

80+ | IsChr ES.String

81+ | IsStr ES.String

82+ | IsBool Bool

8183 deriving (Eq, Ord)

8284

8385

@@ -137,7 +139,7 @@ toDecisionTree rawBranches =

137139isComplete :: [Test] -> Bool

138140isComplete tests =

139141 case head tests of

140− IsCtor _ _ numAlts _ ->

142+ IsCtor _ _ _ numAlts _ ->

141143 numAlts == length tests

142144

143145 IsCons ->

@@ -158,6 +160,9 @@ isComplete tests =

158160 IsInt _ ->

159161 False

160162

163+ IsBool _ ->

164+ length tests == 2

165+

161166

162167

163168-- FLATTEN PATTERNS

@@ -226,6 +231,9 @@ flatten pathPattern@(path, A.At region pattern) otherPathPatterns =

226231 Can.PInt _ ->

227232 pathPattern : otherPathPatterns

228233

234+ Can.PBool _ _ ->

235+ pathPattern : otherPathPatterns

236+

229237

230238subPositions :: Path -> [Can.Pattern] -> [(Path, Can.Pattern)]

231239subPositions path patterns =

@@ -307,8 +315,8 @@ testAtPath selectedPath (Branch _ pathPatterns) =

307315

308316 Just (A.At _ pattern) ->

309317 case pattern of

310− Can.PCtor _ _ (Can.Union _ _ numAlts opts) name index _ ->

311− Just (IsCtor name index numAlts opts)

318+ Can.PCtor home _ (Can.Union _ _ numAlts opts) name index _ ->

319+ Just (IsCtor home name index numAlts opts)

312320

313321 Can.PList ps ->

314322 Just (case ps of { [] -> IsNil ; _ -> IsCons })

@@ -337,6 +345,9 @@ testAtPath selectedPath (Branch _ pathPatterns) =

337345 Can.PChr chr ->

338346 Just (IsChr chr)

339347

348+ Can.PBool _ bool ->

349+ Just (IsBool bool)

350+

340351 Can.PRecord _ ->

341352 Nothing

342353

@@ -362,7 +373,7 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

362373 case pattern of

363374 Can.PCtor _ _ (Can.Union _ _ numAlts _) name _ ctorArgs ->

364375 case test of

365− IsCtor testName _ _ _ | name == testName ->

376+ IsCtor _ testName _ _ _ | name == testName ->

366377 Just $ Branch goal $

367378 case map dearg ctorArgs of

368379 [arg] | numAlts == 1 ->

@@ -422,6 +433,14 @@ toRelevantBranch test path branch@(Branch goal pathPatterns) =

422433 _ ->

423434 Nothing

424435

436+ Can.PBool _ bool ->

437+ case test of

438+ IsBool testBool | bool == testBool ->

439+ Just (Branch goal (start ++ end))

440+

441+ _ ->

442+ Nothing

443+

425444 Can.PUnit ->

426445 Just (Branch goal (start ++ end))

427446

@@ -496,6 +515,7 @@ needsTests (A.At _ pattern) =

496515 Can.PChr _ -> True

497516 Can.PStr _ -> True

498517 Can.PInt _ -> True

518+ Can.PBool _ _ -> True

499519 Can.PAlias _ _ ->

500520 error "aliases should never reach 'isIrrelevantTo' function"

501521

@@ -578,25 +598,27 @@ smallBranchingFactor branches path =

578598instance Binary Test where

579599 put test =

580600 case test of

581− IsCtor a b c d -> putWord8 0 >> put a >> put b >> put c >> put d

582− IsCons -> putWord8 1

583− IsNil -> putWord8 2

584− IsTuple -> putWord8 3

585− IsChr a -> putWord8 4 >> put a

586− IsStr a -> putWord8 5 >> put a

587− IsInt a -> putWord8 6 >> put a

601+ IsCtor a b c d e -> putWord8 0 >> put a >> put b >> put c >> put d >> put e

602+ IsCons -> putWord8 1

603+ IsNil -> putWord8 2

604+ IsTuple -> putWord8 3

605+ IsChr a -> putWord8 4 >> put a

606+ IsStr a -> putWord8 5 >> put a

607+ IsInt a -> putWord8 6 >> put a

608+ IsBool a -> putWord8 7 >> put a

588609

589610 get =

590611 do word <- getWord8

591612 case word of

592− 0 -> liftM4 IsCtor get get get get

613+ 0 -> liftM5 IsCtor get get get get get

593614 1 -> pure IsCons

594615 2 -> pure IsNil

595616 3 -> pure IsTuple

596617 4 -> liftM IsChr get

597618 5 -> liftM IsStr get

598619 6 -> liftM IsInt get

599− _ -> error "problem getting DecisionTree.Test binary"

620+ 7 -> liftM IsBool get

621+ _ -> fail "problem getting DecisionTree.Test binary"

600622

601623

602624instance Binary Path where

@@ -612,4 +634,4 @@ instance Binary Path where

612634 0 -> liftM2 Index get get

613635 1 -> liftM Unbox get

614636 2 -> pure Empty

615− _ -> error "problem getting DecisionTree.Path binary"

637+ _ -> fail "problem getting DecisionTree.Path binary"

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

src/Type/Solve.hs → compiler/src/Type/Solve.hsrenamed+42−29

This diff is too big to show here.

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

This diff is too big to show here.

src/Type/Unify.hs → compiler/src/Type/Unify.hsrenamed+57−75

This diff is too big to show here.

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

The content is the same.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

elm-compiler.cabaldeleted−215

This diff is too big to show here.

elm.cabalnew file+238

This diff is too big to show here.

hints/bad-recursion.md+25−27

This diff is too big to show here.

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

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/effect-modules.mddeleted−10

This diff is too big to show here.

hints/implicit-casts.md+2−5

This diff is too big to show here.

hints/imports.md+7−6

This diff is too big to show here.

hints/infinite-type.md+20−94

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.md+66−69

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/recursive-alias.md+3−2

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.md+1

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.md+2−8

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.xmlnew file+33

This diff is too big to show here.

installers/mac/README.mdnew file+93

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

installers/mac/postinstallnew file+5

This diff is too big to show here.

installers/mac/preinstallnew file+18

This diff is too big to show here.

installers/npm/.gitignorenew file+1

This diff is too big to show here.

installers/npm/.npmignorenew file+3

This diff is too big to show here.

installers/npm/PUBLISHING.mdnew file+59

This diff is too big to show here.

installers/npm/README.mdnew file+45

This diff is too big to show here.

installers/npm/bin/elmnew file+54

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/install.jsnew file+4

This diff is too big to show here.

installers/npm/package.jsonnew file+42

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+76

This diff is too big to show here.

installers/win/CreateInternetShortcut.nshnew file+5

This diff is too big to show here.

installers/win/Nsisfile.nsinew file+264

This diff is too big to show here.

installers/win/README.mdnew file+24

This diff is too big to show here.

installers/win/inst.datnew file+6

This diff is too big to show here.

installers/win/logo.iconew file

Binary file not shown.

installers/win/make_installer.cmdnew file+18

This diff is too big to show here.

installers/win/removefrompath.vbsnew file+17

This diff is too big to show here.

installers/win/uninst.datnew file+6

This diff is too big to show here.

installers/win/updatepath.vbsnew file+14

This diff is too big to show here.

installers/win/welcome.bmpnew file

Binary file not shown.

profiling/Main.hsdeleted−77

This diff is too big to show here.

profiling/cabal.configdeleted−2

This diff is too big to show here.

profiling/elm-prof.cabaldeleted−18

This diff is too big to show here.

reactor/assets/favicon.iconew file

Binary file not shown.

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

Binary file not shown.

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

Binary file not shown.

reactor/assets/styles.cssnew file+157

This diff is too big to show here.

reactor/check.pynew file+48

This diff is too big to show here.

reactor/elm.jsonnew file+31

This diff is too big to show here.

reactor/src/Deps.elmnew file+1210

This diff is too big to show here.

reactor/src/Errors.elmnew file+207

This diff is too big to show here.

reactor/src/Index.elmnew file+280

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

reactor/src/NotFound.elmnew file+29

This diff is too big to show here.

reactor/src/mock.txtnew file+33

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

src/AST/Module/Name.hsdeleted−198

This diff is too big to show here.

src/AST/Source.hsdeleted−193

This diff is too big to show here.

src/AST/Utils/Shader.hsdeleted−36

This diff is too big to show here.

src/AST/Valid.hsdeleted−129

This diff is too big to show here.

src/Canonicalize/Environment/Foreign.hsdeleted−287

This diff is too big to show here.

src/Compile.hsdeleted−124

This diff is too big to show here.

src/Data/OneOrMore.hsdeleted−64

This diff is too big to show here.

src/Elm/Compiler.hsdeleted−70

This diff is too big to show here.

src/Elm/Compiler/Imports.hsdeleted−79

This diff is too big to show here.

src/Elm/Compiler/Module.hsdeleted−96

This diff is too big to show here.

src/Elm/Compiler/Objects.hsdeleted−110

This diff is too big to show here.

src/Elm/Compiler/Type.hsdeleted−248

This diff is too big to show here.

src/Elm/Compiler/Version.hsdeleted−27

This diff is too big to show here.

src/Elm/Docs.hsdeleted−540

This diff is too big to show here.

src/Elm/Header.hsdeleted−73

This diff is too big to show here.

src/Elm/Interface.hsdeleted−113

This diff is too big to show here.

src/Elm/Kernel.hsdeleted−248

This diff is too big to show here.

src/Elm/Name.hsdeleted−316

This diff is too big to show here.

src/Elm/Package.hsdeleted−390

This diff is too big to show here.

src/Elm/Utils.hsdeleted−13

This diff is too big to show here.

src/Generate/JavaScript.hsdeleted−533

This diff is too big to show here.

src/Generate/JavaScript/Builder.hsdeleted−540

This diff is too big to show here.

src/Json/Decode.hsdeleted−306

This diff is too big to show here.

src/Json/Decode/Internals.hsdeleted−367

This diff is too big to show here.

src/Parse/Declaration.hsdeleted−197

This diff is too big to show here.

src/Parse/Expression.hsdeleted−564

This diff is too big to show here.

src/Parse/Module.hsdeleted−295

This diff is too big to show here.

src/Parse/Parse.hsdeleted−65

This diff is too big to show here.

src/Parse/Pattern.hsdeleted−273

This diff is too big to show here.

src/Parse/Primitives.hsdeleted−228

This diff is too big to show here.

src/Parse/Primitives/Internals.hsdeleted−251

This diff is too big to show here.

src/Parse/Primitives/Kernel.hsdeleted−116

This diff is too big to show here.

src/Parse/Primitives/Keyword.hsdeleted−235

This diff is too big to show here.

src/Parse/Primitives/Number.hsdeleted−297

This diff is too big to show here.

src/Parse/Primitives/Shader.hsdeleted−69

This diff is too big to show here.

src/Parse/Primitives/Symbol.hsdeleted−259

This diff is too big to show here.

src/Parse/Primitives/Utf8.hsdeleted−471

This diff is too big to show here.

src/Parse/Primitives/Variable.hsdeleted−376

This diff is too big to show here.

src/Parse/Primitives/Whitespace.hsdeleted−223

This diff is too big to show here.

src/Parse/Repl.hsdeleted−101

This diff is too big to show here.

src/Parse/Shader.hsdeleted−101

This diff is too big to show here.

src/Parse/Type.hsdeleted−228

This diff is too big to show here.

src/Reporting/Annotation.hsdeleted−60

This diff is too big to show here.

src/Reporting/Error.hsdeleted−57

This diff is too big to show here.

src/Reporting/Error/Canonicalize.hsdeleted−1153

This diff is too big to show here.

src/Reporting/Error/Docs.hsdeleted−140

This diff is too big to show here.

src/Reporting/Error/Syntax.hsdeleted−787

This diff is too big to show here.

src/Reporting/Error/Type.hsdeleted−1696

This diff is too big to show here.

src/Reporting/Helpers.hsdeleted−250

This diff is too big to show here.

src/Reporting/Region.hsdeleted−79

This diff is too big to show here.

src/Reporting/Render/Code.hsdeleted−153

This diff is too big to show here.

src/Reporting/Report.hsdeleted−83

This diff is too big to show here.

src/Type/Error.hsdeleted−617

This diff is too big to show here.

src/Validate.hsdeleted−334

This diff is too big to show here.

terminal/impl/Terminal.hsnew file+375

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Bump.hsnew file+169

This diff is too big to show here.

terminal/src/Develop.hsnew file+256

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hsnew file+359

This diff is too big to show here.

terminal/src/Init.hsnew file+104

This diff is too big to show here.

terminal/src/Install.hsnew file+425

This diff is too big to show here.

terminal/src/Main.hsnew file+338

This diff is too big to show here.

terminal/src/Make.hsnew file+319

This diff is too big to show here.

terminal/src/Publish.hsnew file+540

This diff is too big to show here.

terminal/src/Repl.hsnew file+726

This diff is too big to show here.

tests/Test.hsdeleted−14

This diff is too big to show here.

tests/Test/Compiler.hsdeleted−247

This diff is too big to show here.

tests/Test/Property.hsdeleted−68

This diff is too big to show here.

tests/Test/Property/Arbitrary.hsdeleted−193

This diff is too big to show here.

tests/test-files/bad/BBTArgsdeleted−1

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

No changes to the content.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/elm.cabalnew file+210

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hsnew file+73

This diff is too big to show here.