master..978ed5d · elk · git.iko.soy

.github/CONTRIBUTING.md+20−18

since splitsnapshots

unifiedsplit

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

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

5possible.

6

7+## Licensing

7

8

8−## Expectations

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

9−

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

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

11−- Smaller pull requests are easier to review. To fix nine typos, nine specific issues will always go faster than one big one. Learn why [here](https://github.com/elm/expectations/blob/master/small-pull-requests.md).

12−- Reviewers may not know as much as you about certain situations, so add links to supporting evidence for important claims, especially regarding standards for CSS, HTTP, URI, etc.

13−

14−Finally, please be patient with the core team. They are trying their best with limited resources!

15−

16

11

17## Style Guide

12## Style Guide

18

13

@@ -22,20 +17,27 @@ Finally, please be patient with the core team. They are trying their best with l

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

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

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

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

24

19

25−

26## Branches

20## Branches

27

21

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

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

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

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

30−should target this branch!

24+ should target this branch!

31−

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

33

25

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

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

28+ release from source.

34

29

35−## Licensing

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

36−

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

37−Nothing extra to do for this. The default on GitHub described [here](https://docs.github.com/en/github/site-policy/github-terms-of-service#6-contributions-under-repository-license) is that:

38

32

39−> Whenever you add Content to a repository containing notice of a license, you license that Content under the same terms, and you agree that you have the right to license that Content under those terms. If you have a separate agreement to license that Content under different terms, such as a contributor license agreement, that agreement will supersede.

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

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

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

36+features.

40

37

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

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

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

41+your changes maintain this compatibility.

41

42

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

.github/PULL_REQUEST_TEMPLATE.mddeleted−18

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

1−

2−**Quick Summary:** ???

3−

4−

5−## SSCCE

6−

7−```elm

8−

9−```

10−

11−- **Elm:** ???

12−- **Browser:** ???

13−- **Operating System:** ???

14−

15−

16−## Additional Details

17−

18−???

.github/workflows/set-issue-expectations.ymldeleted−21

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

1−name: Set Issue Expectations

2−on:

3− issues:

4− types: [opened]

5−jobs:

6− comment-on-issue:

7− name: Comment On Issue

8− runs-on: ubuntu-latest

9− steps:

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

11− env:

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

13− with:

14− args: |

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

16−

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

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

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

20−

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

.github/workflows/set-pull-expectations.ymldeleted−19

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

1−on:

2− pull_request_target:

3− types: [opened]

4−

5−jobs:

6− comment-on-pull:

7− name: Comment On Pull

8− runs-on: ubuntu-latest

9− steps:

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

11− with:

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

13− script: |

14− github.issues.createComment({

15− issue_number: context.issue.number,

16− owner: context.repo.owner,

17− repo: context.repo.repo,

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

19− })

.gitignore−1

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

5cabal.sandbox.config

6.DS_Store

7*~

8−travis.log

.travis.ymldeleted−28

@@ -1,28 +0,0 @@

1−language: minimal

2−services: docker

3−

4−env:

5− global:

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

7−

8−before_install:

9− - docker build -t elm -f installers/linux/Dockerfile .

10− - docker cp $(docker create elm):/usr/local/bin/elm .

11− - gzip -9 -c elm > $LINUX_ARCHIVE

12−

13−deploy:

14− provider: releases

15− api_key:

16− secure: Yz2Lo4u9rZQ7Ee7ohAsrZpkqsYDUerCSMdSQIH8ryrf7phHhiloPEkTKsM+NupHqU/LEAVsunxbau4QrCEjA2vPavAPVk8cKomRUWK/YjbXHKa24hPkal2c+A2bnMQ6w3qYk/PjL9rW+Goq++/SNLcYZwHBV0Chl2blivMwWCSA=

17− file: $LINUX_ARCHIVE

18− skip_cleanup: true

19− on:

20− branch: master

21− tags: true

22−

23−notifications:

24− email:

25− recipients:

26− - rlefevre@dmy.fr

27− on_success: change

28− on_failure: change

ContributorAgreement.pdfnew file

Binary file not shown.

LICENSE+25−6

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

2

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

4

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

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

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

6

7

8+ * Redistributions of source code must retain the above copyright

7−2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

9+ notice, this list of conditions and the following disclaimer.

8

10

9−3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.

11+ * Redistributions in binary form must reproduce the above

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

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

14+ with the distribution.

10

15

11−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

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

18+ from this software without specific prior written permission.

19+

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

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

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

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

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

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

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

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

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

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

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

README.md+5−10

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

1−# Elm

1+# The Elm Compiler

2

3−A delightful language for reliable webapps.

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

4

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

6−

7−

8−<br>

9

5

10## Install

6## Install

11

7

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

8+Follow [these instructions][installer]!

13

9

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

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

15

11

16−<br>

17

12

18## Help

13## Help

19

14

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

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

21

16

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

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

builder/src/BackgroundWriter.hsdeleted−42

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

1−{-# LANGUAGE BangPatterns #-}

2−module BackgroundWriter

3− ( Scope

4− , withScope

5− , writeBinary

6− )

7− where

8−

9−

10−import Control.Concurrent (forkIO)

11−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)

12−import qualified Data.Binary as Binary

13−import Data.Foldable (traverse_)

14−

15−import qualified File

16−

17−

18−

19−-- BACKGROUND WRITER

20−

21−

22−newtype Scope =

23− Scope (MVar [MVar ()])

24−

25−

26−withScope :: (Scope -> IO a) -> IO a

27−withScope callback =

28− do workList <- newMVar []

29− result <- callback (Scope workList)

30− mvars <- takeMVar workList

31− traverse_ takeMVar mvars

32− return result

33−

34−

35−writeBinary :: (Binary.Binary a) => Scope -> FilePath -> a -> IO ()

36−writeBinary (Scope workList) path value =

37− do mvar <- newEmptyMVar

38− _ <- forkIO (File.writeBinary path value >> putMVar mvar ())

39− oldWork <- takeMVar workList

40− let !newWork = mvar:oldWork

41− putMVar workList newWork

42−

builder/src/Build.hs+333−645

@@ -1,16 +1,12 @@

1{-# OPTIONS_GHC -Wno-unused-do-bind #-}

2−{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}

2+{-# LANGUAGE BangPatterns #-}

3module Build

4 ( fromExposed

5− , fromPaths

5+ , fromMains

6− , fromRepl

7 , Artifacts(..)

6 , Artifacts(..)

8− , Root(..)

7+ , Main(..)

9 , Module(..)

8 , Module(..)

10 , CachedInterface(..)

9 , CachedInterface(..)

11− , ReplArtifacts(..)

12− , DocsGoal(..)

13− , getRootNames

14 )

10 )

15 where

11 where

16

12

@@ -18,8 +14,8 @@ module Build

18import Control.Concurrent (forkIO)

14import Control.Concurrent (forkIO)

19import Control.Concurrent.MVar

15import Control.Concurrent.MVar

20import Control.Monad (filterM, mapM_, sequence_)

16import Control.Monad (filterM, mapM_, sequence_)

21−import qualified Data.ByteString as B

22import qualified Data.Char as Char

17import qualified Data.Char as Char

18+import qualified Data.Either as Either

23import qualified Data.Graph as Graph

19import qualified Data.Graph as Graph

24import qualified Data.List as List

20import qualified Data.List as List

25import qualified Data.Map.Utils as Map

21import qualified Data.Map.Utils as Map

@@ -29,32 +25,25 @@ import qualified Data.Maybe as Maybe

29import qualified Data.Name as Name

25import qualified Data.Name as Name

30import qualified Data.NonEmptyList as NE

26import qualified Data.NonEmptyList as NE

31import qualified Data.OneOrMore as OneOrMore

27import qualified Data.OneOrMore as OneOrMore

32−import qualified Data.Set as Set

33import qualified System.Directory as Dir

28import qualified System.Directory as Dir

34import qualified System.FilePath as FP

29import qualified System.FilePath as FP

35import System.FilePath ((</>), (<.>))

30import System.FilePath ((</>), (<.>))

36

31

37−import qualified AST.Canonical as Can

38import qualified AST.Source as Src

32import qualified AST.Source as Src

39import qualified AST.Optimized as Opt

33import qualified AST.Optimized as Opt

40import qualified Compile

34import qualified Compile

41import qualified Elm.Details as Details

35import qualified Elm.Details as Details

42−import qualified Elm.Docs as Docs

43import qualified Elm.Interface as I

36import qualified Elm.Interface as I

44import qualified Elm.ModuleName as ModuleName

37import qualified Elm.ModuleName as ModuleName

45import qualified Elm.Outline as Outline

38import qualified Elm.Outline as Outline

46import qualified Elm.Package as Pkg

39import qualified Elm.Package as Pkg

47import qualified File

40import qualified File

48−import qualified Json.Encode as E

49import qualified Parse.Module as Parse

41import qualified Parse.Module as Parse

50import qualified Reporting

42import qualified Reporting

51import qualified Reporting.Annotation as A

43import 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

56import qualified Reporting.Exit as Exit

44import qualified Reporting.Exit as Exit

57−import qualified Reporting.Render.Type.Localizer as L

45+import qualified Reporting.Problem as Problem

46+import qualified Reporting.Render.Type.Localizer as Localizer

58import qualified Stuff

47import qualified Stuff

59

48

60

49

@@ -66,57 +55,27 @@ data Env =

66 Env

55 Env

67 { _key :: Reporting.BKey

56 { _key :: Reporting.BKey

68 , _root :: FilePath

57 , _root :: FilePath

69− , _project :: Parse.ProjectType

58+ , _pkg :: Pkg.Name

70− , _srcDirs :: [AbsoluteSrcDir]

59+ , _srcDirs :: [FilePath]

71− , _buildID :: Details.BuildID

72 , _locals :: Map.Map ModuleName.Raw Details.Local

60 , _locals :: Map.Map ModuleName.Raw Details.Local

73 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign

61 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign

74 }

62 }

75

63

76

64

77−makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env

65+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env

78−makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =

66+makeEnv key root (Details.Details _ validOutline locals foreigns _) =

79 case validOutline of

67 case validOutline of

80− Details.ValidApp givenSrcDirs ->

68+ Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->

81− do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)

82− return $ Env key root Parse.Application srcDirs buildID locals foreigns

69+ Env key root Pkg.dummyName srcDirs locals foreigns

83

70

84− Details.ValidPkg pkg _ _ ->

71+ Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->

85− do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")

86− return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns

72+ Env key root pkg ["src"] 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

73

111

74

112

75

113-- FORK

76-- FORK

114

77

115

78

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

120fork :: IO a -> IO (MVar a)

79fork :: IO a -> IO (MVar a)

121fork work =

80fork work =

122 do mvar <- newEmptyMVar

81 do mvar <- newEmptyMVar

@@ -134,22 +93,21 @@ forkWithKey func dict =

134-- FROM EXPOSED

93-- FROM EXPOSED

135

94

136

95

137−fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)

96+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())

138−fromExposed style root details docsGoal exposed@(NE.List e es) =

97+fromExposed style root details (NE.List e es) =

139 Reporting.trackBuild style $ \key ->

98 Reporting.trackBuild style $ \key ->

140− do env <- makeEnv key root details

99+ do let env = makeEnv key root details

141 dmvar <- Details.loadInterfaces root details

100 dmvar <- Details.loadInterfaces root details

142

101

143 -- crawl

102 -- crawl

144 mvar <- newEmptyMVar

103 mvar <- newEmptyMVar

145− let docsNeed = toDocsNeed docsGoal

146− roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)

104+ roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)

147 putMVar mvar roots

105 putMVar mvar roots

148 mapM_ readMVar roots

106 mapM_ readMVar roots

149 statuses <- traverse readMVar =<< readMVar mvar

107 statuses <- traverse readMVar =<< readMVar mvar

150

108

151 -- compile

109 -- compile

152− midpoint <- checkMidpoint dmvar statuses

110+ midpoint <- checkExposedMidpoint dmvar statuses

153 case midpoint of

111 case midpoint of

154 Left problem ->

112 Left problem ->

155 return (Left (Exit.BuildProjectProblem problem))

113 return (Left (Exit.BuildProjectProblem problem))

@@ -160,18 +118,18 @@ fromExposed style root details docsGoal exposed@(NE.List e es) =

160 putMVar rmvar resultMVars

118 putMVar rmvar resultMVars

161 results <- traverse readMVar resultMVars

119 results <- traverse readMVar resultMVars

162 writeDetails root details results

120 writeDetails root details results

163− finalizeExposed root docsGoal exposed results

121+ return (detectProblems results)

164

122

165

123

166

124

167−-- FROM PATHS

125+-- FROM MAINS

168

126

169

127

170data Artifacts =

128data Artifacts =

171 Artifacts

129 Artifacts

172 { _name :: Pkg.Name

130 { _name :: Pkg.Name

173 , _deps :: Dependencies

131 , _deps :: Dependencies

174− , _roots :: NE.List Root

132+ , _mains :: NE.List Main

175 , _modules :: [Module]

133 , _modules :: [Module]

176 }

134 }

177

135

@@ -185,25 +143,25 @@ type Dependencies =

185 Map.Map ModuleName.Canonical I.DependencyInterface

143 Map.Map ModuleName.Canonical I.DependencyInterface

186

144

187

145

188−fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)

146+fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)

189−fromPaths style root details paths =

147+fromMains style root details paths =

190 Reporting.trackBuild style $ \key ->

148 Reporting.trackBuild style $ \key ->

191− do env <- makeEnv key root details

149+ do let env = makeEnv key root details

192

150

193− elroots <- findRoots env paths

151+ elmains <- findMains env paths

194− case elroots of

152+ case elmains of

195 Left problem ->

153 Left problem ->

196 return (Left (Exit.BuildProjectProblem problem))

154 return (Left (Exit.BuildProjectProblem problem))

197

155

198− Right lroots ->

156+ Right lmains ->

199 do -- crawl

157 do -- crawl

200 dmvar <- Details.loadInterfaces root details

158 dmvar <- Details.loadInterfaces root details

201 smvar <- newMVar Map.empty

159 smvar <- newMVar Map.empty

202− srootMVars <- traverse (fork . crawlRoot env smvar) lroots

160+ smainMVars <- traverse (fork . crawlMain env smvar) lmains

203− sroots <- traverse readMVar srootMVars

161+ smains <- traverse readMVar smainMVars

204 statuses <- traverse readMVar =<< readMVar smvar

162 statuses <- traverse readMVar =<< readMVar smvar

205

163

206− midpoint <- checkMidpointAndRoots dmvar statuses sroots

164+ midpoint <- checkMainsMidpoint dmvar statuses smains

207 case midpoint of

165 case midpoint of

208 Left problem ->

166 Left problem ->

209 return (Left (Exit.BuildProjectProblem problem))

167 return (Left (Exit.BuildProjectProblem problem))

@@ -213,26 +171,10 @@ fromPaths style root details paths =

213 rmvar <- newEmptyMVar

171 rmvar <- newEmptyMVar

214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses

172 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses

215 putMVar rmvar resultsMVars

173 putMVar rmvar resultsMVars

216− rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots

174+ rmainMVars <- traverse (fork . checkMain env resultsMVars) smains

217 results <- traverse readMVar resultsMVars

175 results <- traverse readMVar resultsMVars

218 writeDetails root details results

176 writeDetails root details results

219− toArtifacts env foreigns results <$> traverse readMVar rrootMVars

177+ toArtifacts env foreigns results <$> traverse readMVar rmainMVars

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

178

237

179

238

180

@@ -245,9 +187,9 @@ type StatusDict =

245

187

246data Status

188data Status

247 = SCached Details.Local

189 = SCached Details.Local

248− | SChanged Details.Local B.ByteString Src.Module DocsNeed

190+ | SChanged Details.Local Src.Module

249− | SBadImport Import.Problem

191+ | SNotFound Problem.Find

250− | SBadSyntax FilePath File.Time B.ByteString Syntax.Error

192+ | SNotValid Problem.Syntax

251 | SForeign Pkg.Name

193 | SForeign Pkg.Name

252 | SKernel

194 | SKernel

253

195

@@ -262,34 +204,38 @@ crawlDeps env mvar deps blockedValue =

262 mapM_ readMVar statuses

204 mapM_ readMVar statuses

263 return blockedValue

205 return blockedValue

264 where

206 where

265− crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)

207+ crawlNew name () = fork (crawlModule env mvar name)

266

208

267

209

268−crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status

210+crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status

269−crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =

211+crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =

270 do let fileName = ModuleName.toFilePath name <.> "elm"

212 do let fileName = ModuleName.toFilePath name <.> "elm"

213+ let inRoot path = File.exists (root </> path)

271

214

272− paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)

215+ paths <- filterM inRoot (map (</> fileName) srcDirs)

273

216

274 case paths of

217 case paths of

275 [path] ->

218 [path] ->

276 case Map.lookup name foreigns of

219 case Map.lookup name foreigns of

277 Just (Details.Foreign dep deps) ->

220 Just (Details.Foreign dep deps) ->

278− return $ SBadImport $ Import.Ambiguous path [] dep deps

221+ return $ SNotFound $ Problem.Ambiguous path [] dep deps

279

222

280 Nothing ->

223 Nothing ->

281− do newTime <- File.getTime path

282− case Map.lookup name locals of

224+ case Map.lookup name locals of

283− Nothing ->

225+ Nothing ->

284− crawlFile env mvar docsNeed name path newTime buildID

226+ crawlFile env mvar name path

285

227

286− Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->

228+ Just local@(Details.Local oldPath oldTime deps _) ->

287− if path /= oldPath || oldTime /= newTime || needsDocs docsNeed

229+ if path /= oldPath

230+ then crawlFile env mvar name path

231+ else

232+ do newTime <- File.getTime path

233+ if oldTime < newTime

288− then crawlFile env mvar docsNeed name path newTime lastChange

234+ then crawlFile env mvar name path

289− else crawlDeps env mvar deps (SCached local)

235+ else crawlDeps env mvar deps (SCached local)

290

236

291 p1:p2:ps ->

237 p1:p2:ps ->

292− return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)

238+ return $ SNotFound $ Problem.AmbiguousLocal p1 p2 ps

293

239

294 [] ->

240 [] ->

295 case Map.lookup name foreigns of

241 case Map.lookup name foreigns of

@@ -299,43 +245,44 @@ crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar do

299 return $ SForeign dep

245 return $ SForeign dep

300

246

301 d:ds ->

247 d:ds ->

302− return $ SBadImport $ Import.AmbiguousForeign dep d ds

248+ return $ SNotFound $ Problem.AmbiguousForeign dep d ds

303

249

304 Nothing ->

250 Nothing ->

305− if Name.isKernel name && Parse.isKernel projectType then

251+ if Name.isKernel name && Pkg.isKernel pkg then

306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")

252 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")

307− return $ if exists then SKernel else SBadImport Import.NotFound

253+ return $ if exists then SKernel else SNotFound Problem.NotFound

308 else

254 else

309− return $ SBadImport Import.NotFound

255+ return $ SNotFound Problem.NotFound

310

256

311

257

312−crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status

258+crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status

313−crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =

259+crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =

260+ do time <- File.getTime path

314− do source <- File.readUtf8 (root </> path)

261+ bytes <- File.readUtf8 (root </> path)

315

262

316− case Parse.fromByteString projectType source of

263+ case Parse.fromByteString pkg bytes of

317− Left err ->

318− return $ SBadSyntax path time source err

319−

320− Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->

264+ Right modul@(Src.Module maybeActualName _ imports values _ _ _ _) ->

321 case maybeActualName of

265 case maybeActualName of

322− Nothing ->

323− return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)

324−

325− Just name@(A.At _ actualName) ->

266+ Just actualName ->

326 if expectedName == actualName then

267 if expectedName == actualName then

327 let

268 let

328 deps = map Src.getImportName imports

269 deps = map Src.getImportName imports

329− local = Details.Local path time deps (any isMain values) lastChange buildID

270+ local = Details.Local path time deps (any isMain values)

330 in

271 in

331− crawlDeps env mvar deps (SChanged local source modul docsNeed)

272+ crawlDeps env mvar deps (SChanged local modul)

332 else

273 else

333− return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)

274+ return $ SNotValid $ Problem.BadModuleName_Mismatch expectedName actualName

275+

276+ Nothing ->

277+ return $ SNotValid $ Problem.BadModuleName_Unspecified expectedName

278+

279+ Left syntaxError ->

280+ return $ SNotValid $ Problem.SyntaxProblem path time syntaxError

334

281

335

282

336isMain :: A.Located Src.Value -> Bool

283isMain :: A.Located Src.Value -> Bool

337isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =

284isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =

338− name == Name._main

285+ name == Name.main

339

286

340

287

341

288

@@ -347,11 +294,10 @@ type ResultDict =

347

294

348

295

349data Result

296data Result

350− = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)

297+ = RNew Details.Local I.Interface Opt.LocalGraph

351− | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)

298+ | RSame Details.Local I.Interface Opt.LocalGraph

352− | RCached Bool Details.BuildID (MVar CachedInterface)

299+ | RCached Bool (MVar CachedInterface)

353− | RNotFound Import.Problem

300+ | RProblem Problem.Problem

354− | RProblem Error.Module

355 | RBlocked

301 | RBlocked

356 | RForeign I.Interface

302 | RForeign I.Interface

357 | RKernel

303 | RKernel

@@ -364,68 +310,57 @@ data CachedInterface

364

310

365

311

366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result

312checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result

367−checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =

313+checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =

368 case status of

314 case status of

369− SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->

315+ SCached local@(Details.Local path time deps hasMain) ->

370 do results <- readMVar resultsMVar

316 do results <- readMVar resultsMVar

371− depsStatus <- checkDeps root results deps lastCompile

317+ depsStatus <- checkDeps root results deps

372 case depsStatus of

318 case depsStatus of

373 DepsChange ifaces ->

319 DepsChange ifaces ->

374− do source <- File.readUtf8 path

320+ do bytes <- File.readUtf8 path

375− case Parse.fromByteString projectType source of

321+ case Parse.fromByteString pkg bytes of

376− Right modul -> compile env (DocsNeed False) local source ifaces modul

322+ Right modul -> compile env local ifaces modul

377− Left err ->

323+ Left syntaxError ->

378− return $ RProblem $

324+ return $ RProblem $ Problem.BadSyntax $

379− Error.Module name path time source (Error.BadSyntax err)

325+ Problem.SyntaxProblem path time syntaxError

380

326

381 DepsSame _ _ ->

327 DepsSame _ _ ->

382 do mvar <- newMVar Unneeded

328 do mvar <- newMVar Unneeded

383− return (RCached hasMain lastChange mvar)

329+ return (RCached hasMain mvar)

384

330

385 DepsBlock ->

331 DepsBlock ->

386 return RBlocked

332 return RBlocked

387

333

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

334+ SChanged local@(Details.Local _ _ deps _) modul ->

399 do results <- readMVar resultsMVar

335 do results <- readMVar resultsMVar

400− depsStatus <- checkDeps root results deps lastCompile

336+ depsStatus <- checkDeps root results deps

401 case depsStatus of

337 case depsStatus of

402 DepsChange ifaces ->

338 DepsChange ifaces ->

403− compile env docsNeed local source ifaces modul

339+ compile env local ifaces modul

404

340

405 DepsSame same cached ->

341 DepsSame same cached ->

406− do maybeLoaded <- loadInterfaces root same cached

342+ do maybeLoaded <- checkCachedInterfaces root cached

407 case maybeLoaded of

343 case maybeLoaded of

344+ Nothing ->

408− Nothing -> return RBlocked

345+ return RBlocked

346+

347+ Just loaded ->

348+ do let ifaces = Map.union loaded (Map.fromList same)

409− Just ifaces -> compile env docsNeed local source ifaces modul

349+ compile env local ifaces modul

410

350

411 DepsBlock ->

351 DepsBlock ->

412 return RBlocked

352 return RBlocked

413

353

414− DepsNotFound problems ->

354+ SNotFound findProblem ->

415− return $ RProblem $ Error.Module name path time source $

355+ return (RProblem (Problem.BadFind findProblem))

416− Error.BadImports (toImportErrors env results imports problems)

417−

418− SBadImport importProblem ->

419− return (RNotFound importProblem)

420

356

421− SBadSyntax path time source err ->

357+ SNotValid syntaxProblem ->

422− return $ RProblem $ Error.Module name path time source $

358+ return (RProblem (Problem.BadSyntax syntaxProblem))

423− Error.BadSyntax err

424

359

425 SForeign home ->

360 SForeign home ->

426 case foreigns ! ModuleName.Canonical home name of

361 case foreigns ! ModuleName.Canonical home name of

427 I.Public iface -> return (RForeign iface)

362 I.Public iface -> return (RForeign iface)

428− I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name

363+ I.Private _ _ _ -> error "loading private interface in Build"

429

364

430 SKernel ->

365 SKernel ->

431 return RKernel

366 return RKernel

@@ -439,112 +374,71 @@ data DepsStatus

439 = DepsChange (Map.Map ModuleName.Raw I.Interface)

374 = DepsChange (Map.Map ModuleName.Raw I.Interface)

440 | DepsSame [Dep] [CDep]

375 | DepsSame [Dep] [CDep]

441 | DepsBlock

376 | DepsBlock

442− | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))

443

377

444

378

445−checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus

379+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus

446−checkDeps root results deps lastCompile =

380+checkDeps root results deps =

447− checkDepsHelp root results deps [] [] [] [] False 0 lastCompile

381+ checkDepsHelp root results deps [] [] []

448

382

449

383

450type Dep = (ModuleName.Raw, I.Interface)

384type Dep = (ModuleName.Raw, I.Interface)

451type CDep = (ModuleName.Raw, MVar CachedInterface)

385type CDep = (ModuleName.Raw, MVar CachedInterface)

452

386

453

387

454−checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus

388+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> IO DepsStatus

455−checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =

389+checkDepsHelp root results deps new same cached =

456 case deps of

390 case deps of

391+ [] ->

392+ if null new

393+ then return (DepsSame same cached)

394+ else

395+ do maybeLoaded <- checkCachedInterfaces root cached

396+ case maybeLoaded of

397+ Nothing ->

398+ return DepsBlock

399+

400+ Just loaded ->

401+ return $ DepsChange $

402+ Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))

403+

457 dep:otherDeps ->

404 dep:otherDeps ->

458 do result <- readMVar (results ! dep)

405 do result <- readMVar (results ! dep)

459 case result of

406 case result of

460− RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->

407+ RNew _ iface _ ->

461− checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile

408+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached

462

409

463− RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->

410+ RSame _ iface _ ->

464− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile

411+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached

465

412

466− RCached _ lastChange mvar ->

413+ RCached _ mvar ->

467− checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile

414+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached)

468−

469− RNotFound prob ->

470− checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile

471

415

472 RProblem _ ->

416 RProblem _ ->

473− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile

417+ return DepsBlock

474

418

475 RBlocked ->

419 RBlocked ->

476− checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile

420+ return DepsBlock

477

421

478 RForeign iface ->

422 RForeign iface ->

479− checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile

423+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached

480

424

481 RKernel ->

425 RKernel ->

482− checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile

426+ checkDepsHelp root results otherDeps new same cached

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

427

529

428

530

429

531−-- LOAD CACHED INTERFACES

430+-- CACHED INTERFACE

532

431

533

432

534−loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))

433+checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))

535−loadInterfaces root same cached =

434+checkCachedInterfaces root deps =

536− do loading <- traverse (fork . loadInterface root) cached

435+ do loading <- traverse (fork . checkCache root) deps

537− maybeLoaded <- traverse readMVar loading

436+ loaded <- traverse readMVar loading

538− case sequence maybeLoaded of

437+ return $ Map.fromList <$> sequence loaded

539− Nothing ->

540− return Nothing

541−

542− Just loaded ->

543− return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)

544

438

545

439

546−loadInterface :: FilePath -> CDep -> IO (Maybe Dep)

440+checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)

547−loadInterface root (name, ciMvar) =

441+checkCache root (name, ciMvar) =

548 do cachedInterface <- takeMVar ciMvar

442 do cachedInterface <- takeMVar ciMvar

549 case cachedInterface of

443 case cachedInterface of

550 Corrupted ->

444 Corrupted ->

@@ -571,8 +465,8 @@ loadInterface root (name, ciMvar) =

571-- CHECK PROJECT

465-- CHECK PROJECT

572

466

573

467

574−checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)

468+checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)

575−checkMidpoint dmvar statuses =

469+checkExposedMidpoint dmvar statuses =

576 case checkForCycles statuses of

470 case checkForCycles statuses of

577 Nothing ->

471 Nothing ->

578 do maybeForeigns <- readMVar dmvar

472 do maybeForeigns <- readMVar dmvar

@@ -585,11 +479,11 @@ checkMidpoint dmvar statuses =

585 return (Left (Exit.BP_Cycle name names))

479 return (Left (Exit.BP_Cycle name names))

586

480

587

481

588−checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)

482+checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)

589−checkMidpointAndRoots dmvar statuses sroots =

483+checkMainsMidpoint dmvar statuses smains =

590 case checkForCycles statuses of

484 case checkForCycles statuses of

591 Nothing ->

485 Nothing ->

592− case checkUniqueRoots statuses sroots of

486+ case checkUniqueMains statuses smains of

593 Nothing ->

487 Nothing ->

594 do maybeForeigns <- readMVar dmvar

488 do maybeForeigns <- readMVar dmvar

595 case maybeForeigns of

489 case maybeForeigns of

@@ -640,25 +534,25 @@ addToGraph name status graph =

640 let

534 let

641 dependencies =

535 dependencies =

642 case status of

536 case status of

643− SCached (Details.Local _ _ deps _ _ _) -> deps

537+ SCached (Details.Local _ _ deps _) -> deps

644− SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps

538+ SChanged (Details.Local _ _ deps _) _ -> deps

645− SBadImport _ -> []

539+ SNotFound _ -> []

646− SBadSyntax _ _ _ _ -> []

540+ SNotValid _ -> []

647− SForeign _ -> []

541+ SForeign _ -> []

648− SKernel -> []

542+ SKernel -> []

649 in

543 in

650 (name, name, dependencies) : graph

544 (name, name, dependencies) : graph

651

545

652

546

653

547

654−-- CHECK UNIQUE ROOTS

548+-- CHECK UNIQUE MAINS

655

549

656

550

657−checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem

551+checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem

658−checkUniqueRoots insides sroots =

552+checkUniqueMains insides smains =

659 let

553 let

660 outsidesDict =

554 outsidesDict =

661− Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))

555+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))

662 in

556 in

663 case Map.traverseWithKey checkOutside outsidesDict of

557 case Map.traverseWithKey checkOutside outsidesDict of

664 Left problem ->

558 Left problem ->

@@ -670,78 +564,61 @@ checkUniqueRoots insides sroots =

670 Left problem -> Just problem

564 Left problem -> Just problem

671

565

672

566

673−rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)

567+mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)

674−rootStatusToNamePathPair sroot =

568+mainStatusToNamePathPair smain =

675− case sroot of

569+ case smain of

676− SInside _ -> Nothing

570+ SInside _ -> Nothing

677− SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)

571+ SOutsideOk (Details.Local path _ _ _) modul -> Just (Src.getName modul, OneOrMore.one path)

678− SOutsideErr _ -> Nothing

572+ SOutsideErr _ -> Nothing

679

573

680

574

681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath

575checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath

682checkOutside name paths =

576checkOutside name paths =

683 case OneOrMore.destruct NE.List paths of

577 case OneOrMore.destruct NE.List paths of

684 NE.List p [] -> Right p

578 NE.List p [] -> Right p

685− NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)

579+ NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)

686

580

687

581

688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()

582checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()

689checkInside name p1 status =

583checkInside name p1 status =

690 case status of

584 case status of

691− SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)

585+ SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)

692− SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)

586+ SChanged (Details.Local p2 _ _ _) _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)

693− SBadImport _ -> Right ()

587+ SNotFound _ -> Right ()

694− SBadSyntax _ _ _ _ -> Right ()

588+ SNotValid _ -> Right ()

695− SForeign _ -> Right ()

589+ SForeign _ -> Right ()

696− SKernel -> Right ()

590+ SKernel -> Right ()

697

591

698

592

699

593

700-- COMPILE MODULE

594-- COMPILE MODULE

701

595

702

596

703−compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result

597+compile :: Env -> Details.Local -> 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 =

598+compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) ifaces modul =

705− let

706− pkg = projectTypeToPkg projectType

707− in

708 case Compile.compile pkg ifaces modul of

599 case Compile.compile pkg ifaces modul of

709 Right (Compile.Artifacts canonical annotations objects) ->

600 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

601+ do let name = Src.getName modul

717− let iface = I.fromModule pkg canonical annotations

602+ let iface = I.fromModule pkg canonical annotations

718− let elmi = Stuff.elmi root name

719− File.writeBinary (Stuff.elmo root name) objects

603+ File.writeBinary (Stuff.elmo root name) objects

720− maybeOldi <- File.readBinary elmi

604+ maybeOldi <- File.readBinary (Stuff.elmi root name)

721− case maybeOldi of

605+ case maybeOldi of

722− Just oldi | oldi == iface ->

606+ Just oldi | oldi == iface ->

723− do -- iface should be fully forced by equality check

607+ do -- iface should be fully forced by equality check

724− Reporting.report key Reporting.BDone

608+ Reporting.report key Reporting.BDone

725− let local = Details.Local path time deps main lastChange buildID

726− return (RSame local iface objects docs)

609+ return (RSame local iface objects)

727−

610+

728− _ ->

611+ _ ->

729− do -- iface may be lazy still

612+ do -- iface may be lazy still

613+ -- TODO try adding forkIO here

730− File.writeBinary elmi iface

614+ File.writeBinary (Stuff.elmi root name) iface

731− Reporting.report key Reporting.BDone

615+ Reporting.report key Reporting.BDone

732− let local = Details.Local path time deps main buildID buildID

733− return (RNew local iface objects docs)

616+ return (RNew local iface objects)

734−

617+

735− Left err ->

618+ Left errors ->

619+ do Reporting.report key Reporting.BDone

736− return $ RProblem $

620+ return $ RProblem $ Problem.BadContent $

737− Error.Module (Src.getName modul) path time source err

621+ Problem.Module (Src.getName modul) path time errors (Localizer.fromModule modul)

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

622

746

623

747

624

@@ -749,210 +626,44 @@ projectTypeToPkg projectType =

749

626

750

627

751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()

628writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()

752−writeDetails root (Details.Details time outline buildID locals foreigns extras) results =

629+writeDetails root (Details.Details time outline locals foreigns extras) results =

753 File.writeBinary (Stuff.details root) $

630 File.writeBinary (Stuff.details root) $

754− Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras

631+ Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras

755

632

756

633

757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local

634addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local

758addNewLocal name result locals =

635addNewLocal name result locals =

759 case result of

636 case result of

760− RNew local _ _ _ -> Map.insert name local locals

637+ RNew local _ _ -> Map.insert name local locals

761− RSame local _ _ _ -> Map.insert name local locals

638+ RSame local _ _ -> Map.insert name local locals

762− RCached _ _ _ -> locals

639+ RCached _ _ -> locals

763− RNotFound _ -> locals

764− RProblem _ -> locals

640+ RProblem _ -> locals

765− RBlocked -> locals

641+ RBlocked -> locals

766− RForeign _ -> locals

642+ RForeign _ -> locals

767− RKernel -> locals

643+ RKernel -> locals

768−

769

644

770

645

771−-- FINALIZE EXPOSED

772

646

647+-- DETECT PROBLEMS

773

648

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

649

780− [] ->

650+detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()

651+detectProblems results =

781− case Map.foldr addErrors [] results of

652+ case Map.foldr addProblem [] results of

782− [] -> Right <$> finalizeDocs docsGoal results

653+ [] -> Right ()

783− e:es -> return $ Left $ Exit.BuildBadModules root e es

654+ p:ps -> Left (Exit.BuildModuleProblems p ps)

784

655

785

656

786−addErrors :: Result -> [Error.Module] -> [Error.Module]

657+addProblem :: Result -> [Problem.Problem] -> [Problem.Problem]

787−addErrors result errors =

658+addProblem result problems =

788 case result of

659 case result of

789− RNew _ _ _ _ -> errors

660+ RNew _ _ _ -> problems

790− RSame _ _ _ _ -> errors

661+ RSame _ _ _ -> problems

791− RCached _ _ _ -> errors

662+ RCached _ _ -> problems

792− RNotFound _ -> errors

793− RProblem e -> e:errors

663+ RProblem p -> p:problems

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

664+ RBlocked -> problems

808− RForeign _ -> problems

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

666+ RKernel -> problems

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

667

957

668

958

669

@@ -964,25 +675,25 @@ finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Mod

964

675

965

676

966

677

967−-- FIND ROOT

678+-- FIND MAIN

968

679

969

680

970−data RootLocation

681+data MainLocation

971 = LInside ModuleName.Raw

682 = LInside ModuleName.Raw

972 | LOutside FilePath

683 | LOutside FilePath

973

684

974

685

975−findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))

686+findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))

976−findRoots env paths =

687+findMains env paths =

977− do mvars <- traverse (fork . getRootInfo env) paths

688+ do mvars <- traverse (fork . findLocation env) paths

978− einfos <- traverse readMVar mvars

689+ elocs <- traverse readMVar mvars

979− return $ checkRoots =<< sequence einfos

690+ return $ checkLocations =<< sequence elocs

980

691

981

692

982−checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)

693+checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)

983−checkRoots infos =

694+checkLocations locations =

984 let

695 let

985− toOneOrMore loc@(RootInfo absolute _ _) =

696+ toOneOrMore loc@(Location absolute _ _) =

986 (absolute, OneOrMore.one loc)

697 (absolute, OneOrMore.one loc)

987

698

988 fromOneOrMore loc locs =

699 fromOneOrMore loc locs =

@@ -990,83 +701,70 @@ checkRoots infos =

990 [] -> Right ()

701 [] -> Right ()

991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))

702 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))

992 in

703 in

993− fmap (\_ -> fmap _location infos) $

704+ fmap (\_ -> fmap _location locations) $

994 traverse (OneOrMore.destruct fromOneOrMore) $

705 traverse (OneOrMore.destruct fromOneOrMore) $

995− Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)

706+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)

996

707

997

708

998

709

999−-- ROOT INFO

710+-- LOCATIONS

1000

711

1001

712

1002−data RootInfo =

713+data Location =

1003− RootInfo

714+ Location

1004 { _absolute :: FilePath

715 { _absolute :: FilePath

1005 , _relative :: FilePath

716 , _relative :: FilePath

1006− , _location :: RootLocation

717+ , _location :: MainLocation

1007 }

718 }

1008

719

1009

720

1010−getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)

721+findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)

1011−getRootInfo env path =

722+findLocation env path =

1012 do exists <- File.exists path

723 do exists <- File.exists path

1013 if exists

724 if exists

1014− then getRootInfoHelp env path =<< Dir.canonicalizePath path

725+ then isInsideSrcDirs env path <$> Dir.canonicalizePath path

1015 else return (Left (Exit.BP_PathUnknown path))

726 else return (Left (Exit.BP_PathUnknown path))

1016

727

1017

728

1018−getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)

729+isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location

1019−getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =

730+isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =

1020 let

731 let

1021 (dirs, file) = FP.splitFileName absolutePath

732 (dirs, file) = FP.splitFileName absolutePath

1022− (final, ext) = FP.splitExtension file

733+ (final, ext) = break (=='.') file

1023 in

734 in

1024 if ext /= ".elm"

735 if ext /= ".elm"

1025− then

1026− return $ Left $ Exit.BP_WithBadExtension path

736+ then Left (Exit.BP_WithBadExtension path)

1027 else

737 else

1028 let

738 let

739+ roots = FP.splitDirectories root

1029− absoluteSegments = FP.splitDirectories dirs ++ [final]

740+ segments = FP.splitDirectories dirs ++ [final]

1030 in

741 in

1031− case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of

742+ case dropPrefix roots segments of

1032− [] ->

743+ Nothing ->

1033− return $ Right $ RootInfo absolutePath path (LOutside path)

744+ Right (Location absolutePath path (LOutside path))

1034−

745+

1035− [(_, Right names)] ->

746+ Just relativeSegments ->

1036− do let name = Name.fromChars (List.intercalate "." names)

747+ let

1037− matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs

748+ (exits, maybes) =

1038− case matchingDirs of

749+ Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)

1039− d1:d2:_ ->

750+ in

1040− do let p1 = addRelative d1 (FP.joinPath names <.> "elm")

751+ case (exits, Maybe.catMaybes maybes) of

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)

752+ (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))

1046−

753+ ([], []) -> Right (Location absolutePath path (LOutside path))

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

754+ (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)

1052−

755+ (exit:_, _) -> Left exit

1053−

756+

1054−

757+

1055−isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool

758+isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))

1056−isInsideSrcDirByName names srcDir =

759+isInsideSrcDirsHelp segments 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

760 case dropPrefix (FP.splitDirectories srcDir) segments of

1063 Nothing ->

761 Nothing ->

1064− Nothing

762+ Right Nothing

1065

763

1066 Just names ->

764 Just names ->

1067 if all isGoodName names

765 if all isGoodName names

1068− then Just (srcDir, Right names)

766+ then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))

1069− else Just (srcDir, Left names)

767+ else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)

1070

768

1071

769

1072isGoodName :: [Char] -> Bool

770isGoodName :: [Char] -> Bool

@@ -1079,8 +777,6 @@ isGoodName name =

1079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars

777 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars

1080

778

1081

779

1082−-- INVARIANT: Dir.canonicalizePath has been run on both inputs

1083−--

1084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]

780dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]

1085dropPrefix roots paths =

781dropPrefix roots paths =

1086 case roots of

782 case roots of

@@ -1089,162 +785,154 @@ dropPrefix roots paths =

1089

785

1090 r:rs ->

786 r:rs ->

1091 case paths of

787 case paths of

1092− [] -> Nothing

788+ [] -> Nothing

1093 p:ps -> if r == p then dropPrefix rs ps else Nothing

789 p:ps -> if r == p then dropPrefix rs ps else Nothing

1094

790

1095

791

1096

792

1097−-- CRAWL ROOTS

793+-- CRAWL MAINS

1098

794

1099

795

1100−data RootStatus

796+data MainStatus

1101 = SInside ModuleName.Raw

797 = SInside ModuleName.Raw

1102− | SOutsideOk Details.Local B.ByteString Src.Module

798+ | SOutsideOk Details.Local Src.Module

1103− | SOutsideErr Error.Module

799+ | SOutsideErr Problem.Syntax

1104

800

1105

801

1106−crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus

802+crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus

1107−crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =

803+crawlMain env@(Env _ _ pkg _ _ _) mvar given =

1108− case root of

804+ case given of

1109 LInside name ->

805 LInside name ->

1110 do statusMVar <- newEmptyMVar

806 do statusMVar <- newEmptyMVar

1111 statusDict <- takeMVar mvar

807 statusDict <- takeMVar mvar

1112 putMVar mvar (Map.insert name statusMVar statusDict)

808 putMVar mvar (Map.insert name statusMVar statusDict)

1113− putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name

809+ putMVar statusMVar =<< crawlModule env mvar name

1114 return (SInside name)

810 return (SInside name)

1115

811

1116 LOutside path ->

812 LOutside path ->

1117 do time <- File.getTime path

813 do time <- File.getTime path

1118− source <- File.readUtf8 path

814+ bytes <- File.readUtf8 path

1119− case Parse.fromByteString projectType source of

815+ case Parse.fromByteString pkg bytes of

1120− Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->

816+ Right modul@(Src.Module _ _ imports values _ _ _ _) ->

1121 do let deps = map Src.getImportName imports

817 do let deps = map Src.getImportName imports

1122− let local = Details.Local path time deps (any isMain values) buildID buildID

818+ let local = Details.Local path time deps (any isMain values)

1123− crawlDeps env mvar deps (SOutsideOk local source modul)

819+ crawlDeps env mvar deps (SOutsideOk local modul)

1124

820

1125 Left syntaxError ->

821 Left syntaxError ->

1126− return $ SOutsideErr $

822+ return (SOutsideErr (Problem.SyntaxProblem path time syntaxError))

1127− Error.Module "???" path time source (Error.BadSyntax syntaxError)

1128

823

1129

824

1130

825

1131−-- CHECK ROOTS

826+-- CHECK MAINS

1132

827

1133

828

1134−data RootResult

829+data MainResult

1135 = RInside ModuleName.Raw

830 = RInside ModuleName.Raw

1136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph

831 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph

1137− | ROutsideErr Error.Module

832+ | ROutsideErr Problem.Problem

1138 | ROutsideBlocked

833 | ROutsideBlocked

1139

834

1140

835

1141−checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult

836+checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult

1142−checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =

837+checkMain env@(Env _ root _ _ _ _) results pendingMain =

1143− case rootStatus of

838+ case pendingMain of

1144 SInside name ->

839 SInside name ->

1145 return (RInside name)

840 return (RInside name)

1146

841

1147− SOutsideErr err ->

842+ SOutsideErr syntaxProblem ->

1148− return (ROutsideErr err)

843+ return (ROutsideErr (Problem.BadSyntax syntaxProblem))

1149

844

1150− SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->

845+ SOutsideOk local@(Details.Local _ _ deps _) modul ->

1151− do depsStatus <- checkDeps root results deps lastCompile

846+ do depsStatus <- checkDeps root results deps

1152 case depsStatus of

847 case depsStatus of

1153 DepsChange ifaces ->

848 DepsChange ifaces ->

1154− compileOutside env local source ifaces modul

849+ return $ compileOutside env local ifaces modul

1155

850

1156 DepsSame same cached ->

851 DepsSame same cached ->

1157− do maybeLoaded <- loadInterfaces root same cached

852+ do maybeLoaded <- checkCachedInterfaces root cached

1158 case maybeLoaded of

853 case maybeLoaded of

854+ Nothing ->

1159− Nothing -> return ROutsideBlocked

855+ return ROutsideBlocked

856+

857+ Just loaded ->

858+ do let ifaces = Map.union loaded (Map.fromList same)

1160− Just ifaces -> compileOutside env local source ifaces modul

859+ return $ compileOutside env local ifaces modul

1161

860

1162 DepsBlock ->

861 DepsBlock ->

1163 return ROutsideBlocked

862 return ROutsideBlocked

1164

863

1165− DepsNotFound problems ->

1166− return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $

1167− Error.BadImports (toImportErrors env results imports problems)

1168−

1169

864

1170−compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult

865+compileOutside :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult

1171−compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =

866+compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) ifaces modul =

1172 let

867 let

1173− pkg = projectTypeToPkg projectType

1174 name = Src.getName modul

868 name = Src.getName modul

1175 in

869 in

1176 case Compile.compile pkg ifaces modul of

870 case Compile.compile pkg ifaces modul of

1177 Right (Compile.Artifacts canonical annotations objects) ->

871 Right (Compile.Artifacts canonical annotations objects) ->

1178− do Reporting.report key Reporting.BDone

1179− return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects

872+ ROutsideOk name (I.fromModule pkg canonical annotations) objects

1180

873

1181 Left errors ->

874 Left errors ->

875+ ROutsideErr $ Problem.BadContent $

1182− return $ ROutsideErr $ Error.Module name path time source errors

876+ Problem.Module name path time errors (Localizer.fromModule modul)

1183

877

1184

878

1185

879

1186-- TO ARTIFACTS

880-- TO ARTIFACTS

1187

881

1188

882

1189−data Root

883+data Main

1190 = Inside ModuleName.Raw

884 = Inside ModuleName.Raw

1191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph

885 | Outside ModuleName.Raw I.Interface Opt.LocalGraph

1192

886

1193

887

1194−toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts

888+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts

1195−toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =

889+toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =

1196− case gatherProblemsOrMains results rootResults of

890+ case gatherProblemsOrMains results mainResults of

1197− Left (NE.List e es) ->

891+ Left (NE.List p ps) ->

1198− Left (Exit.BuildBadModules root e es)

892+ Left (Exit.BuildModuleProblems p ps)

1199

893

1200− Right roots ->

894+ Right mains ->

1201− Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $

895+ Right $ Artifacts pkg foreigns mains $

1202− Map.foldrWithKey addInside (foldr addOutside [] rootResults) results

896+ Map.foldrWithKey addInside (foldr addOutside [] mainResults) results

1203

897

1204

898

1205−gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)

899+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Problem.Problem) (NE.List Main)

1206−gatherProblemsOrMains results (NE.List rootResult rootResults) =

900+gatherProblemsOrMains results (NE.List mainResult mainResults) =

1207 let

901 let

1208− addResult result (es, roots) =

902+ sortMain result (ps, mains) =

1209 case result of

903 case result of

1210− RInside n -> ( es, Inside n : roots)

904+ RInside n -> ( ps, Inside n : mains)

1211− ROutsideOk n i o -> ( es, Outside n i o : roots)

905+ ROutsideOk n i o -> ( ps, Outside n i o : mains)

1212− ROutsideErr e -> (e:es, roots)

906+ ROutsideErr p -> (p:ps, mains)

1213− ROutsideBlocked -> ( es, roots)

907+ ROutsideBlocked -> ( ps, mains)

1214

908

1215− errors = Map.foldr addErrors [] results

909+ problems = Map.foldr addProblem [] results

1216 in

910 in

1217− case (rootResult, foldr addResult (errors, []) rootResults) of

911+ case (mainResult, foldr sortMain (problems, []) mainResults) of

1218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)

912 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)

1219− (RInside _ , (e:es, _ )) -> Left (NE.List e es)

913+ (RInside _ , (p:ps, _ )) -> Left (NE.List p ps)

1220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)

914 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)

1221− (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)

915+ (ROutsideOk _ _ _, (p:ps, _ )) -> Left (NE.List p ps)

1222− (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)

916+ (ROutsideErr p , ( ps, _ )) -> Left (NE.List p ps)

1223 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"

917 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"

1224− (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)

918+ (ROutsideBlocked , (p:ps, _ )) -> Left (NE.List p ps)

1225

919

1226

920

1227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]

921addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]

1228addInside name result modules =

922addInside name result modules =

1229 case result of

923 case result of

1230− RNew _ iface objs _ -> Fresh name iface objs : modules

924+ RNew _ iface objs -> Fresh name iface objs : modules

1231− RSame _ iface objs _ -> Fresh name iface objs : modules

925+ RSame _ iface objs -> Fresh name iface objs : modules

1232− RCached main _ mvar -> Cached name main mvar : modules

926+ RCached main mvar -> Cached name main mvar : modules

1233− RNotFound _ -> error (badInside name)

1234− RProblem _ -> error (badInside name)

927+ RProblem _ -> error ("I missed the error in `" ++ Name.toChars name ++ "` module.")

1235− RBlocked -> error (badInside name)

928+ RBlocked -> error ("I missed the error in `" ++ Name.toChars name ++ "` module.")

1236− RForeign _ -> modules

929+ RForeign _ -> modules

1237− RKernel -> modules

930+ RKernel -> modules

1238−

931+

1239−

932+

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]

933+addOutside :: MainResult -> [Module] -> [Module]

1246−addOutside root modules =

934+addOutside main modules =

1247− case root of

935+ case main of

1248 RInside _ -> modules

936 RInside _ -> modules

1249 ROutsideOk name iface objs -> Fresh name iface objs : modules

937 ROutsideOk name iface objs -> Fresh name iface objs : modules

1250 ROutsideErr _ -> modules

938 ROutsideErr _ -> modules

builder/src/Deps/Bump.hsdeleted−37

@@ -1,37 +0,0 @@

1−module Deps.Bump

2− ( getPossibilities

3− )

4− where

5−

6−

7−import qualified Data.List as List

8−

9−import qualified Deps.Registry as Registry

10−import qualified Elm.Magnitude as M

11−import qualified Elm.Version as V

12−

13−

14−

15−-- GET POSSIBILITIES

16−

17−

18−getPossibilities :: Registry.KnownVersions -> [(V.Version, V.Version, M.Magnitude)]

19−getPossibilities (Registry.KnownVersions latest previous) =

20− let

21− allVersions = reverse (latest:previous)

22− minorPoints = map last (List.groupBy sameMajor allVersions)

23− patchPoints = map last (List.groupBy sameMinor allVersions)

24− in

25− (latest, V.bumpMajor latest, M.MAJOR)

26− : map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints

27− ++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints

28−

29−

30−sameMajor :: V.Version -> V.Version -> Bool

31−sameMajor (V.Version major1 _ _) (V.Version major2 _ _) =

32− major1 == major2

33−

34−

35−sameMinor :: V.Version -> V.Version -> Bool

36−sameMinor (V.Version major1 minor1 _) (V.Version major2 minor2 _) =

37− major1 == major2 && minor1 == minor2

builder/src/Deps/Diff.hs+5−7

@@ -18,7 +18,7 @@ import qualified Data.List as List

18import qualified Data.Map as Map

19import qualified Data.Name as Name

20import qualified Data.Set as Set

21−import qualified System.Directory as Dir

21+import qualified Data.Utf8 as Utf8

22import System.FilePath ((</>))

23

24import qualified Deps.Website as Website

@@ -204,7 +204,7 @@ isSameName :: Name.Name -> Name.Name -> Bool

204isSameName oldFullName newFullName =

205 let

206 dedot name =

207− reverse (Name.splitDots name)

207+ reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))

208 in

209 case ( dedot oldFullName, dedot newFullName ) of

210 (oldName:[], newName:_) ->

@@ -357,8 +357,7 @@ changeMagnitude (Changes added changed removed) =

357

358getDocs :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.DocsProblem Docs.Documentation)

359getDocs cache manager name version =

360− do let home = Stuff.package cache name version

360+ do let path = Stuff.package cache name version </> "docs.json"

361− let path = home </> "docs.json"

362 exists <- File.exists path

361 exists <- File.exists path

363 if exists

362 if exists

364 then

363 then

@@ -375,9 +374,8 @@ getDocs cache manager name version =

375 Http.get manager url [] Exit.DP_Http $ \body ->

374 Http.get manager url [] Exit.DP_Http $ \body ->

376 case D.fromByteString Docs.decoder body of

375 case D.fromByteString Docs.decoder body of

377 Right docs ->

376 Right docs ->

378− do Dir.createDirectoryIfMissing True home

379− File.writeUtf8 path body

377+ do File.writeUtf8 path body

380 return $ Right docs

378 return $ Right docs

381

379

382 Left _ ->

380 Left _ ->

383− return $ Left $ Exit.DP_Data url body

381+ return $ Left Exit.DP_Data

builder/src/Deps/Plan.hsnew file+64

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

1+module Install.Plan where

2+

3+import qualified Data.Map as Map

4+

5+import qualified Elm.Package.Solution as S

6+import qualified Elm.Package as Package

7+

8+

9+data Plan =

10+ Plan

11+ { installs :: Map.Map Package.Name Package.Version

12+ , upgrades :: Map.Map Package.Name (Package.Version, Package.Version)

13+ , removals :: Map.Map Package.Name Package.Version

14+ }

15+

16+

17+create :: S.Solution -> S.Solution -> Plan

18+create old new =

19+ Plan

20+ { installs = Map.difference new old

21+ , upgrades = discardNoOps (Map.intersectionWith (,) old new)

22+ , removals = Map.difference old new

23+ }

24+ where

25+ discardNoOps updates =

26+ Map.mapMaybe isChanged updates

27+

28+ isChanged upgrade@(oldVersion,newVersion) =

29+ if oldVersion == newVersion

30+ then Nothing

31+ else Just upgrade

32+

33+

34+isEmpty :: Plan -> Bool

35+isEmpty (Plan installs upgrades removals) =

36+ Map.null installs

37+ && Map.null upgrades

38+ && Map.null removals

39+

40+

41+-- DISPLAY

42+

43+display :: Plan -> String

44+display (Plan installs upgrades removals) =

45+ "\n"

46+ ++ displayCategory "Install" displayInstall installs

47+ ++ displayCategory "Upgrade" displayUpgrade upgrades

48+ ++ displayCategory "Remove" displayRemove removals

49+ where

50+ displayCategory name render category =

51+ if Map.null category then "" else

52+ " " ++ name ++ ":"

53+ ++ concatMap (\entry -> "\n " ++ render entry) (Map.toList category)

54+ ++ "\n"

55+

56+ displayInstall (name, version) =

57+ Package.toString name ++ " " ++ Package.versionToString version

58+

59+ displayUpgrade (name, (old, new)) =

60+ Package.toString name ++ " ("

61+ ++ Package.versionToString old ++ " => " ++ Package.versionToString new ++ ")"

62+

63+ displayRemove (name, _version) =

64+ Package.toString name

builder/src/Deps/Registry.hs+68−35

@@ -16,8 +16,11 @@ module Deps.Registry

16import Prelude hiding (read)

17import Control.Monad (liftM2)

18import Data.Binary (Binary, get, put)

19+import Data.Function (on)

19import qualified Data.List as List

20import qualified Data.List as List

20import qualified Data.Map.Strict as Map

21import qualified Data.Map.Strict as Map

22+import qualified Data.Name as Name

23+import qualified Data.Utf8 as Utf8

21

24

22import qualified Deps.Website as Website

25import qualified Deps.Website as Website

23import qualified Elm.Package as Pkg

26import qualified Elm.Package as Pkg

@@ -25,8 +28,8 @@ import qualified Elm.Version as V

25import qualified File

28import qualified File

26import qualified Http

29import qualified Http

27import qualified Json.Decode as D

30import qualified Json.Decode as D

28−import qualified Parse.Primitives as P

29import qualified Reporting.Exit as Exit

31import qualified Reporting.Exit as Exit

32+import qualified Reporting.Suggest as Suggest

30import qualified Stuff

33import qualified Stuff

31

34

32

35

@@ -54,7 +57,11 @@ data KnownVersions =

54

57

55read :: Stuff.PackageCache -> IO (Maybe Registry)

58read :: Stuff.PackageCache -> IO (Maybe Registry)

56read cache =

59read cache =

57− File.readBinary (Stuff.registry cache)

60+ do let path = Stuff.registry cache

61+ exists <- File.exists path

62+ if exists

63+ then File.readBinary path

64+ else return Nothing

58

65

59

66

60

67

@@ -79,19 +86,26 @@ addEntry (KnownVersions _ vs) count =

79

86

80allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)

87allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)

81allPkgsDecoder =

88allPkgsDecoder =

82− let

89+ do pairs <- D.pairs (D.list (D.mapError (\_ -> ()) V.decoder))

83− keyDecoder =

90+ checkKeys pairs Map.empty

84− Pkg.keyDecoder bail

91+ where

92+ checkKeys pairs pkgs =

93+ case pairs of

94+ [] ->

95+ return pkgs

85

96

86− versionsDecoder =

97+ (key, versions) : rest ->

87− D.list (D.mapError (\_ -> ()) V.decoder)

98+ case Pkg.fromString key of

99+ Right pkg ->

100+ case List.sortBy (flip compare) versions of

101+ [] ->

102+ D.failure ()

88

103

89− toKnownVersions versions =

104+ v:vs ->

90− case List.sortBy (flip compare) versions of

91− v:vs -> return (KnownVersions v vs)

105+ checkKeys rest (Map.insert pkg (KnownVersions v vs) pkgs)

106+

107+ Left _ ->

92− [] -> D.failure ()

108+ D.failure ()

93− in

94− D.dict keyDecoder (toKnownVersions =<< versionsDecoder)

95

109

96

110

97

111

@@ -130,26 +144,22 @@ addNew (name, version) versions =

130 Map.alter (Just . add) name versions

144 Map.alter (Just . add) name versions

131

145

132

146

133−

134−-- NEW PACKAGE DECODER

135−

136−

137newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)

147newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)

138newPkgDecoder =

148newPkgDecoder =

139− D.customString newPkgParser bail

149+ do str <- D.string

140−

150+ case Utf8.split 0x40 {-@-} str of

151+ [key, value] ->

152+ case Pkg.fromString key of

153+ Right pkg ->

154+ case V.fromString value of

155+ Just vsn -> return (pkg, vsn)

156+ Nothing -> D.failure ()

141

157

142−newPkgParser :: P.Parser () (Pkg.Name, V.Version)

158+ Left _ ->

143−newPkgParser =

159+ D.failure ()

144− do pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser

145− P.word1 0x40 {-@-} bail

146− vsn <- P.specialize (\_ _ _ -> ()) V.parser

147− return (pkg, vsn)

148

160

149−

161+ _ ->

150−bail :: row -> col -> ()

162+ D.failure ()

151−bail _ _ =

152− ()

153

163

154

164

155

165

@@ -180,7 +190,33 @@ getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions

180getVersions' name (Registry _ versions) =

190getVersions' name (Registry _ versions) =

181 case Map.lookup name versions of

191 case Map.lookup name versions of

182 Just kvs -> Right kvs

192 Just kvs -> Right kvs

183− Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)

193+ Nothing -> Left $ nearbyNames name (Map.keys versions)

194+

195+

196+nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]

197+nearbyNames (Pkg.Name author1 project1) possibleNames =

198+ let

199+ authorDist = authorDistance (Name.toChars author1)

200+ projectDist = projectDistance (Name.toChars project1)

201+

202+ addDistance name@(Pkg.Name author2 project2) =

203+ ( authorDist author2 + projectDist project2, name )

204+ in

205+ map snd $ take 4 $

206+ List.sortBy (compare `on` fst) $

207+ map addDistance possibleNames

208+

209+

210+authorDistance :: String -> Name.Name -> Int

211+authorDistance bad possibility =

212+ abs (Suggest.distance bad (Name.toChars possibility))

213+

214+

215+projectDistance :: String -> Name.Name -> Int

216+projectDistance bad possibility =

217+ if possibility == "elm" || possibility == "elm-explorations"

218+ then 0

219+ else abs (Suggest.distance bad (Name.toChars possibility))

184

220

185

221

186

222

@@ -189,14 +225,11 @@ getVersions' name (Registry _ versions) =

189

225

190post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)

226post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)

191post manager path decoder callback =

227post manager path decoder callback =

192− let

193− url = Website.route path []

194− in

195− Http.post manager url [] Exit.RP_Http $

228+ Http.post manager (Website.route path []) [] Exit.RP_Http $

196 \body ->

229 \body ->

197 case D.fromByteString decoder body of

230 case D.fromByteString decoder body of

198 Right a -> Right <$> callback a

231 Right a -> Right <$> callback a

199− Left _ -> return $ Left $ Exit.RP_Data url body

232+ Left _ -> return $ Left Exit.RP_Data

200

233

201

234

202

235

builder/src/Deps/Solver.hs+29−31

@@ -94,7 +94,6 @@ data Details =

94

95verify :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))

96verify cache connection registry constraints =

97− Stuff.withRegistryLock cache $

98 case try constraints of

97 case try constraints of

99 Solver solver ->

98 Solver solver ->

100 solver (State cache connection registry Map.empty)

99 solver (State cache connection registry Map.empty)

@@ -131,7 +130,6 @@ data AppSolution =

131

130

132addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)

131addToApp :: Stuff.PackageCache -> Connection -> Registry.Registry -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)

133addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =

132addToApp cache connection registry pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =

134− Stuff.withRegistryLock cache $

135 let

133 let

136 allIndirects = Map.union indirect testIndirect

134 allIndirects = Map.union indirect testIndirect

137 allDirects = Map.union direct testDirect

135 allDirects = Map.union direct testDirect

@@ -313,11 +311,10 @@ getConstraints pkg vsn =

313 back state

311 back state

314

312

315 Online manager ->

313 Online manager ->

316− do let url = Website.metadata pkg vsn "elm.json"

314+ do result <- Http.get manager (Website.metadata pkg vsn "elm.json") [] id (return . Right)

317− result <- Http.get manager url [] id (return . Right)

318 case result of

315 case result of

319 Left httpProblem ->

316 Left httpProblem ->

320− err (Exit.SolverBadHttp pkg vsn httpProblem)

317+ err (Exit.SolverBadHttp httpProblem)

321

318

322 Right body ->

319 Right body ->

323 case D.fromByteString constraintsDecoder body of

320 case D.fromByteString constraintsDecoder body of

@@ -327,9 +324,11 @@ getConstraints pkg vsn =

327 ok (toNewState cs) cs back

324 ok (toNewState cs) cs back

328

325

329 Left _ ->

326 Left _ ->

330− err (Exit.SolverBadHttpData pkg vsn url)

327+ err (Exit.SolverBadHttpData pkg vsn)

331

328

332

329

330+-- TODO write constraintsDecoder to be a bit faster

331+--

333constraintsDecoder :: D.Decoder () Constraints

332constraintsDecoder :: D.Decoder () Constraints

334constraintsDecoder =

333constraintsDecoder =

335 do outline <- D.mapError (const ()) Outline.decoder

334 do outline <- D.mapError (const ()) Outline.decoder

@@ -351,31 +350,30 @@ data Env =

351

350

352initEnv :: IO (Either Exit.RegistryProblem Env)

351initEnv :: IO (Either Exit.RegistryProblem Env)

353initEnv =

352initEnv =

354− do mvar <- newEmptyMVar

353+ do mvar <- newEmptyMVar

355− _ <- forkIO $ putMVar mvar =<< Http.getManager

354+ _ <- forkIO $ putMVar mvar =<< Http.getManager

356− cache <- Stuff.getPackageCache

355+ cache <- Stuff.getPackageCache

357− Stuff.withRegistryLock cache $

358− do maybeRegistry <- Registry.read cache

356+ maybeRegistry <- Registry.read cache

359− manager <- readMVar mvar

357+ manager <- readMVar mvar

360−

358+

361− case maybeRegistry of

359+ case maybeRegistry of

362− Nothing ->

360+ Nothing ->

363− do eitherRegistry <- Registry.fetch manager cache

361+ do eitherRegistry <- Registry.fetch manager cache

364− case eitherRegistry of

362+ case eitherRegistry of

365− Right latestRegistry ->

363+ Right latestRegistry ->

366− return $ Right $ Env cache manager (Online manager) latestRegistry

364+ return $ Right $ Env cache manager (Online manager) latestRegistry

367−

365+

368− Left problem ->

366+ Left problem ->

369− return $ Left $ problem

367+ return $ Left $ problem

370−

368+

371− Just cachedRegistry ->

369+ Just cachedRegistry ->

372− do eitherRegistry <- Registry.update manager cache cachedRegistry

370+ do eitherRegistry <- Registry.update manager cache cachedRegistry

373− case eitherRegistry of

371+ case eitherRegistry of

374− Right latestRegistry ->

372+ Right latestRegistry ->

375− return $ Right $ Env cache manager (Online manager) latestRegistry

373+ return $ Right $ Env cache manager (Online manager) latestRegistry

376−

374+

377− Left _ ->

375+ Left _ ->

378− return $ Right $ Env cache manager Offline cachedRegistry

376+ return $ Right $ Env cache manager Offline cachedRegistry

379

377

380

378

381

379

builder/src/Elm/Bump.hsnew file+137

@@ -0,0 +1,137 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Elm.Bump

3+ ( bump

4+ , toPossibleBumps

5+ )

6+ where

7+

8+

9+import Control.Monad.Trans (liftIO)

10+import qualified Data.List as List

11+

12+import qualified Deps.Cache as Cache

13+import qualified Deps.Diff as Diff

14+import qualified Elm.Project.Json as Project

15+import qualified Elm.Project.Summary as Summary

16+import qualified Elm.Version as V

17+import Reporting.Doc ((<>), (<+>))

18+import qualified Reporting.Doc as D

19+import qualified Reporting.Exit as Exit

20+import qualified Reporting.Exit.Bump as E

21+import qualified Reporting.Exit.Help as Help

22+import qualified Reporting.Progress.Terminal as Terminal

23+import qualified Reporting.Task as Task

24+

25+

26+

27+-- BUMP

28+

29+

30+bump :: Summary.Summary -> Task.Task ()

31+bump summary@(Summary.Summary root project _ _ _) =

32+ case project of

33+ Project.App _ ->

34+ Task.throw (Exit.Bump E.Application)

35+

36+ Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->

37+ do registry <- Cache.mandatoryUpdate

38+ case Cache.getVersions name registry of

39+ Left _suggestions ->

40+ checkNewPackage root info

41+

42+ Right publishedVersions ->

43+ let

44+ bumpableVersions =

45+ map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)

46+ in

47+ if elem version bumpableVersions then

48+ suggestVersion summary info

49+ else

50+ Task.throw $ Exit.Bump $ E.Unbumpable version $

51+ map head (List.group (List.sort bumpableVersions))

52+

53+

54+

55+-- VALID BUMPS

56+

57+

58+toPossibleBumps :: [V.Version] -> [(V.Version, V.Version, Diff.Magnitude)]

59+toPossibleBumps publishedVersions =

60+ case publishedVersions of

61+ [] ->

62+ []

63+

64+ _ ->

65+ let

66+ patchPoints =

67+ V.filterLatest V.majorAndMinor publishedVersions

68+

69+ minorPoints =

70+ V.filterLatest V._major publishedVersions

71+

72+ majorPoint =

73+ maximum publishedVersions

74+ in

75+ (majorPoint, V.bumpMajor majorPoint, Diff.MAJOR)

76+ : map (\v -> (v, V.bumpMinor v, Diff.MINOR)) minorPoints

77+ ++ map (\v -> (v, V.bumpPatch v, Diff.PATCH)) patchPoints

78+

79+

80+

81+-- CHECK NEW PACKAGE

82+

83+

84+checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()

85+checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =

86+ do liftIO $ putStrLn Terminal.newPackageOverview

87+ if version == V.one

88+ then

89+ liftIO $ putStrLn "The version number in elm.json is correct so you are all set!"

90+ else

91+ changeVersion root info V.one $

92+ "It looks like the version in elm.json has been changed though!\n\

93+ \Would you like me to change it back to "

94+ <> D.fromUtf8 (V.toString V.one) <> "? [Y/n] "

95+

96+

97+

98+-- SUGGEST VERSION

99+

100+

101+suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()

102+suggestVersion (Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =

103+ do oldDocs <- Cache.getDocs name version

104+ newDocs <- Task.silently (error "TODO Project.generateDocs summary")

105+ let changes = Diff.diff oldDocs newDocs

106+ let newVersion = Diff.bump changes version

107+ changeVersion root info newVersion $

108+ let

109+ old = D.fromUtf8 $ V.toString version

110+ new = D.fromUtf8 $ V.toString newVersion

111+ mag = D.fromChars $ Diff.magnitudeToString (Diff.toMagnitude changes)

112+ in

113+ "Based on your new API, this should be a" <+> D.green mag <+> "change (" <> old <> " => " <> new <> ")\n"

114+ <> "Bail out of this command and run 'elm diff' for a full explanation.\n"

115+ <> "\n"

116+ <> "Should I perform the update (" <> old <> " => " <> new <> ") in elm.json? [Y/n] "

117+

118+

119+

120+-- CHANGE VERSION

121+

122+

123+changeVersion :: FilePath -> Project.PkgInfo -> V.Version -> D.Doc -> Task.Task ()

124+changeVersion root info targetVersion explanation =

125+ do approved <- Task.getApproval explanation

126+ if not approved

127+ then

128+ liftIO $ putStrLn "Okay, I did not change anything!"

129+

130+ else

131+ do liftIO $ Project.write root $ Project.Pkg $

132+ info { Project._pkg_version = targetVersion }

133+

134+ liftIO $ Help.toStdout $

135+ "Version changed to "

136+ <> D.green (D.fromUtf8 (V.toString targetVersion))

137+ <> "!\n"

builder/src/Elm/Details.hs+97−195

@@ -2,7 +2,6 @@

2{-# LANGUAGE BangPatterns, OverloadedStrings #-}

3module Elm.Details

4 ( Details(..)

5− , BuildID

6 , ValidOutline(..)

5 , ValidOutline(..)

7 , Local(..)

6 , Local(..)

8 , Foreign(..)

7 , Foreign(..)

@@ -16,32 +15,25 @@ module Elm.Details

16

15

17import Control.Concurrent (forkIO)

16import Control.Concurrent (forkIO)

18import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)

17import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)

19−import Control.Monad (liftM, liftM2, liftM3)

18+import Control.Monad (liftM, liftM2, liftM4)

20import Data.Binary (Binary, get, put, getWord8, putWord8)

19import Data.Binary (Binary, get, put, getWord8, putWord8)

21−import qualified Data.Either as Either

22import qualified Data.Map as Map

20import qualified Data.Map as Map

23import qualified Data.Map.Utils as Map

21import qualified Data.Map.Utils as Map

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

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

25−import qualified Data.Maybe as Maybe

26import qualified Data.Name as Name

23import qualified Data.Name as Name

27−import qualified Data.NonEmptyList as NE

28import qualified Data.OneOrMore as OneOrMore

24import qualified Data.OneOrMore as OneOrMore

29import qualified Data.Set as Set

25import qualified Data.Set as Set

30import qualified Data.Utf8 as Utf8

26import qualified Data.Utf8 as Utf8

31−import Data.Word (Word64)

32import qualified System.Directory as Dir

27import qualified System.Directory as Dir

33import System.FilePath ((</>), (<.>))

28import System.FilePath ((</>), (<.>))

34

29

35−import qualified AST.Canonical as Can

36import qualified AST.Source as Src

30import qualified AST.Source as Src

37import qualified AST.Optimized as Opt

31import qualified AST.Optimized as Opt

38−import qualified BackgroundWriter as BW

39import qualified Compile

32import qualified Compile

40import qualified Deps.Registry as Registry

33import qualified Deps.Registry as Registry

41import qualified Deps.Solver as Solver

34import qualified Deps.Solver as Solver

42import qualified Deps.Website as Website

35import qualified Deps.Website as Website

43import qualified Elm.Constraint as Con

36import qualified Elm.Constraint as Con

44−import qualified Elm.Docs as Docs

45import qualified Elm.Interface as I

37import qualified Elm.Interface as I

46import qualified Elm.Kernel as Kernel

38import qualified Elm.Kernel as Kernel

47import qualified Elm.ModuleName as ModuleName

39import qualified Elm.ModuleName as ModuleName

@@ -51,10 +43,8 @@ import qualified Elm.Version as V

51import qualified File

43import qualified File

52import qualified Http

44import qualified Http

53import qualified Json.Decode as D

45import qualified Json.Decode as D

54−import qualified Json.Encode as E

55import qualified Parse.Module as Parse

46import qualified Parse.Module as Parse

56import qualified Reporting

47import qualified Reporting

57−import qualified Reporting.Annotation as A

58import qualified Reporting.Exit as Exit

48import qualified Reporting.Exit as Exit

59import qualified Reporting.Task as Task

49import qualified Reporting.Task as Task

60import qualified Stuff

50import qualified Stuff

@@ -68,42 +58,23 @@ data Details =

68 Details

58 Details

69 { _outlineTime :: File.Time

59 { _outlineTime :: File.Time

70 , _outline :: ValidOutline

60 , _outline :: ValidOutline

71− , _buildID :: BuildID

72 , _locals :: Map.Map ModuleName.Raw Local

61 , _locals :: Map.Map ModuleName.Raw Local

73 , _foreigns :: Map.Map ModuleName.Raw Foreign

62 , _foreigns :: Map.Map ModuleName.Raw Foreign

74 , _extras :: Extras

63 , _extras :: Extras

75 }

64 }

76

65

77

66

78−type BuildID = Word64

67+data ValidOutline

68+ = ValidApp Outline.AppOutline

69+ | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)

79

70

80

71

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

99data Local =

72data Local =

100 Local

73 Local

101 { _path :: FilePath

74 { _path :: FilePath

102 , _time :: File.Time

75 , _time :: File.Time

103 , _deps :: [ModuleName.Raw]

76 , _deps :: [ModuleName.Raw]

104 , _main :: Bool

77 , _main :: Bool

105− , _lastChange :: BuildID

106− , _lastCompile :: BuildID

107 }

78 }

108

79

109

80

@@ -125,14 +96,14 @@ type Interfaces =

125

96

126

97

127loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))

98loadObjects :: FilePath -> Details -> IO (MVar (Maybe Opt.GlobalGraph))

128−loadObjects root (Details _ _ _ _ _ extras) =

99+loadObjects root (Details _ _ _ _ extras) =

129 case extras of

100 case extras of

130 ArtifactsFresh _ o -> newMVar (Just o)

101 ArtifactsFresh _ o -> newMVar (Just o)

131 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))

102 ArtifactsCached -> fork (File.readBinary (Stuff.objects root))

132

103

133

104

134loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))

105loadInterfaces :: FilePath -> Details -> IO (MVar (Maybe Interfaces))

135−loadInterfaces root (Details _ _ _ _ _ extras) =

106+loadInterfaces root (Details _ _ _ _ extras) =

136 case extras of

107 case extras of

137 ArtifactsFresh i _ -> newMVar (Just i)

108 ArtifactsFresh i _ -> newMVar (Just i)

138 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))

109 ArtifactsCached -> fork (File.readBinary (Stuff.interfaces root))

@@ -142,11 +113,11 @@ loadInterfaces root (Details _ _ _ _ _ extras) =

142-- VERIFY INSTALL -- used by Install

113-- VERIFY INSTALL -- used by Install

143

114

144

115

145−verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())

116+verifyInstall :: FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ())

146−verifyInstall scope root (Solver.Env cache manager connection registry) outline =

117+verifyInstall root (Solver.Env cache manager connection registry) outline =

147 do time <- File.getTime (root </> "elm.json")

118 do time <- File.getTime (root </> "elm.json")

148 let key = Reporting.ignorer

119 let key = Reporting.ignorer

149− let env = Env key scope root cache manager connection registry

120+ let env = Env key root cache manager connection registry

150 case outline of

121 case outline of

151 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())

122 Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())

152 Outline.App app -> Task.run (verifyApp env time app >> return ())

123 Outline.App app -> Task.run (verifyApp env time app >> return ())

@@ -156,28 +127,28 @@ verifyInstall scope root (Solver.Env cache manager connection registry) outline

156-- LOAD -- used by Make, Repl, Reactor

127-- LOAD -- used by Make, Repl, Reactor

157

128

158

129

159−load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)

130+load :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)

160−load style scope root =

131+load style root =

161 do newTime <- File.getTime (root </> "elm.json")

132 do newTime <- File.getTime (root </> "elm.json")

162 maybeDetails <- File.readBinary (Stuff.details root)

133 maybeDetails <- File.readBinary (Stuff.details root)

163 case maybeDetails of

134 case maybeDetails of

164 Nothing ->

135 Nothing ->

165− generate style scope root newTime

136+ generate style root newTime

166

137

167− Just details@(Details oldTime _ buildID _ _ _) ->

138+ Just details@(Details oldTime _ _ _ _) ->

168 if oldTime == newTime

139 if oldTime == newTime

169− then return (Right details { _buildID = buildID + 1 })

140+ then return (Right details)

170− else generate style scope root newTime

141+ else generate style root newTime

171

142

172

143

173

144

174-- GENERATE

145-- GENERATE

175

146

176

147

177−generate :: Reporting.Style -> BW.Scope -> FilePath -> File.Time -> IO (Either Exit.Details Details)

148+generate :: Reporting.Style -> FilePath -> File.Time -> IO (Either Exit.Details Details)

178−generate style scope root time =

149+generate style root time =

179 Reporting.trackDetails style $ \key ->

150 Reporting.trackDetails style $ \key ->

180− do result <- initEnv key scope root

151+ do result <- initEnv key root

181 case result of

152 case result of

182 Left exit ->

153 Left exit ->

183 return (Left exit)

154 return (Left exit)

@@ -195,7 +166,6 @@ generate style scope root time =

195data Env =

166data Env =

196 Env

167 Env

197 { _key :: Reporting.DKey

168 { _key :: Reporting.DKey

198− , _scope :: BW.Scope

199 , _root :: FilePath

169 , _root :: FilePath

200 , _cache :: Stuff.PackageCache

170 , _cache :: Stuff.PackageCache

201 , _manager :: Http.Manager

171 , _manager :: Http.Manager

@@ -204,8 +174,8 @@ data Env =

204 }

174 }

205

175

206

176

207−initEnv :: Reporting.DKey -> BW.Scope -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))

177+initEnv :: Reporting.DKey -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))

208−initEnv key scope root =

178+initEnv key root =

209 do mvar <- fork Solver.initEnv

179 do mvar <- fork Solver.initEnv

210 eitherOutline <- Outline.read root

180 eitherOutline <- Outline.read root

211 case eitherOutline of

181 case eitherOutline of

@@ -219,7 +189,7 @@ initEnv key scope root =

219 return $ Left $ Exit.DetailsCannotGetRegistry problem

189 return $ Left $ Exit.DetailsCannotGetRegistry problem

220

190

221 Right (Solver.Env cache manager connection registry) ->

191 Right (Solver.Env cache manager connection registry) ->

222− return $ Right (Env key scope root cache manager connection registry, outline)

192+ return $ Right (Env key root cache manager connection registry, outline)

223

193

224

194

225

195

@@ -230,25 +200,24 @@ type Task a = Task.Task Exit.Details a

230

200

231

201

232verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details

202verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details

233−verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect elm) =

203+verifyPkg env time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =

234 if Con.goodElm elm

204 if Con.goodElm elm

235 then

205 then

236 do solution <- verifyConstraints env =<< union noDups direct testDirect

206 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

207+ let vsns = Map.map (\(Solver.Details v _) -> v) solution

239− verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct

208+ verifyDependencies env time (ValidPkg outline vsns) solution direct

240 else

209 else

241 Task.throw $ Exit.DetailsBadElmInPkg elm

210 Task.throw $ Exit.DetailsBadElmInPkg elm

242

211

243

212

244verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details

213verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details

245−verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _) =

214+verifyApp env time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =

246 if elmVersion == V.compiler

215 if elmVersion == V.compiler

247 then

216 then

248 do stated <- checkAppDeps outline

217 do stated <- checkAppDeps outline

249 actual <- verifyConstraints env (Map.map Con.exactly stated)

218 actual <- verifyConstraints env (Map.map Con.exactly stated)

250 if Map.size stated == Map.size actual

219 if Map.size stated == Map.size actual

251− then verifyDependencies env time (ValidApp srcDirs) actual direct

220+ then verifyDependencies env time (ValidApp outline) actual direct

252 else Task.throw $ Exit.DetailsHandEditedDependencies

221 else Task.throw $ Exit.DetailsHandEditedDependencies

253 else

222 else

254 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion

223 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion

@@ -266,7 +235,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =

266

235

267

236

268verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)

237verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)

269−verifyConstraints (Env _ _ _ cache _ connection registry) constraints =

238+verifyConstraints (Env _ _ cache _ connection registry) constraints =

270 do result <- Task.io $ Solver.verify cache connection registry constraints

239 do result <- Task.io $ Solver.verify cache connection registry constraints

271 case result of

240 case result of

272 Solver.Ok details -> return details

241 Solver.Ok details -> return details

@@ -312,30 +281,27 @@ fork work =

312

281

313

282

314verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details

283verifyDependencies :: 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 =

284+verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =

316 Task.eio id $

285 Task.eio id $

317 do Reporting.report key (Reporting.DStart (Map.size solution))

286 do Reporting.report key (Reporting.DStart (Map.size solution))

318 mvar <- newEmptyMVar

287 mvar <- newEmptyMVar

319− mvars <- Stuff.withRegistryLock cache $

320− Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution

288+ mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution

321 putMVar mvar mvars

289 putMVar mvar mvars

322 deps <- traverse readMVar mvars

290 deps <- traverse readMVar mvars

323 case sequence deps of

291 case sequence deps of

324− Left _ ->

292+ Left problem ->

325− do home <- Stuff.getElmHome

293+ error "TODO verifyDependencies" problem

326− return $ Left $ Exit.DetailsBadDeps home $

327− Maybe.catMaybes $ Either.lefts $ Map.elems deps

328

294

329 Right artifacts ->

295 Right artifacts ->

330 let

296 let

331 objs = Map.foldr addObjects Opt.empty artifacts

297 objs = Map.foldr addObjects Opt.empty artifacts

332 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts

298 ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts

333− foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty $ Map.intersection artifacts directDeps

299+ foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts

334− details = Details time outline 0 Map.empty foreigns (ArtifactsFresh ifaces objs)

300+ details = Details time outline Map.empty foreigns (ArtifactsFresh ifaces objs)

335 in

301 in

336− do BW.writeBinary scope (Stuff.objects root) objs

302+ do File.writeBinary (Stuff.objects root) objs

337− BW.writeBinary scope (Stuff.interfaces root) ifaces

303+ File.writeBinary (Stuff.interfaces root) ifaces

338− BW.writeBinary scope (Stuff.details root) details

304+ File.writeBinary (Stuff.details root) details

339 return (Right details)

305 return (Right details)

340

306

341

307

@@ -375,36 +341,44 @@ data Artifacts =

375

341

376

342

377type Dep =

343type Dep =

378− Either (Maybe Exit.DetailsBadDep) Artifacts

344+ Either Problem Artifacts

345+

346+

347+data Problem

348+ = BadDownload Exit.PackageProblem

349+ | BadBuild

350+ | BadDependency

379

351

380

352

381verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep

353verifyDep :: 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) =

354+verifyDep (Env key _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =

355+ let

383− do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps

356+ fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps

357+ in

384− exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")

358+ do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")

385 if exists

359 if exists

386 then

360 then

387 do Reporting.report key Reporting.DCached

361 do Reporting.report key Reporting.DCached

388 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")

362 maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")

389 case maybeCache of

363 case maybeCache of

390 Nothing ->

364 Nothing ->

391− build key cache depsMVar pkg details fingerprint Set.empty

365+ build key cache depsMVar pkg details (Set.singleton fingerprint)

392

366

393 Just (ArtifactCache fingerprints artifacts) ->

367 Just (ArtifactCache fingerprints artifacts) ->

394 if Set.member fingerprint fingerprints

368 if Set.member fingerprint fingerprints

395 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)

369 then Reporting.report key Reporting.DBuilt >> return (Right artifacts)

396− else build key cache depsMVar pkg details fingerprint fingerprints

370+ else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)

397 else

371 else

398 do Reporting.report key Reporting.DRequested

372 do Reporting.report key Reporting.DRequested

399 result <- downloadPackage cache manager pkg vsn

373 result <- downloadPackage cache manager pkg vsn

400 case result of

374 case result of

401− Left problem ->

375+ Left p ->

402 do Reporting.report key (Reporting.DFailed pkg vsn)

376 do Reporting.report key (Reporting.DFailed pkg vsn)

403− return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem

377+ return (Left (BadDownload p))

404

378

405 Right () ->

379 Right () ->

406 do Reporting.report key (Reporting.DReceived pkg vsn)

380 do Reporting.report key (Reporting.DReceived pkg vsn)

407− build key cache depsMVar pkg details fingerprint Set.empty

381+ build key cache depsMVar pkg details (Set.singleton fingerprint)

408

382

409

383

410

384

@@ -426,17 +400,17 @@ type Fingerprint =

426-- BUILD

400-- BUILD

427

401

428

402

429−build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep

403+build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Dep

430−build key cache depsMVar pkg (Solver.Details vsn _) f fs =

404+build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =

431 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)

405 do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)

432 case eitherOutline of

406 case eitherOutline of

433 Left _ ->

407 Left _ ->

434 do Reporting.report key Reporting.DBroken

408 do Reporting.report key Reporting.DBroken

435− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f

409+ return (Left BadBuild)

436

410

437 Right (Outline.App _) ->

411 Right (Outline.App _) ->

438 do Reporting.report key Reporting.DBroken

412 do Reporting.report key Reporting.DBroken

439− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f

413+ return (Left BadBuild)

440

414

441 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->

415 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->

442 do allDeps <- readMVar depsMVar

416 do allDeps <- readMVar depsMVar

@@ -444,22 +418,21 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =

444 case sequence directDeps of

418 case sequence directDeps of

445 Left _ ->

419 Left _ ->

446 do Reporting.report key Reporting.DBroken

420 do Reporting.report key Reporting.DBroken

447− return $ Left $ Nothing

421+ return (Left BadDependency)

448

422

449 Right directArtifacts ->

423 Right directArtifacts ->

450 do let src = Stuff.package cache pkg vsn </> "src"

424 do let src = Stuff.package cache pkg vsn </> "src"

451 let foreignDeps = gatherForeignInterfaces directArtifacts

425 let foreignDeps = gatherForeignInterfaces directArtifacts

452 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)

426 let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)

453− docsStatus <- getDocsStatus cache pkg vsn

454 mvar <- newEmptyMVar

427 mvar <- newEmptyMVar

455− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict

428+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) exposedDict

456 putMVar mvar mvars

429 putMVar mvar mvars

457 mapM_ readMVar mvars

430 mapM_ readMVar mvars

458 maybeStatuses <- traverse readMVar =<< readMVar mvar

431 maybeStatuses <- traverse readMVar =<< readMVar mvar

459 case sequence maybeStatuses of

432 case sequence maybeStatuses of

460 Nothing ->

433 Nothing ->

461 do Reporting.report key Reporting.DBroken

434 do Reporting.report key Reporting.DBroken

462− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f

435+ return (Left BadBuild)

463

436

464 Just statuses ->

437 Just statuses ->

465 do rmvar <- newEmptyMVar

438 do rmvar <- newEmptyMVar

@@ -469,7 +442,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =

469 case sequence maybeResults of

442 case sequence maybeResults of

470 Nothing ->

443 Nothing ->

471 do Reporting.report key Reporting.DBroken

444 do Reporting.report key Reporting.DBroken

472− return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f

445+ return (Left BadBuild)

473

446

474 Just results ->

447 Just results ->

475 let

448 let

@@ -477,10 +450,8 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =

477 ifaces = gatherInterfaces exposedDict results

450 ifaces = gatherInterfaces exposedDict results

478 objects = gatherObjects results

451 objects = gatherObjects results

479 artifacts = Artifacts ifaces objects

452 artifacts = Artifacts ifaces objects

480− fingerprints = Set.insert f fs

481 in

453 in

482− do writeDocs cache pkg vsn docsStatus results

483− File.writeBinary path (ArtifactCache fingerprints artifacts)

454+ do File.writeBinary path (ArtifactCache fingerprints artifacts)

484 Reporting.report key Reporting.DBuilt

455 Reporting.report key Reporting.DBuilt

485 return (Right artifacts)

456 return (Right artifacts)

486

457

@@ -497,7 +468,7 @@ gatherObjects results =

497addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph

468addLocalGraph :: ModuleName.Raw -> Result -> Opt.GlobalGraph -> Opt.GlobalGraph

498addLocalGraph name status graph =

469addLocalGraph name status graph =

499 case status of

470 case status of

500− RLocal _ objs _ -> Opt.addLocalGraph objs graph

471+ RLocal _ objs -> Opt.addLocalGraph objs graph

501 RForeign _ -> graph

472 RForeign _ -> graph

502 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph

473 RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph

503 RKernelForeign -> graph

474 RKernelForeign -> graph

@@ -516,10 +487,10 @@ gatherInterfaces exposed artifacts =

516toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a

487toLocalInterface :: (I.Interface -> a) -> Result -> Maybe a

517toLocalInterface func result =

488toLocalInterface func result =

518 case result of

489 case result of

519− RLocal iface _ _ -> Just (func iface)

490+ RLocal iface _ -> Just (func iface)

520− RForeign _ -> Nothing

491+ RForeign _ -> Nothing

521− RKernelLocal _ -> Nothing

492+ RKernelLocal _ -> Nothing

522− RKernelForeign -> Nothing

493+ RKernelForeign -> Nothing

523

494

524

495

525

496

@@ -562,14 +533,14 @@ type StatusDict =

562

533

563

534

564data Status

535data Status

565− = SLocal DocsStatus (Map.Map ModuleName.Raw ()) Src.Module

536+ = SLocal (Map.Map ModuleName.Raw ()) Src.Module

566 | SForeign I.Interface

537 | SForeign I.Interface

567 | SKernelLocal [Kernel.Chunk]

538 | SKernelLocal [Kernel.Chunk]

568 | SKernelForeign

539 | SKernelForeign

569

540

570

541

571−crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> IO (Maybe Status)

542+crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)

572−crawlModule foreignDeps mvar pkg src docsStatus name =

543+crawlModule foreignDeps mvar pkg src name =

573 do let path = src </> ModuleName.toFilePath name <.> "elm"

544 do let path = src </> ModuleName.toFilePath name <.> "elm"

574 exists <- File.exists path

545 exists <- File.exists path

575 case Map.lookup name foreignDeps of

546 case Map.lookup name foreignDeps of

@@ -583,7 +554,7 @@ crawlModule foreignDeps mvar pkg src docsStatus name =

583

554

584 Nothing ->

555 Nothing ->

585 if exists then

556 if exists then

586− crawlFile foreignDeps mvar pkg src docsStatus name path

557+ crawlFile foreignDeps mvar pkg src name path

587

558

588 else if Pkg.isKernel pkg && Name.isKernel name then

559 else if Pkg.isKernel pkg && Name.isKernel name then

589 crawlKernel foreignDeps mvar pkg src name

560 crawlKernel foreignDeps mvar pkg src name

@@ -592,13 +563,13 @@ crawlModule foreignDeps mvar pkg src docsStatus name =

592 return Nothing

563 return Nothing

593

564

594

565

595−crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> DocsStatus -> ModuleName.Raw -> FilePath -> IO (Maybe Status)

566+crawlFile :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> FilePath -> IO (Maybe Status)

596−crawlFile foreignDeps mvar pkg src docsStatus expectedName path =

567+crawlFile foreignDeps mvar pkg src name path =

597 do bytes <- File.readUtf8 path

568 do bytes <- File.readUtf8 path

598− case Parse.fromByteString (Parse.Package pkg) bytes of

569+ case Parse.fromByteString pkg bytes of

599− Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->

570+ Right modul@(Src.Module (Just actualName) _ imports _ _ _ _ _) | name == actualName ->

600 do deps <- crawlImports foreignDeps mvar pkg src imports

571 do deps <- crawlImports foreignDeps mvar pkg src imports

601− return (Just (SLocal docsStatus deps modul))

572+ return (Just (SLocal deps modul))

602

573

603 _ ->

574 _ ->

604 return Nothing

575 return Nothing

@@ -609,7 +580,7 @@ crawlImports foreignDeps mvar pkg src imports =

609 do statusDict <- takeMVar mvar

580 do statusDict <- takeMVar mvar

610 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)

581 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)

611 let news = Map.difference deps statusDict

582 let news = Map.difference deps statusDict

612− mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news

583+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) news

613 putMVar mvar (Map.union mvars statusDict)

584 putMVar mvar (Map.union mvars statusDict)

614 mapM_ readMVar mvars

585 mapM_ readMVar mvars

615 return deps

586 return deps

@@ -645,7 +616,7 @@ getDepHome fi =

645

616

646

617

647data Result

618data Result

648− = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)

619+ = RLocal !I.Interface !Opt.LocalGraph

649 | RForeign I.Interface

620 | RForeign I.Interface

650 | RKernelLocal [Kernel.Chunk]

621 | RKernelLocal [Kernel.Chunk]

651 | RKernelForeign

622 | RKernelForeign

@@ -654,7 +625,7 @@ data Result

654compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)

625compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)

655compile pkg mvar status =

626compile pkg mvar status =

656 case status of

627 case status of

657− SLocal docsStatus deps modul ->

628+ SLocal deps modul ->

658 do resultsDict <- readMVar mvar

629 do resultsDict <- readMVar mvar

659 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)

630 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)

660 case sequence maybeResults of

631 case sequence maybeResults of

@@ -667,11 +638,7 @@ compile pkg mvar status =

667 return Nothing

638 return Nothing

668

639

669 Right (Compile.Artifacts canonical annotations objects) ->

640 Right (Compile.Artifacts canonical annotations objects) ->

670− let

671− ifaces = I.fromModule pkg canonical annotations

641+ return (Just (RLocal (I.fromModule pkg canonical annotations) objects))

672− docs = makeDocs docsStatus canonical

673− in

674− return (Just (RLocal ifaces objects docs))

675

642

676 SForeign iface ->

643 SForeign iface ->

677 return (Just (RForeign iface))

644 return (Just (RForeign iface))

@@ -686,59 +653,10 @@ compile pkg mvar status =

686getInterface :: Result -> Maybe I.Interface

653getInterface :: Result -> Maybe I.Interface

687getInterface result =

654getInterface result =

688 case result of

655 case result of

689− RLocal iface _ _ -> Just iface

656+ RLocal iface _ -> Just iface

690− RForeign iface -> Just iface

657+ RForeign iface -> Just iface

691− RKernelLocal _ -> Nothing

658+ RKernelLocal _ -> Nothing

692− RKernelForeign -> Nothing

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

660

743

661

744

662

@@ -747,27 +665,24 @@ toDocs result =

747

665

748downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())

666downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())

749downloadPackage cache manager pkg vsn =

667downloadPackage cache manager pkg vsn =

750− let

751− url = Website.metadata pkg vsn "endpoint.json"

752− in

753 do eitherByteString <-

668 do eitherByteString <-

754− Http.get manager url [] id (return . Right)

669+ Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)

755

670

756 case eitherByteString of

671 case eitherByteString of

757 Left err ->

672 Left err ->

758− return $ Left $ Exit.PP_BadEndpointRequest err

673+ return (Left (Exit.PP_BadEndpointRequest err))

759

674

760 Right byteString ->

675 Right byteString ->

761 case D.fromByteString endpointDecoder byteString of

676 case D.fromByteString endpointDecoder byteString of

762 Left _ ->

677 Left _ ->

763− return $ Left $ Exit.PP_BadEndpointContent url

678+ return (Left Exit.PP_BadEndpointContent)

764

679

765 Right (endpoint, expectedHash) ->

680 Right (endpoint, expectedHash) ->

766− Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $

681+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $

767 \(sha, archive) ->

682 \(sha, archive) ->

768 if expectedHash == Http.shaToChars sha

683 if expectedHash == Http.shaToChars sha

769 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive

684 then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive

770− else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)

685+ else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)

771

686

772

687

773endpointDecoder :: D.Decoder e (String, String)

688endpointDecoder :: D.Decoder e (String, String)

@@ -782,40 +697,27 @@ endpointDecoder =

782

697

783

698

784instance Binary Details where

699instance 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)

700+ get = do { a <- get; b <- get; c <- get; d <- get; return (Details a b c d ArtifactsCached) }

701+ put (Details a b c d _) = put a >> put b >> put c >> put d

793

702

794

703

795instance Binary ValidOutline where

704instance Binary ValidOutline where

796 put outline =

705 put outline =

797 case outline of

706 case outline of

798− ValidApp a -> putWord8 0 >> put a

707+ ValidApp a -> putWord8 0 >> put a

799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c

708+ ValidPkg a b -> putWord8 1 >> put a >> put b

800

709

801 get =

710 get =

802 do n <- getWord8

711 do n <- getWord8

803 case n of

712 case n of

804 0 -> liftM ValidApp get

713 0 -> liftM ValidApp get

805− 1 -> liftM3 ValidPkg get get get

714+ 1 -> liftM2 ValidPkg get get

806− _ -> fail "binary encoding of ValidOutline was corrupted"

715+ _ -> error "binary encoding of ValidOutline was corrupted"

807

716

808

717

809instance Binary Local where

718instance Binary Local where

719+ get = liftM4 Local get get get get

810− put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f

720+ put (Local a b c d) = put a >> put b >> put c >> put d

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

721

820

722

821instance Binary Foreign where

723instance Binary Foreign where

builder/src/Elm/Diff.hsnew file+284

@@ -0,0 +1,284 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Elm.Diff

4+ ( Args(..)

5+ , diff

6+ )

7+ where

8+

9+

10+import Control.Monad.Except (liftIO)

11+import qualified Data.List as List

12+import qualified Data.Map as Map

13+import qualified Data.Maybe as Maybe

14+import qualified Data.Name as Name

15+

16+import qualified Deps.Cache as Cache

17+import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))

18+import qualified Deps.Diff as Diff

19+import qualified Elm.Compiler.Type as Type

20+import qualified Elm.Docs as Docs

21+import qualified Elm.ModuleName as ModuleName

22+import qualified Elm.Package as Pkg

23+import qualified Elm.Project as Project

24+import qualified Elm.Project.Json as Project

25+import qualified Elm.Project.Summary as Summary

26+import qualified Elm.Version as V

27+import Reporting.Doc ((<>), (<+>))

28+import qualified Reporting.Doc as D

29+import qualified Reporting.Exit as Exit

30+import qualified Reporting.Exit.Diff as E

31+import qualified Reporting.Exit.Help as Help

32+import qualified Reporting.Render.Type.Localizer as L

33+import qualified Reporting.Task as Task

34+

35+

36+

37+-- DIFF

38+

39+

40+data Args

41+ = CodeVsLatest

42+ | CodeVsExactly V.Version

43+ | LocalInquiry V.Version V.Version

44+ | GlobalInquiry Pkg.Name V.Version V.Version

45+

46+

47+diff :: Args -> Task.Task ()

48+diff args =

49+ case args of

50+ GlobalInquiry name v1 v2 ->

51+ do registry <- Cache.mandatoryUpdate

52+ case Cache.getVersions name registry of

53+ Left suggestions ->

54+ throw $ E.UnknownPackage name suggestions

55+

56+ Right vsns ->

57+ do oldDocs <- getDocs name vsns (min v1 v2)

58+ newDocs <- getDocs name vsns (max v1 v2)

59+ writeDiff oldDocs newDocs

60+

61+ LocalInquiry v1 v2 ->

62+ do (_, name, vsns) <- getPackageInfo

63+ oldDocs <- getDocs name vsns (min v1 v2)

64+ newDocs <- getDocs name vsns (max v1 v2)

65+ writeDiff oldDocs newDocs

66+

67+ CodeVsLatest ->

68+ do (summary, name, vsns) <- getPackageInfo

69+ oldDocs <- getDocs name vsns (maximum vsns)

70+ newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)

71+ writeDiff oldDocs newDocs

72+

73+ CodeVsExactly version ->

74+ do (summary, name, vsns) <- getPackageInfo

75+ oldDocs <- getDocs name vsns version

76+ newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)

77+ writeDiff oldDocs newDocs

78+

79+

80+throw :: E.Exit -> Task.Task a

81+throw exit =

82+ Task.throw $ Exit.Diff exit

83+

84+

85+

86+-- DIFF HELPERS

87+

88+

89+getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation

90+getDocs name allVersions version =

91+ if elem version allVersions then

92+ Cache.getDocs name version

93+ else

94+ throw $ E.UnknownVersion name version allVersions

95+

96+

97+getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])

98+getPackageInfo =

99+ do summary <- Project.getRoot

100+ case Summary._project summary of

101+ Project.App _ ->

102+ throw $ E.Application

103+

104+ Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->

105+ do registry <- Cache.mandatoryUpdate

106+ case Cache.getVersions name registry of

107+ Right vsns ->

108+ return ( summary, name, vsns )

109+

110+ Left _ ->

111+ throw E.Unpublished

112+

113+

114+

115+-- WRITE DOC

116+

117+

118+writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()

119+writeDiff oldDocs newDocs =

120+ let

121+ changes = Diff.diff oldDocs newDocs

122+ localizer = L.fromNames (Map.union oldDocs newDocs)

123+ in

124+ liftIO $ Help.toStdout (toDoc localizer changes <> "\n")

125+

126+

127+

128+-- TO DOC

129+

130+

131+toDoc :: L.Localizer -> PackageChanges -> D.Doc

132+toDoc localizer changes@(PackageChanges added changed removed) =

133+ if null added && Map.null changed && null removed then

134+ "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."

135+ else

136+ let

137+ magDoc =

138+ D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))

139+

140+ header =

141+ "This is a" <+> D.green magDoc <+> "change."

142+

143+ addedChunk =

144+ if null added then [] else

145+ [ Chunk "ADDED MODULES" MINOR $

146+ D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added

147+ ]

148+

149+ removedChunk =

150+ if null removed then [] else

151+ [ Chunk "REMOVED MODULES" MAJOR $

152+ D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed

153+ ]

154+

155+ chunks =

156+ addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)

157+ in

158+ D.vcat (header : "" : map chunkToDoc chunks)

159+

160+

161+data Chunk =

162+ Chunk

163+ { _title :: String

164+ , _magnitude :: Magnitude

165+ , _details :: D.Doc

166+ }

167+

168+

169+chunkToDoc :: Chunk -> D.Doc

170+chunkToDoc (Chunk title magnitude details) =

171+ let

172+ magDoc =

173+ Diff.magnitudeToString magnitude

174+

175+ header =

176+ "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"

177+ in

178+ D.vcat

179+ [ D.dullcyan header

180+ , ""

181+ , D.indent 4 details

182+ , ""

183+ , ""

184+ ]

185+

186+

187+changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk

188+changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =

189+ let

190+ magnitude =

191+ Diff.moduleChangeMagnitude changes

192+

193+ (unionAdd, unionChange, unionRemove) =

194+ changesToDocTriple (unionToDoc localizer) unions

195+

196+ (aliasAdd, aliasChange, aliasRemove) =

197+ changesToDocTriple (aliasToDoc localizer) aliases

198+

199+ (valueAdd, valueChange, valueRemove) =

200+ changesToDocTriple (valueToDoc localizer) values

201+

202+ (binopAdd, binopChange, binopRemove) =

203+ changesToDocTriple (binopToDoc localizer) binops

204+ in

205+ Chunk (Name.toChars name) magnitude $

206+ D.vcat $ List.intersperse "" $ Maybe.catMaybes $

207+ [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd

208+ , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove

209+ , changesToDoc "Changed" unionChange aliasChange valueChange binopChange

210+ ]

211+

212+

213+changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])

214+changesToDocTriple entryToDoc (Changes added changed removed) =

215+ let

216+ indented (name, value) =

217+ D.indent 4 (entryToDoc name value)

218+

219+ diffed (name, (oldValue, newValue)) =

220+ D.vcat

221+ [ " - " <> entryToDoc name oldValue

222+ , " + " <> entryToDoc name newValue

223+ , ""

224+ ]

225+ in

226+ ( map indented (Map.toList added)

227+ , map diffed (Map.toList changed)

228+ , map indented (Map.toList removed)

229+ )

230+

231+

232+changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc

233+changesToDoc categoryName unions aliases values binops =

234+ if null unions && null aliases && null values && null binops then

235+ Nothing

236+

237+ else

238+ Just $ D.vcat $

239+ D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values

240+

241+

242+unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc

243+unionToDoc localizer name (Docs.Union _ tvars ctors) =

244+ let

245+ setup =

246+ "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)

247+

248+ ctorDoc (ctor, tipes) =

249+ typeDoc localizer (Type.Type ctor tipes)

250+ in

251+ D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))

252+

253+

254+aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc

255+aliasToDoc localizer name (Docs.Alias _ tvars tipe) =

256+ let

257+ declaration =

258+ "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="

259+ in

260+ D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])

261+

262+

263+valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc

264+valueToDoc localizer name (Docs.Value _ tipe) =

265+ D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]

266+

267+

268+binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc

269+binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =

270+ "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details

271+ where

272+ details =

273+ " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"

274+

275+ assoc =

276+ case associativity of

277+ Docs.Left -> "left"

278+ Docs.Non -> "non"

279+ Docs.Right -> "right"

280+

281+

282+typeDoc :: L.Localizer -> Type.Type -> D.Doc

283+typeDoc localizer tipe =

284+ Type.toDoc localizer Type.None tipe

builder/src/Elm/Install.hsnew file+448

@@ -0,0 +1,448 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Elm.Install

3+ ( install

4+ )

5+ where

6+

7+

8+import Control.Monad (filterM, foldM, forM, msum, void)

9+import Control.Monad.Except (catchError, lift, liftIO)

10+import Data.Map ((!))

11+import qualified Data.Map as Map

12+import qualified Data.Map.Merge.Lazy as Map

13+

14+import qualified Elm.Package as Pkg

15+

16+import qualified Deps.Cache as Cache

17+import Deps.Explorer (Explorer)

18+import qualified Deps.Explorer as Explorer

19+import qualified Deps.Verify as Verify

20+import qualified Deps.Solver as Solver

21+import qualified Elm.Constraint as C

22+import qualified Elm.Project.Json as Project

23+import qualified Elm.Project.Root as Root

24+import qualified Elm.Version as V

25+import Reporting.Doc ((<>), (<+>))

26+import qualified Reporting.Doc as D

27+import qualified Reporting.Exit as Exit

28+import qualified Reporting.Exit.Install as E

29+import qualified Reporting.Task as Task

30+

31+

32+

33+-- INSTALL

34+

35+

36+install :: Pkg.Name -> Task.Task ()

37+install pkg =

38+ do (root, oldProject) <- Root.unsafeGet

39+ registry <- Cache.optionalUpdate

40+

41+ case oldProject of

42+ Project.App info ->

43+ do changes <- makeAppPlan registry pkg info

44+ attemptElmJsonChange root oldProject V.toChars changes

45+

46+ Project.Pkg info ->

47+ do changes <- makePkgPlan registry pkg info

48+ attemptElmJsonChange root oldProject C.toChars changes

49+

50+

51+attemptElmJsonChange :: FilePath -> Project.Project -> (a -> String) -> Changes a -> Task.Task ()

52+attemptElmJsonChange root oldProject toChars changes =

53+ let

54+ attempt newProject question =

55+ do approved <- Task.getApproval question

56+ if approved

57+ then upgrade newProject `catchError` revert

58+ else liftIO $ putStrLn "Okay, I did not change anything!"

59+

60+ upgrade newProject =

61+ do liftIO $ Project.write root newProject

62+ void $ Verify.verify root newProject

63+

64+ revert err =

65+ do liftIO $ Project.write root oldProject

66+ Task.throw err

67+ in

68+ case changes of

69+ AlreadyInstalled ->

70+ do liftIO $ putStrLn "It is already installed!"

71+

72+ PromoteTrans newProject ->

73+ attempt newProject $

74+ D.vcat

75+ [ D.fillSep

76+ ["I","found","it","in","your","elm.json","file,"

77+ ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."

78+ ]

79+ , D.fillSep

80+ ["Should","I","move","it","into",D.green "\"direct\""

81+ ,"dependencies","for","more","general","use?","[Y/n]: "

82+ ]

83+ ]

84+

85+ PromoteTest newProject ->

86+ attempt newProject $

87+ D.vcat

88+ [ D.fillSep

89+ ["I","found","it","in","your","elm.json","file,"

90+ ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."

91+ ]

92+ , D.fillSep

93+ ["Should","I","move","it","into",D.green "\"dependencies\""

94+ ,"for","more","general","use?","[Y/n]: "

95+ ]

96+ ]

97+

98+ Changes changeDict newProject ->

99+ let

100+ widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict

101+ changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict

102+ in

103+ attempt newProject $ D.vcat $

104+ [ "Here is my plan:"

105+ , viewChangeDocs changeDocs

106+ , ""

107+ , "Would you like me to update your elm.json accordingly? [Y/n]: "

108+ ]

109+

110+

111+

112+-- MAKE PLANS

113+

114+

115+data Changes vsn

116+ = AlreadyInstalled

117+ | PromoteTest Project.Project

118+ | PromoteTrans Project.Project

119+ | Changes (Map.Map Pkg.Name (Change vsn)) Project.Project

120+

121+

122+makeAppPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Changes V.Version)

123+makeAppPlan registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =

124+ if Map.member pkg depsDirect then

125+ return AlreadyInstalled

126+ else

127+ do (AppAnswer old new newInfo) <- toAppAnswer registry pkg info

128+

129+ return $

130+ if Map.member pkg depsTrans then

131+ PromoteTrans (Project.App newInfo)

132+

133+ else if Map.member pkg testDirect || Map.member pkg testTrans then

134+ PromoteTest (Project.App newInfo)

135+

136+ else

137+ Changes (detectChanges old new) (Project.App newInfo)

138+

139+

140+makePkgPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Changes C.Constraint)

141+makePkgPlan registry pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) =

142+ if Map.member pkg deps then

143+ return AlreadyInstalled

144+ else

145+ case Map.lookup pkg test of

146+ Just con ->

147+ return $ PromoteTest $ Project.Pkg $

148+ info

149+ { Project._pkg_deps = Map.insert pkg con deps

150+ , Project._pkg_test_deps = Map.delete pkg test

151+ }

152+

153+ Nothing ->

154+ do changes <- addToPkg registry pkg info

155+ let news = Map.mapMaybe keepNew changes

156+ return $ Changes changes $ Project.Pkg $

157+ info

158+ { Project._pkg_deps = addNews (Just pkg) news deps

159+ , Project._pkg_test_deps = addNews Nothing news test

160+ }

161+

162+

163+addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a

164+addNews pkg new old =

165+ Map.merge

166+ Map.preserveMissing

167+ (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))

168+ (Map.zipWithMatched (\_ _ n -> n))

169+ old

170+ new

171+

172+

173+

174+-- CHANGES

175+

176+

177+data Change a

178+ = Insert a

179+ | Change a a

180+ | Remove a

181+

182+

183+detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)

184+detectChanges old new =

185+ Map.merge

186+ (Map.mapMissing (\_ v -> Remove v))

187+ (Map.mapMissing (\_ v -> Insert v))

188+ (Map.zipWithMaybeMatched keepChange)

189+ old

190+ new

191+

192+

193+keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)

194+keepChange _ old new =

195+ if old == new then

196+ Nothing

197+ else

198+ Just (Change old new)

199+

200+

201+keepNew :: Change a -> Maybe a

202+keepNew change =

203+ case change of

204+ Insert a ->

205+ Just a

206+

207+ Change _ a ->

208+ Just a

209+

210+ Remove _ ->

211+ Nothing

212+

213+

214+

215+-- ADD TO APP

216+

217+

218+data AppAnswer =

219+ AppAnswer

220+ { _old :: Map.Map Pkg.Name V.Version

221+ , _new :: Map.Map Pkg.Name V.Version

222+ , _info :: Project.AppInfo

223+ }

224+

225+

226+toAppAnswer :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task AppAnswer

227+toAppAnswer registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =

228+ Explorer.run registry $

229+ do Explorer.exists pkg

230+ result <- Solver.run (toAppAnswerHelp pkg info)

231+ case result of

232+ Just answer ->

233+ return answer

234+

235+ Nothing ->

236+ do badNames <-

237+ filterM isBadElm $

238+ pkg : Map.keys depsDirect

239+ ++ Map.keys depsTrans

240+ ++ Map.keys testDirect

241+ ++ Map.keys testTrans

242+ lift $ Task.throw (Exit.Install (E.NoSolution badNames))

243+

244+

245+toAppAnswerHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver AppAnswer

246+toAppAnswerHelp pkg (Project.AppInfo elm srcDirs depsDirect depsTrans testDirect testTrans) =

247+ let

248+ directs =

249+ Map.union depsDirect testDirect

250+

251+ directAndTrans =

252+ Map.union directs (Map.union depsTrans testTrans)

253+

254+ try toConstraint deps =

255+ do solution <- Solver.solve $ Map.insert pkg C.anything (Map.map toConstraint deps)

256+ let newDepsDirect = Map.intersection solution (Map.insert pkg V.one depsDirect)

257+ newDeps <- lift $ foldM (collectTransitive solution) Map.empty (Map.keys newDepsDirect)

258+ return $

259+ AppAnswer

260+ { _old = directAndTrans

261+ , _new = solution

262+ , _info =

263+ Project.AppInfo

264+ elm

265+ srcDirs

266+ newDepsDirect

267+ (Map.difference newDeps newDepsDirect)

268+ (Map.intersection solution testDirect)

269+ (Map.difference (Map.difference solution newDeps) testDirect)

270+ }

271+ in

272+ msum

273+ [ try C.exactly directAndTrans

274+ , try C.exactly directs

275+ , try C.untilNextMinor directs

276+ , try C.untilNextMajor directs

277+ , try (\_ -> C.anything) directs

278+ ]

279+

280+

281+collectTransitive

282+ :: Map.Map Pkg.Name V.Version

283+ -> Map.Map Pkg.Name V.Version

284+ -> Pkg.Name

285+ -> Explorer (Map.Map Pkg.Name V.Version)

286+collectTransitive solution state name =

287+ do let version = solution ! name

288+ (Explorer.Info _ trans) <- Explorer.getConstraints name version

289+ foldM

290+ (collectTransitive solution)

291+ (Map.insert name version state)

292+ (Map.keys trans)

293+

294+

295+

296+

297+

298+-- ADD TO PKG

299+

300+

301+addToPkg :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Map.Map Pkg.Name (Change C.Constraint))

302+addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =

303+ Explorer.run registry $

304+ do Explorer.exists pkg

305+ let old = Map.union deps tests

306+ result <- Solver.run (addToPkgHelp pkg info)

307+ case result of

308+ Just new ->

309+ return $ detectChanges old new

310+

311+ Nothing ->

312+ do let pkgs = Map.keys deps ++ Map.keys tests

313+ badNames <- filterM isBadElm (pkg : pkgs)

314+ lift $ Task.throw (Exit.Install (E.NoSolution badNames))

315+

316+

317+addToPkgHelp :: Pkg.Name -> Project.PkgInfo -> Solver.Solver (Map.Map Pkg.Name C.Constraint)

318+addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =

319+ do let directs = Map.union deps tests

320+ let newCons = Map.insert pkg C.anything directs

321+ solution <- Solver.solve newCons

322+ let con = C.untilNextMajor (solution ! pkg)

323+ return $ Map.insert pkg con directs

324+

325+

326+

327+-- FAILURE HINTS

328+

329+

330+isBadElm :: Pkg.Name -> Explorer Bool

331+isBadElm name =

332+ do versions <- Explorer.getVersions name

333+

334+ elmVersions <- forM versions $ \vsn ->

335+ Explorer._elm <$> Explorer.getConstraints name vsn

336+

337+ return (not (any C.goodElm elmVersions))

338+

339+

340+

341+-- VIEW CHANGE DOCS

342+

343+

344+data ChangeDocs =

345+ Docs

346+ { _doc_inserts :: [D.Doc]

347+ , _doc_changes :: [D.Doc]

348+ , _doc_removes :: [D.Doc]

349+ }

350+

351+

352+viewChangeDocs :: ChangeDocs -> D.Doc

353+viewChangeDocs (Docs inserts changes removes) =

354+ D.indent 2 $ D.vcat $ concat $

355+ [ viewNonZero "Add:" inserts

356+ , viewNonZero "Change:" changes

357+ , viewNonZero "Remove:" removes

358+ ]

359+

360+

361+viewNonZero :: String -> [D.Doc] -> [D.Doc]

362+viewNonZero title entries =

363+ if null entries then

364+ []

365+ else

366+ [ ""

367+ , D.fromChars title

368+ , D.indent 2 (D.vcat entries)

369+ ]

370+

371+

372+

373+-- VIEW CHANGE

374+

375+

376+addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs

377+addChange toChars widths name change (Docs inserts changes removes) =

378+ case change of

379+ Insert new ->

380+ Docs (viewInsert toChars widths name new : inserts) changes removes

381+

382+ Change old new ->

383+ Docs inserts (viewChange toChars widths name old new : changes) removes

384+

385+ Remove old ->

386+ Docs inserts changes (viewRemove toChars widths name old : removes)

387+

388+

389+viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc

390+viewInsert toChars (Widths nameWidth leftWidth _) name new =

391+ viewName nameWidth name <+> pad leftWidth (toChars new)

392+

393+

394+viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc

395+viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =

396+ D.hsep

397+ [ viewName nameWidth name

398+ , pad leftWidth (toChars old)

399+ , "=>"

400+ , pad rightWidth (toChars new)

401+ ]

402+

403+

404+viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc

405+viewRemove toChars (Widths nameWidth leftWidth _) name old =

406+ viewName nameWidth name <+> pad leftWidth (toChars old)

407+

408+

409+viewName :: Int -> Pkg.Name -> D.Doc

410+viewName width name =

411+ D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))

412+

413+

414+pad :: Int -> String -> D.Doc

415+pad width string =

416+ D.fromChars (replicate (width - length string) ' ') <> D.fromChars string

417+

418+

419+

420+-- WIDTHS

421+

422+

423+data Widths =

424+ Widths

425+ { _name :: !Int

426+ , _left :: !Int

427+ , _right :: !Int

428+ }

429+

430+

431+widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths

432+widen toChars pkg change (Widths name left right) =

433+ let

434+ toLength a =

435+ length (toChars a)

436+

437+ newName =

438+ max name (length (Pkg.toChars pkg))

439+ in

440+ case change of

441+ Insert new ->

442+ Widths newName (max left (toLength new)) right

443+

444+ Change old new ->

445+ Widths newName (max left (toLength old)) (max right (toLength new))

446+

447+ Remove old ->

448+ Widths newName (max left (toLength old)) right

builder/src/Elm/Outline.hs+115−148

@@ -1,11 +1,10 @@

1{-# OPTIONS_GHC -Wall #-}

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

2+{-# LANGUAGE OverloadedStrings #-}

3module Elm.Outline

4 ( Outline(..)

5 , AppOutline(..)

6 , PkgOutline(..)

7 , Exposed(..)

8− , SrcDir(..)

9 , read

8 , read

10 , write

9 , write

11 , encode

10 , encode

@@ -19,12 +18,10 @@ module Elm.Outline

19import Prelude hiding (read)

18import Prelude hiding (read)

20import Control.Monad (filterM, liftM)

19import Control.Monad (filterM, liftM)

21import Data.Binary (Binary, get, put, getWord8, putWord8)

20import Data.Binary (Binary, get, put, getWord8, putWord8)

21+import Data.Foldable (traverse_)

22import qualified Data.Map as Map

23−import qualified Data.NonEmptyList as NE

23+import qualified Data.Utf8 as Utf8

24−import qualified Data.OneOrMore as OneOrMore

25−import Foreign.Ptr (minusPtr)

26import qualified System.Directory as Dir

24import qualified System.Directory as Dir

27−import qualified System.FilePath as FP

28import System.FilePath ((</>))

25import System.FilePath ((</>))

29

26

30import qualified Elm.Constraint as Con

27import qualified Elm.Constraint as Con

@@ -35,9 +32,6 @@ import qualified Elm.Version as V

35import qualified File

32import qualified File

36import qualified Json.Decode as D

33import qualified Json.Decode as D

37import qualified Json.Encode as E

34import qualified Json.Encode as E

38−import Json.Encode ((==>))

39−import qualified Json.String as Json

40−import qualified Parse.Primitives as P

41import qualified Reporting.Exit as Exit

35import qualified Reporting.Exit as Exit

42

36

43

37

@@ -53,7 +47,7 @@ data Outline

53data AppOutline =

47data AppOutline =

54 AppOutline

48 AppOutline

55 { _app_elm_version :: V.Version

49 { _app_elm_version :: V.Version

56− , _app_source_dirs :: NE.List SrcDir

50+ , _app_source_dirs :: [FilePath]

57 , _app_deps_direct :: Map.Map Pkg.Name V.Version

51 , _app_deps_direct :: Map.Map Pkg.Name V.Version

58 , _app_deps_indirect :: Map.Map Pkg.Name V.Version

52 , _app_deps_indirect :: Map.Map Pkg.Name V.Version

59 , _app_test_direct :: Map.Map Pkg.Name V.Version

53 , _app_test_direct :: Map.Map Pkg.Name V.Version

@@ -64,7 +58,7 @@ data AppOutline =

64data PkgOutline =

58data PkgOutline =

65 PkgOutline

59 PkgOutline

66 { _pkg_name :: Pkg.Name

60 { _pkg_name :: Pkg.Name

67− , _pkg_summary :: Json.String

61+ , _pkg_summary :: Utf8.String

68 , _pkg_license :: Licenses.License

62 , _pkg_license :: Licenses.License

69 , _pkg_version :: V.Version

63 , _pkg_version :: V.Version

70 , _pkg_exposed :: Exposed

64 , _pkg_exposed :: Exposed

@@ -76,21 +70,16 @@ data PkgOutline =

76

70

77data Exposed

71data Exposed

78 = ExposedList [ModuleName.Raw]

72 = ExposedList [ModuleName.Raw]

79− | ExposedDict [(Json.String, [ModuleName.Raw])]

73+ | ExposedDict [(Utf8.String, [ModuleName.Raw])]

80−

81−

82−data SrcDir

83− = AbsoluteSrcDir FilePath

84− | RelativeSrcDir FilePath

85

74

86

75

87

76

88-- DEFAULTS

77-- DEFAULTS

89

78

90

79

91−defaultSummary :: Json.String

80+defaultSummary :: Utf8.String

92defaultSummary =

81defaultSummary =

93− Json.fromChars "helpful summary of your project, less than 80 characters"

82+ "helpful summary of your project, less than 80 characters"

94

83

95

84

96

85

@@ -125,8 +114,8 @@ encode outline =

125 case outline of

114 case outline of

126 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->

115 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->

127 E.object

116 E.object

128− [ "type" ==> E.chars "application"

117+ [ "type" ==> E.string "application"

129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)

118+ , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs

130 , "elm-version" ==> V.encode elm

119 , "elm-version" ==> V.encode elm

131 , "dependencies" ==>

120 , "dependencies" ==>

132 E.object

121 E.object

@@ -142,7 +131,7 @@ encode outline =

142

131

143 Pkg (PkgOutline name summary license version exposed deps tests elm) ->

132 Pkg (PkgOutline name summary license version exposed deps tests elm) ->

144 E.object

133 E.object

145− [ "type" ==> E.string (Json.fromChars "package")

134+ [ "type" ==> E.string "package"

146 , "name" ==> Pkg.encode name

135 , "name" ==> Pkg.encode name

147 , "summary" ==> E.string summary

136 , "summary" ==> E.string summary

148 , "license" ==> Licenses.encode license

137 , "license" ==> Licenses.encode license

@@ -154,6 +143,11 @@ encode outline =

154 ]

143 ]

155

144

156

145

146+(==>) :: a -> b -> (a, b)

147+(==>) a b =

148+ (a, b)

149+

150+

157encodeExposed :: Exposed -> E.Value

151encodeExposed :: Exposed -> E.Value

158encodeExposed exposed =

152encodeExposed exposed =

159 case exposed of

153 case exposed of

@@ -171,14 +165,7 @@ encodeModule name =

171

165

172encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value

166encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value

173encodeDeps encodeValue deps =

167encodeDeps encodeValue deps =

174− E.dict Pkg.toJsonString encodeValue deps

168+ E.dict Pkg.toString encodeValue deps

175−

176−

177−encodeSrcDir :: SrcDir -> E.Value

178−encodeSrcDir srcDir =

179− case srcDir of

180− AbsoluteSrcDir dir -> E.chars dir

181− RelativeSrcDir dir -> E.chars dir

182

169

183

170

184

171

@@ -194,72 +181,19 @@ read root =

194

181

195 Right outline ->

182 Right outline ->

196 case outline of

183 case outline of

197− Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->

184+ Pkg _ ->

198− return $

199− if Map.notMember Pkg.core deps && pkg /= Pkg.core

200− then Left Exit.OutlineNoPkgCore

201− else Right outline

185+ return $ 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

186

252−toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)

187+ App (AppOutline _ srcDirs _ _ _ _) ->

253−toPair root srcDir =

188+ do badDirs <- filterM (isBadSrcDir root) srcDirs

254− do key <- Dir.canonicalizePath (toAbsolute root srcDir)

189+ case badDirs of

255− return (key, OneOrMore.one (toGiven srcDir))

190+ [] -> return $ Right outline

191+ d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)

256

192

257

193

258−isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)

194+isBadSrcDir :: FilePath -> FilePath -> IO Bool

259−isDup paths =

195+isBadSrcDir root dir =

260− case paths of

196+ not <$> Dir.doesDirectoryExist (root </> dir)

261− OneOrMore.One _ -> Nothing

262− OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)

263

197

264

198

265

199

@@ -272,21 +206,23 @@ type Decoder a =

272

206

273decoder :: Decoder Outline

207decoder :: Decoder Outline

274decoder =

208decoder =

275− let

276− application = Json.fromChars "application"

277− package = Json.fromChars "package"

278− in

279 do tipe <- D.field "type" D.string

209 do tipe <- D.field "type" D.string

210+ case tipe of

211+ "application" ->

280− if | tipe == application -> App <$> appDecoder

212+ App <$> appDecoder

213+

214+ "package" ->

281− | tipe == package -> Pkg <$> pkgDecoder

215+ Pkg <$> pkgDecoder

216+

217+ other ->

282− | otherwise -> D.failure Exit.OP_BadType

218+ D.failure (Exit.OP_BadType other)

283

219

284

220

285appDecoder :: Decoder AppOutline

221appDecoder :: Decoder AppOutline

286appDecoder =

222appDecoder =

287 AppOutline

223 AppOutline

288 <$> D.field "elm-version" versionDecoder

224 <$> D.field "elm-version" versionDecoder

289− <*> D.field "source-directories" dirsDecoder

225+ <*> D.field "source-directories" (D.list dirDecoder)

290 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))

226 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))

291 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))

227 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))

292 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))

228 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))

@@ -296,7 +232,7 @@ appDecoder =

296pkgDecoder :: Decoder PkgOutline

232pkgDecoder :: Decoder PkgOutline

297pkgDecoder =

233pkgDecoder =

298 PkgOutline

234 PkgOutline

299− <$> D.field "name" nameDecoder

235+ <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)

300 <*> D.field "summary" summaryDecoder

236 <*> D.field "summary" summaryDecoder

301 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)

237 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)

302 <*> D.field "version" versionDecoder

238 <*> D.field "version" versionDecoder

@@ -310,21 +246,17 @@ pkgDecoder =

310-- JSON DECODE HELPERS

246-- JSON DECODE HELPERS

311

247

312

248

313−nameDecoder :: Decoder Pkg.Name

314−nameDecoder =

315− D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder

316−

317−

318−summaryDecoder :: Decoder Json.String

249+summaryDecoder :: Decoder Utf8.String

319summaryDecoder =

250summaryDecoder =

320− D.customString

251+ do summary <- D.string

321− (boundParser 80 Exit.OP_BadSummaryTooLong)

252+ if Utf8.size summary < 80

253+ then return summary

322− (\_ _ -> Exit.OP_BadSummaryTooLong)

254+ else D.failure Exit.OP_BadSummaryTooLong

323

255

324

256

325versionDecoder :: Decoder V.Version

257versionDecoder :: Decoder V.Version

326versionDecoder =

258versionDecoder =

327− D.mapError (uncurry Exit.OP_BadVersion) V.decoder

259+ D.mapError Exit.OP_BadVersion V.decoder

328

260

329

261

330constraintDecoder :: Decoder Con.Constraint

262constraintDecoder :: Decoder Con.Constraint

@@ -334,19 +266,24 @@ constraintDecoder =

334

266

335depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)

267depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)

336depsDecoder valueDecoder =

268depsDecoder valueDecoder =

337− D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder

269+ Map.fromList <$> (

270+ traverse validateKey =<< D.pairs valueDecoder

271+ )

338

272

339

273

340−dirsDecoder :: Decoder (NE.List SrcDir)

274+validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)

341−dirsDecoder =

275+validateKey (key, value) =

342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs

276+ case Pkg.fromString key of

277+ Right name ->

278+ return (name, value)

343

279

280+ Left _ ->

281+ D.failure (Exit.OP_BadDependencyName key)

344

282

345−toSrcDir :: FilePath -> SrcDir

283+

346−toSrcDir path =

284+dirDecoder :: Decoder FilePath

347− if FP.isRelative path

285+dirDecoder =

348− then RelativeSrcDir path

286+ Utf8.toChars <$> D.string

349− else AbsoluteSrcDir path

350

287

351

288

352

289

@@ -357,51 +294,81 @@ exposedDecoder :: Decoder Exposed

357exposedDecoder =

294exposedDecoder =

358 D.oneOf

295 D.oneOf

359 [ ExposedList <$> D.list moduleDecoder

296 [ ExposedList <$> D.list moduleDecoder

360− , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)

297+ , do pairs <- D.pairs (D.list moduleDecoder)

298+ traverse_ (checkHeader . fst) pairs

299+ return (ExposedDict pairs)

361 ]

300 ]

362

301

363

302

364moduleDecoder :: Decoder ModuleName.Raw

303moduleDecoder :: Decoder ModuleName.Raw

365moduleDecoder =

304moduleDecoder =

366− D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder

305+ D.mapError Exit.OP_BadModuleName ModuleName.decoder

367

306

368

307

369−headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String

308+checkHeader :: Utf8.String -> Decoder ()

370−headerKeyDecoder =

309+checkHeader header =

371− D.KeyDecoder

310+ if Utf8.size header < 20

372− (boundParser 20 Exit.OP_BadModuleHeaderTooLong)

311+ then return ()

373− (\_ _ -> Exit.OP_BadModuleHeaderTooLong)

312+ else D.failure (Exit.OP_BadModuleHeaderTooLong header)

374

313

375

314

376

315

377−-- BOUND PARSER

316+-- BINARY

378

317

379

318

380−boundParser :: Int -> x -> P.Parser x Json.String

319+instance Binary Outline where

381−boundParser bound tooLong =

320+ put outline =

382− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->

321+ case outline of

383− let

322+ App a -> putWord8 0 >> put a

384− len = minusPtr end pos

323+ Pkg a -> putWord8 1 >> put a

385− newCol = col + fromIntegral len

386− in

387− if len < bound

388− then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)

389− else cerr row newCol (\_ _ -> tooLong)

390

324

325+ get =

326+ do n <- getWord8

327+ case n of

328+ 0 -> liftM App get

329+ 1 -> liftM Pkg get

330+ _ -> error "binary encoding of Outline was corrupted"

391

331

392

332

393−-- BINARY

333+instance Binary AppOutline where

334+ put (AppOutline a b c d e f) =

335+ put a >> put b >> put c >> put d >> put e >> put f

394

336

337+ get =

338+ do a <- get

339+ b <- get

340+ c <- get

341+ d <- get

342+ e <- get

343+ f <- get

344+ return (AppOutline a b c d e f)

395

345

346+

347+instance Binary PkgOutline where

348+ put (PkgOutline a b c d e f g h) =

349+ put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h

350+

351+ get =

352+ do a <- get

353+ b <- get

354+ c <- get

355+ d <- get

356+ e <- get

357+ f <- get

358+ g <- get

359+ h <- get

360+ return (PkgOutline a b c d e f g h)

361+

362+

396−instance Binary SrcDir where

363+instance Binary Exposed where

397− put outline =

364+ put exposed =

398− case outline of

365+ case exposed of

399− AbsoluteSrcDir a -> putWord8 0 >> put a

366+ ExposedList a -> putWord8 0 >> put a

400− RelativeSrcDir a -> putWord8 1 >> put a

367+ ExposedDict a -> putWord8 1 >> put a

401

368

402 get =

369 get =

403 do n <- getWord8

370 do n <- getWord8

404 case n of

371 case n of

405− 0 -> liftM AbsoluteSrcDir get

372+ 0 -> liftM ExposedList get

406− 1 -> liftM RelativeSrcDir get

373+ 1 -> liftM ExposedDict get

407− _ -> fail "binary encoding of SrcDir was corrupted"

374+ _ -> error "binary encoding of ProjectDeps was corrupted"

builder/src/Elm/Publish.hsnew file+255

@@ -0,0 +1,255 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Elm.Publish (publish) where

3+

4+

5+import Control.Monad (when)

6+import Control.Monad.Except (catchError, runExceptT)

7+import Control.Monad.Trans (liftIO, lift)

8+import qualified Data.List as List

9+import qualified Data.Utf8 as Utf8

10+import qualified System.Directory as Dir

11+import qualified System.Exit as Exit

12+import System.FilePath ((</>))

13+import qualified System.IO as IO

14+import qualified System.Process as Process

15+

16+import qualified Deps.Cache as Cache

17+import qualified Deps.Diff as Diff

18+import qualified Deps.Website as Website

19+import qualified Elm.Bump as Bump

20+import qualified Elm.Docs as Docs

21+import qualified Elm.Package as Pkg

22+import qualified Elm.Project.Json as Project

23+import qualified Elm.Project.Summary as Summary

24+import qualified Elm.Version as V

25+import qualified Reporting.Exit as Exit

26+import qualified Reporting.Exit.Publish as E

27+import qualified Reporting.Progress as Progress

28+import qualified Reporting.Task as Task

29+import qualified Stuff.Paths as Path

30+

31+

32+

33+-- PUBLISH

34+

35+

36+publish :: Summary.Summary -> Task.Task ()

37+publish summary@(Summary.Summary root project _ _ _) =

38+ case project of

39+ Project.App _ ->

40+ throw E.Application

41+

42+ Project.Pkg (Project.PkgInfo name smry _ version exposed _ _ _) ->

43+ do

44+ registry <- Cache.mandatoryUpdate

45+ let maybePublishedVersions = either (const Nothing) Just (Cache.getVersions name registry)

46+

47+ Task.report (Progress.PublishStart name version maybePublishedVersions)

48+

49+ when (noExposed exposed) $ throw E.NoExposed

50+ when (badSummary smry) $ throw E.NoSummary

51+

52+ verifyReadme root

53+ verifyLicense root

54+ docs <- Task.silently (error "TODO Project.generateDocs summary" summary)

55+ verifyVersion name version docs maybePublishedVersions

56+ commitHash <- verifyTag name version

57+ verifyNoChanges commitHash version

58+ zipHash <- verifyZip name version

59+

60+ Website.register name version commitHash zipHash

61+

62+ Task.report Progress.PublishEnd

63+

64+

65+throw :: E.Exit -> Task.Task a

66+throw exit =

67+ Task.throw (Exit.Publish exit)

68+

69+

70+

71+-- VERIFY SUMMARY

72+

73+

74+badSummary :: Utf8.String -> Bool

75+badSummary summary =

76+ Utf8.isEmpty summary || Project.defaultSummary == summary

77+

78+

79+noExposed :: Project.Exposed -> Bool

80+noExposed exposed =

81+ case exposed of

82+ Project.ExposedList modules ->

83+ null modules

84+

85+ Project.ExposedDict chunks ->

86+ all (null . snd) chunks

87+

88+

89+

90+-- VERIFY README

91+

92+

93+verifyReadme :: FilePath -> Task.Task ()

94+verifyReadme root =

95+ phase Progress.CheckReadme $

96+ do let readmePath = root </> "README.md"

97+ exists <- liftIO $ Dir.doesFileExist readmePath

98+ case exists of

99+ False ->

100+ throw E.NoReadme

101+

102+ True ->

103+ do size <- liftIO $ IO.withFile readmePath IO.ReadMode IO.hFileSize

104+ if size < 300

105+ then throw E.ShortReadme

106+ else return ()

107+

108+

109+

110+-- VERIFY LICENSE

111+

112+

113+verifyLicense :: FilePath -> Task.Task ()

114+verifyLicense root =

115+ phase Progress.CheckLicense $

116+ do let licensePath = root </> "LICENSE"

117+ exists <- liftIO $ Dir.doesFileExist licensePath

118+ if exists

119+ then return ()

120+ else throw E.NoLicense

121+

122+

123+

124+-- VERIFY GITHUB TAG

125+

126+

127+verifyTag :: Pkg.Name -> V.Version -> Task.Task String

128+verifyTag name version =

129+ phase (Progress.CheckTag version) $

130+ Website.githubCommit name version `catchError` \_ ->

131+ throw (E.MissingTag version)

132+

133+

134+

135+-- VERIFY NO LOCAL CHANGES SINCE TAG

136+

137+

138+verifyNoChanges :: String -> V.Version -> Task.Task ()

139+verifyNoChanges commitHash version =

140+ phase Progress.CheckChanges $

141+ do maybeGit <- liftIO $ Dir.findExecutable "git"

142+ case maybeGit of

143+ Nothing ->

144+ throw E.NoGit

145+

146+ Just git ->

147+ do -- https://stackoverflow.com/questions/3878624/how-do-i-programmatically-determine-if-there-are-uncommited-changes

148+ exitCode <- liftIO $

149+ Process.rawSystem git [ "diff-index", "--quiet", commitHash, "--" ]

150+

151+ case exitCode of

152+ Exit.ExitSuccess ->

153+ return ()

154+

155+ Exit.ExitFailure _ ->

156+ throw (E.LocalChanges version)

157+

158+

159+

160+-- VERIFY THAT ZIP BUILDS / COMPUTE HASH

161+

162+

163+verifyZip :: Pkg.Name -> V.Version -> Task.Task Website.Sha

164+verifyZip name version =

165+ withTempDir $ \dir ->

166+ do hash <- phase Progress.CheckDownload $

167+ Website.githubDownload name version dir

168+

169+ phase Progress.CheckBuild $

170+ do runner <- Task.getSilentRunner

171+ result <- liftIO $ Dir.withCurrentDirectory dir $ runner $

172+ Task.silently $ error "TODO Project.generateDocs =<< Project.getRoot"

173+ either Task.throw (\_ -> return ()) result

174+

175+ return hash

176+

177+

178+withTempDir :: (FilePath -> Task.Task a) -> Task.Task a

179+withTempDir callback =

180+ do liftIO $ Dir.createDirectoryIfMissing True Path.prepublishDir

181+ result <- lift $ runExceptT $ callback Path.prepublishDir

182+ liftIO $ Dir.removeDirectoryRecursive Path.prepublishDir

183+ either Task.throw return result

184+

185+

186+

187+-- PHASE REPORTING

188+

189+

190+phase :: Progress.PublishPhase -> Task.Task a -> Task.Task a

191+phase publishPhase task =

192+ do Task.report $ Progress.PublishProgress publishPhase Nothing

193+

194+ result <- task `catchError` \exit ->

195+ do Task.report $ Progress.PublishProgress publishPhase (Just Progress.Bad)

196+ Task.throw exit

197+

198+ Task.report $ Progress.PublishProgress publishPhase (Just Progress.Good)

199+

200+ return result

201+

202+

203+

204+-- VERIFY VERSION

205+

206+

207+verifyVersion :: Pkg.Name -> V.Version -> Docs.Documentation -> Maybe [V.Version] -> Task.Task ()

208+verifyVersion name version docs maybePublishedVersions =

209+ let

210+ reportBumpPhase bumpPhase =

211+ Task.report $ Progress.PublishCheckBump version bumpPhase

212+ in

213+ do reportBumpPhase Progress.StatedVersion

214+ case maybePublishedVersions of

215+ Nothing ->

216+ if version == V.one then

217+ reportBumpPhase Progress.GoodStart

218+ else

219+ throw (E.NotInitialVersion version)

220+

221+ Just publishedVersions ->

222+ if elem version publishedVersions then

223+ throw $ E.AlreadyPublished version

224+ else

225+ do (old, magnitude) <- verifyBump name version docs publishedVersions

226+ reportBumpPhase (Progress.GoodBump old magnitude)

227+

228+ `catchError` \exit ->

229+ do reportBumpPhase Progress.BadBump

230+ Task.throw exit

231+

232+

233+verifyBump :: Pkg.Name -> V.Version -> Docs.Documentation -> [V.Version] -> Task.Task (V.Version, Diff.Magnitude)

234+verifyBump name statedVersion newDocs publishedVersions =

235+ let

236+ possibleBumps =

237+ Bump.toPossibleBumps publishedVersions

238+

239+ isTheBump (_ ,new, _) =

240+ statedVersion == new

241+ in

242+ case List.find isTheBump possibleBumps of

243+ Nothing ->

244+ throw $ E.InvalidBump statedVersion (last publishedVersions)

245+

246+ Just (old, new, magnitude) ->

247+ do oldDocs <- Cache.getDocs name old

248+ let changes = Diff.diff oldDocs newDocs

249+ let realNew = Diff.bump changes old

250+ if new == realNew

251+ then

252+ return (old, magnitude)

253+ else

254+ throw $ E.BadBump old new magnitude realNew $

255+ Diff.toMagnitude changes

builder/src/File.hs+5−28

@@ -1,7 +1,6 @@

1module File

2 ( Time

3 , getTime

4− , zeroTime

5 , writeBinary

4 , writeBinary

6 , readBinary

5 , readBinary

7 , writeUtf8

6 , writeUtf8

@@ -24,7 +23,6 @@ import qualified Data.ByteString.Builder as B

24import qualified Data.ByteString.Lazy as LBS

23import qualified Data.ByteString.Lazy as LBS

25import qualified Data.Fixed as Fixed

24import qualified Data.Fixed as Fixed

26import qualified Data.List as List

25import qualified Data.List as List

27−import qualified Data.Time.Clock as Time

28import qualified Data.Time.Clock.POSIX as Time

26import qualified Data.Time.Clock.POSIX as Time

29import qualified Foreign.ForeignPtr as FPtr

27import qualified Foreign.ForeignPtr as FPtr

30import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))

28import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))

@@ -46,15 +44,11 @@ newtype Time = Time Fixed.Pico

46getTime :: FilePath -> IO Time

44getTime :: FilePath -> IO Time

47getTime path =

45getTime path =

48 fmap

46 fmap

47+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)

49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

48+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

50 (Dir.getModificationTime path)

49 (Dir.getModificationTime path)

51

50

52

51

53−zeroTime :: Time

54−zeroTime =

55− Time 0

56−

57−

58instance Binary.Binary Time where

52instance Binary.Binary Time where

59 put (Time time) = Binary.put time

53 put (Time time) = Binary.put time

60 get = Time <$> Binary.get

54 get = Time <$> Binary.get

@@ -78,21 +72,8 @@ readBinary path =

78 then

72 then

79 do result <- Binary.decodeFileOrFail path

73 do result <- Binary.decodeFileOrFail path

80 case result of

74 case result of

81− Right a ->

82− return (Just a)

75+ Right a -> return (Just a)

83−

84− Left (offset, message) ->

85− do IO.hPutStrLn IO.stderr $ unlines $

86− [ "+-------------------------------------------------------------------------------"

87− , "| Corrupt File: " ++ path

88− , "| Byte Offset: " ++ show offset

89− , "| Message: " ++ message

90− , "|"

91− , "| Please report this to https://github.com/elm/compiler/issues"

92− , "| Trying to continue anyway."

93− , "+-------------------------------------------------------------------------------"

94− ]

95− return Nothing

76+ Left e -> return Nothing

96 else

77 else

97 return Nothing

78 return Nothing

98

79

@@ -190,11 +171,7 @@ writeEntry destination root entry =

190 let

171 let

191 path = drop root (Zip.eRelativePath entry)

172 path = drop root (Zip.eRelativePath entry)

192 in

173 in

193− if List.isPrefixOf "src/" path

174+ if List.isPrefixOf "src/" path then

194− || path == "LICENSE"

195− || path == "README.md"

196− || path == "elm.json"

197− then

198 if not (null path) && last path == '/'

175 if not (null path) && last path == '/'

199 then Dir.createDirectoryIfMissing True (destination </> path)

176 then Dir.createDirectoryIfMissing True (destination </> path)

200 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)

177 else LBS.writeFile (destination </> path) (Zip.fromEntry entry)

builder/src/Generate.hsdeleted−211

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

1−{-# LANGUAGE BangPatterns #-}

2−module Generate

3− ( debug

4− , dev

5− , prod

6− , repl

7− )

8− where

9−

10−

11−import Prelude hiding (cycle, print)

12−import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)

13−import Control.Monad (liftM2)

14−import qualified Data.ByteString.Builder as B

15−import Data.Map ((!))

16−import qualified Data.Map as Map

17−import qualified Data.Maybe as Maybe

18−import qualified Data.Name as N

19−import qualified Data.NonEmptyList as NE

20−

21−import qualified AST.Optimized as Opt

22−import qualified Build

23−import qualified Elm.Compiler.Type.Extract as Extract

24−import qualified Elm.Details as Details

25−import qualified Elm.Interface as I

26−import qualified Elm.ModuleName as ModuleName

27−import qualified Elm.Package as Pkg

28−import qualified File

29−import qualified Generate.JavaScript as JS

30−import qualified Generate.Mode as Mode

31−import qualified Nitpick.Debug as Nitpick

32−import qualified Reporting.Exit as Exit

33−import qualified Reporting.Task as Task

34−import qualified Stuff

35−

36−

37−-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be

38−-- desireable to have Repl and Reactor to keep foreign objects in memory

39−-- to make things a bit faster?

40−

41−

42−

43−-- GENERATORS

44−

45−

46−type Task a =

47− Task.Task Exit.Generate a

48−

49−

50−debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder

51−debug root details (Build.Artifacts pkg ifaces roots modules) =

52− do loading <- loadObjects root details modules

53− types <- loadTypes root ifaces modules

54− objects <- finalizeObjects loading

55− let mode = Mode.Dev (Just types)

56− let graph = objectsToGlobalGraph objects

57− let mains = gatherMains pkg objects roots

58− return $ JS.generate mode graph mains

59−

60−

61−dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder

62−dev root details (Build.Artifacts pkg _ roots modules) =

63− do objects <- finalizeObjects =<< loadObjects root details modules

64− let mode = Mode.Dev Nothing

65− let graph = objectsToGlobalGraph objects

66− let mains = gatherMains pkg objects roots

67− return $ JS.generate mode graph mains

68−

69−

70−prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder

71−prod root details (Build.Artifacts pkg _ roots modules) =

72− do objects <- finalizeObjects =<< loadObjects root details modules

73− checkForDebugUses objects

74− let graph = objectsToGlobalGraph objects

75− let mode = Mode.Prod (Mode.shortenFieldNames graph)

76− let mains = gatherMains pkg objects roots

77− return $ JS.generate mode graph mains

78−

79−

80−repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder

81−repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =

82− do objects <- finalizeObjects =<< loadObjects root details modules

83− let graph = objectsToGlobalGraph objects

84− return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)

85−

86−

87−

88−-- CHECK FOR DEBUG

89−

90−

91−checkForDebugUses :: Objects -> Task ()

92−checkForDebugUses (Objects _ locals) =

93− case Map.keys (Map.filter Nitpick.hasDebugUses locals) of

94− [] -> return ()

95− m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)

96−

97−

98−

99−-- GATHER MAINS

100−

101−

102−gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main

103−gatherMains pkg (Objects _ locals) roots =

104− Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)

105−

106−

107−lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)

108−lookupMain pkg locals root =

109− let

110− toPair name (Opt.LocalGraph maybeMain _ _) =

111− (,) (ModuleName.Canonical pkg name) <$> maybeMain

112− in

113− case root of

114− Build.Inside name -> toPair name =<< Map.lookup name locals

115− Build.Outside name _ g -> toPair name g

116−

117−

118−

119−-- LOADING OBJECTS

120−

121−

122−data LoadingObjects =

123− LoadingObjects

124− { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)

125− , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))

126− }

127−

128−

129−loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects

130−loadObjects root details modules =

131− Task.io $

132− do mvar <- Details.loadObjects root details

133− mvars <- traverse (loadObject root) modules

134− return $ LoadingObjects mvar (Map.fromList mvars)

135−

136−

137−loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))

138−loadObject root modul =

139− case modul of

140− Build.Fresh name _ graph ->

141− do mvar <- newMVar (Just graph)

142− return (name, mvar)

143−

144− Build.Cached name _ _ ->

145− do mvar <- newEmptyMVar

146− _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)

147− return (name, mvar)

148−

149−

150−

151−-- FINALIZE OBJECTS

152−

153−

154−data Objects =

155− Objects

156− { _foreign :: Opt.GlobalGraph

157− , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph

158− }

159−

160−

161−finalizeObjects :: LoadingObjects -> Task Objects

162−finalizeObjects (LoadingObjects mvar mvars) =

163− Task.eio id $

164− do result <- readMVar mvar

165− results <- traverse readMVar mvars

166− case liftM2 Objects result (sequence results) of

167− Just loaded -> return (Right loaded)

168− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)

169−

170−

171−objectsToGlobalGraph :: Objects -> Opt.GlobalGraph

172−objectsToGlobalGraph (Objects globals locals) =

173− foldr Opt.addLocalGraph globals locals

174−

175−

176−

177−-- LOAD TYPES

178−

179−

180−loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types

181−loadTypes root ifaces modules =

182− Task.eio id $

183− do mvars <- traverse (loadTypesHelp root) modules

184− let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))

185− results <- traverse readMVar mvars

186− case sequence results of

187− Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))

188− Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)

189−

190−

191−loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))

192−loadTypesHelp root modul =

193− case modul of

194− Build.Fresh name iface _ ->

195− newMVar (Just (Extract.fromInterface name iface))

196−

197− Build.Cached name _ ciMVar ->

198− do cachedInterface <- readMVar ciMVar

199− case cachedInterface of

200− Build.Unneeded ->

201− do mvar <- newEmptyMVar

202− _ <- forkIO $

203− do maybeIface <- File.readBinary (Stuff.elmi root name)

204− putMVar mvar (Extract.fromInterface name <$> maybeIface)

205− return mvar

206−

207− Build.Loaded iface ->

208− newMVar (Just (Extract.fromInterface name iface))

209−

210− Build.Corrupted ->

211− newMVar Nothing

builder/src/Http.hs+1−14

@@ -16,7 +16,6 @@ module Http

16 -- upload

17 , upload

18 , filePart

19− , jsonPart

20 , stringPart

19 , stringPart

21 )

20 )

22 where

21 where

@@ -27,7 +26,6 @@ import qualified Codec.Archive.Zip as Zip

27import Control.Exception (SomeException, handle)

26import Control.Exception (SomeException, handle)

28import qualified Data.Binary as Binary

27import qualified Data.Binary as Binary

29import qualified Data.Binary.Get as Binary

28import qualified Data.Binary.Get as Binary

30−import qualified Data.ByteString.Builder as B

31import qualified Data.ByteString.Char8 as BS

29import qualified Data.ByteString.Char8 as BS

32import qualified Data.Digest.Pure.SHA as SHA

30import qualified Data.Digest.Pure.SHA as SHA

33import qualified Data.String as String

31import qualified Data.String as String

@@ -36,10 +34,8 @@ import Network.HTTP.Client

36import Network.HTTP.Client.TLS (tlsManagerSettings)

34import Network.HTTP.Client.TLS (tlsManagerSettings)

37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)

35import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)

38import Network.HTTP.Types.Method (Method, methodGet, methodPost)

36import Network.HTTP.Types.Method (Method, methodGet, methodPost)

39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))

40import qualified Network.HTTP.Client.MultipartFormData as Multi

37import qualified Network.HTTP.Client.MultipartFormData as Multi

41

38

42−import qualified Json.Encode as Encode

43import qualified Elm.Version as V

39import qualified Elm.Version as V

44

40

45

41

@@ -230,15 +226,6 @@ filePart name filePath =

230 Multi.partFileSource (String.fromString name) filePath

226 Multi.partFileSource (String.fromString name) filePath

231

227

232

228

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−

242stringPart :: String -> String -> Multi.Part

229stringPart :: String -> String -> Multi.Part

243stringPart name string =

230stringPart name string =

244− Multi.partBS (String.fromString name) (BS.pack string)

231+ Multi.partBS (String.fromString name) (BS.pack string)

builder/src/Reporting.hs+22−49

@@ -1,7 +1,6 @@

1{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2module Reporting

3 ( Style

4− , silent

5 , json

4 , json

6 , terminal

5 , terminal

7 --

6 --

@@ -10,7 +9,6 @@ module Reporting

10 --

9 --

11 , Key

10 , Key

12 , report

11 , report

13− , ignorer

14 , ask

12 , ask

15 --

13 --

16 , DKey

14 , DKey

@@ -33,7 +31,7 @@ import qualified Data.ByteString.Builder as B

33import qualified Data.NonEmptyList as NE

31import qualified Data.NonEmptyList as NE

34import qualified System.Exit as Exit

32import qualified System.Exit as Exit

35import qualified System.Info as Info

33import qualified System.Info as Info

36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)

34+import System.IO (hFlush, hPutStr, stderr, stdout)

37

35

38import qualified Elm.ModuleName as ModuleName

36import qualified Elm.ModuleName as ModuleName

39import qualified Elm.Package as Pkg

37import qualified Elm.Package as Pkg

@@ -50,16 +48,10 @@ import qualified Reporting.Exit.Help as Help

50

48

51

49

52data Style

50data Style

53− = Silent

54− | Json

51+ = Json

55 | Terminal (MVar ())

52 | Terminal (MVar ())

56

53

57

54

58−silent :: Style

59−silent =

60− Silent

61−

62−

63json :: Style

55json :: Style

64json =

56json =

65 Json

57 Json

@@ -78,9 +70,7 @@ attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a

78attempt toReport work =

70attempt toReport work =

79 do result <- work `catch` reportExceptionsNicely

71 do result <- work `catch` reportExceptionsNicely

80 case result of

72 case result of

81− Right a ->

82− return a

73+ Right a -> return a

83−

84 Left x ->

74 Left x ->

85 do Exit.toStderr (toReport x)

75 do Exit.toStderr (toReport x)

86 Exit.exitFailure

76 Exit.exitFailure

@@ -90,14 +80,9 @@ attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a

90attemptWithStyle style toReport work =

80attemptWithStyle style toReport work =

91 do result <- work `catch` reportExceptionsNicely

81 do result <- work `catch` reportExceptionsNicely

92 case result of

82 case result of

93− Right a ->

94− return a

83+ Right a -> return a

95−

96 Left x ->

84 Left x ->

97 case style of

85 case style of

98− Silent ->

99− do Exit.exitFailure

100−

101 Json ->

86 Json ->

102 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))

87 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))

103 Exit.exitFailure

88 Exit.exitFailure

@@ -122,6 +107,11 @@ badMark =

122 D.red $ if isWindows then "X" else "✗"

107 D.red $ if isWindows then "X" else "✗"

123

108

124

109

110+_waitingMark :: D.Doc

111+_waitingMark =

112+ D.dullyellow $ if isWindows then "-" else "→"

113+

114+

125isWindows :: Bool

115isWindows :: Bool

126isWindows =

116isWindows =

127 Info.os == "mingw32"

117 Info.os == "mingw32"

@@ -139,11 +129,6 @@ report (Key send) msg =

139 send msg

129 send msg

140

130

141

131

142−ignorer :: Key msg

143−ignorer =

144− Key (\_ -> return ())

145−

146−

147

132

148-- ASK

133-- ASK

149

134

@@ -177,9 +162,6 @@ type DKey = Key DMsg

177trackDetails :: Style -> (DKey -> IO a) -> IO a

162trackDetails :: Style -> (DKey -> IO a) -> IO a

178trackDetails style callback =

163trackDetails style callback =

179 case style of

164 case style of

180− Silent ->

181− callback (Key (\_ -> return ()))

182−

183 Json ->

165 Json ->

184 callback (Key (\_ -> return ()))

166 callback (Key (\_ -> return ()))

185

167

@@ -264,8 +246,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()

264putDownload mark pkg vsn =

246putDownload mark pkg vsn =

265 Help.toStdout $ D.indent 2 $

247 Help.toStdout $ D.indent 2 $

266 mark

248 mark

267− <+> D.fromPackage pkg

249+ <+> D.fromUtf8 (Pkg.toString pkg)

268− <+> D.fromVersion vsn

250+ <+> D.fromUtf8 (V.toString vsn)

269 <> "\n"

251 <> "\n"

270

252

271

253

@@ -309,9 +291,6 @@ type BResult a = Either Exit.BuildProblem a

309trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)

291trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)

310trackBuild style callback =

292trackBuild style callback =

311 case style of

293 case style of

312− Silent ->

313− callback (Key (\_ -> return ()))

314−

315 Json ->

294 Json ->

316 callback (Key (\_ -> return ()))

295 callback (Key (\_ -> return ()))

317

296

@@ -364,10 +343,10 @@ toFinalMessage done result =

364

343

365 Left problem ->

344 Left problem ->

366 case problem of

345 case problem of

367− Exit.BuildBadModules _ _ [] ->

346+ Exit.BuildModuleProblems _ [] ->

368 "Detected problems in 1 module."

347 "Detected problems in 1 module."

369

348

370− Exit.BuildBadModules _ _ (_:ps) ->

349+ Exit.BuildModuleProblems _ (_:ps) ->

371 "Detected problems in " ++ show (2 + length ps) ++ " modules."

350 "Detected problems in " ++ show (2 + length ps) ++ " modules."

372

351

373 Exit.BuildProjectProblem _ ->

352 Exit.BuildProjectProblem _ ->

@@ -381,9 +360,6 @@ toFinalMessage done result =

381reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()

360reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()

382reportGenerate style names output =

361reportGenerate style names output =

383 case style of

362 case style of

384− Silent ->

385− return ()

386−

387 Json ->

363 Json ->

388 return ()

364 return ()

389

365

@@ -446,23 +422,20 @@ reportExceptionsNicely e =

446

422

447

423

448putException :: SomeException -> IO ()

424putException :: SomeException -> IO ()

449−putException e = do

425+putException e =

450− hPutStrLn stderr ""

451 Help.toStderr $ D.stack $

426 Help.toStderr $ D.stack $

452− [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"

453− , D.reflow $

427+ [ D.reflow $

454− "I ran into something that bypassed the normal error reporting process!\

428+ "Oh no! I ran into something that bypassed the normal error reporting process!\

455 \ I extracted whatever information I could from the internal error:"

429 \ I extracted whatever information I could from the internal error:"

456 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))

430 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))

457 , D.reflow $

431 , D.reflow $

458− "These errors are usually pretty confusing, so start by asking around on one of\

432+ "These errors are usually pretty confusing, so start by asking around on Slack\

459− \ forums listed at https://elm-lang.org/community to see if anyone can get you\

460− \ unstuck quickly."

433+ \ or Discourse to see if anyone can get you unstuck quickly."

461− , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"

434+ , "------------------------------------------------------------"

462 , D.reflow $

435 , D.reflow $

463− "If you are feeling up to it, please try to get your code down to the smallest\

436+ "From there, if you are feeling up to it, please try to get your code down to the\

464− \ version that still triggers this message. Ideally in a single Main.elm and\

437+ \ smallest version that still triggers this message. Ideally in a single Main.elm\

465− \ elm.json file."

438+ \ and elm.json file."

466 , D.reflow $

439 , D.reflow $

467 "From there open a NEW issue at https://github.com/elm/compiler/issues with\

440 "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\

441 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\

builder/src/Reporting/Exit.hs+326−1649

@@ -1,27 +1,28 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Reporting.Exit

3+ ( Exit(..)

4+ --

5+ , Init(..)

3− ( Init(..), initToReport

6+ , initToReport

7+ --

8+ , Diff(..)

4− , Diff(..), diffToReport

9+ , diffToReport

5− , Make(..), makeToReport

10+ --

6− , Bump(..), bumpToReport

11+ , Install(..)

7− , Repl(..), replToReport

8− , Publish(..), publishToReport

9− , Install(..), installToReport

12+ , installToReport

10− , Reactor(..), reactorToReport

11− , newPackageOverview

12 --

13 --

13− , Solver(..)

14− , Outline(..)

15− , OutlineProblem(..)

16 , Details(..)

14 , Details(..)

17− , DetailsBadDep(..)

15+ , OutlineProblem(..)

18− , PackageProblem(..)

16+ , OutlineStructureProblem(..)

19 , RegistryProblem(..)

17 , RegistryProblem(..)

18+ , PackageProblem(..)

19+ --

20+ , Make(..)

20 , BuildProblem(..)

21 , BuildProblem(..)

21 , BuildProjectProblem(..)

22 , BuildProjectProblem(..)

22− , DocsProblem(..)

23+ , makeToReport

23− , Generate(..)

24 --

25+ , DocsProblem(..)

25 , toString

26 , toString

26 , toStderr

27 , toStderr

27 , toJson

28 , toJson

@@ -29,56 +30,59 @@ module Reporting.Exit

29 where

30 where

30

31

32

32−import qualified Data.ByteString as BS

33−import qualified Data.ByteString.UTF8 as BS_UTF8

34import qualified Data.List as List

33import qualified Data.List as List

35−import qualified Data.Map as Map

34+import qualified Data.Utf8 as Utf8

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

35

44import qualified Elm.Constraint as C

36import qualified Elm.Constraint as C

45import qualified Elm.Magnitude as M

37import qualified Elm.Magnitude as M

46import qualified Elm.ModuleName as ModuleName

38import qualified Elm.ModuleName as ModuleName

47import qualified Elm.Package as Pkg

39import qualified Elm.Package as Pkg

48import qualified Elm.Version as V

40import qualified Elm.Version as V

49−import qualified File

50import qualified Http

41import qualified Http

51−import qualified Json.Decode as Decode

52import qualified Json.Encode as Encode

42import 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

56import Reporting.Doc ((<>))

43import Reporting.Doc ((<>))

57import qualified Reporting.Doc as D

44import qualified Reporting.Doc as D

58−import qualified Reporting.Error.Import as Import

59import qualified Reporting.Error.Json as Json

45import qualified Reporting.Error.Json as Json

60import qualified Reporting.Exit.Help as Help

46import qualified Reporting.Exit.Help as Help

61−import qualified Reporting.Error as Error

47+import qualified Reporting.Problem as Problem

62−import qualified Reporting.Render.Code as Code

63−

64−

65

48

66−-- RENDERERS

67

49

68

50

69−toString :: Help.Report -> String

51+-- ALL POSSIBLE ERRORS

70−toString report =

71− Help.toString (Help.reportToDoc report)

72

52

73

53

74−toStderr :: Help.Report -> IO ()

54+data Exit

75−toStderr report =

55+ -- bump

76− Help.toStderr (Help.reportToDoc report)

56+ = BumpApplication

57+ | BumpUnexpectedVersion V.Version [V.Version]

58+ | BumpMustHaveLatestRegistry RegistryProblem

59+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem

60+ -- publish

61+ | PublishMustHaveLatestRegistry RegistryProblem

62+ | PublishApplication

63+ | PublishNotInitialVersion V.Version

64+ | PublishAlreadyPublished V.Version

65+ | PublishInvalidBump V.Version V.Version

66+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude

67+ | PublishNoSummary

68+ | PublishNoExposed

69+ | PublishNoReadme

70+ | PublishShortReadme

71+ | PublishNoLicense

72+ | PublishCannotGetTag Http.Error

73+ | PublishCannotGetZip Http.Error

74+ | PublishCannotDecodeZip

75+ | PublishCannotGetDocs DocsProblem

76+ | PublishCannotRegister Http.Error

77+ | PublishMissingTag V.Version

78+ | PublishNoGit

79+ | PublishLocalChanges V.Version

77

80

78

81

79−toJson :: Help.Report -> Encode.Value

82+data DocsProblem

80−toJson report =

83+ = DP_Http Http.Error

81− Help.reportToJson report

84+ | DP_Data

85+ | DP_Cache

82

86

83

87

84

88

@@ -87,8 +91,6 @@ toJson report =

87

91

88data Init

92data Init

89 = InitNoSolution [Pkg.Name]

93 = InitNoSolution [Pkg.Name]

90− | InitNoOfflineSolution [Pkg.Name]

91− | InitSolverProblem Solver

92 | InitAlreadyExists

94 | InitAlreadyExists

93 | InitRegistryProblem RegistryProblem

95 | InitRegistryProblem RegistryProblem

94

96

@@ -107,21 +109,6 @@ initToReport exit =

107 \ what is going on!"

109 \ what is going on!"

108 ]

110 ]

109

111

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

112 InitAlreadyExists ->

126 Help.report "EXISTING PROJECT" Nothing

113 Help.report "EXISTING PROJECT" Nothing

127 "You already have an elm.json file, so there is nothing for me to initialize!"

114 "You already have an elm.json file, so there is nothing for me to initialize!"

@@ -131,9 +118,8 @@ initToReport exit =

131 ]

118 ]

132 ]

119 ]

133

120

134− InitRegistryProblem problem ->

121+ InitRegistryProblem _ ->

135− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

122+ error "TODO InitRegistryProblem"

136− "I need the list of published packages before I can start initializing projects"

137

123

138

124

139

125

@@ -141,48 +127,22 @@ initToReport exit =

141

127

142

128

143data Diff

129data Diff

144− = DiffNoOutline

145− | DiffBadOutline Outline

146− | DiffApplication

130+ = DiffApplication

147− | DiffNoExposed

148 | DiffUnpublished

131 | DiffUnpublished

149 | DiffUnknownPackage Pkg.Name [Pkg.Name]

132 | DiffUnknownPackage Pkg.Name [Pkg.Name]

150 | DiffUnknownVersion Pkg.Name V.Version [V.Version]

133 | DiffUnknownVersion Pkg.Name V.Version [V.Version]

151− | DiffDocsProblem V.Version DocsProblem

134+ | DiffCannotFindDocs DocsProblem

152 | DiffMustHaveLatestRegistry RegistryProblem

135 | DiffMustHaveLatestRegistry RegistryProblem

153− | DiffBadDetails Details

154− | DiffBadBuild BuildProblem

155

136

156

137

157diffToReport :: Diff -> Help.Report

138diffToReport :: Diff -> Help.Report

158diffToReport diff =

139diffToReport diff =

159 case diff of

140 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 ->

141 DiffApplication ->

172− Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")

142+ Help.report "CANNOT DIFF APPLICATIONS" Nothing

173− "Your elm.json says this project is an application, but `elm diff` only works\

143+ "I cannot perform diffs on applications, only packages! If you are\

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:"

144+ \ 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"

145+ [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"

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 ]

146 ]

187

147

188 DiffUnpublished ->

148 DiffUnpublished ->

@@ -194,16 +154,16 @@ diffToReport diff =

194 Help.report "UNKNOWN PACKAGE" Nothing

154 Help.report "UNKNOWN PACKAGE" Nothing

195 ( "I cannot find a package called:"

155 ( "I cannot find a package called:"

196 )

156 )

197− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg

157+ [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg

198 , "Maybe you want one of these instead?"

158 , "Maybe you want one of these instead?"

199− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions

159+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions

200 , "But check <https://package.elm-lang.org> to see all possibilities!"

160 , "But check <https://package.elm-lang.org> to see all possibilities!"

201 ]

161 ]

202

162

203 DiffUnknownVersion _pkg vsn realVersions ->

163 DiffUnknownVersion _pkg vsn realVersions ->

204 Help.docReport "UNKNOWN VERSION" Nothing

164 Help.docReport "UNKNOWN VERSION" Nothing

205 ( D.fillSep $

165 ( D.fillSep $

206− [ "Version", D.red (D.fromVersion vsn)

166+ [ "Version", D.red (D.fromUtf8 (V.toString vsn))

207 , "has", "never", "been", "published,", "so", "I"

167 , "has", "never", "been", "published,", "so", "I"

208 , "cannot", "diff", "against", "it."

168 , "cannot", "diff", "against", "it."

209 ]

169 ]

@@ -212,57 +172,191 @@ diffToReport diff =

212 , D.indent 4 $ D.dullyellow $ D.vcat $

172 , D.indent 4 $ D.dullyellow $ D.vcat $

213 let

173 let

214 sameMajor v1 v2 = V._major v1 == V._major v2

174 sameMajor v1 v2 = V._major v1 == V._major v2

215− mkRow vsns = D.hsep $ map D.fromVersion vsns

175+ mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns

216 in

176 in

217 map mkRow $ List.groupBy sameMajor (List.sort realVersions)

177 map mkRow $ List.groupBy sameMajor (List.sort realVersions)

218 , "Want one of those instead?"

178 , "Want one of those instead?"

219 ]

179 ]

220

180

221− DiffDocsProblem version problem ->

181+ DiffCannotFindDocs problem ->

222− toDocsProblemReport problem $

182+ error "TODO DiffCannotFindDocs" problem

223− "I need the docs for " ++ V.toChars version ++ " to compute this diff"

224

183

225 DiffMustHaveLatestRegistry problem ->

184 DiffMustHaveLatestRegistry problem ->

226− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

185+ error "TODO DiffMustHaveLatestRegistry" problem

227− "I need the latest list of published packages before I do this diff"

228−

229− DiffBadDetails details ->

230− toDetailsReport details

231

186

232− DiffBadBuild buildProblem ->

233− toBuildProblemReport buildProblem

234

187

235

188

189+-- INSTALL

236

190

237−-- BUMP

238

191

192+data Install

193+ = InstallNoProject

194+ | InstallNoArgs FilePath

195+ | InstallNoSolution [Pkg.Name]

239

196

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

197

198+installToReport :: Install -> Help.Report

199+installToReport exit =

200+ case exit of

201+ InstallNoProject ->

202+ Help.report "NEW PROJECT?" Nothing

203+ (error "TODO InstallNoProject")

204+ (error "TODO InstallNoProject details")

251

205

252−bumpToReport :: Bump -> Help.Report

206+ InstallNoArgs elmHome ->

253−bumpToReport bump =

254− case bump of

255− BumpNoOutline ->

256− Help.report "BUMP WHAT?" Nothing

207+ Help.report "INSTALL WHAT?" Nothing

257− "I cannot find an elm.json so I am not sure what you want me to bump."

208+ "I am expecting commands like:"

258− [ D.reflow $

209+ [ D.green $ D.indent 4 $ D.vcat $

259− "Elm packages always have an elm.json that says current the version number. If\

210+ [ "elm install elm/http"

260− \ you run this command from a directory with an elm.json file, I will try to bump\

211+ , "elm install elm/json"

261− \ the version in there based on the API changes."

212+ , "elm install elm/random"

213+ ]

214+ , D.toFancyHint

215+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."

216+ ,"\"Gotta","download","everything!\"","But","why","download","packages"

217+ ,"again","and","again?","Instead,","Elm","caches","packages","in"

218+ ,D.dullyellow (D.fromChars elmHome)

219+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."

220+ ,"Elm","projects","check","that","cache","before","trying","the","internet."

221+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"

222+ ,"easier","to","work","offline.","As","a","result"

223+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"

224+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"

225+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"

226+ ]

262 ]

227 ]

263

228

264− BumpBadOutline outline ->

229+ InstallNoSolution badPackages ->

265− toOutlineReport outline

230+ case badPackages of

231+ [] ->

232+ Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO give better advice!

233+ "This usually happens if you try to modify dependency constraints by\

234+ \ hand. I recommend deleting any dependency you added recently (or all\

235+ \ of them if things are bad) and then adding them again with:"

236+ [ D.indent 4 $ D.green "elm install"

237+ , D.reflow $

238+ "And do not be afaid to ask for help on Slack if you get stuck!"

239+ ]

240+

241+ _:_ ->

242+ Help.report "OLD DEPENDENCIES" (Just "elm.json")

243+ ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"

244+ )

245+ [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages

246+ , D.reflow $

247+ "This may be because it is not upgraded yet. It may be because a\

248+ \ better solution came along, so there was no need to upgrade it.\

249+ \ Etc. Try asking around on Slack to learn more about the topic."

250+ , D.toSimpleNote

251+ "Whatever the case, please be kind to the relevant package authors! Having\

252+ \ friendly interactions with users is great motivation, and conversely, getting\

253+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\

254+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\

255+ \ goals, etc. They face obstacles outside of their technical work you will never\

256+ \ know about, so please assume the best and try to be patient and supportive!"

257+ ]

258+

259+

260+

261+-- DETAILS

262+

263+

264+data Details

265+ = DetailsCorrupt

266+ | DetailsBadElmInPkg C.Constraint

267+ | DetailsBadElmInAppOutline V.Version

268+ | DetailsHandEditedDependencies

269+ | DetailsBadOutline OutlineProblem

270+ | DetailsCannotGetRegistry RegistryProblem

271+ | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem

272+

273+

274+data OutlineProblem

275+ = BadOutlineStructure (Json.Error OutlineStructureProblem)

276+ | BadOutlineSrcDirs FilePath [FilePath]

277+

278+

279+data OutlineStructureProblem

280+ = OSP_BadType Utf8.String

281+ | OSP_BadPkgName Pkg.BadName

282+ | OSP_BadVersion Utf8.String

283+ | OSP_BadConstraint C.Error

284+ | OSP_BadModuleName Utf8.String

285+ | OSP_BadModuleHeaderTooLong Utf8.String

286+ | OSP_BadDependencyName Utf8.String

287+ | OSP_BadLicense Utf8.String [Utf8.String]

288+ | OSP_BadSummaryTooLong

289+

290+

291+data RegistryProblem

292+ = RP_Http Http.Error

293+ | RP_Data

294+

295+

296+data PackageProblem

297+ = PP_BadEndpointRequest Http.Error

298+ | PP_BadEndpointContent

299+ | PP_BadArchiveRequest Http.Error

300+ | PP_BadArchiveContent

301+ | PP_BadArchiveHash String String

302+

303+

304+

305+-- MAKE

306+

307+

308+data Make

309+ = MakeNeedsOutline

310+ | MakeCannotOptimizeAndDebug

311+ | MakeBlockedByDetailsProblem Details

312+ | MakeAppNeedsFileNames

313+ | MakePkgNeedsExposing

314+ | MakeMultipleFilesIntoHtml

315+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]

316+ | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]

317+ | MakeCannotBuild BuildProblem

318+ | MakeCannotLoadArtifacts

319+

320+

321+data BuildProblem

322+ = BuildModuleProblems Problem.Problem [Problem.Problem]

323+ | BuildProjectProblem BuildProjectProblem

324+

325+

326+data BuildProjectProblem

327+ = BP_PathUnknown FilePath

328+ | BP_WithBadExtension FilePath

329+ | BP_WithAmbiguousSrcDir FilePath FilePath

330+ | BP_MainPathDuplicate FilePath FilePath

331+ | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath

332+ | BP_CannotLoadDependencies

333+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]

334+

335+

336+

337+-- RENDERERS

338+

339+

340+toString :: Help.Report -> String

341+toString report =

342+ Help.toString (Help.reportToDoc report)

343+

344+

345+toStderr :: Help.Report -> IO ()

346+toStderr report =

347+ Help.toStderr (Help.reportToDoc report)

348+

349+

350+toJson :: Help.Report -> Encode.Value

351+toJson report =

352+ Help.reportToJson report

353+

354+

355+_toReport :: Exit -> Help.Report

356+_toReport exit =

357+ case exit of

358+

359+ -- bump

266

360

267 BumpApplication ->

361 BumpApplication ->

268 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")

362 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")

@@ -274,7 +368,7 @@ bumpToReport bump =

274 Help.docReport "CANNOT BUMP" (Just "elm.json")

368 Help.docReport "CANNOT BUMP" (Just "elm.json")

275 ( D.fillSep

369 ( D.fillSep

276 ["Your","elm.json","says","I","should","bump","relative","to","version"

370 ["Your","elm.json","says","I","should","bump","relative","to","version"

277− ,D.red (D.fromVersion vsn) <> ","

371+ ,D.red (D.fromUtf8 (V.toString vsn)) <> ","

278 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."

372 ,"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"

373 ,"That","means","there","is","no","API","for","me","to","diff","against","and"

280 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."

374 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."

@@ -283,116 +377,19 @@ bumpToReport bump =

283 [ D.fillSep $

377 [ D.fillSep $

284 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]

378 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]

285 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]

379 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]

286− , D.vcat $ map (D.green . D.fromVersion) versions

380+ , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions

287 ]

381 ]

288

382

289 BumpMustHaveLatestRegistry problem ->

383 BumpMustHaveLatestRegistry problem ->

290− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

384+ error "TODO BumpMustHaveLatestRegistry" 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

385

341−-- PUBLISH

386+ BumpCannotFindDocs name version problem ->

387+ error "TODO BumpCannotFindDocs" name version problem

342

388

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

389+ -- publish

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

390

393 PublishMustHaveLatestRegistry problem ->

391 PublishMustHaveLatestRegistry problem ->

394− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

392+ error "TODO PublishMustHaveLatestRegistry" problem

395− "I need the latest list of published packages to make sure this is safe to publish"

396

393

397 PublishApplication ->

394 PublishApplication ->

398 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []

395 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []

@@ -401,7 +398,7 @@ publishToReport publish =

401 Help.docReport "INVALID VERSION" Nothing

398 Help.docReport "INVALID VERSION" Nothing

402 ( D.fillSep

399 ( D.fillSep

403 ["I","cannot","publish"

400 ["I","cannot","publish"

404− ,D.red (D.fromVersion vsn)

401+ ,D.red (D.fromUtf8 (V.toString vsn))

405 ,"as","the","initial","version."

402 ,"as","the","initial","version."

406 ]

403 ]

407 )

404 )

@@ -415,7 +412,7 @@ publishToReport publish =

415 Help.docReport "ALREADY PUBLISHED" Nothing

412 Help.docReport "ALREADY PUBLISHED" Nothing

416 ( D.vcat

413 ( D.vcat

417 [ D.fillSep

414 [ D.fillSep

418− [ "Version", D.green (D.fromVersion vsn)

415+ [ "Version", D.green (D.fromUtf8 (V.toString vsn))

419 , "has", "already", "been", "published.", "You", "cannot"

416 , "has", "already", "been", "published.", "You", "cannot"

420 , "publish", "it", "again!"

417 , "publish", "it", "again!"

421 ]

418 ]

@@ -432,14 +429,14 @@ publishToReport publish =

432 Help.docReport "INVALID VERSION" (Just "elm.json")

429 Help.docReport "INVALID VERSION" (Just "elm.json")

433 ( D.fillSep $

430 ( D.fillSep $

434 ["Your","elm.json","says","the","next","version","should","be"

431 ["Your","elm.json","says","the","next","version","should","be"

435− ,D.red (D.fromVersion statedVersion) <> ","

432+ ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","

436 ,"but","that","is","not","valid","based","on","the","previously"

433 ,"but","that","is","not","valid","based","on","the","previously"

437 ,"published","versions."

434 ,"published","versions."

438 ]

435 ]

439 )

436 )

440 [ D.fillSep $

437 [ D.fillSep $

441 ["Change","the","version","back","to"

438 ["Change","the","version","back","to"

442− ,D.green (D.fromVersion latestVersion)

439+ ,D.green (D.fromUtf8 (V.toString latestVersion))

443 ,"which","is","the","most","recently","published","version."

440 ,"which","is","the","most","recently","published","version."

444 ,"From","there,","have","Elm","bump","the","version","by","running:"

441 ,"From","there,","have","Elm","bump","the","version","by","running:"

445 ]

442 ]

@@ -454,7 +451,7 @@ publishToReport publish =

454 (

451 (

455 D.fillSep $

452 D.fillSep $

456 ["Your","elm.json","says","the","next","version","should","be"

453 ["Your","elm.json","says","the","next","version","should","be"

457− ,D.red (D.fromVersion new) <> ","

454+ ,D.red (D.fromUtf8 (V.toString new)) <> ","

458 ,"indicating","a",D.fromChars (M.toChars magnitude)

455 ,"indicating","a",D.fromChars (M.toChars magnitude)

459 ,"change","to","the","public","API."

456 ,"change","to","the","public","API."

460 ,"This","does","not","match","the","API","diff","given","by:"

457 ,"This","does","not","match","the","API","diff","given","by:"

@@ -467,7 +464,7 @@ publishToReport publish =

467 ["This","command","says","this","is","a"

464 ["This","command","says","this","is","a"

468 ,D.fromChars (M.toChars realMagnitude)

465 ,D.fromChars (M.toChars realMagnitude)

469 ,"change,","so","the","next","version","should","be"

466 ,"change,","so","the","next","version","should","be"

470− ,D.green (D.fromVersion realNew) <> "."

467+ ,D.green (D.fromUtf8 (V.toString realNew)) <> "."

471 ,"Double","check","everything","to","make","sure","you"

468 ,"Double","check","everything","to","make","sure","you"

472 ,"are","publishing","what","you","want!"

469 ,"are","publishing","what","you","want!"

473 ]

470 ]

@@ -497,17 +494,16 @@ publishToReport publish =

497 ]

494 ]

498 )

495 )

499 [ D.reflow $

496 [ D.reflow $

500− "Which modules do you want users of the package to have access to? Add their\

497+ "What is the point of a package that has no modules?!"

501− \ names to the \"exposed-modules\" list."

502 ]

498 ]

503

499

504 PublishNoReadme ->

500 PublishNoReadme ->

505− toBadReadmeReport "NO README" $

501+ badReadmeReport "NO README" $

506 "Every published package must have a helpful README.md\

502 "Every published package must have a helpful README.md\

507 \ file, but I do not see one in your project."

503 \ file, but I do not see one in your project."

508

504

509 PublishShortReadme ->

505 PublishShortReadme ->

510− toBadReadmeReport "SHORT README" $

506+ badReadmeReport "SHORT README" $

511 "This README.md is too short. Having more details will help\

507 "This README.md is too short. Having more details will help\

512 \ people assess your package quickly and fairly."

508 \ people assess your package quickly and fairly."

513

509

@@ -524,8 +520,20 @@ publishToReport publish =

524 \ named LICENSE. Add that file and you will be all set!"

520 \ named LICENSE. Add that file and you will be all set!"

525 ]

521 ]

526

522

527− PublishBuildProblem buildProblem ->

523+ PublishCannotGetTag httpError ->

528− toBuildProblemReport buildProblem

524+ error "TODO PublishCannotGetTag" httpError

525+

526+ PublishCannotGetZip httpError ->

527+ error "TODO PublishCannotGetZip" httpError

528+

529+ PublishCannotDecodeZip ->

530+ error "TODO PublishCannotDecodeZip"

531+

532+ PublishCannotGetDocs docsProblem ->

533+ error "TODO PublishCannotGetDocs" docsProblem

534+

535+ PublishCannotRegister httpError ->

536+ error "TODO PublishCannotRegister" httpError

529

537

530 PublishMissingTag version ->

538 PublishMissingTag version ->

531 let vsn = V.toChars version in

539 let vsn = V.toChars version in

@@ -546,70 +554,6 @@ publishToReport publish =

546 , "The -m flag is for a helpful message. Try to make it more informative!"

554 , "The -m flag is for a helpful message. Try to make it more informative!"

547 ]

555 ]

548

556

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

557 PublishNoGit ->

614 Help.report "NO GIT" Nothing

558 Help.report "NO GIT" Nothing

615 "I searched your PATH environment variable for `git` and could not\

559 "I searched your PATH environment variable for `git` and could not\

@@ -639,21 +583,9 @@ publishToReport publish =

639 ++ vsn ++ "` and publish your code from there."

583 ++ vsn ++ "` and publish your code from there."

640 ]

584 ]

641

585

642− PublishZipBadDetails _ ->

643− badZipReport

644−

645− PublishZipApplication ->

646− badZipReport

647−

648− PublishZipNoExposed ->

649− badZipReport

650

586

651− PublishZipBuildProblem _ ->

652− badZipReport

653−

654−

655−toBadReadmeReport :: String -> String -> Help.Report

587+badReadmeReport :: String -> String -> Help.Report

656−toBadReadmeReport title summary =

588+badReadmeReport title summary =

657 Help.report title (Just "README.md") summary

589 Help.report title (Just "README.md") summary

658 [ D.reflow $

590 [ D.reflow $

659 "When people look at your README, they are wondering:"

591 "When people look at your README, they are wondering:"

@@ -666,942 +598,65 @@ toBadReadmeReport title summary =

666 \ most common usage scenario. Show people what they can expect if\

598 \ most common usage scenario. Show people what they can expect if\

667 \ they learn more!"

599 \ they learn more!"

668 , D.toSimpleNote $

600 , D.toSimpleNote $

669− "By publishing your package, you are inviting people to invest time in\

601+ "By publishing your package, you are inviting people to invest time\

670− \ understanding your work. Spending an hour on your README to communicate your\

602+ \ in understanding your work. Spending an hour to communicate your\

671− \ knowledge more clearly can save the community days or weeks of time in\

603+ \ knowledge more clearly can save the community days or weeks of time\

672− \ aggregate, and saving time in aggregate is the whole point of publishing\

604+ \ in aggregate, and saving time in aggregate is the whole point of\

673− \ packages! People really appreciate it, and it makes the whole ecosystem feel\

605+ \ publishing packages! People really appreciate it, and it makes the\

674− \ nicer!"

606+ \ whole ecosystem feel 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 ]

607 ]

688

608

689

609

690

610

691−-- DOCS

611+-- DETAILS TO REPORT

692

612

693

613

694−data DocsProblem

614+detailsToReport :: Details -> Help.Report

695− = DP_Http Http.Error

615+detailsToReport details =

696− | DP_Data String BS.ByteString

616+ case details of

697− | DP_Cache

617+ DetailsCorrupt ->

698−

618+ error "TODO DetailsCorrupt"

699

619

700−toDocsProblemReport :: DocsProblem -> String -> Help.Report

620+ DetailsBadElmInPkg constraint ->

701−toDocsProblemReport problem context =

621+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")

702− case problem of

622+ "Your elm.json says this package needs a version of Elm in this range:"

703− DP_Http httpError ->

623+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint

704− toHttpErrorReport "PROBLEM LOADING DOCS" httpError context

624+ , D.fillSep

705−

625+ [ "But", "you", "are", "using", "Elm"

706− DP_Data url body ->

626+ , D.red (D.fromUtf8 (V.toString V.compiler))

707− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")

627+ , "right", "now."

708− [ D.indent 4 $ D.dullyellow $ D.fromChars url

628+ ]

709− , D.reflow $

629+ ]

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

630

1320 DetailsBadElmInAppOutline version ->

631 DetailsBadElmInAppOutline version ->

1321 Help.report "ELM VERSION MISMATCH" (Just "elm.json")

632 Help.report "ELM VERSION MISMATCH" (Just "elm.json")

1322 "Your elm.json says this application needs a different version of Elm."

633 "Your elm.json says this application needs a different version of Elm."

1323 [ D.fillSep

634 [ D.fillSep

1324 [ "It", "requires"

635 [ "It", "requires"

1325− , D.green (D.fromVersion version) <> ","

636+ , D.green (D.fromUtf8 (V.toString version)) <> ","

1326 , "but", "you", "are", "using"

637 , "but", "you", "are", "using"

1327− , D.red (D.fromVersion V.compiler)

638+ , D.red (D.fromUtf8 (V.toString V.compiler))

1328 , "right", "now."

639 , "right", "now."

1329 ]

640 ]

1330 ]

641 ]

1331

642

1332 DetailsHandEditedDependencies ->

643 DetailsHandEditedDependencies ->

1333− Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")

644+ error "TODO DetailsHandEditedDependencies"

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

645

1345− DetailsBadOutline outline ->

646+ DetailsBadOutline problem ->

1346− toOutlineReport outline

647+ error "TODO DetailsBadOutline" problem

1347

648

1348 DetailsCannotGetRegistry problem ->

649 DetailsCannotGetRegistry problem ->

1349− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

650+ error "TODO DetailsCannotGetRegistry" 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

651

1574−toRedirectDoc :: HTTP.Response body -> D.Doc

652+ DetailsCannotBuildPackage name version problem ->

1575−toRedirectDoc response =

653+ error "TODO DetailsCannotBuildPackage" name version problem

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

654

1600

655

1601makeToReport :: Make -> Help.Report

656makeToReport :: Make -> Help.Report

1602makeToReport make =

657makeToReport make =

1603 case make of

658 case make of

1604− MakeNoOutline ->

659+ MakeNeedsOutline ->

1605 Help.report "NO elm.json FILE" Nothing

660 Help.report "NO elm.json FILE" Nothing

1606 "It looks like you are starting a new Elm project. Very exciting! Try running:"

661 "It looks like you are starting a new Elm project. Very exciting! Try running:"

1607 [ D.indent 4 $ D.green $ "elm init"

662 [ D.indent 4 $ D.green $ "elm init"

@@ -1622,344 +677,27 @@ makeToReport make =

1622 \ at once though! Pick just one of those flags and it should work!"

677 \ at once though! Pick just one of those flags and it should work!"

1623 ]

678 ]

1624

679

1625− MakeBadDetails detailsProblem ->

680+ MakeBlockedByDetailsProblem detailsProblem ->

1626− toDetailsReport detailsProblem

681+ detailsToReport detailsProblem

1627

682

1628 MakeAppNeedsFileNames ->

683 MakeAppNeedsFileNames ->

1629 Help.report "NO INPUT" Nothing

684 Help.report "NO INPUT" Nothing

1630− "What should I make though? I need specific files like:"

685+ "What should I make though? I need a specific file like this:"

1631− [ D.vcat

1632− [ D.indent 4 $ D.green "elm make src/Main.elm"

686+ [ 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 $

687+ , D.reflow

1636− "I recommend reading through https://guide.elm-lang.org for guidance on what to\

688+ "However many files you give, I will create one JS file out of them."

1637− \ actually put in those files!"

1638 ]

689 ]

1639

690

1640 MakePkgNeedsExposing ->

691 MakePkgNeedsExposing ->

1641− Help.report "NO INPUT" Nothing

692+ error "TODO MakePkgNeedsExposing"

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

693

1652 MakeMultipleFilesIntoHtml ->

694 MakeMultipleFilesIntoHtml ->

1653− Help.report "TOO MANY FILES" Nothing

695+ error "TODO MakeMultipleFilesIntoHtml"

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

696

1887− Import.Ambiguous _ _ pkg _ ->

697+ MakeNonMainFilesIntoJavaScript _ _ ->

1888− Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

698+ error "TODO MakeNonMainFilesIntoJavaScript"

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

699

1939− bar =

700+ MakeCannotOptimizeDebugValues m ms ->

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

701 Help.report "DEBUG REMNANTS" Nothing

1964 "There are uses of the `Debug` module in the following modules:"

702 "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)

703 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)

@@ -1968,7 +706,7 @@ toGenerateReport problem =

1968 "The issue is that --optimize strips out info needed by `Debug` functions.\

706 "The issue is that --optimize strips out info needed by `Debug` functions.\

1969 \ Here are two examples:"

707 \ Here are two examples:"

1970 , D.indent 4 $ D.reflow $

708 , D.indent 4 $ D.reflow $

1971− "(1) It shortens record field names. This makes the generated JavaScript\

709+ "(1) It shortens record field names. This makes the generated JavaScript is\

1972 \ smaller, but `Debug.toString` cannot know the real field names anymore."

710 \ smaller, but `Debug.toString` cannot know the real field names anymore."

1973 , D.indent 4 $ D.reflow $

711 , D.indent 4 $ D.reflow $

1974 "(2) Values like `type Height = Height Float` are unboxed. This reduces\

712 "(2) Values like `type Height = Height Float` are unboxed. This reduces\

@@ -1981,89 +719,28 @@ toGenerateReport problem =

1981 \ exists!"

719 \ exists!"

1982 ]

720 ]

1983

721

722+ MakeCannotBuild buildProblem ->

723+ case buildProblem of

724+ BuildProjectProblem bp ->

725+ case bp of

726+ BP_PathUnknown _ -> error "TODO BP_PathUnknown"

727+ BP_WithBadExtension _ -> error "TODO BP_WithBadExtension"

728+ BP_WithAmbiguousSrcDir _ _ -> error "TODO BP_WithAmbiguousSrcDir"

729+ BP_MainPathDuplicate _ _ -> error "TODO BP_MainPathDuplicate"

730+ BP_MainNameDuplicate _ _ _ -> error "TODO BP_MainNameDuplicate"

731+ BP_CannotLoadDependencies -> error "TODO BP_CannotLoadDependencies"

732+ BP_Cycle name names ->

733+ Help.report "IMPORT CYCLE" Nothing

734+ "Your module imports form a cycle:"

735+ [ D.cycle 4 name names

736+ , D.reflow $

737+ "Learn more about why this is disallowed and how to break cycles here:"

738+ ++ D.makeLink "import-cycles"

739+ ]

1984

740

1985

741

1986−-- CORRUPT CACHE

742+ BuildModuleProblems p ps ->

1987−

743+ error "TODO MakeCannotBuild" p ps

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

744

2068− ReplBlocked ->

745+ MakeCannotLoadArtifacts ->

2069− corruptCacheReport

746+ error "TODO MakeCannotLoadArtifacts"

builder/src/Reporting/Exit/Assets.hsnew file+227

@@ -0,0 +1,227 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Reporting.Exit.Assets

3+ ( Exit(..)

4+ , ElmJsonProblem(..)

5+ , toReport

6+ , BadElmJsonContent(..)

7+ , badContentToDocs

8+ )

9+ where

10+

11+

12+import qualified Data.Text as Text

13+

14+import qualified Elm.Package as Pkg

15+import Reporting.Doc ((<>))

16+import qualified Reporting.Doc as D

17+import qualified Reporting.Exit.Help as Help

18+

19+

20+

21+-- EXITS

22+

23+

24+data Exit

25+ = BadElmJson ElmJsonProblem

26+ | CorruptElmJson Pkg.Name Pkg.Version

27+ | CorruptDocumentation Pkg.Name Pkg.Version

28+ | CorruptBinary FilePath FilePath

29+

30+

31+

32+-- ELM JSON PROBLEM

33+

34+

35+data ElmJsonProblem

36+ = BadJson D.Doc

37+ | BadSrcDir FilePath

38+ | NoPkgCore

39+ | NoAppCore

40+ | NoAppJson

41+

42+

43+

44+-- TO REPORT

45+

46+

47+toReport :: Exit -> Help.Report

48+toReport exit =

49+ case exit of

50+ CorruptElmJson pkg vsn ->

51+ corruptJsonToReport "elm.json" pkg vsn

52+

53+ CorruptDocumentation pkg vsn ->

54+ corruptJsonToReport "docs.json" pkg vsn

55+

56+ CorruptBinary elmHome path ->

57+ Help.report "CORRUPT BINARY" (Just path)

58+ ("The binary data at " ++ path ++ " is corrupt.")

59+ [ D.reflow "Elm caches build artifacts in the following directories:"

60+ , D.dullyellow $ D.indent 4 $ D.vcat $

61+ [ D.fromString elmHome

62+ , "elm-stuff/"

63+ ]

64+ , D.reflow

65+ "Maybe you recently installed a command line tool or editor plugin that messes\

66+ \ with them? They definitely should not be doing that, but you never know! So\

67+ \ maybe try deleting them? Everything will be rebuilt from scratch. This may\

68+ \ help reveal the corrupting influence."

69+ ]

70+

71+ BadElmJson problem ->

72+ elmJsonProblemToReport problem

73+

74+

75+

76+-- CORRUPT JSON

77+

78+

79+corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report

80+corruptJsonToReport path pkg vsn =

81+ Help.report "CORRUPT JSON" Nothing

82+ ( "The " ++ path ++ " for " ++ Pkg.toString pkg

83+ ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."

84+ )

85+ [ D.reflow $

86+ "I removed it from my file cache, so if it was some transient\

87+ \ error it should be fixed if you try the same thing again.\

88+ \ Please report this if it seems like an Elm problem though!"

89+ ]

90+

91+

92+

93+-- BAD ELM JSON

94+

95+

96+elmJsonProblemToReport :: ElmJsonProblem -> Help.Report

97+elmJsonProblemToReport problem =

98+ case problem of

99+ BadJson doc ->

100+ Help.jsonReport "BAD JSON" (Just "elm.json") doc

101+

102+ BadSrcDir dir ->

103+ Help.report "BAD JSON" (Just "elm.json")

104+ "The \"source-directories\" in your elm.json lists the following directory:"

105+ [ D.indent 4 (D.dullyellow (D.fromString dir))

106+ , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"

107+ ]

108+

109+ NoPkgCore ->

110+ Help.report "MISSING DEPENDENCY" (Just "elm.json")

111+ "A package must have \"elm/core\" as a dependency. Try running:"

112+ [ D.indent 4 $ D.green $ "elm install elm/core"

113+ , D.reflow "I need it for the default imports that make `List` and `Maybe` available."

114+ ]

115+

116+ NoAppCore ->

117+ Help.report "MISSING DEPENDENCY" (Just "elm.json")

118+ "An application must have \"elm/core\" as a dependency. Try running:"

119+ [ D.indent 4 $ D.green $ "elm install elm/core"

120+ , D.reflow "It has some supporting code that is needed by every Elm application!"

121+ ]

122+

123+ NoAppJson ->

124+ Help.report "MISSING DEPENDENCY" (Just "elm.json")

125+ "An application must have \"elm/json\" as a dependency. Try running:"

126+ [ D.indent 4 $ D.green $ "elm install elm/json"

127+ , D.reflow "It helps me handle flags and ports."

128+ ]

129+

130+

131+

132+-- PROBLEM TO DOCS

133+

134+

135+data BadElmJsonContent

136+ = BadType Text.Text

137+ | BadPkgName String

138+ | BadVersion Text.Text

139+ | BadConstraint String

140+ | BadModuleName Text.Text

141+ | BadModuleHeaderTooLong Text.Text

142+ | BadDependencyName Text.Text

143+ | BadLicense Text.Text [Text.Text]

144+ | BadDirectoryNotString

145+ | BadSummaryTooLong

146+

147+

148+badContentToDocs :: BadElmJsonContent -> [D.Doc]

149+badContentToDocs badContent =

150+ case badContent of

151+ BadType _ ->

152+ ["The","only","valid","types","of","elm.json","are"

153+ ,D.green "\"application\"","and",D.green "\"package\"" <> "."

154+ ]

155+

156+ BadPkgName problem ->

157+ map D.fromString (words problem)

158+

159+ BadVersion txt ->

160+ ["You","provided",D.red (D.fromString (show txt))

161+ ,"which","is","not","a","valid","version.","I","need","something","like"

162+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."

163+ ]

164+

165+ BadConstraint problem ->

166+ map D.fromString (words ("It is not a valid constraint. " ++ problem))

167+

168+ BadModuleName name ->

169+ ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."

170+ ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."

171+ ]

172+

173+ BadModuleHeaderTooLong header ->

174+ ["The",D.fromString (show header),"header","is","too","long."

175+ ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"

176+ ,"to","ensure","that","formatting","is","nice","on","the","package","website."

177+ ]

178+

179+ BadDependencyName name ->

180+ ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."

181+ ,"I","recommend","deleting","it,","finding","the","package","you","want","on"

182+ ,"the","package","website,","and","installing","it","with","the"

183+ ,D.green "`elm install`","command","instead."

184+ ]

185+

186+ BadLicense _given suggestions ->

187+ case suggestions of

188+ [] ->

189+ ["I","need","an","OSI","approved","SPDX","license,","like"

190+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"

191+ ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."

192+ ]

193+

194+ code:codes ->

195+ ["I","need","an","OSI","approved","SPDX","license."]

196+ ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]

197+ ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]

198+

199+ BadDirectoryNotString ->

200+ ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."

201+ ]

202+

203+ BadSummaryTooLong ->

204+ ["Your","summary","is","too","long.","I","need","it","to"

205+ ,"be",D.green "under",D.green "80",D.green "characters."

206+ ]

207+

208+

209+oneOf :: Text.Text -> [Text.Text] -> [D.Doc]

210+oneOf code codes =

211+ let

212+ toDoc spdx =

213+ D.green (D.fromString (show spdx))

214+ in

215+ case codes of

216+ [] ->

217+ [toDoc code]

218+

219+ [code2] ->

220+ [toDoc code,"or",toDoc code2]

221+

222+ _:_ ->

223+ let

224+ these = code : init codes

225+ final = last codes

226+ in

227+ map (\spdx -> toDoc spdx <> ",") these ++ ["or",toDoc final]

builder/src/Reporting/Exit/Compile.hsnew file+104

@@ -0,0 +1,104 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Reporting.Exit.Compile

4+ ( Exit(..)

5+ , toJson

6+ , toDoc

7+ )

8+ where

9+

10+

11+import qualified Data.List as List

12+import qualified Data.Time.Clock as Time

13+

14+import qualified Elm.Compiler as Compiler

15+import qualified Elm.ModuleName as ModuleName

16+import qualified Json.Encode as Encode

17+import qualified Reporting.Doc as D

18+

19+

20+

21+-- EXITS

22+

23+

24+data Exit =

25+ Exit

26+ { _name :: ModuleName.Raw

27+ , _path :: FilePath

28+ , _time :: Time.UTCTime

29+ , _source :: String

30+ , _errors :: [Compiler.Error]

31+ }

32+

33+

34+

35+-- TO JSON

36+

37+

38+toJson :: Exit -> Encode.Value

39+toJson (Exit name path _ source errors) =

40+ Compiler.errorsToJson name path source errors

41+

42+

43+

44+-- TO DOC

45+

46+

47+toDoc :: Exit -> [Exit] -> D.Doc

48+toDoc e es =

49+ let

50+ (exit, exits) = sortByTime e es

51+ in

52+ D.vcat (toDocHelp exit exits)

53+

54+

55+toDocHelp :: Exit -> [Exit] -> [D.Doc]

56+toDocHelp e1 exits =

57+ case exits of

58+ [] ->

59+ [exitToDoc e1]

60+

61+ e2 : otherErrors ->

62+ exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors

63+

64+

65+exitToDoc :: Exit -> D.Doc

66+exitToDoc (Exit _name path _time source errors) =

67+ Compiler.errorsToDoc path source errors

68+

69+

70+separator :: ModuleName.Raw -> ModuleName.Raw -> D.Doc

71+separator beforeName afterName =

72+ let

73+ before = ModuleName.nameToChars beforeName ++ " ↑ "

74+ after = " ↓ " ++ ModuleName.nameToChars afterName

75+ in

76+ D.dullred $ D.vcat $

77+ [ D.indent (80 - length before) (D.fromChars before)

78+ , "====o======================================================================o===="

79+ , D.fromChars after

80+ , D.empty

81+ , D.empty

82+ ]

83+

84+

85+

86+-- SORT BY TIME

87+

88+

89+sortByTime :: Exit -> [Exit] -> (Exit, [Exit])

90+sortByTime exit exits =

91+ case List.sortBy timeCompare exits of

92+ [] ->

93+ (exit, [])

94+

95+ e:es ->

96+ if _time exit < _time e then

97+ (exit, e:es)

98+ else

99+ (e, List.insertBy timeCompare exit es)

100+

101+

102+timeCompare :: Exit -> Exit -> Ordering

103+timeCompare e1 e2 =

104+ compare (_time e1) (_time e2)

builder/src/Reporting/Exit/Crawl.hsnew file+345

@@ -0,0 +1,345 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Reporting.Exit.Crawl

3+ ( Exit(..)

4+ , Problem(..)

5+ , Origin(..)

6+ , SrcDirs(..)

7+ , toReport

8+ )

9+ where

10+

11+

12+import qualified Data.Char as Char

13+import qualified Data.Map as Map

14+import qualified Data.Time.Clock as Time

15+

16+import qualified Elm.Compiler as Compiler

17+import qualified Elm.ModuleName as ModuleName

18+import qualified Elm.Package as Pkg

19+import qualified Elm.Version as V

20+import Reporting.Doc ((<+>), (<>))

21+import qualified Reporting.Doc as D

22+import qualified Reporting.Exit.Compile as Compile

23+import qualified Reporting.Exit.Help as Help

24+

25+

26+

27+-- EXIT

28+

29+

30+data Exit

31+ = RootFileNotFound FilePath

32+ | RootModuleNameDuplicate ModuleName.Raw [FilePath]

33+ | RootNameless FilePath

34+ | DependencyProblems Problem [Problem]

35+ | BadKernelHeader FilePath

36+

37+

38+data Problem

39+ = ModuleNotFound Origin ModuleName.Raw SrcDirs

40+ | ModuleAmbiguous Origin ModuleName.Raw [FilePath] [Pkg.Canonical]

41+ | BadHeader FilePath Time.UTCTime String Compiler.Error

42+ | ModuleNameReservedForKernel Origin ModuleName.Raw

43+ | ModuleNameMissing FilePath ModuleName.Raw

44+ | ModuleNameMismatch

45+ FilePath

46+ ModuleName.Raw -- expected

47+ ModuleName.Raw -- actual

48+ | PortsInPackage FilePath ModuleName.Raw

49+ | EffectsUnexpected FilePath ModuleName.Raw

50+

51+

52+data Origin

53+ = ElmJson

54+ | File FilePath

55+ | Module FilePath ModuleName.Raw

56+

57+

58+data SrcDirs

59+ = App [FilePath]

60+ | Pkg

61+

62+

63+

64+-- TO REPORT

65+

66+

67+toReport :: Exit -> Help.Report

68+toReport exit =

69+ case exit of

70+ RootFileNotFound path ->

71+ Help.report "FILE NOT FOUND" Nothing

72+ "You want me to compile this file:"

73+ [ D.indent 4 $ D.dullyellow $ D.fromChars path

74+ , "I cannot find it though! Is there a typo?"

75+ ]

76+

77+ RootModuleNameDuplicate name paths ->

78+ Help.report "DUPLICATE NAMES" Nothing

79+ "I am trying to compile multiple modules with the same name:"

80+ [ D.indent 4 $ D.dullyellow $ D.vcat $

81+ map D.fromChars paths

82+ , D.fillSep $

83+ [ "These", "modules", if length paths == 2 then "both" else "all", "claim"

84+ , "to", "be", "named", D.dullyellow (D.fromChars (ModuleName.nameToChars name)) <> "."

85+ , "Change", "them", "to", "have", "unique", "names", "and", "you"

86+ , "should", "be", "all", "set!"

87+ ]

88+ ]

89+

90+ RootNameless path ->

91+ namelessToDoc path "Main"

92+

93+ DependencyProblems problem otherProblems ->

94+ case otherProblems of

95+ [] ->

96+ problemToReport problem

97+

98+ _ ->

99+ problemToReport problem

100+ -- error "TODO handle multiple dependency errors"

101+

102+ BadKernelHeader filePath ->

103+ Help.report "BAD KERNEL HEADER" Nothing

104+ "I ran into a bad header in this file:"

105+ [ D.indent 4 $ D.dullyellow $ D.fromChars filePath

106+ , D.reflow $

107+ "NOTE: Kernel code is only available to core Elm libraries to ensure\

108+ \ the portability and security of the Elm ecosystem. This restriction\

109+ \ also makes it possible to improve code gen (i.e. performance) without\

110+ \ disrupting the ecosystem."

111+ ]

112+

113+

114+

115+-- PROBLEM TO REPORT

116+

117+

118+problemToReport :: Problem -> Help.Report

119+problemToReport problem =

120+ case problem of

121+ ModuleNotFound origin name srcDirs ->

122+ notFoundToDoc origin name srcDirs

123+

124+ ModuleAmbiguous origin child paths pkgs ->

125+ ambiguousToDoc origin child paths pkgs

126+

127+ BadHeader path time source compilerError ->

128+ let

129+ compilerExit =

130+ Compile.Exit "???" path time source [compilerError]

131+ in

132+ Help.compilerReport compilerExit []

133+

134+ ModuleNameMissing path name ->

135+ namelessToDoc path name

136+

137+ ModuleNameMismatch path expected actual ->

138+ Help.report "MODULE NAME MISMATCH" (Just path)

139+ ( "The file at " ++ path ++ " has a typo in the module name. It says:"

140+ )

141+ [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromChars (ModuleName.nameToChars actual)) <+> "exposing (..)"

142+ , "Looks like a typo or copy/paste error. Instead it needs to say:"

143+ , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromChars (ModuleName.nameToChars expected)) <+> "exposing (..)"

144+ , "Make the change and you should be all set!"

145+ ]

146+

147+ ModuleNameReservedForKernel origin name ->

148+ kernelNameToDoc origin name

149+

150+ PortsInPackage path name ->

151+ badTagToDoc path name "port" "port-modules" $

152+ "Packages cannot have any `port` modules."

153+

154+ EffectsUnexpected path name ->

155+ badTagToDoc path name "effect" "effect-modules" $

156+ "Creating `effect` modules is relatively experimental. There are a\

157+ \ couple in @elm repos right now, but we have decided to be very\

158+ \ cautious in expanding its usage."

159+

160+

161+badTagToDoc :: FilePath -> ModuleName.Raw -> String -> String -> String -> Help.Report

162+badTagToDoc path name tag hintName summary =

163+ Help.report

164+ ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")

165+ (Just path)

166+ summary

167+ [ D.fillSep $

168+ [ "Get", "rid", "of", "all", "the"

169+ , D.red (D.fromChars tag)

170+ , "stuff", "in"

171+ , D.dullyellow (D.fromChars (ModuleName.nameToChars name))

172+ , "to", "proceed."

173+ ]

174+ , D.toSimpleNote $

175+ "You can learn the reasoning behind this design choice at "

176+ ++ D.makeLink hintName

177+ ]

178+

179+

180+

181+-- NAMELESS

182+

183+

184+namelessToDoc :: FilePath -> ModuleName.Raw -> Help.Report

185+namelessToDoc path name =

186+ Help.report "UNNAMED MODULE" (Just path)

187+ ( "The `" ++ ModuleName.nameToChars name

188+ ++ "` module must start with a line like this:"

189+ )

190+ [ D.indent 4 $ D.dullyellow $ D.fromChars $

191+ "module " ++ ModuleName.nameToChars name ++ " exposing (..)"

192+ , D.reflow $

193+ "Try adding that as the first line of your file!"

194+ , D.toSimpleNote $

195+ "It is best to replace (..) with an explicit list of types and\

196+ \ functions you want to expose. If you know a value is only used\

197+ \ WITHIN this module, it is extra easy to refactor. This kind of\

198+ \ information is great, especially as your project grows!"

199+ ]

200+

201+

202+

203+-- NOT FOUND

204+

205+

206+notFoundToDoc :: Origin -> ModuleName.Raw -> SrcDirs -> Help.Report

207+notFoundToDoc origin child srcDirs =

208+ case origin of

209+ ElmJson ->

210+ Help.report "MODULE NOT FOUND" (Just "elm.json")

211+ "Your elm.json says your project has the following module:"

212+ [ D.indent 4 $ D.red $ D.fromChars $ ModuleName.nameToChars child

213+ , D.reflow $

214+ "When creating packages, all modules must live in the src/ directory."

215+ ]

216+

217+ File path ->

218+ Help.report "UNKNOWN IMPORT" (Just path)

219+ ("I cannot find a `" ++ ModuleName.nameToChars child ++ "` module to import.")

220+ (notFoundDetails child srcDirs)

221+

222+ Module path parent ->

223+ Help.report "UNKNOWN IMPORT" (Just path)

224+ ("The " ++ ModuleName.nameToChars parent ++ " module has a bad import:")

225+ (notFoundDetails child srcDirs)

226+

227+

228+notFoundDetails :: ModuleName.Raw -> SrcDirs -> [D.Doc]

229+notFoundDetails child srcDirs =

230+ let

231+ simulatedCode =

232+ D.indent 4 $ D.red $ D.fromChars $ "import " ++ ModuleName.nameToChars child

233+ in

234+ case Map.lookup child Pkg.suggestions of

235+ Just pkg ->

236+ [ simulatedCode

237+ , D.reflow $

238+ "Do you want the one from the " ++ Pkg.toChars pkg

239+ ++ " package? If so, run this command to add that dependency to your elm.json file:"

240+ , D.indent 4 $ D.green $ D.fromChars $ "elm install " ++ Pkg.toChars pkg

241+ , case srcDirs of

242+ Pkg ->

243+ D.reflow $

244+ "If you want a local file, make sure the `"

245+ ++ ModuleName.nameToChars child

246+ ++ "` module is in your src/ directory."

247+

248+ App _ ->

249+ D.reflow $

250+ "If you want a local file, make sure the `"

251+ ++ ModuleName.nameToChars child

252+ ++ "` module is in one of the \"source-directories\" listed in your elm.json file."

253+ ]

254+

255+ Nothing ->

256+ [ simulatedCode

257+ , "I cannot find that module! Is there a typo in the module name?"

258+ , D.reflow $

259+ case srcDirs of

260+ Pkg ->

261+ "When creating a package, all modules must live in the src/ directory."

262+

263+ App [] ->

264+ "The \"source-directories\" field of your elm.json is empty, so I only\

265+ \ searched in packages. Maybe you need to add a \"src\" directory there?"

266+

267+ App [dir] ->

268+ "The \"source-directories\" field of your elm.json tells me to only look in the "

269+ ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"

270+

271+ App (dir:_:_) ->

272+ "The \"source-directories\" field of your elm.json tells me to look in directories like "

273+ ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"

274+ ]

275+

276+

277+ambiguousToDoc :: Origin -> ModuleName.Raw -> [FilePath] -> [Pkg.Canonical] -> Help.Report

278+ambiguousToDoc origin child paths pkgs =

279+ let

280+ pkgToString (Pkg.Canonical pkg vsn) =

281+ "exposed by " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn

282+

283+ makeReport maybePath summary yellowString =

284+ Help.report "AMBIGUOUS IMPORT" maybePath summary

285+ [ D.indent 4 $ D.dullyellow $ D.fromChars yellowString

286+ , D.reflow $

287+ "I found multiple module with that name though:"

288+ , D.indent 4 $ D.dullyellow $ D.vcat $

289+ map D.fromChars $ paths ++ map pkgToString pkgs

290+ , D.reflow $

291+ if null paths then

292+ "It looks like the name clash is in your dependencies, which is\

293+ \ out of your control. Elm does not support this scenario right\

294+ \ now, but it may be worthwhile. Please open an issue describing\

295+ \ your scenario so we can gather more usage information!"

296+ else

297+ "Which is the right one? Try renaming your modules to have unique names."

298+ ]

299+ in

300+ case origin of

301+ ElmJson ->

302+ makeReport

303+ Nothing

304+ "Your elm.json wants the following module:"

305+ (ModuleName.nameToChars child)

306+

307+ File path ->

308+ makeReport

309+ (Just path)

310+ ("The file at " ++ path ++ " has an ambiguous import:")

311+ ("import " ++ ModuleName.nameToChars child)

312+

313+ Module path parent ->

314+ makeReport

315+ (Just path)

316+ ("The " ++ ModuleName.nameToChars parent ++ " module has an ambiguous import:")

317+ ("import " ++ ModuleName.nameToChars child)

318+

319+

320+kernelNameToDoc :: Origin -> ModuleName.Raw -> Help.Report

321+kernelNameToDoc origin kernelName =

322+ let

323+ (maybePath, statement) =

324+ case origin of

325+ ElmJson ->

326+ ( Nothing

327+ , "Your elm.json says your project has the following module:"

328+ )

329+

330+ File path ->

331+ ( Just path

332+ , "This file is trying to import the following module:"

333+ )

334+

335+ Module path parent ->

336+ ( Just path

337+ , "Your " ++ ModuleName.nameToChars parent ++ " module is trying to import:"

338+ )

339+ in

340+ Help.report "BAD MODULE NAME" maybePath statement

341+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ ModuleName.nameToChars kernelName

342+ , D.reflow $

343+ "But names like that are reserved for internal use.\

344+ \ Switch to a name outside of the Elm/Kernel/ namespace."

345+ ]

builder/src/Reporting/Exit/Deps.hsnew file+123

@@ -0,0 +1,123 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Reporting.Exit.Deps

3+ ( Exit(..)

4+ , toReport

5+ )

6+ where

7+

8+

9+import qualified Elm.Constraint as Con

10+import qualified Elm.Package as Pkg

11+import qualified Elm.Version as V

12+import Reporting.Doc ((<>))

13+import qualified Reporting.Doc as D

14+import qualified Reporting.Exit.Help as Help

15+

16+

17+

18+-- EXITS

19+

20+

21+data Exit

22+ = CorruptVersionCache FilePath Pkg.Name

23+ | PackageNotFound Pkg.Name [Pkg.Name]

24+ -- verify

25+ | PkgBadElm Con.Constraint

26+ | AppBadElm V.Version

27+ | AppMissingTrans [(Pkg.Name, V.Version)]

28+ | BadDeps

29+ | BuildFailure FilePath Pkg.Name V.Version

30+

31+

32+

33+-- TO DOC

34+

35+

36+toReport :: Exit -> Help.Report

37+toReport exit =

38+ case exit of

39+ CorruptVersionCache elmHome pkg ->

40+ Help.report "CORRUPT CACHE" Nothing

41+ ( "I ran into an unknown package while exploring dependencies:"

42+ )

43+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Pkg.toString pkg

44+ , D.reflow $

45+ "This suggests that your " ++ elmHome ++ " directory has been corrupted.\

46+ \ Maybe some program is messing with it? It is just cached files,\

47+ \ so you can delete it and see if that fixes the issue."

48+ ]

49+

50+ PackageNotFound package suggestions ->

51+ Help.docReport "PACKAGE NOT FOUND" Nothing

52+ ( D.fillSep

53+ ["I","cannot","find","a"

54+ ,D.red (D.fromUtf8 (Pkg.toString package))

55+ ,"package","on","the","package","website."

56+ ]

57+ )

58+ [ "Maybe you want one of these instead?"

59+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions

60+ , "But check <https://package.elm-lang.org> to see all possibilities!"

61+ ]

62+

63+ PkgBadElm constraint ->

64+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")

65+ "Your elm.json says this package needs a version of Elm in this range:"

66+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ Con.toString constraint

67+ , D.fillSep

68+ [ "But", "you", "are", "using", "Elm"

69+ , D.red (D.fromUtf8 (V.toString V.compiler))

70+ , "right", "now."

71+ ]

72+ ]

73+

74+ AppBadElm version ->

75+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")

76+ "Your elm.json says this application needs a different version of Elm."

77+ [ D.fillSep

78+ [ "It", "requires"

79+ , D.green (D.fromUtf8 (V.toString version)) <> ","

80+ , "but", "you", "are", "using"

81+ , D.red (D.fromUtf8 (V.toString V.compiler))

82+ , "right", "now."

83+ ]

84+ ]

85+

86+ AppMissingTrans missingDeps ->

87+ let

88+ toEntry (pkg, vsn) =

89+ "\"" ++ Pkg.toChars pkg ++ "\": \"" ++ V.toChars vsn ++ "\""

90+ in

91+ Help.report "MISSING DEPENDENCIES" (Just "elm.json")

92+ "Your elm.json is missing some \"indirect\" dependencies:"

93+ [ D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . toEntry) missingDeps

94+ , D.fillSep

95+ ["This","usually","means","you","are","editing","elm.json","by","hand."

96+ ,"It","is","much","more","reliable","to","use","the"

97+ ,D.green "elm install","command","instead."

98+ ]

99+ ]

100+

101+ BadDeps ->

102+ Help.report "INVALID PACKAGE DEPENDENCIES" (Just "elm.json")

103+ "The dependencies in your elm.json are not compatible."

104+ [ D.fillSep

105+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"

106+ ,"It","is","much","better","to","add","dependencies","with",D.green "elm install"

107+ ,"or","the","dependency","management","tool","in",D.green "elm reactor" <> "."

108+ ]

109+ , D.reflow $

110+ "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\

111+ \ you try those paths and still cannot figure it out!"

112+ ]

113+

114+ BuildFailure elmHome pkg vsn ->

115+ Help.report "CORRUPT DEPENDENCY" Nothing

116+ "I ran into a problem while building the following package:"

117+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn

118+ , D.fillSep

119+ ["This","probably","means","the","downloaded","files","got","corrupted","somehow."

120+ ,"Try","deleting",D.dullyellow (D.fromChars elmHome),"(a","directory","for"

121+ ,"caching","build","artifacts)","and","see","if","that","resolves","the","issue."

122+ ]

123+ ]

builder/src/Reporting/Exit/Help.hs+12−11

@@ -14,6 +14,7 @@ module Reporting.Exit.Help

14 where

15

16

17+import qualified Data.Utf8 as Utf8

17import GHC.IO.Handle (hIsTerminalDevice)

18import GHC.IO.Handle (hIsTerminalDevice)

18import System.IO (Handle, hPutStr, stderr, stdout)

19import System.IO (Handle, hPutStr, stderr, stdout)

19

20

@@ -21,7 +22,7 @@ import qualified Json.Encode as E

21import Json.Encode ((==>))

22import Json.Encode ((==>))

22import Reporting.Doc ((<+>))

23import Reporting.Doc ((<+>))

23import qualified Reporting.Doc as D

24import qualified Reporting.Doc as D

24−import qualified Reporting.Error as Error

25+import qualified Reporting.Exit.Compile as Compile

25

26

27

28

@@ -29,7 +30,7 @@ import qualified Reporting.Error as Error

29

30

31

31data Report

32data Report

32− = CompilerReport FilePath Error.Module [Error.Module]

33+ = CompilerReport Compile.Exit [Compile.Exit]

33 | Report

34 | Report

34 { _title :: String

35 { _title :: String

35 , _path :: Maybe FilePath

36 , _path :: Maybe FilePath

@@ -52,7 +53,7 @@ jsonReport =

52 Report

53 Report

53

54

55

55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report

56+compilerReport :: Compile.Exit -> [Compile.Exit] -> Report

56compilerReport =

57compilerReport =

57 CompilerReport

58 CompilerReport

58

59

@@ -64,8 +65,8 @@ compilerReport =

64reportToDoc :: Report -> D.Doc

65reportToDoc :: Report -> D.Doc

65reportToDoc report_ =

66reportToDoc report_ =

66 case report_ of

67 case report_ of

67− CompilerReport root e es ->

68+ CompilerReport e es ->

68− Error.toDoc root e es

69+ Compile.toDoc e es

69

70

70 Report title maybePath message ->

71 Report title maybePath message ->

71 let

72 let

@@ -94,17 +95,17 @@ reportToDoc report_ =

94reportToJson :: Report -> E.Value

95reportToJson :: Report -> E.Value

95reportToJson report_ =

96reportToJson report_ =

96 case report_ of

97 case report_ of

97− CompilerReport _ e es ->

98+ CompilerReport e es ->

98 E.object

99 E.object

99− [ "type" ==> E.chars "compile-errors"

100+ [ "type" ==> E.string "compile-errors"

100− , "errors" ==> E.list Error.toJson (e:es)

101+ , "errors" ==> E.list Compile.toJson (e:es)

101 ]

102 ]

102

103

103 Report title maybePath message ->

104 Report title maybePath message ->

104 E.object

105 E.object

105− [ "type" ==> E.chars "error"

106+ [ "type" ==> E.string "error"

106− , "path" ==> maybe E.null E.chars maybePath

107+ , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath

107− , "title" ==> E.chars title

108+ , "title" ==> E.string (Utf8.fromChars title)

108 , "message" ==> D.encode message

109 , "message" ==> D.encode message

109 ]

110 ]

110

111

builder/src/Reporting/Exit/Http.hsnew file+104

@@ -0,0 +1,104 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Reporting.Exit.Http

3+ ( Exit(..)

4+ , toReport

5+ , BadJson(..)

6+ , badJsonToDocs

7+ )

8+ where

9+

10+

11+import qualified Data.Text as Text

12+

13+import Reporting.Doc ((<>))

14+import qualified Reporting.Doc as D

15+import qualified Reporting.Exit.Help as Help

16+

17+

18+

19+-- EXITS

20+

21+

22+data Exit

23+ = Unknown String

24+ | BadJson String D.Doc

25+ | BadZipData

26+ | BadZipSha String String

27+

28+

29+

30+-- TO REPORT

31+

32+

33+toReport :: String -> Exit -> Help.Report

34+toReport url exit =

35+ let

36+ urlDoc =

37+ D.indent 4 $ D.dullyellow $ "<" <> D.fromString url <> ">"

38+ in

39+ case exit of

40+ Unknown message ->

41+ Help.report "HTTP PROBLEM" Nothing "The following HTTP request failed:"

42+ [ urlDoc

43+ , D.stack

44+ [ "Here is the error message I was able to extract:"

45+ , D.indent 4 $ D.reflow message

46+ ]

47+ ]

48+

49+ BadJson path doc ->

50+ Help.jsonReport "UNEXPECTED JSON" (Just path) doc

51+

52+ BadZipData ->

53+ Help.report "CORRUPT ZIP" Nothing "I could not unzip the file downloaded from:"

54+ [ urlDoc

55+ , D.reflow $

56+ "If it is a transient issue, it should be fixed if you try this\

57+ \ again. If it seems like an Elm problem, please report it though!"

58+ ]

59+

60+ BadZipSha expectedHash actualHash ->

61+ Help.report "CORRUPT ZIP" Nothing "I got an unexpected zip file from:"

62+ [ urlDoc

63+ , D.reflow "I check the hash the zip, and it seems off:"

64+ , D.vcat $ map D.fromString $

65+ [ " Expected: " ++ expectedHash

66+ , " Actual: " ++ actualHash

67+ ]

68+ , D.reflow $

69+ "This usually means that the package author moved the version\

70+ \ tag, so report it to them and see if that is the issue. Folks\

71+ \ on Elm slack can probably help as well."

72+ ]

73+

74+

75+

76+-- BAD JSON

77+

78+

79+data BadJson

80+ = BadNewPkg Text.Text

81+ | BadAllPkg Text.Text String

82+ | BadAllVsn Text.Text

83+

84+

85+badJsonToDocs :: BadJson -> [D.Doc]

86+badJsonToDocs badJson =

87+ case badJson of

88+ BadNewPkg txt ->

89+ ["I","ran","into",D.red (D.fromString (show txt)) <> ","

90+ ,"but","I","need","entries","like"

91+ ,D.green "\"elm/core@6.0.0\"" <> "."

92+ ]

93+

94+ BadAllPkg txt suggestion ->

95+ ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."

96+ ]

97+ ++ map D.fromString (words suggestion)

98+

99+ BadAllVsn txt ->

100+ ["You","provided",D.red (D.fromString (show txt))

101+ ,"which","is","not","a","valid","version.","I","need","something","like"

102+ ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."

103+ ]

104+

builder/src/Reporting/Task.hs−17

@@ -3,10 +3,8 @@ module Reporting.Task

3 ( Task

4 , run

5 , throw

6− , mapError

7 --

6 --

8 , io

7 , io

9− , mio

10 , eio

8 , eio

11 )

9 )

12 where

10 where

@@ -33,12 +31,6 @@ throw x =

33 Task $ \_ err -> err x

31 Task $ \_ err -> err x

34

32

35

33

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

34

43-- IO

35-- IO

44

36

@@ -49,15 +41,6 @@ io work =

49 Task $ \ok _ -> work >>= ok

41 Task $ \ok _ -> work >>= ok

50

42

51

43

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−

61eio :: (x -> y) -> IO (Either x a) -> Task y a

44eio :: (x -> y) -> IO (Either x a) -> Task y a

62eio func work =

45eio func work =

63 Task $ \ok err ->

46 Task $ \ok err ->

builder/src/Stuff.hs+9−8

@@ -8,8 +8,8 @@ module Stuff

8 , elmo

9 , temp

10 , findRoot

11− , withRootLock

11+ , withProjectLock

12− , withRegistryLock

12+ , withCacheLock

13 , PackageCache

14 , getPackageCache

15 , registry

@@ -120,16 +120,17 @@ findRootHelp dirs =

120-- LOCKS

121

122

123−withRootLock :: FilePath -> IO a -> IO a

123+withProjectLock :: FilePath -> IO a -> IO a

124−withRootLock root work =

124+withProjectLock root work =

125 do let dir = stuff root

126 Dir.createDirectoryIfMissing True dir

127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

127+ Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)

128

129

130−withRegistryLock :: PackageCache -> IO a -> IO a

130+withCacheLock :: PackageCache -> IO a -> IO a

131−withRegistryLock (PackageCache dir) work =

131+withCacheLock (PackageCache dir) work =

132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

132+ Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)

133+

133

134

135

136

cabal.configdeleted−2

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

1−profiling: False

2−library-profiling: True

compiler/src/AST/Canonical.hs+8−11

@@ -56,14 +56,12 @@ import Data.Binary

56import qualified Data.List as List

57import qualified Data.Map as Map

58import Data.Name (Name)

59+import qualified Data.Utf8 as Utf8

59

60

60−import qualified AST.Source as Src

61import qualified AST.Utils.Binop as Binop

62import qualified AST.Utils.Shader as Shader

63import qualified Data.Index as Index

64−import qualified Elm.Float as EF

65import qualified Elm.ModuleName as ModuleName

64import qualified Elm.ModuleName as ModuleName

66−import qualified Elm.String as ES

67import qualified Reporting.Annotation as A

65import qualified Reporting.Annotation as A

68

66

69

67

@@ -84,10 +82,10 @@ data Expr_

84 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation

82 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation

85 | VarDebug ModuleName.Canonical Name Annotation

83 | VarDebug ModuleName.Canonical Name Annotation

86 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization

84 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization

87− | Chr ES.String

85+ | Chr Utf8.String

88− | Str ES.String

86+ | Str Utf8.String

89 | Int Int

87 | Int Int

90− | Float EF.Float

88+ | Float (Utf8.Under256 Float)

91 | List [Expr]

89 | List [Expr]

92 | Negate Expr

90 | Negate Expr

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

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

@@ -152,8 +150,8 @@ data Pattern_

152 | PList [Pattern]

150 | PList [Pattern]

153 | PCons Pattern Pattern

151 | PCons Pattern Pattern

154 | PBool Union Bool

152 | PBool Union Bool

155− | PChr ES.String

153+ | PChr Utf8.String

156− | PStr ES.String

154+ | PStr Utf8.String

157 | PInt Int

155 | PInt Int

158 | PCtor

156 | PCtor

159 { _p_home :: ModuleName.Canonical

157 { _p_home :: ModuleName.Canonical

@@ -233,7 +231,6 @@ data Module =

233 Module

231 Module

234 { _name :: ModuleName.Canonical

232 { _name :: ModuleName.Canonical

235 , _exports :: Exports

233 , _exports :: Exports

236− , _docs :: Src.Docs

237 , _decls :: Decls

234 , _decls :: Decls

238 , _unions :: Map.Map Name Union

235 , _unions :: Map.Map Name Union

239 , _aliases :: Map.Map Name Alias

236 , _aliases :: Map.Map Name Alias

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

342 0 -> return Normal

339 0 -> return Normal

343 1 -> return Enum

340 1 -> return Enum

344 2 -> return Unbox

341 2 -> return Unbox

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

342+ _ -> error "binary encoding of CtorOpts was corrupted"

346

343

347

344

348instance Binary Annotation where

345instance Binary Annotation where

@@ -393,7 +390,7 @@ instance Binary AliasType where

393 case n of

390 case n of

394 0 -> liftM Holey get

391 0 -> liftM Holey get

395 1 -> liftM Filled get

392 1 -> liftM Filled get

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

393+ _ -> error "binary encoding of AliasType was corrupted"

397

394

398

395

399instance Binary FieldType where

396instance Binary FieldType where

compiler/src/AST/Optimized.hs+14−31

@@ -27,15 +27,14 @@ import qualified Data.Map as Map

27import qualified Data.Name as Name

28import Data.Name (Name)

29import qualified Data.Set as Set

30+import qualified Data.Utf8 as Utf8

30

31

31import qualified AST.Canonical as Can

32import qualified AST.Canonical as Can

32import qualified AST.Utils.Shader as Shader

33import qualified AST.Utils.Shader as Shader

33import qualified Data.Index as Index

34import qualified Data.Index as Index

34−import qualified Elm.Float as EF

35import qualified Elm.Kernel as K

36import qualified Elm.ModuleName as ModuleName

37import qualified Elm.Package as Pkg

38−import qualified Elm.String as ES

39import qualified Optimize.DecisionTree as DT

38import qualified Optimize.DecisionTree as DT

40import qualified Reporting.Annotation as A

39import qualified Reporting.Annotation as A

41

40

@@ -46,10 +45,10 @@ import qualified Reporting.Annotation as A

46

45

47data Expr

46data Expr

48 = Bool Bool

47 = Bool Bool

49− | Chr ES.String

48+ | Chr Utf8.String

50− | Str ES.String

49+ | Str Utf8.String

51 | Int Int

50 | Int Int

52− | Float EF.Float

51+ | Float (Utf8.Under256 Float)

53 | VarLocal Name

52 | VarLocal Name

54 | VarGlobal Global

53 | VarGlobal Global

55 | VarEnum Global Index.ZeroBased

54 | VarEnum Global Index.ZeroBased

@@ -75,6 +74,7 @@ data Expr

75

74

76

75

77data Global = Global ModuleName.Canonical Name

76data Global = Global ModuleName.Canonical Name

77+ deriving (Eq, Ord)

78

79

80

@@ -135,7 +135,7 @@ data GlobalGraph =

135data LocalGraph =

136 LocalGraph

137 { _l_main :: Maybe Main

138− , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name

138+ , _l_nodes :: Map.Map Global Node -- TODO profile switching Global to Name

139 , _l_fields :: Map.Map Name Int

140 }

141

@@ -222,23 +222,6 @@ toKernelGlobal shortName =

222

223

224

225−-- INSTANCES

226−

227−

228−instance Eq Global where

229− (==) (Global home1 name1) (Global home2 name2) =

230− name1 == name2 && home1 == home2

231−

232−

233−instance Ord Global where

234− compare (Global home1 name1) (Global home2 name2) =

235− case compare name1 name2 of

236− LT -> LT

237− EQ -> compare home1 home2

238− GT -> GT

239−

240−

241−

242-- BINARY

225-- BINARY

243

226

244

227

@@ -308,7 +291,7 @@ instance Binary Expr where

308 24 -> pure Unit

291 24 -> pure Unit

309 25 -> liftM3 Tuple get get get

292 25 -> liftM3 Tuple get get get

310 26 -> liftM3 Shader get get get

293 26 -> liftM3 Shader get get get

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

294+ _ -> error "problem getting Opt.Expr binary"

312

295

313

296

314instance Binary Def where

297instance Binary Def where

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

322 case word of

305 case word of

323 0 -> liftM2 Def get get

306 0 -> liftM2 Def get get

324 1 -> liftM3 TailDef get get get

307 1 -> liftM3 TailDef get get get

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

308+ _ -> error "problem getting Opt.Def binary"

326

309

327

310

328instance Binary Destructor where

311instance Binary Destructor where

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

345 1 -> liftM2 Field get get

328 1 -> liftM2 Field get get

346 2 -> liftM Unbox get

329 2 -> liftM Unbox get

347 3 -> liftM Root get

330 3 -> liftM Root get

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

331+ _ -> error "problem getting Opt.Path binary"

349

332

350

333

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

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

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

361 0 -> liftM Leaf get

344 0 -> liftM Leaf get

362 1 -> liftM3 Chain get get get

345 1 -> liftM3 Chain get get get

363 2 -> liftM3 FanOut get get get

346 2 -> liftM3 FanOut get get get

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

347+ _ -> error "problem getting Opt.Decider binary"

365

348

366

349

367instance Binary Choice where

350instance Binary Choice where

@@ -375,7 +358,7 @@ instance Binary Choice where

375 case word of

358 case word of

376 0 -> liftM Inline get

359 0 -> liftM Inline get

377 1 -> liftM Jump get

360 1 -> liftM Jump get

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

361+ _ -> error "problem getting Opt.Choice binary"

379

362

380

363

381

364

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

400 case word of

383 case word of

401 0 -> return Static

384 0 -> return Static

402 1 -> liftM2 Dynamic get get

385 1 -> liftM2 Dynamic get get

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

386+ _ -> error "problem getting Opt.Main binary"

404

387

405

388

406instance Binary Node where

389instance Binary Node where

@@ -432,7 +415,7 @@ instance Binary Node where

432 8 -> liftM2 Kernel get get

415 8 -> liftM2 Kernel get get

433 9 -> liftM2 PortIncoming get get

416 9 -> liftM2 PortIncoming get get

434 10 -> liftM2 PortOutgoing get get

417 10 -> liftM2 PortOutgoing get get

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

418+ _ -> error "problem getting Opt.Node binary"

436

419

437

420

438instance Binary EffectsType where

421instance Binary EffectsType where

@@ -448,4 +431,4 @@ instance Binary EffectsType where

448 0 -> return Cmd

431 0 -> return Cmd

449 1 -> return Sub

432 1 -> return Sub

450 2 -> return Fx

433 2 -> return Fx

451− _ -> fail "problem getting Opt.EffectsType binary"

434+ _ -> error "problem getting Opt.EffectsType binary"

compiler/src/AST/Source.hs+19−36

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

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module AST.Source

3module AST.Source

3 ( Expr, Expr_(..), VarType(..)

4 ( Expr, Expr_(..), VarType(..)

4 , Def(..)

5 , Def(..)

@@ -11,12 +12,10 @@ module AST.Source

11 , Value(..)

12 , Value(..)

12 , Union(..)

13 , Union(..)

13 , Alias(..)

14 , Alias(..)

14− , Infix(..)

15+ , Binop(..)

15 , Port(..)

16 , Port(..)

16 , Effects(..)

17 , Effects(..)

17 , Manager(..)

18 , Manager(..)

18− , Docs(..)

19− , Comment(..)

20 , Exposing(..)

19 , Exposing(..)

21 , Exposed(..)

20 , Exposed(..)

22 , Privacy(..)

21 , Privacy(..)

@@ -25,13 +24,10 @@ module AST.Source

25

24

26

25

27import Data.Name (Name)

26import Data.Name (Name)

28−import qualified Data.Name as Name

27+import qualified Data.Utf8 as Utf8

29

28

30import qualified AST.Utils.Binop as Binop

29import qualified AST.Utils.Binop as Binop

31import qualified AST.Utils.Shader as Shader

30import qualified AST.Utils.Shader as Shader

32−import qualified Elm.Float as EF

33−import qualified Elm.String as ES

34−import qualified Parse.Primitives as P

35import qualified Reporting.Annotation as A

31import qualified Reporting.Annotation as A

36

32

37

33

@@ -43,10 +39,10 @@ type Expr = A.Located Expr_

43

39

44

40

45data Expr_

41data Expr_

46− = Chr ES.String

42+ = Chr Utf8.String

47− | Str ES.String

43+ | Str Utf8.String

48 | Int Int

44 | Int Int

49− | Float EF.Float

45+ | Float (Utf8.Under256 Float)

50 | Var VarType Name

46 | Var VarType Name

51 | VarQual VarType Name Name

47 | VarQual VarType Name Name

52 | List [Expr]

48 | List [Expr]

@@ -97,8 +93,8 @@ data Pattern_

97 | PCtorQual A.Region Name Name [Pattern]

93 | PCtorQual A.Region Name Name [Pattern]

98 | PList [Pattern]

94 | PList [Pattern]

99 | PCons Pattern Pattern

95 | PCons Pattern Pattern

100− | PChr ES.String

96+ | PChr Utf8.String

101− | PStr ES.String

97+ | PStr Utf8.String

102 | PInt Int

98 | PInt Int

103

99

104

100

@@ -126,26 +122,22 @@ data Type_

126

122

127data Module =

123data Module =

128 Module

124 Module

129− { _name :: Maybe (A.Located Name)

125+ { _name :: Maybe Name

130 , _exports :: A.Located Exposing

126 , _exports :: A.Located Exposing

131− , _docs :: Docs

132 , _imports :: [Import]

127 , _imports :: [Import]

133 , _values :: [A.Located Value]

128 , _values :: [A.Located Value]

134 , _unions :: [A.Located Union]

129 , _unions :: [A.Located Union]

135 , _aliases :: [A.Located Alias]

130 , _aliases :: [A.Located Alias]

136− , _binops :: [A.Located Infix]

131+ , _binops :: [A.Located Binop]

137 , _effects :: Effects

132 , _effects :: Effects

138 }

133 }

139

134

140

135

141getName :: Module -> Name

136getName :: Module -> Name

142−getName (Module maybeName _ _ _ _ _ _ _ _) =

137+getName (Module maybeName _ _ _ _ _ _ _) =

143 case maybeName of

138 case maybeName of

144− Just (A.At _ name) ->

139+ Just name -> name

145− name

146−

147− Nothing ->

140+ Nothing -> "Main"

148− Name._Main

149

141

150

142

151getImportName :: Import -> Name

143getImportName :: Import -> Name

@@ -164,7 +156,7 @@ data Import =

164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)

156data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)

165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]

157data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]

166data Alias = Alias (A.Located Name) [A.Located Name] Type

158data Alias = Alias (A.Located Name) [A.Located Name] Type

167−data Infix = Infix Name Binop.Associativity Binop.Precedence Name

159+data Binop = Binop Name Binop.Associativity Binop.Precedence Name

168data Port = Port (A.Located Name) Type

160data Port = Port (A.Located Name) Type

169

161

170

162

@@ -180,30 +172,21 @@ data Manager

180 | Fx (A.Located Name) (A.Located Name)

172 | Fx (A.Located Name) (A.Located Name)

181

173

182

174

183−data Docs

184− = NoDocs A.Region

185− | YesDocs Comment [(Name, Comment)]

186−

187−

188−newtype Comment =

189− Comment P.Snippet

190−

191−

192

175

193-- EXPOSING

176-- EXPOSING

194

177

195

178

196data Exposing

179data Exposing

197 = Open

180 = Open

198− | Explicit [Exposed]

181+ | Explicit [A.Located Exposed]

199

182

200

183

201data Exposed

184data Exposed

202− = Lower (A.Located Name)

185+ = Lower Name

203− | Upper (A.Located Name) Privacy

186+ | Upper Name Privacy

204− | Operator A.Region Name

187+ | Operator Name

205

188

206

189

207data Privacy

190data Privacy

208− = Public A.Region

191+ = Public

209 | Private

192 | Private

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

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

41instance Binary Associativity where

42 get =

43 do n <- getWord8

44+ return $

44− case n of

45+ case n of

45− 0 -> return Left

46+ 0 -> Left

46− 1 -> return Non

47+ 1 -> Non

47− 2 -> return Right

48+ 2 -> Right

48− _ -> fail "Error reading valid associativity from serialized string"

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

49

50

50 put assoc =

51 put assoc =

51 putWord8 $

52 putWord8 $

compiler/src/AST/Utils/Shader.hs+4−51

@@ -4,27 +4,22 @@ module AST.Utils.Shader

4 ( Source

5 , Types(..)

6 , Type(..)

7− , fromChars

8− , toJsStringBuilder

9 )

7 )

10 where

8 where

11

9

12

10

13−import Control.Monad (liftM)

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

15−import qualified Data.ByteString as BS

16−import qualified Data.ByteString.Builder as B

17−import qualified Data.ByteString.UTF8 as BS_UTF8

18import qualified Data.Map as Map

11import qualified Data.Map as Map

19import qualified Data.Name as Name

12import qualified Data.Name as Name

13+import qualified Data.Utf8 as Utf8

20

14

21

15

22

16

23-- SOURCE

17-- SOURCE

24

18

25

19

26−newtype Source =

20+type Source = Utf8.VeryLong SOURCE

27− Source BS.ByteString

21+

22+data SOURCE

28

23

29

24

30

25

@@ -47,45 +42,3 @@ data Type

47 | V4

42 | V4

48 | M4

43 | M4

49 | Texture

44 | Texture

50−

51−

52−

53−-- TO BUILDER

54−

55−

56−toJsStringBuilder :: Source -> B.Builder

57−toJsStringBuilder (Source src) =

58− B.byteString src

59−

60−

61−

62−-- FROM CHARS

63−

64−

65−fromChars :: [Char] -> Source

66−fromChars chars =

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

68−

69−

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

71−escape chars =

72− case chars of

73− [] ->

74− []

75−

76− c:cs

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

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

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

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

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

82− | otherwise -> c : escape cs

83−

84−

85−

86−-- BINARY

87−

88−

89−instance Binary Source where

90− get = liftM Source get

91− put (Source a) = put a

compiler/src/AST/Utils/Type.hs+1

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

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module AST.Utils.Type

3module AST.Utils.Type

3 ( delambda

4 ( delambda

4 , dealias

5 , dealias

compiler/src/Canonicalize/Environment.hs+20−50

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

4 ( Env(..)

5 , Exposed

6 , Qualified

7− , Info(..)

8− , mergeInfo

9 , Var(..)

7 , Var(..)

10 , Type(..)

8 , Type(..)

11 , Ctor(..)

9 , Ctor(..)

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

22

20

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

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

24import qualified Data.Map.Strict as Map

22import qualified Data.Map.Strict as Map

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

25import qualified Data.Name as Name

24import qualified Data.Name as Name

26−import qualified Data.OneOrMore as OneOrMore

27

25

28import qualified AST.Utils.Binop as Binop

26import qualified AST.Utils.Binop as Binop

29import qualified AST.Canonical as Can

27import qualified AST.Canonical as Can

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

60

58

61

59

62type Exposed a =

60type Exposed a =

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

61+ Map.Map Name.Name (Map.Map ModuleName.Canonical a)

64

62

65

63

66type Qualified a =

64type Qualified a =

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

65+ Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))

68−

69−

70−

71−-- INFO

72−

73−

74−data Info a

75− = Specific ModuleName.Canonical a

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

77−

78−

79−mergeInfo :: Info a -> Info a -> Info a

80−mergeInfo info1 info2 =

81− case info1 of

82− Specific h1 _ ->

83− case info2 of

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

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

86−

87− Ambiguous h1 hs1 ->

88− case info2 of

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

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

91

66

92

67

93

68

@@ -97,8 +72,7 @@ mergeInfo info1 info2 =

97data Var

72data Var

98 = Local A.Region

73 = Local A.Region

99 | TopLevel A.Region

74 | TopLevel A.Region

100− | Foreign ModuleName.Canonical Can.Annotation

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

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

102

76

103

77

104

78

@@ -165,10 +139,7 @@ addLocalLeft _ region =

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

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

166addLocalBoth name region var =

140addLocalBoth name region var =

167 case var of

141 case var of

168− Foreign _ _ ->

142+ Foreign _ ->

169− Result.ok (Local region)

170−

171− Foreigns _ _ ->

172 Result.ok (Local region)

143 Result.ok (Local region)

173

144

174 Local parentRegion ->

145 Local parentRegion ->

@@ -179,18 +150,17 @@ addLocalBoth name region var =

179

150

180

151

181

152

182−

183-- FIND TYPE

153-- FIND TYPE

184

154

185

155

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

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

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

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

188 case Map.lookup name ts of

158 case Map.lookup name ts of

189− Just (Specific _ tipe) ->

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

190 Result.ok tipe

160 Result.ok tipe

191

161

192− Just (Ambiguous h hs) ->

162+ Just homes ->

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

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

194

164

195 Nothing ->

165 Nothing ->

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

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

@@ -201,11 +171,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

201 case Map.lookup prefix qts of

171 case Map.lookup prefix qts of

202 Just qualified ->

172 Just qualified ->

203 case Map.lookup name qualified of

173 case Map.lookup name qualified of

204− Just (Specific _ tipe) ->

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

205 Result.ok tipe

175 Result.ok tipe

206

176

207− Just (Ambiguous h hs) ->

177+ Just homes ->

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

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

209

179

210 Nothing ->

180 Nothing ->

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

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

@@ -221,11 +191,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

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

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

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

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

223 case Map.lookup name cs of

193 case Map.lookup name cs of

224− Just (Specific _ ctor) ->

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

225 Result.ok ctor

195 Result.ok ctor

226

196

227− Just (Ambiguous h hs) ->

197+ Just homes ->

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

198+ Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))

229

199

230 Nothing ->

200 Nothing ->

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

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

@@ -236,11 +206,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

236 case Map.lookup prefix qcs of

206 case Map.lookup prefix qcs of

237 Just qualified ->

207 Just qualified ->

238 case Map.lookup name qualified of

208 case Map.lookup name qualified of

239− Just (Specific _ pattern) ->

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

240 Result.ok pattern

210 Result.ok pattern

241

211

242− Just (Ambiguous h hs) ->

212+ Just homes ->

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

213+ Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))

244

214

245 Nothing ->

215 Nothing ->

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

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

@@ -256,11 +226,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

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

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

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

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

258 case Map.lookup name binops of

228 case Map.lookup name binops of

259− Just (Specific _ binop) ->

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

260 Result.ok binop

230 Result.ok binop

261

231

262− Just (Ambiguous h hs) ->

232+ Just homes ->

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

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

264

234

265 Nothing ->

235 Nothing ->

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

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

compiler/src/Canonicalize/Environment/Dups.hs+3−6

@@ -57,11 +57,8 @@ detectHelp toError name values =

57 OneOrMore.One (Info _ value) ->

58 return value

59

60− OneOrMore.More left right ->

60+ OneOrMore.More _ _ ->

61− let

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

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

63− OneOrMore.getFirstTwo left right

64− in

65 Result.throw (toError name r1 r2)

62 Result.throw (toError name r1 r2)

66

63

67

64

@@ -105,7 +102,7 @@ one name region value =

105

102

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

103insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a

107insert name region value dict =

104insert name region value dict =

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

105+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dict

109

106

110

107

111union :: Dict a -> Dict a -> Dict a

108union :: Dict a -> Dict a -> Dict a

compiler/src/Canonicalize/Environment/Foreign.hs+37−49

@@ -35,14 +35,7 @@ type Result i w a =

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

36createInitialEnv 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)

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

39−

40−

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

42−infoToVar info =

43− case info of

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

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

46

39

47

40

48

41

@@ -68,7 +61,7 @@ emptyState =

68

61

69emptyTypes :: Env.Exposed Env.Type

62emptyTypes :: Env.Exposed Env.Type

70emptyTypes =

63emptyTypes =

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

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

72

65

73

66

74

67

@@ -109,8 +102,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe

109 (Map.mapMaybeWithKey (unionToType home) unions)

102 (Map.mapMaybeWithKey (unionToType home) unions)

110 (Map.mapMaybeWithKey (aliasToType home) aliases)

103 (Map.mapMaybeWithKey (aliasToType home) aliases)

111

104

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

105+ !vars = Map.map (Map.singleton home) defs

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

106+ !types = Map.map (Map.singleton home . fst) rawTypeInfo

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

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

115

108

116 !qvs2 = addQualified prefix vars qvs

109 !qvs2 = addQualified prefix vars qvs

@@ -136,7 +129,7 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe

136

129

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

130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a

138addExposed =

131addExposed =

139− Map.unionWith Env.mergeInfo

132+ Map.unionWith Map.union

140

133

141

134

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

135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a

@@ -157,7 +150,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,

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

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

158 let

151 let

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

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

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

153+ Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict

161 in

154 in

162 ( Env.Union (length vars) home

155 ( Env.Union (length vars) home

163 , List.foldl' addCtor Map.empty ctors

156 , List.foldl' addCtor Map.empty ctors

@@ -188,7 +181,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =

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

181 (Can.TAlias home name avars (Can.Filled tipe))

189 (Can.fieldsToList fields)

182 (Can.fieldsToList fields)

190 in

183 in

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

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

192

185

193 _ ->

186 _ ->

194 Map.empty

187 Map.empty

@@ -199,9 +192,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =

199-- BINOP

192-- BINOP

200

193

201

194

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

195+binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop

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

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

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

197+ Map.singleton home (Env.Binop op home name annotation associativity precedence)

205

198

206

199

207

200

@@ -214,19 +207,19 @@ addExposedValue

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

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

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

208 -> Map.Map Name.Name I.Binop

216 -> State

209 -> State

217− -> Src.Exposed

210+ -> A.Located Src.Exposed

218 -> Result i w State

211 -> Result i w State

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

212+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =

220 case exposed of

213 case exposed of

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

214+ Src.Lower name ->

222 case Map.lookup name vars of

215 case Map.lookup name vars of

223 Just info ->

216 Just info ->

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

217+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)

225

218

226 Nothing ->

219 Nothing ->

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

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

228

221

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

222+ Src.Upper name privacy ->

230 case privacy of

223 case privacy of

231 Src.Private ->

224 Src.Private ->

232 case Map.lookup name types of

225 case Map.lookup name types of

@@ -234,43 +227,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =

234 case tipe of

227 case tipe of

235 Env.Union _ _ ->

228 Env.Union _ _ ->

236 let

229 let

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

230+ !ts2 = Map.insert name (Map.singleton home tipe) ts

238 in

231 in

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

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

240

233

241 Env.Alias _ _ _ _ ->

234 Env.Alias _ _ _ _ ->

242 let

235 let

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

236+ !ts2 = Map.insert name (Map.singleton home tipe) ts

244 !cs2 = addExposed cs ctors

237 !cs2 = addExposed cs ctors

245 in

238 in

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

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

247

240

248 Nothing ->

241 Nothing ->

249− case checkForCtorMistake name types of

242+ case Map.lookup name (toCtors types) of

250− tipe:_ ->

243+ Just tipe ->

251 Result.throw $ Error.ImportCtorByName region name tipe

244 Result.throw $ Error.ImportCtorByName region name tipe

252

245

253− [] ->

246+ Nothing ->

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

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

255

248

256− Src.Public dotDotRegion ->

249+ Src.Public ->

257 case Map.lookup name types of

250 case Map.lookup name types of

258 Just (tipe, ctors) ->

251 Just (tipe, ctors) ->

259 case tipe of

252 case tipe of

260 Env.Union _ _ ->

253 Env.Union _ _ ->

261 let

254 let

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

255+ !ts2 = Map.insert name (Map.singleton home tipe) ts

263 !cs2 = addExposed cs ctors

256 !cs2 = addExposed cs ctors

264 in

257 in

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

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

266

259

267 Env.Alias _ _ _ _ ->

260 Env.Alias _ _ _ _ ->

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

261+ Result.throw (Error.ImportOpenAlias region name)

269

262

270 Nothing ->

263 Nothing ->

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

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

272

265

273− Src.Operator region op ->

266+ Src.Operator op ->

274 case Map.lookup op binops of

267 case Map.lookup op binops of

275 Just binop ->

268 Just binop ->

276 let

269 let

@@ -282,23 +275,18 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =

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

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

283

276

284

277

278+

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

279+toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name

286−checkForCtorMistake givenName types =

280+toCtors types =

287− Map.foldr addMatches [] types

281+ Map.foldr addCtors Map.empty types

288 where

282 where

289− addMatches (_, exposedCtors) matches =

283+ addCtors (_, exposedCtors) dict =

290− Map.foldrWithKey addMatch matches exposedCtors

284+ Map.foldrWithKey addCtor dict exposedCtors

291−

285+

292− addMatch ctorName info matches =

286+ addCtor ctorName homes dict =

293− if ctorName /= givenName

294− then matches

295− else

296− case info of

287+ case Map.elems homes of

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

288+ [Env.Ctor _ tipeName _ _ _] ->

298− tipeName : matches

289+ Map.insert ctorName tipeName dict

299−

290+

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

291+ _ ->

301− matches

292+ dict

302−

303− Env.Ambiguous _ _ ->

304− matches

compiler/src/Canonicalize/Environment/Local.hs+8−8

@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =

54

55

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

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

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

58 let

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

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

@@ -95,7 +95,7 @@ toEffectDups effects =

95

96

97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env

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

98+addTypes (Src.Module _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =

99 let

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

@@ -110,7 +110,7 @@ addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs

110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)

111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =

112 do arity <- checkUnionFreeVars union

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

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

114 Result.ok $ Map.insert name one types

115

116

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

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

134 do args <- checkAliasFreeVars alias

135 ctype <- Type.canonicalize env tipe

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

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

137 let ts1 = Map.insert name one ts

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

139

@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =

262

263

264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)

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

265+addCtors (Src.Module _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =

266 do unionInfo <- traverse (canonicalizeUnion env) unions

267 aliasInfo <- traverse (canonicalizeAlias env) aliases

268

@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs

281 )

282

283

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

284+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)

285

286

287

@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi

297 ,

298 case ctipe of

299 Can.TRecord fields Nothing ->

300− Dups.one name region (Env.Specific home (toRecordCtor home name vars fields))

300+ Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))

301

302 _ ->

303 Dups.none

@@ -351,5 +351,5 @@ toOpts ctors =

351

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

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

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

354+ Dups.one name region $ Map.singleton home $

355 Env.Ctor home typeName union index args

compiler/src/Canonicalize/Expression.hs+7−6

@@ -14,6 +14,7 @@ import Control.Monad (foldM)

14import qualified Data.Graph as Graph

15import qualified Data.List as List

16import qualified Data.Map.Strict as Map

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

17import qualified Data.Name as Name

18import qualified Data.Name as Name

18

19

19import qualified AST.Canonical as Can

20import qualified AST.Canonical as Can

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

695 Env.TopLevel _ ->

696 Env.TopLevel _ ->

696 logVar name (Can.VarTopLevel localHome name)

697 logVar name (Can.VarTopLevel localHome name)

697

698

698− Env.Foreign home annotation ->

699+ Env.Foreign (I.Bin 1 home annotation _ _) ->

699 Result.ok $

700 Result.ok $

700 if home == ModuleName.debug then

701 if home == ModuleName.debug then

701 Can.VarDebug localHome name annotation

702 Can.VarDebug localHome name annotation

702 else

703 else

703 Can.VarForeign home name annotation

704 Can.VarForeign home name annotation

704

705

705− Env.Foreigns h hs ->

706+ Env.Foreign homes ->

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

707+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))

707

708

708 Nothing ->

709 Nothing ->

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

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

@@ -714,15 +715,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =

714 case Map.lookup prefix qvs of

715 case Map.lookup prefix qvs of

715 Just qualified ->

716 Just qualified ->

716 case Map.lookup name qualified of

717 case Map.lookup name qualified of

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

718+ Just (I.Bin 1 home annotation _ _) ->

718 Result.ok $

719 Result.ok $

719 if home == ModuleName.debug then

720 if home == ModuleName.debug then

720 Can.VarDebug localHome name annotation

721 Can.VarDebug localHome name annotation

721 else

722 else

722 Can.VarForeign home name annotation

723 Can.VarForeign home name annotation

723

724

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

725+ Just homes ->

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

726+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))

726

727

727 Nothing ->

728 Nothing ->

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

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

compiler/src/Canonicalize/Module.hs+11−11

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

42

43

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

45−canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =

45+canonicalize pkg ifaces modul@(Src.Module _ exports imports values _ _ binops effects) =

46 do let home = ModuleName.Canonical pkg (Src.getName modul)

47 let cbinops = Map.fromList (map canonicalizeBinop binops)

48

@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ bino

54 ceffects <- Effects.canonicalize env values cunions effects

55 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports

56

57− return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects

57+ return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects

58

59

60

61-- CANONICALIZE BINOP

62

63

64−canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )

64+canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )

65−canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =

65+canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =

66 ( op, Can.Binop_ associativity precedence func )

67

68

@@ -236,11 +236,11 @@ checkExposed

236 -> Map.Map Name.Name alias

237 -> Map.Map Name.Name binop

238 -> Can.Effects

239− -> Src.Exposed

239+ -> A.Located Src.Exposed

240 -> Result i w (Dups.Dict (A.Located Can.Export))

241−checkExposed values unions aliases binops effects exposed =

241+checkExposed values unions aliases binops effects (A.At region exposed) =

242 case exposed of

243− Src.Lower (A.At region name) ->

243+ Src.Lower name ->

244 if Map.member name values then

245 ok name region Can.ExportValue

246 else

@@ -252,23 +252,23 @@ checkExposed values unions aliases binops effects exposed =

252 Result.throw $ Error.ExportNotFound region Error.BadVar name $

253 ports ++ Map.keys values

254

255− Src.Operator region name ->

255+ Src.Operator name ->

256 if Map.member name binops then

257 ok name region Can.ExportBinop

258 else

259 Result.throw $ Error.ExportNotFound region Error.BadOp name $

260 Map.keys binops

261

262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->

262+ Src.Upper name Src.Public ->

263 if Map.member name unions then

264 ok name region Can.ExportUnionOpen

265 else if Map.member name aliases then

266− Result.throw $ Error.ExportOpenAlias dotDotRegion name

266+ Result.throw $ Error.ExportOpenAlias region name

267 else

268 Result.throw $ Error.ExportNotFound region Error.BadType name $

269 Map.keys unions ++ Map.keys aliases

270

271− Src.Upper (A.At region name) Src.Private ->

271+ Src.Upper name Src.Private ->

272 if Map.member name unions then

273 ok name region Can.ExportUnionClosed

274 else if Map.member name aliases then

compiler/src/Canonicalize/Pattern.hs+2−3

@@ -8,7 +8,6 @@ module Canonicalize.Pattern

8 where

9

10

11−import qualified Data.List as List

12import qualified Data.Map.Strict as Map

11import qualified Data.Map.Strict as Map

13import qualified Data.Name as Name

12import qualified Data.Name as Name

14

13

@@ -174,8 +173,8 @@ logVar name region value =

174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a

173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a

175logFields fields value =

174logFields fields value =

176 let

175 let

177− addField dict (A.At region name) =

176+ addField (A.At region name) dict =

178 Dups.insert name region region dict

177 Dups.insert name region region dict

179 in

178 in

180 Result.Result $ \bindings warnings _ ok ->

179 Result.Result $ \bindings warnings _ ok ->

181− ok (List.foldl' addField bindings fields) warnings value

180+ ok (foldr addField bindings fields) warnings value

compiler/src/Compile.hs+18−26

@@ -8,6 +8,7 @@ module Compile

8

9import qualified Data.Map as Map

10import qualified Data.Name as Name

11+import qualified Data.OneOrMore as OneOrMore

11

12

12import qualified AST.Source as Src

13import qualified AST.Source as Src

13import qualified AST.Canonical as Can

14import qualified AST.Canonical as Can

@@ -20,7 +21,7 @@ import qualified Nitpick.PatternMatches as PatternMatches

20import qualified Optimize.Module as Optimize

21import qualified Optimize.Module as Optimize

21import qualified Reporting.Error as E

22import qualified Reporting.Error as E

22import qualified Reporting.Result as R

23import qualified Reporting.Result as R

23−import qualified Reporting.Render.Type.Localizer as Localizer

24+import qualified Reporting.Warning as W

24import qualified Type.Constrain.Module as Type

25import qualified Type.Constrain.Module as Type

25import qualified Type.Solve as Type

26import qualified Type.Solve as Type

26

27

@@ -39,12 +40,13 @@ data Artifacts =

39 }

40 }

40

41

42

42−compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts

43+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either (OneOrMore.OneOrMore E.Error) Artifacts

43compile pkg ifaces modul =

44compile pkg ifaces modul =

45+ snd $ R.run $

44 do canonical <- canonicalize pkg ifaces modul

46 do canonical <- canonicalize pkg ifaces modul

45− annotations <- typeCheck modul canonical

47+ annotations <- typeCheck canonical

46 () <- nitpick canonical

48 () <- nitpick canonical

47− objects <- optimize modul annotations canonical

49+ objects <- optimize annotations canonical

48 return (Artifacts canonical annotations objects)

50 return (Artifacts canonical annotations objects)

49

51

50

52

@@ -52,41 +54,31 @@ compile pkg ifaces modul =

52-- PHASES

54-- PHASES

53

55

54

56

55−canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module

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

56canonicalize pkg ifaces modul =

58canonicalize pkg ifaces modul =

57− case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of

59+ R.mapError E.Canonicalize $ Canonicalize.canonicalize pkg ifaces modul

58− Right canonical ->

59− Right canonical

60−

61− Left errors ->

62− Left $ E.BadNames errors

63

60

64

61

65−typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)

62+typeCheck :: Can.Module -> R.Result i w E.Error (Map.Map Name.Name Can.Annotation)

66−typeCheck modul canonical =

63+typeCheck canonical =

67 case unsafePerformIO (Type.run =<< Type.constrain canonical) of

64 case unsafePerformIO (Type.run =<< Type.constrain canonical) of

68 Right annotations ->

65 Right annotations ->

69− Right annotations

66+ R.ok annotations

70

67

71 Left errors ->

68 Left errors ->

72− Left (E.BadTypes (Localizer.fromModule modul) errors)

69+ R.throw (E.Type errors)

73

70

74

71

75−nitpick :: Can.Module -> Either E.Error ()

72+nitpick :: Can.Module -> R.Result i w E.Error ()

76nitpick canonical =

73nitpick canonical =

77 case PatternMatches.check canonical of

74 case PatternMatches.check canonical of

78 Right () ->

75 Right () ->

79− Right ()

76+ R.ok ()

80

77

81 Left errors ->

78 Left errors ->

82− Left (E.BadPatterns errors)

79+ R.throw (E.Pattern errors)

83

80

84

81

85−optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph

82+optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> R.Result i [W.Warning] E.Error Opt.LocalGraph

86−optimize modul annotations canonical =

83+optimize annotations canonical =

87− case snd $ R.run $ Optimize.optimize annotations canonical of

84+ R.mapError E.Main $ Optimize.optimize annotations canonical

88− Right localGraph ->

89− Right localGraph

90−

91− Left errors ->

92− Left (E.BadMains (Localizer.fromModule modul) errors)

compiler/src/Data/Map/Utils.hs−6

@@ -1,7 +1,6 @@

1module Data.Map.Utils

2 ( fromKeys

3 , fromKeysA

4− , fromValues

5 , any

4 , any

6 )

5 )

7 where

6 where

@@ -26,11 +25,6 @@ fromKeysA toValue keys =

26 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys

25 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys

27

26

28

27

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

28

35-- ANY

29-- ANY

36

30

compiler/src/Data/Name.hs+177−166

@@ -1,119 +1,130 @@

1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}

3module Data.Name

4 ( Name

5− --

5+ , toUtf8

6− , toChars

6+ , fromUtf8

7− , toElmString

7+ , toEscapedBuilder

8− , toBuilder

8+ , Utf8.toBuilder

9− --

10− , fromPtr

9+ , Utf8.fromPtr

11− , fromChars

10+ , Utf8.fromChars

11+ , Utf8.toChars

12− --

12+ -- misc

13 , getKernel

14 , hasDot

15− , splitDots

16 , isKernel

15 , isKernel

17 , isNumberType

16 , isNumberType

18 , isComparableType

17 , isComparableType

19 , isAppendableType

18 , isAppendableType

20 , isCompappendType

19 , isCompappendType

21 , fromVarIndex

20 , fromVarIndex

21+ , fromReplCount

22 , fromWords

23 , fromManyNames

24 , fromTypeVariable

25 , fromTypeVariableScheme

26 , sepBy

27− --

27+ -- interned

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

33+ , node, program, main, dollar, identity

34− , replModule, replValueToPrint

34+ , replModule

35 )

36 where

37

38

39import Prelude hiding (length, maybe, negate)

40import Control.Exception (assert)

41−import qualified Data.Binary as Binary

42import qualified Data.ByteString.Builder.Internal as B

41import qualified Data.ByteString.Builder.Internal as B

43−import qualified Data.Coerce as Coerce

42+import Data.Coerce (coerce)

44import qualified Data.List as List

43import qualified Data.List as List

45−import qualified Data.String as Chars

46import qualified Data.Utf8 as Utf8

44import qualified Data.Utf8 as Utf8

45+import Foreign.Ptr (plusPtr, minusPtr)

47import GHC.Exts

46import GHC.Exts

48− ( Int(I#), Ptr

47+ ( Int(I#), Ptr(Ptr)

48+ , RealWorld

49 , MutableByteArray#

50 , isTrue#

51 , newByteArray#

52 , sizeofByteArray#

53+ , writeWord8OffAddr#

54+ , copyByteArrayToAddr#

53 , unsafeFreezeByteArray#

55 , unsafeFreezeByteArray#

54 )

56 )

57+import GHC.IO

55import GHC.ST (ST(ST), runST)

58import GHC.ST (ST(ST), runST)

56import GHC.Prim

59import GHC.Prim

57import GHC.Word (Word8(W8#))

60import GHC.Word (Word8(W8#))

58

61

59−import qualified Elm.String as ES

60−

61

62

63

63-- NAME

64-- NAME

64

65

66

66−type Name =

67+type Name = Utf8.Under256 NAME

67− Utf8.Utf8 ELM_NAME

68−

69−

70−data ELM_NAME

71−

72−

73−

74−-- INSTANCES

75−

76

68

77−instance Chars.IsString (Utf8.Utf8 ELM_NAME) where

78− fromString = Utf8.fromChars

79

69

80−instance Binary.Binary (Utf8.Utf8 ELM_NAME) where

70+data NAME

81− get = Utf8.getUnder256

82− put = Utf8.putUnder256

83

71

84

72

73+toUtf8 :: Name -> Utf8.String

74+toUtf8 =

75+ coerce

85

76

86−-- TO

87

77

78+fromUtf8 :: Utf8.String -> Name

79+fromUtf8 =

80+ coerce

88

81

89−toChars :: Name -> [Char]

90−toChars =

91− Utf8.toChars

92

82

93

83

94−toElmString :: Name -> ES.String

84+-- TO ESCAPED BUILDER

95−toElmString =

96− Coerce.coerce

97

85

98

86

99−{-# INLINE toBuilder #-}

87+{-# INLINE toEscapedBuilder #-}

100−toBuilder :: Name -> B.Builder

88+toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder

101−toBuilder =

89+toEscapedBuilder before after =

102− Utf8.toBuilder

90+ \name -> B.builder (toEscapedBuilderHelp before after name)

103

91

104

92

93+{-# INLINE toEscapedBuilderHelp #-}

94+toEscapedBuilderHelp :: Word8 -> Word8 -> Name -> B.BuildStep a -> B.BuildStep a

95+toEscapedBuilderHelp before after !name@(Utf8.Utf8 ba#) k =

96+ go 0 (I# (sizeofByteArray# ba#))

97+ where

98+ go !offset !len !(B.BufferRange bOffset bEnd) =

99+ let

100+ !bLen = minusPtr bEnd bOffset

101+ in

102+ if len <= bLen then

103+ do -- TODO test if writing word-by-word is faster

104+ stToIO (copyToPtr name offset bOffset len)

105+ stToIO (escape before after bOffset name offset len 0)

106+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd

107+ k newBufferRange

108+ else

109+ do stToIO (copyToPtr name offset bOffset bLen)

110+ stToIO (escape before after bOffset name offset bLen 0)

111+ let !newOffset = offset + bLen

112+ let !newLength = len - bLen

113+ return $ B.bufferFull 1 bEnd (go newOffset newLength)

114+

115+

116+escape :: Word8 -> Word8 -> Ptr a -> Name -> Int -> Int -> Int -> ST RealWorld ()

117+escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =

118+ if isTrue# (i# <# len#) then

119+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))

120+ then

121+ do writeWordToPtr ptr i after

122+ escape before after ptr name offset len (i + 1)

123+ else

124+ do escape before after ptr name offset len (i + 1)

105

125

106−-- FROM

126+ else

107−

127+ return ()

108−

109−fromPtr :: Ptr Word8 -> Ptr Word8 -> Name

110−fromPtr =

111− Utf8.fromPtr

112−

113−

114−fromChars :: [Char] -> Name

115−fromChars =

116− Utf8.fromChars

117

128

118

129

119

130

@@ -122,12 +133,7 @@ fromChars =

122

133

123hasDot :: Name -> Bool

134hasDot :: Name -> Bool

124hasDot name =

135hasDot name =

125− Utf8.contains 0x2E {- . -} name

136+ Utf8.contains 0x2E {- . -} (coerce name)

126−

127−

128−splitDots :: Name -> [Name]

129−splitDots name =

130− Utf8.split 0x2E {- . -} name

131

137

132

138

133

139

@@ -175,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend

175

181

176{-# NOINLINE prefix_kernel #-}

182{-# NOINLINE prefix_kernel #-}

177prefix_kernel :: Name

183prefix_kernel :: Name

178−prefix_kernel = fromChars "Elm.Kernel."

184+prefix_kernel = "Elm.Kernel."

179

185

180{-# NOINLINE prefix_number #-}

186{-# NOINLINE prefix_number #-}

181prefix_number :: Name

187prefix_number :: Name

182−prefix_number = fromChars "number"

188+prefix_number = "number"

183

189

184{-# NOINLINE prefix_comparable #-}

190{-# NOINLINE prefix_comparable #-}

185prefix_comparable :: Name

191prefix_comparable :: Name

186−prefix_comparable = fromChars "comparable"

192+prefix_comparable = "comparable"

187

193

188{-# NOINLINE prefix_appendable #-}

194{-# NOINLINE prefix_appendable #-}

189prefix_appendable :: Name

195prefix_appendable :: Name

190−prefix_appendable = fromChars "appendable"

196+prefix_appendable = "appendable"

191

197

192{-# NOINLINE prefix_compappend #-}

198{-# NOINLINE prefix_compappend #-}

193prefix_compappend :: Name

199prefix_compappend :: Name

194−prefix_compappend = fromChars "compappend"

200+prefix_compappend = "compappend"

195

201

196

202

197

203

@@ -202,11 +208,11 @@ fromVarIndex :: Int -> Name

202fromVarIndex n =

208fromVarIndex n =

203 runST

209 runST

204 (

210 (

205− do let !size = 2 + getIndexSize n

211+ do let !size = getIndexSize n

206 mba <- newByteArray size

212 mba <- newByteArray size

207 writeWord8 mba 0 0x5F {- _ -}

213 writeWord8 mba 0 0x5F {- _ -}

208 writeWord8 mba 1 0x76 {- v -}

214 writeWord8 mba 1 0x76 {- v -}

209− writeDigitsAtEnd mba size n

215+ writeDigits mba (size - 1) n

210 freeze mba

216 freeze mba

211 )

217 )

212

218

@@ -214,20 +220,19 @@ fromVarIndex n =

214{-# INLINE getIndexSize #-}

220{-# INLINE getIndexSize #-}

215getIndexSize :: Int -> Int

221getIndexSize :: Int -> Int

216getIndexSize n

222getIndexSize n

217− | n < 10 = 1

223+ | n < 10 = 3

218− | n < 100 = 2

224+ | n < 100 = 4

219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

225+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)

220

226

221

227

222

228

223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()

229+writeDigits :: MBA s -> Int -> Int -> ST s ()

224−writeDigitsAtEnd !mba !oldOffset !n =

230+writeDigits !mba !offset !n =

225 do let (q,r) = quotRem n 10

231 do let (q,r) = quotRem n 10

226− let !newOffset = oldOffset - 1

227− writeWord8 mba newOffset (0x30 + fromIntegral r)

232+ writeWord8 mba offset (0x30 + fromIntegral r)

228 if q <= 0

233 if q <= 0

229 then return ()

234 then return ()

230− else writeDigitsAtEnd mba newOffset q

235+ else writeDigits mba (offset-1) q

231

236

232

237

233

238

@@ -250,7 +255,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =

250 mba <- newByteArray size

255 mba <- newByteArray size

251 copyToMBA name mba

256 copyToMBA name mba

252 writeWord8 mba (I# len#) 0x5F {- _ -}

257 writeWord8 mba (I# len#) 0x5F {- _ -}

253− writeDigitsAtEnd mba size index

258+ writeDigits mba (size - 1) index

254 freeze mba

259 freeze mba

255 )

260 )

256 else

261 else

@@ -259,7 +264,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =

259 do let !size = I# len# + getIndexSize index

264 do let !size = I# len# + getIndexSize index

260 mba <- newByteArray size

265 mba <- newByteArray size

261 copyToMBA name mba

266 copyToMBA name mba

262− writeDigitsAtEnd mba size index

267+ writeDigits mba (size - 1) index

263 freeze mba

268 freeze mba

264 )

269 )

265

270

@@ -278,61 +283,61 @@ fromTypeVariableScheme scheme =

278 freeze mba

283 freeze mba

279 else

284 else

280 do let (extra, letter) = quotRem scheme 26

285 do let (extra, letter) = quotRem scheme 26

281− let !size = 1 + getIndexSize extra

286+ let !size = getIndexSize extra

282 mba <- newByteArray size

287 mba <- newByteArray size

283 writeWord8 mba 0 (0x61 + fromIntegral letter)

288 writeWord8 mba 0 (0x61 + fromIntegral letter)

284− writeDigitsAtEnd mba size extra

289+ writeDigits mba (size - 1) extra

285 freeze mba

290 freeze mba

286 )

291 )

287

292

288

293

289

294

295+-- FROM REPL COUNT

296+

297+

298+fromReplCount :: Int -> Name

299+fromReplCount n =

300+ Utf8.fromChars ("repl_value_" ++ show n)

301+

302+

303+

290-- FROM MANY NAMES

304-- FROM MANY NAMES

291−--

292−-- Creating a unique name by combining all the subnames can create names

293−-- longer than 256 bytes relatively easily. So instead, the first given name

294−-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)

295−--

296−-- This should be a unique name since 0.19 disallows shadowing. It would not

297−-- be possible for multiple top-level cycles to include values with the same

298−-- name, so the important thing is to make the cycle name distinct from the

299−-- normal name. Same logic for destructuring patterns like (x,y)

300

305

301

306

302fromManyNames :: [Name] -> Name

307fromManyNames :: [Name] -> Name

303fromManyNames names =

308fromManyNames names =

304− case names of

309+ let

305− [] ->

306− blank

307− -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)

308− -- but maybe unused patterns should be stripped out instead

309−

310− Utf8.Utf8 ba# : _ ->

311− let

312− len# = sizeofByteArray# ba#

310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)

313− in

311+ in

314− runST

312+ runST

315− (

313+ (

316− ST $ \s ->

314+ ST $ \s ->

317− case newByteArray# (len# +# 3#) s of

315+ case newByteArray# size# s of

316+ (# s, mba# #) ->

317+ case writeNames mba# 0# names s of

318− (# s, mba# #) ->

318+ s ->

319− case writeWord8Array# mba# 0# 0x5F## {-_-} s of

320− s ->

321− case writeWord8Array# mba# 1# 0x4D## {-M-} s of

322− s ->

323− case writeWord8Array# mba# 2# 0x24## {-$-} s of

324− s ->

325− case copyByteArray# ba# 0# mba# 3# len# s of

326− s ->

327− case unsafeFreezeByteArray# mba# s of

319+ case unsafeFreezeByteArray# mba# s of

328− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

329− )

321+ )

330

322

331

323

332−{-# NOINLINE blank #-}

324+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s

333−blank :: Name

325+writeNames mba# !offset# names s =

334−blank =

326+ case names of

335− fromWords [0x5F,0x4D,0x24] {-_M$-}

327+ [] ->

328+ s

329+

330+ (Utf8.Utf8 ba#) : names ->

331+ case writeWord8Array# mba# offset# 0x24## {- $ -} s of

332+ s ->

333+ let

334+ !offset1# = offset# +# 1#

335+ !len# = sizeofByteArray# ba#

336+ !newOffset# = offset1# +# len#

337+ in

338+ case copyByteArray# ba# 0# mba# offset1# len# s of

339+ s ->

340+ writeNames mba# newOffset# names s

336

341

337

342

338

343

@@ -418,6 +423,22 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

418 s -> (# s, () #)

423 s -> (# s, () #)

419

424

420

425

426+{-# INLINE writeWordToPtr #-}

427+writeWordToPtr :: Ptr a -> Int -> Word8 -> ST s ()

428+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =

429+ ST $ \s ->

430+ case writeWord8OffAddr# addr# offset# word# s of

431+ s -> (# s, () #)

432+

433+

434+{-# INLINE copyToPtr #-}

435+copyToPtr :: Name -> Int -> Ptr a -> Int -> ST RealWorld ()

436+copyToPtr (Utf8.Utf8 ba#) (I# offset#) (Ptr addr#) (I# len#) =

437+ ST $ \s ->

438+ case copyByteArrayToAddr# ba# offset# addr# len# s of

439+ s -> (# s, () #)

440+

441+

421{-# INLINE copyToMBA #-}

442{-# INLINE copyToMBA #-}

422copyToMBA :: Name -> MBA s -> ST s ()

443copyToMBA :: Name -> MBA s -> ST s ()

423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

@@ -432,179 +453,169 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

432

453

433{-# NOINLINE int #-}

454{-# NOINLINE int #-}

434int :: Name

455int :: Name

435−int = fromChars "Int"

456+int = "Int"

436

457

437

458

438{-# NOINLINE float #-}

459{-# NOINLINE float #-}

439float :: Name

460float :: Name

440−float = fromChars "Float"

461+float = "Float"

441

462

442

463

443{-# NOINLINE bool #-}

464{-# NOINLINE bool #-}

444bool :: Name

465bool :: Name

445−bool = fromChars "Bool"

466+bool = "Bool"

446

467

447

468

448{-# NOINLINE char #-}

469{-# NOINLINE char #-}

449char :: Name

470char :: Name

450−char = fromChars "Char"

471+char = "Char"

451

472

452

473

453{-# NOINLINE string #-}

474{-# NOINLINE string #-}

454string :: Name

475string :: Name

455−string = fromChars "String"

476+string = "String"

456

477

457

478

458{-# NOINLINE maybe #-}

479{-# NOINLINE maybe #-}

459maybe :: Name

480maybe :: Name

460−maybe = fromChars "Maybe"

481+maybe = "Maybe"

461

482

462

483

463{-# NOINLINE result #-}

484{-# NOINLINE result #-}

464result :: Name

485result :: Name

465−result = fromChars "Result"

486+result = "Result"

466

487

467

488

468{-# NOINLINE list #-}

489{-# NOINLINE list #-}

469list :: Name

490list :: Name

470−list = fromChars "List"

491+list = "List"

471

492

472

493

473{-# NOINLINE array #-}

494{-# NOINLINE array #-}

474array :: Name

495array :: Name

475−array = fromChars "Array"

496+array = "Array"

476

497

477

498

478{-# NOINLINE dict #-}

499{-# NOINLINE dict #-}

479dict :: Name

500dict :: Name

480−dict = fromChars "Dict"

501+dict = "Dict"

481

502

482

503

483{-# NOINLINE tuple #-}

504{-# NOINLINE tuple #-}

484tuple :: Name

505tuple :: Name

485−tuple = fromChars "Tuple"

506+tuple = "Tuple"

486

507

487

508

488{-# NOINLINE jsArray #-}

509{-# NOINLINE jsArray #-}

489jsArray :: Name

510jsArray :: Name

490−jsArray = fromChars "JsArray"

511+jsArray = "JsArray"

491

512

492

513

493{-# NOINLINE task #-}

514{-# NOINLINE task #-}

494task :: Name

515task :: Name

495−task = fromChars "Task"

516+task = "Task"

496

517

497

518

498{-# NOINLINE router #-}

519{-# NOINLINE router #-}

499router :: Name

520router :: Name

500−router = fromChars "Router"

521+router = "Router"

501

522

502

523

503{-# NOINLINE cmd #-}

524{-# NOINLINE cmd #-}

504cmd :: Name

525cmd :: Name

505−cmd = fromChars "Cmd"

526+cmd = "Cmd"

506

527

507

528

508{-# NOINLINE sub #-}

529{-# NOINLINE sub #-}

509sub :: Name

530sub :: Name

510−sub = fromChars "Sub"

531+sub = "Sub"

511

532

512

533

513{-# NOINLINE platform #-}

534{-# NOINLINE platform #-}

514platform :: Name

535platform :: Name

515−platform = fromChars "Platform"

536+platform = "Platform"

516

537

517

538

518{-# NOINLINE virtualDom #-}

539{-# NOINLINE virtualDom #-}

519virtualDom :: Name

540virtualDom :: Name

520−virtualDom = fromChars "VirtualDom"

541+virtualDom = "VirtualDom"

521

542

522

543

523{-# NOINLINE shader #-}

544{-# NOINLINE shader #-}

524shader :: Name

545shader :: Name

525−shader = fromChars "Shader"

546+shader = "Shader"

526

547

527

548

528{-# NOINLINE debug #-}

549{-# NOINLINE debug #-}

529debug :: Name

550debug :: Name

530−debug = fromChars "Debug"

551+debug = "Debug"

531

552

532

553

533{-# NOINLINE debugger #-}

554{-# NOINLINE debugger #-}

534debugger :: Name

555debugger :: Name

535−debugger = fromChars "Debugger"

556+debugger = "Debugger"

536

557

537

558

538{-# NOINLINE bitwise #-}

559{-# NOINLINE bitwise #-}

539bitwise :: Name

560bitwise :: Name

540−bitwise = fromChars "Bitwise"

561+bitwise = "Bitwise"

541

562

542

563

543{-# NOINLINE basics #-}

564{-# NOINLINE basics #-}

544basics :: Name

565basics :: Name

545−basics = fromChars "Basics"

566+basics = "Basics"

546

567

547

568

548{-# NOINLINE utils #-}

569{-# NOINLINE utils #-}

549utils :: Name

570utils :: Name

550−utils = fromChars "Utils"

571+utils = "Utils"

551

572

552

573

553{-# NOINLINE negate #-}

574{-# NOINLINE negate #-}

554negate :: Name

575negate :: Name

555−negate = fromChars "negate"

576+negate = "negate"

556

577

557

578

558{-# NOINLINE true #-}

579{-# NOINLINE true #-}

559true :: Name

580true :: Name

560−true = fromChars "True"

581+true = "True"

561

582

562

583

563{-# NOINLINE false #-}

584{-# NOINLINE false #-}

564false :: Name

585false :: Name

565−false = fromChars "False"

586+false = "False"

566

587

567

588

568{-# NOINLINE value #-}

589{-# NOINLINE value #-}

569value :: Name

590value :: Name

570−value = fromChars "Value"

591+value = "Value"

571

592

572

593

573{-# NOINLINE node #-}

594{-# NOINLINE node #-}

574node :: Name

595node :: Name

575−node = fromChars "Node"

596+node = "Node"

576

597

577

598

578{-# NOINLINE program #-}

599{-# NOINLINE program #-}

579program :: Name

600program :: Name

580−program = fromChars "Program"

601+program = "Program"

581−

582

602

583−{-# NOINLINE _main #-}

584−_main :: Name

585−_main = fromChars "main"

586

603

587−

588−{-# NOINLINE _Main #-}

604+{-# NOINLINE main #-}

589−_Main :: Name

605+main :: Name

590−_Main = fromChars "Main"

606+main = "main"

591

607

592

608

593{-# NOINLINE dollar #-}

609{-# NOINLINE dollar #-}

594dollar :: Name

610dollar :: Name

595−dollar = fromChars "$"

611+dollar = "$"

596

612

597

613

598{-# NOINLINE identity #-}

614{-# NOINLINE identity #-}

599identity :: Name

615identity :: Name

600−identity = fromChars "identity"

616+identity = "identity"

601

617

602

618

603{-# NOINLINE replModule #-}

619{-# NOINLINE replModule #-}

604replModule :: Name

620replModule :: Name

605−replModule = fromChars "Elm_Repl"

621+replModule = "Elm_Repl"

606−

607−

608−{-# NOINLINE replValueToPrint #-}

609−replValueToPrint :: Name

610−replValueToPrint = fromChars "repl_input_value_"

compiler/src/Data/NonEmptyList.hs−42

@@ -1,17 +1,10 @@

1module Data.NonEmptyList

2 ( List(..)

3− , singleton

4 , toList

3 , toList

5− , sortBy

6 )

4 )

7 where

5 where

8

6

9

7

10−import Control.Monad (liftM2)

11−import Data.Binary (Binary, get, put)

12−import qualified Data.List as List

13−

14−

15

8

16-- LIST

9-- LIST

17

10

@@ -20,11 +13,6 @@ data List a =

20 List a [a]

13 List a [a]

21

14

22

15

23−singleton :: a -> List a

24−singleton a =

25− List a []

26−

27−

28toList :: List a -> [a]

16toList :: List a -> [a]

29toList (List x xs) =

17toList (List x xs) =

30 x:xs

18 x:xs

@@ -46,33 +34,3 @@ instance Foldable List where

46 foldr step state (List x xs) = step x (foldr step state xs)

34 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

35 foldl step state (List x xs) = foldl step (step state x) xs

48 foldl1 step (List x xs) = foldl step x xs

36 foldl1 step (List x xs) = foldl step x xs

49−

50−

51−

52−-- SORT BY

53−

54−

55−sortBy :: (Ord b) => (a -> b) -> List a -> List a

56−sortBy toRank (List x xs) =

57− let

58− comparison a b =

59− compare (toRank a) (toRank b)

60− in

61− case List.sortBy comparison xs of

62− [] ->

63− List x []

64−

65− y:ys ->

66− case comparison x y of

67− LT -> List x (y:ys)

68− EQ -> List x (y:ys)

69− GT -> List y (List.insertBy comparison x ys)

70−

71−

72−

73−-- BINARY

74−

75−

76−instance (Binary a) => Binary (List a) where

77− put (List x xs) = put x >> put xs

78− get = liftM2 List get get

compiler/src/Data/OneOrMore.hs+24−39

@@ -3,9 +3,9 @@ module Data.OneOrMore

3 ( OneOrMore(..)

4 , one

5 , more

6+ , toList

6 , map

7 , map

7 , destruct

8 , destruct

8− , getFirstTwo

9 )

10 where

11

@@ -33,6 +33,25 @@ more =

33

34

35

36+-- TO LIST

37+

38+

39+toList :: OneOrMore a -> [a]

40+toList oneOrMore =

41+ toListHelp oneOrMore []

42+

43+

44+toListHelp :: OneOrMore a -> [a] -> [a]

45+toListHelp oneOrMore list =

46+ case oneOrMore of

47+ One x ->

48+ x : list

49+

50+ More a b ->

51+ toListHelp a (toListHelp b list)

52+

53+

54+

36-- MAP

55-- MAP

37

56

38

57

@@ -52,48 +71,14 @@ map func oneOrMore =

52

71

53destruct :: (a -> [a] -> b) -> OneOrMore a -> b

72destruct :: (a -> [a] -> b) -> OneOrMore a -> b

54destruct func oneOrMore =

73destruct func oneOrMore =

55− destructLeft func oneOrMore []

74+ destructHelp func oneOrMore []

56

75

57

76

58−destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

77+destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

59−destructLeft func oneOrMore xs =

78+destructHelp func oneOrMore xs =

60 case oneOrMore of

79 case oneOrMore of

61 One x ->

80 One x ->

62 func x xs

81 func x xs

63

82

64 More a b ->

83 More a b ->

65− destructLeft func a (destructRight b xs)

84+ destructHelp func a (toListHelp b xs)

66−

67−

68−destructRight :: OneOrMore a -> [a] -> [a]

69−destructRight oneOrMore xs =

70− case oneOrMore of

71− One x ->

72− x : xs

73−

74− More a b ->

75− destructRight a (destructRight b xs)

76−

77−

78−

79−-- GET FIRST TWO

80−

81−

82−getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)

83−getFirstTwo left right =

84− case left of

85− One x ->

86− (x, getFirstOne right)

87−

88− More lleft lright ->

89− getFirstTwo lleft lright

90−

91−

92−getFirstOne :: OneOrMore a -> a

93−getFirstOne oneOrMore =

94− case oneOrMore of

95− One x ->

96− x

97−

98− More left _ ->

99− getFirstOne left

compiler/src/Data/Utf8.hs+300−158

@@ -1,42 +1,36 @@

1{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

3module Data.Utf8

4+ ( String

4− ( Utf8(..)

5+ , Utf8(..)

6+ , VeryLong

7+ , Under256

5 , isEmpty

8 , isEmpty

6− , empty

7 , size

9 , size

8 , contains

10 , contains

11+ , containsDouble

9 , startsWith

12 , startsWith

10 , startsWithChar

13 , startsWithChar

11− , endsWithWord8

14+ , endsWithWord

12 , split

15 , split

13 , join

16 , join

14− --

17+ , all

15− , getUnder256

18+ , any

16− , putUnder256

19+ , toWord16

17− --

20+ , fromWord16

18− , getVeryLong

21+ -- conversions

19− , putVeryLong

22+ , fromChars

20− --

21 , toChars

23 , toChars

22 , toBuilder

24 , toBuilder

23− , toEscapedBuilder

24− --

25 , fromPtr

26− , fromSnippet

26+ , fromChunks

27− , fromChars

27+ , Chunk(..)

28− --

29− , MBA

30− , newByteArray

31− , copyFromPtr

32− , writeWord8

33− , freeze

34 )

28 )

35 where

29 where

36

30

37

31

38import Prelude hiding (String, all, any, concat)

32import Prelude hiding (String, all, any, concat)

39−import Data.Binary (Get, get, getWord8, Put, put, putWord8)

33+import Data.Binary (Binary(..), Get, getWord8, putWord8)

40import Data.Binary.Put (putBuilder)

34import Data.Binary.Put (putBuilder)

41import Data.Binary.Get.Internal (readN)

35import Data.Binary.Get.Internal (readN)

42import Data.Bits ((.&.), shiftR)

36import Data.Bits ((.&.), shiftR)

@@ -44,6 +38,7 @@ import qualified Data.ByteString.Internal as B

44import qualified Data.ByteString.Builder.Internal as B

38import qualified Data.ByteString.Builder.Internal as B

45import qualified Data.Char as Char

39import qualified Data.Char as Char

46import qualified Data.List as List

40import qualified Data.List as List

41+import Data.String (IsString(..))

47import Foreign.ForeignPtr (touchForeignPtr)

42import Foreign.ForeignPtr (touchForeignPtr)

48import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

43import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

49import Foreign.Ptr (minusPtr, plusPtr)

44import Foreign.Ptr (minusPtr, plusPtr)

@@ -58,35 +53,36 @@ import GHC.Exts

58 , copyByteArray#

53 , copyByteArray#

59 , copyAddrToByteArray#

54 , copyAddrToByteArray#

60 , copyByteArrayToAddr#

55 , copyByteArrayToAddr#

61− , writeWord8Array#

56+ , writeWord8Array#,

62 )

57 )

63import GHC.IO

58import GHC.IO

64import GHC.ST (ST(ST), runST)

59import GHC.ST (ST(ST), runST)

65import GHC.Prim

60import GHC.Prim

66−import GHC.Word (Word8(W8#))

61+import GHC.Word (Word8(W8#), Word16(W16#))

67−

68−import qualified Parse.Primitives as P

69

62

70

63

71

64

72-- UTF-8

65-- UTF-8

73

66

74

67

75−data Utf8 tipe =

68+data Utf8 size tipe =

76 Utf8 ByteArray#

69 Utf8 ByteArray#

77

70

78

71

72+type String = Utf8 VERY_LONG STRING

73+type VeryLong t = Utf8 VERY_LONG t

74+type Under256 t = Utf8 UNDER_256 t

79

75

80−-- EMPTY

76+data STRING

77+data VERY_LONG

78+data UNDER_256

81

79

82

80

83−{-# NOINLINE empty #-}

84−empty :: Utf8 t

85−empty =

86− runST (freeze =<< newByteArray 0)

87

81

82+-- IS EMPTY

88

83

84+

89−isEmpty :: Utf8 t -> Bool

85+isEmpty :: Utf8 l t -> Bool

90isEmpty (Utf8 ba#) =

86isEmpty (Utf8 ba#) =

91 isTrue# (sizeofByteArray# ba# ==# 0#)

87 isTrue# (sizeofByteArray# ba# ==# 0#)

92

88

@@ -95,7 +91,7 @@ isEmpty (Utf8 ba#) =

95-- SIZE

91-- SIZE

96

92

97

93

98−size :: Utf8 t -> Int

94+size :: Utf8 l t -> Int

99size (Utf8 ba#) =

95size (Utf8 ba#) =

100 I# (sizeofByteArray# ba#)

96 I# (sizeofByteArray# ba#)

101

97

@@ -104,7 +100,7 @@ size (Utf8 ba#) =

104-- CONTAINS

100-- CONTAINS

105

101

106

102

107−contains :: Word8 -> Utf8 t -> Bool

103+contains :: Word8 -> Utf8 l t -> Bool

108contains (W8# word#) (Utf8 ba#) =

104contains (W8# word#) (Utf8 ba#) =

109 containsHelp word# ba# 0# (sizeofByteArray# ba#)

105 containsHelp word# ba# 0# (sizeofByteArray# ba#)

110

106

@@ -120,11 +116,32 @@ containsHelp word# ba# !offset# len# =

120

116

121

117

122

118

119+-- CONTAINS DOUBLE

120+

121+

122+containsDouble :: Word8 -> Utf8 l t -> Bool

123+containsDouble (W8# word#) (Utf8 ba#) =

124+ containsDoubleHelp word# ba# 0# (sizeofByteArray# ba#)

125+

126+

127+containsDoubleHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool

128+containsDoubleHelp word# ba# !offset# len# =

129+ let !offset1# = offset# +# 1# in

130+ if isTrue# (offset1# <# len#) then

131+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset# ))

132+ && isTrue# (eqWord# word# (indexWord8Array# ba# offset1#))

133+ then True

134+ else containsDoubleHelp word# ba# (offset# +# 1#) len#

135+ else

136+ False

137+

138+

139+

123-- STARTS WITH

140-- STARTS WITH

124

141

125

142

126{-# INLINE startsWith #-}

143{-# INLINE startsWith #-}

127−startsWith :: Utf8 t -> Utf8 t -> Bool

144+startsWith :: Utf8 l t -> Utf8 l t -> Bool

128startsWith (Utf8 ba1#) (Utf8 ba2#) =

145startsWith (Utf8 ba1#) (Utf8 ba2#) =

129 let

146 let

130 !len1# = sizeofByteArray# ba1#

147 !len1# = sizeofByteArray# ba1#

@@ -139,9 +156,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =

139-- STARTS WITH CHAR

156-- STARTS WITH CHAR

140

157

141

158

142−startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool

159+startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool

143−startsWithChar isGood bytes@(Utf8 ba#) =

160+startsWithChar isGood str@(Utf8 ba#) =

144− if isEmpty bytes then

161+ if isEmpty str then

145 False

162 False

146 else

163 else

147 let

164 let

@@ -159,8 +176,8 @@ startsWithChar isGood bytes@(Utf8 ba#) =

159-- ENDS WITH WORD

176-- ENDS WITH WORD

160

177

161

178

162−endsWithWord8 :: Word8 -> Utf8 t -> Bool

179+endsWithWord :: Word8 -> Utf8 l t -> Bool

163−endsWithWord8 (W8# w#) (Utf8 ba#) =

180+endsWithWord (W8# w#) (Utf8 ba#) =

164 let len# = sizeofByteArray# ba# in

181 let len# = sizeofByteArray# ba# in

165 isTrue# (len# ># 0#)

182 isTrue# (len# ># 0#)

166 &&

183 &&

@@ -171,12 +188,12 @@ endsWithWord8 (W8# w#) (Utf8 ba#) =

171-- SPLIT

188-- SPLIT

172

189

173

190

174−split :: Word8 -> Utf8 t -> [Utf8 t]

191+split :: Word8 -> String -> [String]

175split (W8# divider#) str@(Utf8 ba#) =

192split (W8# divider#) str@(Utf8 ba#) =

176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

193 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

177

194

178

195

179−splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]

196+splitHelp :: String -> Int -> [Int] -> [String]

180splitHelp str start offsets =

197splitHelp str start offsets =

181 case offsets of

198 case offsets of

182 [] ->

199 [] ->

@@ -197,7 +214,7 @@ findDividers divider# ba# !offset# len# revOffsets =

197 reverse revOffsets

214 reverse revOffsets

198

215

199

216

200−unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t

217+unsafeSlice :: String -> Int -> Int -> String

201unsafeSlice str start end =

218unsafeSlice str start end =

202 let !len = end - start in

219 let !len = end - start in

203 if len == 0 then

220 if len == 0 then

@@ -213,7 +230,7 @@ unsafeSlice str start end =

213-- JOIN

230-- JOIN

214

231

215

232

216−join :: Word8 -> [Utf8 t] -> Utf8 t

233+join :: Word8 -> [String] -> String

217join sep strings =

234join sep strings =

218 case strings of

235 case strings of

219 [] ->

236 [] ->

@@ -227,7 +244,7 @@ join sep strings =

227 freeze mba

244 freeze mba

228

245

229

246

230−joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()

247+joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()

231joinHelp sep mba offset str strings =

248joinHelp sep mba offset str strings =

232 let

249 let

233 !len = size str

250 !len = size str

@@ -245,10 +262,46 @@ joinHelp sep mba offset str strings =

245

262

246

263

247

264

265+-- ALL

266+

267+

268+all :: (Char -> Bool) -> Utf8 l t -> Bool

269+all isGood utf8 =

270+ not (any (not . isGood) utf8)

271+

272+

273+

274+-- ANY

275+

276+

277+any :: (Char -> Bool) -> Utf8 l t -> Bool

278+any isGood (Utf8 ba#) =

279+ anyHelp isGood ba# 0# (sizeofByteArray# ba#)

280+

281+

282+anyHelp :: (Char -> Bool) -> ByteArray# -> Int# -> Int# -> Bool

283+anyHelp isGood ba# offset# len# =

284+ if isTrue# (offset# >=# len#) then

285+ False

286+ else

287+ let

288+ !w# = indexWord8Array# ba# offset#

289+ !(# char, width# #)

290+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)

291+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)

292+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)

293+ | True = (# chr4 ba# offset# w#, 4# #)

294+ in

295+ if isGood char

296+ then True

297+ else anyHelp isGood ba# (offset# +# width#) len#

298+

299+

300+

248-- EQUAL

301-- EQUAL

249

302

250

303

251−instance Eq (Utf8 t) where

304+instance Eq (Utf8 l t) where

252 (==) (Utf8 ba1#) (Utf8 ba2#) =

305 (==) (Utf8 ba1#) (Utf8 ba2#) =

253 let

306 let

254 !len1# = sizeofByteArray# ba1#

307 !len1# = sizeofByteArray# ba1#

@@ -261,11 +314,9 @@ instance Eq (Utf8 t) where

261

314

262

315

263-- COMPARE

316-- COMPARE

264−--

265−-- TODO: is it fine to sort by length and only compare bytes on length ties?

266−--

267

317

318+

268−instance Ord (Utf8 t) where

319+instance Ord (Utf8 l t) where

269 compare (Utf8 ba1#) (Utf8 ba2#) =

320 compare (Utf8 ba1#) (Utf8 ba2#) =

270 let

321 let

271 !len1# = sizeofByteArray# ba1#

322 !len1# = sizeofByteArray# ba1#

@@ -282,20 +333,84 @@ instance Ord (Utf8 t) where

282

333

283

334

284

335

336+-- TO WORD16

337+

338+

339+toWord16 :: String -> Maybe Word16

340+toWord16 (Utf8 ba#) =

341+ let !len# = sizeofByteArray# ba# in

342+ if isTrue# (len# ==# 0#) then

343+ Nothing

344+ else

345+ let !w# = indexWord8Array# ba# 0# in

346+ if isTrue# (eqWord# w# 0x30##) then

347+ if isTrue# (len# ==# 1#) then Just 0 else Nothing

348+ else

349+ toWordHelp ba# 0# len# 0##

350+

351+

352+toWordHelp :: ByteArray# -> Int# -> Int# -> Word# -> Maybe Word16

353+toWordHelp ba# offset# len# number# =

354+ if isTrue# (offset# <# len#) then

355+ let !w# = indexWord8Array# ba# offset# in

356+ if isTrue# (leWord# w# 0x39##) && isTrue# (geWord# w# 0x30##) then

357+ let !newNumber# = plusWord# (timesWord# 10## number#) (minusWord# w# 0x30##) in

358+ toWordHelp ba# (offset# +# 1#) len# newNumber#

359+ else

360+ Nothing

361+ else

362+ Just (W16# number#)

363+

364+

365+

366+-- FROM WORD16

367+

368+

369+fromWord16 :: Word16 -> String

370+fromWord16 n =

371+ runST $

372+ do let !size = getWordSize n

373+ mba <- newByteArray size

374+ writeDigits mba (size - 1) n

375+ freeze mba

376+

377+

378+getWordSize :: Word16 -> Int

379+getWordSize n

380+ | n < 10 = 1

381+ | n < 100 = 2

382+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

383+

384+

385+writeDigits :: MBA s -> Int -> Word16 -> ST s ()

386+writeDigits !mba !offset !n =

387+ do let (q,r) = quotRem n 10

388+ writeWord8 mba offset (0x30 + fromIntegral r)

389+ if q <= 0

390+ then return ()

391+ else writeDigits mba (offset-1) q

392+

393+

394+

285-- FROM STRING

395-- FROM STRING

286

396

287

397

288−fromChars :: [Char] -> Utf8 t

398+fromChars :: [Char] -> Utf8 l t

289−fromChars chars =

399+fromChars =

290− runST

400+ fromString

291− (

401+

292− do mba <- newByteArray (sum (map getWidth chars))

293− writeChars mba 0 chars

294− )

295

402

403+instance IsString (Utf8 l t) where

404+ fromString str =

405+ runST

406+ (

407+ do mba <- newByteArray (sum (map getWidth str))

408+ writeString mba 0 str

409+ )

296

410

411+

297−writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)

412+writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)

298−writeChars !mba !offset chars =

413+writeString !mba !offset chars =

299 case chars of

414 case chars of

300 [] ->

415 [] ->

301 freeze mba

416 freeze mba

@@ -303,25 +418,25 @@ writeChars !mba !offset chars =

303 char : chars

418 char : chars

304 | n < 0x80 ->

419 | n < 0x80 ->

305 do writeWord8 mba (offset ) (fromIntegral n)

420 do writeWord8 mba (offset ) (fromIntegral n)

306− writeChars mba (offset + 1) chars

421+ writeString mba (offset + 1) chars

307

422

308 | n < 0x800 ->

423 | n < 0x800 ->

309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

424 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

425 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

311− writeChars mba (offset + 2) chars

426+ writeString mba (offset + 2) chars

312

427

313 | n < 0x10000 ->

428 | n < 0x10000 ->

314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

429 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

430 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

431 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

317− writeChars mba (offset + 3) chars

432+ writeString mba (offset + 3) chars

318

433

319 | otherwise ->

434 | otherwise ->

320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

435 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

436 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

437 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

438 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

324− writeChars mba (offset + 4) chars

439+ writeString mba (offset + 4) chars

325

440

326 where

441 where

327 n = Char.ord char

442 n = Char.ord char

@@ -339,10 +454,10 @@ getWidth char

339

454

340

455

341

456

342−-- TO CHARS

457+-- TO STRING

343

458

344

459

345−toChars :: Utf8 t -> [Char]

460+toChars :: Utf8 l t -> [Char]

346toChars (Utf8 ba#) =

461toChars (Utf8 ba#) =

347 toCharsHelp ba# 0# (sizeofByteArray# ba#)

462 toCharsHelp ba# 0# (sizeofByteArray# ba#)

348

463

@@ -412,13 +527,13 @@ chr4 ba# offset# firstWord# =

412

527

413

528

414{-# INLINE toBuilder #-}

529{-# INLINE toBuilder #-}

415−toBuilder :: Utf8 t -> B.Builder

530+toBuilder :: Utf8 l t -> B.Builder

416toBuilder =

531toBuilder =

417 \bytes -> B.builder (toBuilderHelp bytes)

532 \bytes -> B.builder (toBuilderHelp bytes)

418

533

419

534

420{-# INLINE toBuilderHelp #-}

535{-# INLINE toBuilderHelp #-}

421−toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a

536+toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a

422toBuilderHelp !bytes@(Utf8 ba#) k =

537toBuilderHelp !bytes@(Utf8 ba#) k =

423 go 0 (I# (sizeofByteArray# ba#))

538 go 0 (I# (sizeofByteArray# ba#))

424 where

539 where

@@ -438,57 +553,10 @@ toBuilderHelp !bytes@(Utf8 ba#) k =

438

553

439

554

440

555

441−-- TO ESCAPED BUILDER

442−

443−

444−{-# INLINE toEscapedBuilder #-}

445−toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder

446−toEscapedBuilder before after =

447− \name -> B.builder (toEscapedBuilderHelp before after name)

448−

449−

450−{-# INLINE toEscapedBuilderHelp #-}

451−toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a

452−toEscapedBuilderHelp before after !name@(Utf8 ba#) k =

453− go 0 (I# (sizeofByteArray# ba#))

454− where

455− go !offset !len !(B.BufferRange bOffset bEnd) =

456− let

457− !bLen = minusPtr bEnd bOffset

458− in

459− if len <= bLen then

460− do -- PERF test if writing word-by-word is faster

461− copyToPtr name offset bOffset len

462− escape before after bOffset name offset len 0

463− let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd

464− k newBufferRange

465− else

466− do copyToPtr name offset bOffset bLen

467− escape before after bOffset name offset bLen 0

468− let !newOffset = offset + bLen

469− let !newLength = len - bLen

470− return $ B.bufferFull 1 bEnd (go newOffset newLength)

471−

472−

473−escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()

474−escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =

475− if isTrue# (i# <# len#) then

476− if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))

477− then

478− do writeWordToPtr ptr i after

479− escape before after ptr name offset len (i + 1)

480− else

481− do escape before after ptr name offset len (i + 1)

482−

483− else

484− return ()

485−

486−

487−

488-- FROM PTR

556-- FROM PTR

489

557

490

558

491−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t

559+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t

492fromPtr pos end =

560fromPtr pos end =

493 unsafeDupablePerformIO (stToIO (

561 unsafeDupablePerformIO (stToIO (

494 do let !len = minusPtr end pos

562 do let !len = minusPtr end pos

@@ -499,48 +567,130 @@ fromPtr pos end =

499

567

500

568

501

569

502−-- FROM SNIPPET

570+-- FROM CHUNKS

503

571

504

572

505−fromSnippet :: P.Snippet -> Utf8 t

573+data Chunk

506−fromSnippet (P.Snippet fptr off len _ _) =

574+ = Slice (Ptr Word8) Int

575+ | Escape Word8

576+ | CodePoint Int

577+

578+

579+fromChunks :: [Chunk] -> Utf8 l t

580+fromChunks chunks =

507 unsafeDupablePerformIO (stToIO (

581 unsafeDupablePerformIO (stToIO (

508− do mba <- newByteArray len

582+ do let !len = sum (map chunkToWidth chunks)

509− let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off

583+ mba <- newByteArray len

510− copyFromPtr pos mba 0 len

584+ writeChunks mba 0 chunks

511 freeze mba

585 freeze mba

512 ))

586 ))

513

587

514

588

589+chunkToWidth :: Chunk -> Int

590+chunkToWidth chunk =

591+ case chunk of

592+ Slice _ len ->

593+ len

594+

595+ Escape _ ->

596+ 2

597+

598+ CodePoint code ->

599+ if code < 0xFFFF then 6 else 12

600+

601+

602+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

603+writeChunks mba offset chunks =

604+ case chunks of

605+ [] ->

606+ return ()

607+

608+ chunk : chunks ->

609+ case chunk of

610+ Slice ptr len ->

611+ do copyFromPtr ptr mba offset len

612+ let !newOffset = offset + len

613+ writeChunks mba newOffset chunks

614+

615+ Escape word ->

616+ do writeWord8 mba offset 0x5C {- \ -}

617+ writeWord8 mba (offset + 1) word

618+ let !newOffset = offset + 2

619+ writeChunks mba newOffset chunks

620+

621+ CodePoint code ->

622+ if code < 0xFFFF then

623+ do writeCode mba offset code

624+ let !newOffset = offset + 6

625+ writeChunks mba newOffset chunks

626+ else

627+ do let (hi,lo) = divMod (code - 0x10000) 0x400

628+ writeCode mba (offset ) (hi + 0xD800)

629+ writeCode mba (offset + 6) (lo + 0xDC00)

630+ let !newOffset = offset + 12

631+ writeChunks mba newOffset chunks

632+

633+

634+-- TODO see if it is faster to writeWord32 a block of hex-as-ascii

635+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

636+writeCode mba offset code =

637+ do writeWord8 mba offset 0x5C {- \ -}

638+ writeWord8 mba offset 0x75 {- u -}

639+ writeHex mba (offset + 2) (shiftR code 12)

640+ writeHex mba (offset + 3) (shiftR code 8)

641+ writeHex mba (offset + 4) (shiftR code 4)

642+ writeHex mba (offset + 5) code

643+

644+

645+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

646+writeHex mba !offset !bits =

647+ do let !n = fromIntegral bits .&. 0x0F

648+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)

515

649

516−-- BINARY

517

650

518

651

519−putUnder256 :: Utf8 t -> Put

652+-- UNDER 256 BINARY

520−putUnder256 bytes =

521− do putWord8 (fromIntegral (size bytes))

522− putBuilder (toBuilder bytes)

523

653

524

654

525−getUnder256 :: Get (Utf8 t)

655+instance Binary (Utf8 UNDER_256 t) where

526−getUnder256 =

656+ put bytes@(Utf8 ba#) =

657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))

658+ putBuilder (toBuilder bytes)

659+ get =

527− do word <- getWord8

660+ getUnder256 =<< getWord8

528− let !n = fromIntegral word

529− readN n (copyFromByteString n)

530

661

531

662

532−putVeryLong :: Utf8 t -> Put

663+{-# INLINE getUnder256 #-}

533−putVeryLong bytes =

664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)

534− do put (size bytes)

665+getUnder256 w =

535− putBuilder (toBuilder bytes)

666+ let !n = fromIntegral w in

667+ readN n (copyFromByteString n)

536

668

537

669

670+

671+-- VERY LONG BINARY

672+

673+

674+instance Binary (Utf8 VERY_LONG t) where

675+ put str =

676+ do put (size str)

677+ putBuilder (toBuilder str)

678+ get =

538−getVeryLong :: Get (Utf8 t)

679+ getVeryLong =<< get

680+

681+

682+{-# INLINE getVeryLong #-}

683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)

539−getVeryLong =

684+getVeryLong n =

540− do n <- get

541− if n > 0

685+ if n > 0

542− then readN n (copyFromByteString n)

686+ then readN n (copyFromByteString n)

543− else return empty

687+ else return empty

688+

689+

690+{-# NOINLINE empty #-}

691+empty :: Utf8 l t

692+empty =

693+ runST (freeze =<< newByteArray 0)

544

694

545

695

546

696

@@ -548,7 +698,7 @@ getVeryLong =

548

698

549

699

550{-# INLINE copyFromByteString #-}

700{-# INLINE copyFromByteString #-}

551−copyFromByteString :: Int -> B.ByteString -> Utf8 t

701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t

552copyFromByteString len (B.PS fptr offset _) =

702copyFromByteString len (B.PS fptr offset _) =

553 unsafeDupablePerformIO

703 unsafeDupablePerformIO

554 (

704 (

@@ -567,21 +717,21 @@ data MBA s =

567 MBA# (MutableByteArray# s)

717 MBA# (MutableByteArray# s)

568

718

569

719

570−newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive

720+newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive

571newByteArray (I# len#) =

721newByteArray (I# len#) =

572 ST $ \s ->

722 ST $ \s ->

573 case newByteArray# len# s of

723 case newByteArray# len# s of

574 (# s, mba# #) -> (# s, MBA# mba# #)

724 (# s, mba# #) -> (# s, MBA# mba# #)

575

725

576

726

577−freeze :: MBA s -> ST s (Utf8 t)

727+freeze :: MBA s -> ST s (Utf8 l t)

578freeze (MBA# mba#) =

728freeze (MBA# mba#) =

579 ST $ \s ->

729 ST $ \s ->

580 case unsafeFreezeByteArray# mba# s of

730 case unsafeFreezeByteArray# mba# s of

581 (# s, ba# #) -> (# s, Utf8 ba# #)

731 (# s, ba# #) -> (# s, Utf8 ba# #)

582

732

583

733

584−copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()

734+copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()

585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

735copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

586 ST $ \s ->

736 ST $ \s ->

587 case copyByteArray# ba# offset# mba# i# len# s of

737 case copyByteArray# ba# offset# mba# i# len# s of

@@ -595,11 +745,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =

595 s -> (# s, () #)

745 s -> (# s, () #)

596

746

597

747

598−copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()

748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()

599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

600− IO $ \s ->

750+ IO $ \s ->

601− case copyByteArrayToAddr# ba# offset# mba# len# s of

751+ case copyByteArrayToAddr# ba# offset# mba# len# s of

602− s -> (# s, () #)

752+ s -> (# s, () #)

603

753

604

754

605{-# INLINE writeWord8 #-}

755{-# INLINE writeWord8 #-}

@@ -608,11 +758,3 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

608 ST $ \s ->

758 ST $ \s ->

609 case writeWord8Array# mba# offset# w# s of

759 case writeWord8Array# mba# offset# w# s of

610 s -> (# s, () #)

760 s -> (# s, () #)

611−

612−

613−{-# INLINE writeWordToPtr #-}

614−writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()

615−writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =

616− IO $ \s ->

617− case writeWord8OffAddr# addr# offset# word# s of

618− s -> (# s, () #)

compiler/src/Elm/Compiler.hsnew file+99

@@ -0,0 +1,99 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Elm.Compiler

3+ ( Compile.Artifacts(..)

4+ , compile

5+ , Error.Error

6+ , errorsToDoc

7+ , errorsToJson

8+ , Warning.Warning

9+ )

10+ where

11+

12+

13+import qualified Data.ByteString as BS

14+import qualified Data.Map as Map

15+import qualified Data.Name as Name

16+import qualified Data.Utf8 as Utf8

17+

18+import qualified Compile

19+import qualified Elm.Interface as I

20+import qualified Elm.ModuleName as ModuleName

21+import qualified Elm.Package as Pkg

22+import qualified Json.Encode as E

23+import Json.Encode ((==>))

24+import qualified Reporting.Annotation as A

25+import qualified Reporting.Doc as D

26+import qualified Reporting.Error as Error

27+import qualified Reporting.Render.Code as Code

28+import qualified Reporting.Report as Report

29+import qualified Reporting.Result as Result

30+import qualified Reporting.Warning as Warning

31+

32+

33+

34+-- COMPILE

35+

36+

37+compile

38+ :: Pkg.Name

39+ -> Map.Map ModuleName.Raw ModuleName.Canonical

40+ -> I.Interfaces

41+ -> BS.ByteString

42+ -> ( [Warning.Warning], Either [Error.Error] Compile.Artifacts )

43+compile pkg importDict interfaces source =

44+ Result.run $ Compile.compile pkg importDict interfaces source

45+

46+

47+

48+-- ERRORS TO DOC

49+

50+

51+errorsToDoc :: FilePath -> String -> [Error.Error] -> D.Doc

52+errorsToDoc filePath source errors =

53+ let

54+ reports =

55+ concatMap (Error.toReports (Code.toSource source)) errors

56+ in

57+ D.vcat $ map (Report.toDoc filePath) reports

58+

59+

60+

61+-- ERRORS TO JSON

62+

63+

64+errorsToJson :: ModuleName.Raw -> FilePath -> String -> [Error.Error] -> E.Value

65+errorsToJson moduleName filePath source errors =

66+ let

67+ reports =

68+ concatMap (Error.toReports (Code.toSource source)) errors

69+ in

70+ E.object

71+ [ "path" ==> E.string (Utf8.fromChars filePath)

72+ , "name" ==> E.string (Name.toUtf8 moduleName)

73+ , "problems" ==> E.array (map reportToJson reports)

74+ ]

75+

76+

77+reportToJson :: Report.Report -> E.Value

78+reportToJson (Report.Report title region _sgstns message) =

79+ E.object

80+ [ "title" ==> E.string (Utf8.fromChars title)

81+ , "region" ==> encodeRegion region

82+ , "message" ==> D.encode message

83+ ]

84+

85+

86+encodeRegion :: A.Region -> E.Value

87+encodeRegion (A.Region (A.Position sr sc) (A.Position er ec)) =

88+ E.object

89+ [ "start" ==>

90+ E.object

91+ [ ("line", E.int (fromIntegral sr))

92+ , ("column", E.int (fromIntegral sc))

93+ ]

94+ , "end" ==>

95+ E.object

96+ [ ("line", E.int (fromIntegral er))

97+ , ("column", E.int (fromIntegral ec))

98+ ]

99+ ]

compiler/src/Elm/Compiler/Imports.hs+13−4

@@ -1,7 +1,7 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module Elm.Compiler.Imports

4− ( defaults

4+ ( addDefaults

5 )

6 where

7

@@ -14,6 +14,15 @@ import qualified Reporting.Annotation as A

14

15

16

17+-- ADD DEFAULTS

18+

19+

20+addDefaults :: [Src.Import] -> [Src.Import]

21+addDefaults imports =

22+ defaults ++ imports

23+

24+

25+

17-- DEFAULTS

26-- DEFAULTS

18

27

19

28

@@ -49,14 +58,14 @@ closed =

49

58

50typeOpen :: Name.Name -> Src.Exposing

59typeOpen :: Name.Name -> Src.Exposing

51typeOpen name =

60typeOpen name =

52− Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]

61+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]

53

62

54

63

55typeClosed :: Name.Name -> Src.Exposing

64typeClosed :: Name.Name -> Src.Exposing

56typeClosed name =

65typeClosed name =

57− Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]

66+ Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]

58

67

59

68

60operator :: Name.Name -> Src.Exposing

69operator :: Name.Name -> Src.Exposing

61operator op =

70operator op =

62− Src.Explicit [ Src.Operator A.zero op ]

71+ Src.Explicit [ A.At A.zero (Src.Operator op) ]

compiler/src/Elm/Compiler/Type.hs+27−26

@@ -15,12 +15,9 @@ module Elm.Compiler.Type

15

16

17import qualified Data.Name as Name

18+import qualified Data.Utf8 as Utf8

18

19

19import qualified AST.Source as Src

20import 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

24import qualified Parse.Primitives as P

21import qualified Parse.Primitives as P

25import qualified Parse.Type as Type

22import qualified Parse.Type as Type

26import qualified Reporting.Annotation as A

23import qualified Reporting.Annotation as A

@@ -28,6 +25,10 @@ import qualified Reporting.Doc as D

28import qualified Reporting.Render.Type as RT

25import qualified Reporting.Render.Type as RT

29import qualified Reporting.Render.Type.Localizer as L

26import qualified Reporting.Render.Type.Localizer as L

30

27

28+import qualified Json.Decode as D

29+import qualified Json.Encode as E

30+import Json.Encode ((==>))

31+

31

32

33

33-- TYPES

34-- TYPES

@@ -113,16 +114,18 @@ collectLambdas tipe =

113

114

114encode :: Type -> E.Value

115encode :: Type -> E.Value

115encode tipe =

116encode tipe =

116− E.chars $ D.toLine (toDoc L.empty RT.None tipe)

117+ E.string $ Utf8.fromChars $ D.toLine (toDoc L.empty RT.None tipe)

117

118

119

119decoder :: D.Decoder () Type

120decoder :: D.Decoder () Type

120decoder =

121decoder =

121− let

122+ do str <- D.string

122− parser =

123+ case P.fromByteString Type.expression (error "TODO turn Utf8 to something that can be parsed" str) of

123− P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)

124+ P.Ok (tipe, _, _) _ ->

124− in

125+ return (fromRawType tipe)

125− D.customString parser (\_ _ -> ())

126+

127+ P.Err _ _ _ _ ->

128+ D.failure ()

126

129

127

130

128fromRawType :: Src.Type -> Type

131fromRawType :: Src.Type -> Type

@@ -164,31 +167,29 @@ encodeMetadata :: DebugMetadata -> E.Value

164encodeMetadata (DebugMetadata msg aliases unions) =

167encodeMetadata (DebugMetadata msg aliases unions) =

165 E.object

168 E.object

166 [ "message" ==> encode msg

169 [ "message" ==> encode msg

167− , "aliases" ==> E.object (map toTypeAliasField aliases)

170+ , "aliases" ==> E.object (map toAliasField aliases)

168− , "unions" ==> E.object (map toCustomTypeField unions)

171+ , "unions" ==> E.object (map toUnionField unions)

169 ]

172 ]

170

173

171

174

172−toTypeAliasField :: Alias -> ( Json.String, E.Value )

175+toAliasField :: Alias -> ( Utf8.String, E.Value )

173−toTypeAliasField (Alias name args tipe) =

176+toAliasField (Alias name args tipe) =

174− ( Json.fromName name

177+ Name.toUtf8 name ==>

175− , E.object

178+ E.object

176 [ "args" ==> E.list E.name args

179 [ "args" ==> E.list E.name args

177 , "type" ==> encode tipe

180 , "type" ==> encode tipe

178 ]

181 ]

179− )

180

182

181

183

182−toCustomTypeField :: Union -> ( Json.String, E.Value )

184+toUnionField :: Union -> ( Utf8.String, E.Value )

183−toCustomTypeField (Union name args constructors) =

185+toUnionField (Union name args constructors) =

184− ( Json.fromName name

186+ Name.toUtf8 name ==>

185− , E.object

187+ E.object

186 [ "args" ==> E.list E.name args

188 [ "args" ==> E.list E.name args

187− , "tags" ==> E.object (map toVariantObject constructors)

189+ , "tags" ==> E.object (map toCtorObject constructors)

188 ]

190 ]

189− )

190

191

192

192−toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )

193+toCtorObject :: (Name.Name, [Type]) -> ( Utf8.String, E.Value )

193−toVariantObject (name, args) =

194+toCtorObject (name, args) =

194− ( Json.fromName name, E.list encode args )

195+ Name.toUtf8 name ==> E.list encode args

compiler/src/Elm/Compiler/Type/Extract.hs+1−1

@@ -87,7 +87,7 @@ toPublicName (ModuleName.Canonical _ home) name =

87

88newtype Types =

89 Types (Map.Map ModuleName.Canonical Types_)

90− -- PERF profile Opt.Global representation

90+ -- TODO profile Opt.Global representation

91 -- current representation needs less allocation

92 -- but maybe the lookup is much worse

93

compiler/src/Elm/Constraint.hs+77−55

@@ -5,6 +5,9 @@ module Elm.Constraint

5 , exactly

6 , anything

7 , toChars

8+ , toString

9+ , Error(..)

10+ , fromString

8 , satisfies

11 , satisfies

9 , check

12 , check

10 , intersect

13 , intersect

@@ -13,8 +16,6 @@ module Elm.Constraint

13 , untilNextMajor

16 , untilNextMajor

14 , untilNextMinor

17 , untilNextMinor

15 , expand

18 , expand

16− --

17− , Error(..)

18 , decoder

19 , decoder

19 , encode

20 , encode

20 )

21 )

@@ -23,12 +24,11 @@ module Elm.Constraint

23

24

24import Control.Monad (liftM4)

25import Control.Monad (liftM4)

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

26import Data.Binary (Binary, get, put, getWord8, putWord8)

27+import qualified Data.Utf8 as Utf8

26

28

27import qualified Elm.Version as V

29import qualified Elm.Version as V

28import qualified Json.Decode as D

30import qualified Json.Decode as D

29import qualified Json.Encode as E

31import qualified Json.Encode as E

30−import qualified Parse.Primitives as P

31−import Parse.Primitives (Row, Col)

32

33

34

@@ -61,21 +61,78 @@ anything =

61

62

63

64−-- TO CHARS

64+-- TO STRING

65

66

67−toChars :: Constraint -> [Char]

67+toChars :: Constraint -> String

68toChars constraint =

69+ Utf8.toChars (toString constraint)

70+

71+

72+toString :: Constraint -> Utf8.String

73+toString constraint =

69 case constraint of

74 case constraint of

70 Range lower lowerOp upperOp upper ->

75 Range lower lowerOp upperOp upper ->

71− V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper

76+ Utf8.join 0x20 {- -}

77+ [ V.toString lower

78+ , toStringHelp lowerOp

79+ , "v"

80+ , toStringHelp upperOp

81+ , V.toString upper

82+ ]

72

83

73

84

74−opToChars :: Op -> [Char]

85+toStringHelp :: Op -> Utf8.String

75−opToChars op =

86+toStringHelp op =

76 case op of

87 case op of

77− Less -> " < "

88+ Less -> "<"

78− LessOrEqual -> " <= "

89+ LessOrEqual -> "<="

90+

91+

92+

93+-- FROM STRING

94+

95+

96+data Error

97+ = BadLower Utf8.String

98+ | BadUpper Utf8.String

99+ | BadFormat

100+ | InvalidOp

101+ | InvalidRange V.Version V.Version

102+

103+

104+fromString :: Utf8.String -> Either Error Constraint

105+fromString string =

106+ case Utf8.split 0x20 {- -} string of

107+ [lower, lowerOp, "v", upperOp, upper] ->

108+ do lo <- versionFromString lower BadLower

109+ lop <- opFromString lowerOp

110+ hop <- opFromString upperOp

111+ hi <- versionFromString upper BadUpper

112+ if lo < hi

113+ then Right (Range lo lop hop hi)

114+ else Left (InvalidRange lo hi)

115+

116+ _ ->

117+ Left BadFormat

118+

119+

120+versionFromString :: Utf8.String -> (Utf8.String -> Error) -> Either Error V.Version

121+versionFromString string toError =

122+ case V.fromString string of

123+ Just vsn ->

124+ Right vsn

125+

126+ Nothing ->

127+ Left (toError string)

128+

129+

130+opFromString :: Utf8.String -> Either Error Op

131+opFromString text =

132+ case text of

133+ "<=" -> Right LessOrEqual

134+ "<" -> Right Less

135+ _ -> Left InvalidOp

79

136

80

137

81

138

@@ -188,12 +245,18 @@ expand constraint@(Range lower lowerOp upperOp upper) version

188

245

189encode :: Constraint -> E.Value

246encode :: Constraint -> E.Value

190encode constraint =

247encode constraint =

191− E.chars (toChars constraint)

248+ E.string (toString constraint)

192

249

193

250

194decoder :: D.Decoder Error Constraint

251decoder :: D.Decoder Error Constraint

195decoder =

252decoder =

196− D.customString parser BadFormat

253+ do str <- D.string

254+ case fromString str of

255+ Right constraint ->

256+ return constraint

257+

258+ Left err ->

259+ D.failure err

197

260

198

261

199

262

@@ -216,45 +279,4 @@ instance Binary Op where

216 case n of

279 case n of

217 0 -> return Less

280 0 -> return Less

218 1 -> return LessOrEqual

281 1 -> return LessOrEqual

219− _ -> fail "binary encoding of Op was corrupted"

282+ _ -> error "binary encoding of Op was corrupted"

220−

221−

222−

223−-- PARSER

224−

225−

226−data Error

227− = BadFormat Row Col

228− | InvalidRange V.Version V.Version

229−

230−

231−parser :: P.Parser Error Constraint

232−parser =

233− do lower <- parseVersion

234− P.word1 0x20 {- -} BadFormat

235− loOp <- parseOp

236− P.word1 0x20 {- -} BadFormat

237− P.word1 0x76 {-v-} BadFormat

238− P.word1 0x20 {- -} BadFormat

239− hiOp <- parseOp

240− P.word1 0x20 {- -} BadFormat

241− higher <- parseVersion

242− P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->

243− if lower < higher

244− then eok (Range lower loOp hiOp higher) state

245− else eerr row col (\_ _ -> InvalidRange lower higher)

246−

247−

248−parseVersion :: P.Parser Error V.Version

249−parseVersion =

250− P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser

251−

252−

253−parseOp :: P.Parser Error Op

254−parseOp =

255− do P.word1 0x3C {-<-} BadFormat

256− P.oneOfWithFallback

257− [ do P.word1 0x3D {-=-} BadFormat

258− return LessOrEqual

259− ]

260− Less

compiler/src/Elm/Docs.hs+158−218

@@ -1,7 +1,8 @@

1{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}

2+{-# LANGUAGE OverloadedStrings #-}

3module Elm.Docs

4 ( Documentation

5+ , toDict

5 , Module(..)

6 , Module(..)

6 , fromModule

7 , fromModule

7 , Union(..)

8 , Union(..)

@@ -17,35 +18,33 @@ module Elm.Docs

17 where

18 where

18

19

20

20−import qualified Data.Coerce as Coerce

21+import qualified Data.ByteString as B

21import qualified Data.List as List

22import qualified Data.List as List

22import Data.Map ((!))

23import Data.Map ((!))

23import qualified Data.Map as Map

24import qualified Data.Map as Map

24−import qualified Data.Map.Merge.Strict as Map

25import qualified Data.Name as Name

26−import qualified Data.NonEmptyList as NE

26+import qualified Data.Text as Text

27−import qualified Data.OneOrMore as OneOrMore

27+import qualified Data.Text.Encoding as Text

28−import Data.Word (Word8)

29−import Foreign.Ptr (Ptr, plusPtr)

30

28

31import qualified AST.Canonical as Can

29import qualified AST.Canonical as Can

32−import qualified AST.Source as Src

33import qualified AST.Utils.Binop as Binop

30import qualified AST.Utils.Binop as Binop

31+import qualified Data.OneOrMore as OneOrMore

34import qualified Elm.Compiler.Type as Type

32import qualified Elm.Compiler.Type as Type

35import qualified Elm.Compiler.Type.Extract as Extract

33import qualified Elm.Compiler.Type.Extract as Extract

36import qualified Elm.ModuleName as ModuleName

34import qualified Elm.ModuleName as ModuleName

37import qualified Json.Decode as D

35import qualified Json.Decode as D

38import qualified Json.Encode as E

36import qualified Json.Encode as E

39import Json.Encode ((==>))

37import Json.Encode ((==>))

40−import qualified Json.String as Json

41−import Parse.Primitives (Row, Col, word1)

42−import qualified Parse.Primitives as P

43−import qualified Parse.Space as Space

44−import qualified Parse.Symbol as Symbol

45−import qualified Parse.Variable as Var

46import qualified Reporting.Annotation as A

38import qualified Reporting.Annotation as A

39+import qualified Reporting.Error as Error

47import qualified Reporting.Error.Docs as E

40import qualified Reporting.Error.Docs as E

41+import qualified Reporting.Region as R

48import qualified Reporting.Result as Result

42import qualified Reporting.Result as Result

43+import Parse.Primitives (Parser)

44+import qualified Parse.Primitives as P

45+import qualified Parse.Primitives.Symbol as Symbol

46+import qualified Parse.Primitives.Variable as Var

47+import qualified Parse.Primitives.Whitespace as W

49

48

50

49

51

50

@@ -56,6 +55,21 @@ type Documentation =

56 Map.Map Name.Name Module

55 Map.Map Name.Name Module

57

56

58

57

58+toDict :: [Module] -> Documentation

59+toDict modules =

60+ Map.fromList (map toPair modules)

61+

62+

63+

64+toPair :: Module -> (Name.Name, Module)

65+toPair modul@(Module name _ _ _ _ _) =

66+ (name, modul)

67+

68+

69+

70+-- MODULES

71+

72+

59data Module =

73data Module =

60 Module

74 Module

61 { _name :: Name.Name

75 { _name :: Name.Name

@@ -66,7 +80,9 @@ data Module =

66 , _binops :: Map.Map Name.Name Binop

80 , _binops :: Map.Map Name.Name Binop

67 }

81 }

68

82

83+

69−type Comment = Json.String

84+type Comment = Text.Text

85+

70

86

71data Alias = Alias Comment [Name.Name] Type.Type

87data Alias = Alias Comment [Name.Name] Type.Type

72data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]

88data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]

@@ -75,19 +91,14 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence

75

91

76

92

77

93

78−-- JSON

94+-- JSON ENCODE / DECODE

79−

80−

81−encode :: Documentation -> E.Value

82−encode docs =

83− E.list encodeModule (Map.elems docs)

84

95

85

96

86−encodeModule :: Module -> E.Value

97+encode :: Module -> E.Value

87−encodeModule (Module name comment unions aliases values binops) =

98+encode (Module name comment unions aliases values binops) =

88 E.object $

99 E.object $

89 [ "name" ==> ModuleName.encode name

100 [ "name" ==> ModuleName.encode name

90− , "comment" ==> E.string comment

101+ , "comment" ==> E.text comment

91 , "unions" ==> E.list encodeUnion (Map.toList unions)

102 , "unions" ==> E.list encodeUnion (Map.toList unions)

92 , "aliases" ==> E.list encodeAlias (Map.toList aliases)

103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)

93 , "values" ==> E.list encodeValue (Map.toList values)

104 , "values" ==> E.list encodeValue (Map.toList values)

@@ -96,31 +107,16 @@ encodeModule (Module name comment unions aliases values binops) =

96

107

97

108

98data Error

109data Error

99− = BadAssociativity

110+ = BadAssociativity Text.Text

100− | BadModuleName

111+ | BadName

101 | BadType

112 | BadType

102

113

103

114

104−decoder :: D.Decoder Error Documentation

115+decoder :: D.Decoder Error Module

105decoder =

116decoder =

106− toDict <$> D.list moduleDecoder

107−

108−

109−toDict :: [Module] -> Documentation

110−toDict modules =

111− Map.fromList (map toDictHelp modules)

112−

113−

114−toDictHelp :: Module -> (Name.Name, Module)

115−toDictHelp modul@(Module name _ _ _ _ _) =

116− (name, modul)

117−

118−

119−moduleDecoder :: D.Decoder Error Module

120−moduleDecoder =

121 Module

117 Module

122− <$> D.field "name" moduleNameDecoder

118+ <$> D.field "name" nameDecoder

123− <*> D.field "comment" D.string

119+ <*> D.field "comment" D.text

124 <*> D.field "unions" (dictDecoder union)

120 <*> D.field "unions" (dictDecoder union)

125 <*> D.field "aliases" (dictDecoder alias)

121 <*> D.field "aliases" (dictDecoder alias)

126 <*> D.field "values" (dictDecoder value)

122 <*> D.field "values" (dictDecoder value)

@@ -135,18 +131,13 @@ dictDecoder entryDecoder =

135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)

131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)

136named entryDecoder =

132named entryDecoder =

137 (,)

133 (,)

138− <$> D.field "name" nameDecoder

134+ <$> D.field "name" D.name

139 <*> entryDecoder

135 <*> entryDecoder

140

136

141

137

142−nameDecoder :: D.Decoder e Name.Name

138+nameDecoder :: D.Decoder Error Name.Name

143nameDecoder =

139nameDecoder =

144− fmap Coerce.coerce D.string

145−

146−

147−moduleNameDecoder :: D.Decoder Error ModuleName.Raw

148−moduleNameDecoder =

149− D.mapError (const BadModuleName) ModuleName.decoder

140+ D.mapError (const BadName) ModuleName.decoder

150

141

151

142

152typeDecoder :: D.Decoder Error Type.Type

143typeDecoder :: D.Decoder Error Type.Type

@@ -162,7 +153,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value

162encodeUnion (name, Union comment args cases) =

153encodeUnion (name, Union comment args cases) =

163 E.object

154 E.object

164 [ "name" ==> E.name name

155 [ "name" ==> E.name name

165− , "comment" ==> E.string comment

156+ , "comment" ==> E.text comment

166 , "args" ==> E.list E.name args

157 , "args" ==> E.list E.name args

167 , "cases" ==> E.list encodeCase cases

158 , "cases" ==> E.list encodeCase cases

168 ]

159 ]

@@ -171,8 +162,8 @@ encodeUnion (name, Union comment args cases) =

171union :: D.Decoder Error Union

162union :: D.Decoder Error Union

172union =

163union =

173 Union

164 Union

174− <$> D.field "comment" D.string

165+ <$> D.field "comment" D.text

175− <*> D.field "args" (D.list nameDecoder)

166+ <*> D.field "args" (D.list D.name)

176 <*> D.field "cases" (D.list caseDecoder)

167 <*> D.field "cases" (D.list caseDecoder)

177

168

178

169

@@ -183,7 +174,7 @@ encodeCase ( tag, args ) =

183

174

184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )

175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )

185caseDecoder =

176caseDecoder =

186− D.pair nameDecoder (D.list typeDecoder)

177+ D.pair D.name (D.list typeDecoder)

187

178

188

179

189

180

@@ -194,7 +185,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value

194encodeAlias ( name, Alias comment args tipe) =

185encodeAlias ( name, Alias comment args tipe) =

195 E.object

186 E.object

196 [ "name" ==> E.name name

187 [ "name" ==> E.name name

197− , "comment" ==> E.string comment

188+ , "comment" ==> E.text comment

198 , "args" ==> E.list E.name args

189 , "args" ==> E.list E.name args

199 , "type" ==> Type.encode tipe

190 , "type" ==> Type.encode tipe

200 ]

191 ]

@@ -203,8 +194,8 @@ encodeAlias ( name, Alias comment args tipe) =

203alias :: D.Decoder Error Alias

194alias :: D.Decoder Error Alias

204alias =

195alias =

205 Alias

196 Alias

206− <$> D.field "comment" D.string

197+ <$> D.field "comment" D.text

207− <*> D.field "args" (D.list nameDecoder)

198+ <*> D.field "args" (D.list D.name)

208 <*> D.field "type" typeDecoder

199 <*> D.field "type" typeDecoder

209

200

210

201

@@ -216,7 +207,7 @@ encodeValue :: (Name.Name, Value) -> E.Value

216encodeValue (name, Value comment tipe) =

207encodeValue (name, Value comment tipe) =

217 E.object

208 E.object

218 [ "name" ==> E.name name

209 [ "name" ==> E.name name

219− , "comment" ==> E.string comment

210+ , "comment" ==> E.text comment

220 , "type" ==> Type.encode tipe

211 , "type" ==> Type.encode tipe

221 ]

212 ]

222

213

@@ -224,7 +215,7 @@ encodeValue (name, Value comment tipe) =

224value :: D.Decoder Error Value

215value :: D.Decoder Error Value

225value =

216value =

226 Value

217 Value

227− <$> D.field "comment" D.string

218+ <$> D.field "comment" D.text

228 <*> D.field "type" typeDecoder

219 <*> D.field "type" typeDecoder

229

220

230

221

@@ -236,7 +227,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value

236encodeBinop (name, Binop comment tipe assoc prec) =

227encodeBinop (name, Binop comment tipe assoc prec) =

237 E.object

228 E.object

238 [ "name" ==> E.name name

229 [ "name" ==> E.name name

239− , "comment" ==> E.string comment

230+ , "comment" ==> E.text comment

240 , "type" ==> Type.encode tipe

231 , "type" ==> Type.encode tipe

241 , "associativity" ==> encodeAssoc assoc

232 , "associativity" ==> encodeAssoc assoc

242 , "precedence" ==> encodePrec prec

233 , "precedence" ==> encodePrec prec

@@ -246,7 +237,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =

246binop :: D.Decoder Error Binop

237binop :: D.Decoder Error Binop

247binop =

238binop =

248 Binop

239 Binop

249− <$> D.field "comment" D.string

240+ <$> D.field "comment" D.text

250 <*> D.field "type" typeDecoder

241 <*> D.field "type" typeDecoder

251 <*> D.field "associativity" assocDecoder

242 <*> D.field "associativity" assocDecoder

252 <*> D.field "precedence" precDecoder

243 <*> D.field "precedence" precDecoder

@@ -259,23 +250,19 @@ binop =

259encodeAssoc :: Binop.Associativity -> E.Value

250encodeAssoc :: Binop.Associativity -> E.Value

260encodeAssoc assoc =

251encodeAssoc assoc =

261 case assoc of

252 case assoc of

262− Binop.Left -> E.chars "left"

253+ Binop.Left -> E.text "left"

263− Binop.Non -> E.chars "non"

254+ Binop.Non -> E.text "non"

264− Binop.Right -> E.chars "right"

255+ Binop.Right -> E.text "right"

265

256

266

257

267assocDecoder :: D.Decoder Error Binop.Associativity

258assocDecoder :: D.Decoder Error Binop.Associativity

268assocDecoder =

259assocDecoder =

269− let

260+ do txt <- D.text

270− left = Json.fromChars "left"

261+ case txt of

271− non = Json.fromChars "non"

272− right = Json.fromChars "right"

273− in

274− do str <- D.string

275− if | str == left -> return Binop.Left

262+ "left" -> D.succeed Binop.Left

276− | str == non -> return Binop.Non

263+ "non" -> D.succeed Binop.Non

277− | str == right -> return Binop.Right

264+ "right" -> D.succeed Binop.Right

278− | otherwise -> D.failure BadAssociativity

265+ _ -> D.fail (BadAssociativity txt)

279

266

280

267

281

268

@@ -296,190 +283,142 @@ precDecoder =

296-- FROM MODULE

283-- FROM MODULE

297

284

298

285

299−fromModule :: Can.Module -> Either E.Error Module

286+fromModule :: Can.Module -> Result.Result i w Error.Error Module

300−fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =

287+fromModule (Can.Module name docs exports decls unions aliases binops effects) =

301 case exports of

288 case exports of

302 Can.ExportEverything region ->

289 Can.ExportEverything region ->

303− Left (E.ImplicitExposing region)

290+ Result.throw $ Error.Docs $ E.ImplicitExposing region

304

291

305 Can.Export exportDict ->

292 Can.Export exportDict ->

306 case docs of

293 case docs of

307− Src.NoDocs region ->

294+ Can.NoDocs region ->

308− Left (E.NoDocs region)

295+ Result.throw $ Error.Docs $ E.NoDocs region

309

296

310− Src.YesDocs overview comments ->

297+ Can.YesDocs region overview comments ->

311− do names <- parseOverview overview

298+ do names <- parseOverview region overview

299+ Result.mapError Error.Docs $

312− checkNames exportDict names

300+ do checkNames exportDict names

313− checkDefs exportDict overview (Map.fromList comments) modul

301+ let types = gatherTypes decls Map.empty

302+ let info = Info comments types unions aliases binops effects

303+ inserters <- Map.traverseWithKey (checkExport info) exportDict

304+ return $ foldr ($) (emptyModule name overview) inserters

305+

306+

307+emptyModule :: ModuleName.Canonical -> B.ByteString -> Module

308+emptyModule (ModuleName.Canonical _ name) overview =

309+ Module name (Text.decodeUtf8 overview) Map.empty Map.empty Map.empty Map.empty

314

310

315

311

316

312

317-- PARSE OVERVIEW

313-- PARSE OVERVIEW

318

314

319

315

320−parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]

316+parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]

321−parseOverview (Src.Comment snippet) =

317+parseOverview (R.Region (R.Position row col) _) overview =

322− case P.fromSnippet (chompOverview []) E.BadEnd snippet of

318+ case P.runAt row (col + 3) (chompOverview []) overview of

323 Left err ->

319 Left err ->

324− Left (E.SyntaxProblem err)

320+ Result.throw (Error.Syntax err)

325

321

326 Right names ->

322 Right names ->

327− Right names

323+ Result.ok names

328−

329−

330−type Parser a =

331− P.Parser E.SyntaxProblem a

332

324

333

325

334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

335chompOverview names =

327chompOverview names =

336− do isDocs <- chompUntilDocs

328+ do isDocs <- W.chompUntilDocs

337 if isDocs

329 if isDocs

338− then

330+ then chompOverviewHelp names

339− do Space.chomp E.Space

331+ else return names

332+

333+

334+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

335+chompOverviewHelp names =

336+ do pos <- P.getPosition

337+ (W.SPos spos) <- W.whitespace

338+ if pos == spos

339+ then chompOverview names

340− chompOverview =<< chompDocs names

340+ else chompOverview =<< chompDocs names

341− else

342− return names

343

341

344

342

345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

346chompDocs names =

344chompDocs names =

347− do name <-

345+ do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])

348− P.addLocation $

346+ spos <- W.whitespace

349− P.oneOf E.Name

347+ P.oneOf

350− [ Var.lower E.Name

348+ [ do P.checkSpace spos

351− , Var.upper E.Name

349+ Symbol.comma

352− , chompOperator

350+ P.spaces

353− ]

354−

355− Space.chomp E.Space

356−

357− P.oneOfWithFallback

358− [ do pos <- P.getPosition

359− Space.checkIndent pos E.Comma

360− word1 0x2C {-,-} E.Comma

361− Space.chomp E.Space

362 chompDocs (name:names)

351 chompDocs (name:names)

352+ , return (name:names)

363 ]

353 ]

364− (name:names)

354+

365−

355+

366−

367−chompOperator :: Parser Name.Name

356+chompBinop :: Parser Name.Name

368−chompOperator =

357+chompBinop =

369− do word1 0x28 {-(-} E.Op

358+ do Symbol.leftParen

370− op <- Symbol.operator E.Op E.OpBad

359+ name <- Symbol.binop

371− word1 0x29 {-)-} E.Op

360+ Symbol.rightParen

372− return op

361+ return name

373−

374−

375−-- TODO add rule that @docs must be after newline in 0.20

376−--

377−chompUntilDocs :: Parser Bool

378−chompUntilDocs =

379− P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->

380− let

381− (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col

382− !newState = P.State src newPos end indent newRow newCol

383− in

384− cok isDocs newState

385−

386−

387−untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)

388−untilDocs pos end row col =

389− if pos >= end then

390− (# False, pos, row, col #)

391− else

392− let !word = P.unsafeIndex pos in

393− if word == 0x0A {-\n-} then

394− untilDocs (plusPtr pos 1) end (row + 1) 1

395− else

396− let !pos5 = plusPtr pos 5 in

397− if pos5 <= end

398− && P.unsafeIndex ( pos ) == 0x40 {-@-}

399− && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}

400− && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}

401− && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}

402− && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}

403− && Var.getInnerWidth pos5 end == 0

404− then

405− (# True, pos5, row, col + 5 #)

406− else

407− let !newPos = plusPtr pos (P.getCharWidth word) in

408− untilDocs newPos end row (col + 1)

409

362

410

363

411

364

412-- CHECK NAMES

365-- CHECK NAMES

413

366

414

367

415−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()

368+type Result i w a =

416−checkNames exports names =

369+ Result.Result i w E.Error a

417− let

370+

418− docs = List.foldl' addName Map.empty names

371+

419− loneDoc = Map.traverseMissing onlyInDocs

372+type Dups =

420− loneExport = Map.traverseMissing onlyInExports

373+ Map.Map Name.Name (OneOrMore.OneOrMore R.Region)

421− checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)

422− in

423− case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of

424− (_, Right _) -> Right ()

425− (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))

426

374

427

375

428−type DocNameRegions =

376+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()

429− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)

377+checkNames exports names =

378+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)

379+ let overlap = Map.size (Map.intersection docs exports)

380+ if Map.size exports == overlap && overlap == Map.size docs

381+ then Result.ok ()

382+ else

383+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)

384+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)

385+ Result.ok ()

430

386

431

387

432−addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions

388+addName :: Dups -> A.Located Name.Name -> Dups

433addName dict (A.At region name) =

389addName dict (A.At region name) =

434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

435

391

436

392

437−isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region

393+isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region

438isUnique name regions =

394isUnique name regions =

439 case regions of

395 case regions of

440 OneOrMore.One region ->

396 OneOrMore.One region ->

441 Result.ok region

397 Result.ok region

442

398

443− OneOrMore.More left right ->

399+ OneOrMore.More _ _ ->

444− let (r1, r2) = OneOrMore.getFirstTwo left right in

400+ let (r1:r2:_) = OneOrMore.toList regions in

445− Result.throw (E.NameDuplicate name r1 r2)

401+ Result.throw (E.Duplicate name r1 r2)

446

402

447

403

448−onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a

404+onlyInDocs :: Name.Name -> R.Region -> Result i w a

449−onlyInDocs name regions =

405+onlyInDocs name region =

450− do region <- isUnique name regions

451− Result.throw $ E.NameOnlyInDocs name region

406+ Result.throw $ E.OnlyInDocs name region

452

407

453

408

454−onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a

409+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a

455onlyInExports name (A.At region _) =

410onlyInExports name (A.At region _) =

456− Result.throw $ E.NameOnlyInExports name region

411+ Result.throw $ E.OnlyInExports name region

457−

458−

459−

460−-- CHECK DEFS

461−

462

412

463−checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module

464−checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) =

465− let

466− types = gatherTypes decls Map.empty

467− info = Info comments types unions aliases infixes effects

468− in

469− case Result.run (Map.traverseWithKey (checkExport info) exportDict) of

470− (_, Left problems ) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems)

471− (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters

472

413

473

414

474−emptyModule :: ModuleName.Canonical -> Src.Comment -> Module

415+-- CHECK EXPORTS

475−emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =

476− Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty

477

416

478

417

479data Info =

418data Info =

480 Info

419 Info

481− { _iComments :: Map.Map Name.Name Src.Comment

420+ { _iComments :: Map.Map Name.Name Comment

482− , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)

421+ , _iValues :: Types

483 , _iUnions :: Map.Map Name.Name Can.Union

422 , _iUnions :: Map.Map Name.Name Can.Union

484 , _iAliases :: Map.Map Name.Name Can.Alias

423 , _iAliases :: Map.Map Name.Name Can.Alias

485 , _iBinops :: Map.Map Name.Name Can.Binop

424 , _iBinops :: Map.Map Name.Name Can.Binop

@@ -487,7 +426,7 @@ data Info =

487 }

426 }

488

427

489

428

490−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)

429+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)

491checkExport info name (A.At region export) =

430checkExport info name (A.At region export) =

492 case export of

431 case export of

493 Can.ExportValue ->

432 Can.ExportValue ->

@@ -528,23 +467,23 @@ checkExport info name (A.At region export) =

528 m { _values = Map.insert name (Value comment tipe) (_values m) }

467 m { _values = Map.insert name (Value comment tipe) (_values m) }

529

468

530

469

531−getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment

470+getComment :: R.Region -> Name.Name -> Info -> Result i w Comment

532getComment region name info =

471getComment region name info =

533 case Map.lookup name (_iComments info) of

472 case Map.lookup name (_iComments info) of

534 Nothing ->

473 Nothing ->

535 Result.throw (E.NoComment name region)

474 Result.throw (E.NoComment name region)

536

475

537− Just (Src.Comment snippet) ->

476+ Just comment ->

538− Result.ok (Json.fromComment snippet)

477+ Result.ok comment

539

478

540

479

541−getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type

480+getType :: Name.Name -> Info -> Result i w Type.Type

542getType name info =

481getType name info =

543 case _iValues info ! name of

482 case _iValues info ! name of

544− Left region ->

483+ A.At defRegion Nothing ->

545− Result.throw (E.NoAnnotation name region)

484+ Result.throw (E.NoAnnotation name defRegion)

546

485

547− Right tipe ->

486+ A.At _ (Just tipe) ->

548 Result.ok (Extract.fromType tipe)

487 Result.ok (Extract.fromType tipe)

549

488

550

489

@@ -558,7 +497,7 @@ dector (Can.Ctor name _ _ args) =

558

497

559

498

560type Types =

499type Types =

561− Map.Map Name.Name (Either A.Region Can.Type)

500+ Map.Map Name.Name (A.Located (Maybe Can.Type))

562

501

563

502

564gatherTypes :: Can.Decls -> Types -> Types

503gatherTypes :: Can.Decls -> Types -> Types

@@ -567,8 +506,8 @@ gatherTypes decls types =

567 Can.Declare def subDecls ->

506 Can.Declare def subDecls ->

568 gatherTypes subDecls (addDef types def)

507 gatherTypes subDecls (addDef types def)

569

508

570− Can.DeclareRec def defs subDecls ->

509+ Can.DeclareRec defs subDecls ->

571− gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)

510+ gatherTypes subDecls (List.foldl' addDef types defs)

572

511

573 Can.SaveTheEnvironment ->

512 Can.SaveTheEnvironment ->

574 types

513 types

@@ -578,10 +517,11 @@ addDef :: Types -> Can.Def -> Types

578addDef types def =

517addDef types def =

579 case def of

518 case def of

580 Can.Def (A.At region name) _ _ ->

519 Can.Def (A.At region name) _ _ ->

581− Map.insert name (Left region) types

520+ Map.insert name (A.At region Nothing) types

582

521

583− Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->

522+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->

584 let

523 let

524+ tipe =

585− tipe = foldr Can.TLambda resultType (map snd typedArgs)

525+ foldr Can.TLambda resultType (map snd typedArgs)

586 in

526 in

587− Map.insert name (Right tipe) types

527+ Map.insert name (A.At region (Just tipe)) types

compiler/src/Elm/Float.hsdeleted−51

@@ -1,51 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}

3−module Elm.Float

4− ( Float

5− , fromPtr

6− , toBuilder

7− )

8− where

9−

10−

11−import Prelude hiding (Float)

12−import Data.Binary (Binary, get, put)

13−import qualified Data.ByteString.Builder as B

14−import qualified Data.Utf8 as Utf8

15−import Data.Word (Word8)

16−import Foreign.Ptr (Ptr)

17−

18−

19−

20−-- FLOATS

21−

22−

23−type Float =

24− Utf8.Utf8 ELM_FLOAT

25−

26−

27−data ELM_FLOAT

28−

29−

30−

31−-- HELPERS

32−

33−

34−fromPtr :: Ptr Word8 -> Ptr Word8 -> Float

35−fromPtr =

36− Utf8.fromPtr

37−

38−

39−{-# INLINE toBuilder #-}

40−toBuilder :: Float -> B.Builder

41−toBuilder =

42− Utf8.toBuilder

43−

44−

45−

46−-- BINARY

47−

48−

49−instance Binary (Utf8.Utf8 ELM_FLOAT) where

50− get = Utf8.getUnder256

51− put = Utf8.putUnder256

compiler/src/Elm/Interface.hs+4−4

@@ -73,7 +73,7 @@ data Binop =

73

74

75fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface

76−fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =

76+fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =

77 Interface

78 { _home = home

79 , _values = restrict exports annotations

@@ -215,7 +215,7 @@ instance Binary Union where

215 0 -> liftM OpenUnion get

216 1 -> liftM ClosedUnion get

217 2 -> liftM PrivateUnion get

218− _ -> fail "binary encoding of Union was corrupted"

218+ _ -> error "binary encoding of Union was corrupted"

219

220

221instance Binary Alias where

@@ -229,7 +229,7 @@ instance Binary Alias where

229 case n of

230 0 -> liftM PublicAlias get

231 1 -> liftM PrivateAlias get

232− _ -> fail "binary encoding of Alias was corrupted"

232+ _ -> error "binary encoding of Alias was corrupted"

233

234

235instance Binary Binop where

@@ -251,4 +251,4 @@ instance Binary DependencyInterface where

251 case n of

252 0 -> liftM Public get

253 1 -> liftM3 Private get get get

254− _ -> fail "binary encoding of DependencyInterface was corrupted"

254+ _ -> error "binary encoding of DependencyInterface was corrupted"

compiler/src/Elm/Kernel.hs+58−73

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

3module Elm.Kernel

4 ( Content(..)

5 , Chunk(..)

6− , fromByteString

6+ , fromFile

7 , countFields

8 )

9 where

@@ -11,24 +11,24 @@ module Elm.Kernel

11

12import Control.Monad (liftM, liftM2)

13import Data.Binary (Binary, get, put, getWord8, putWord8)

14−import qualified Data.ByteString.Internal as B

14+import Data.Coerce (coerce)

15import qualified Data.List as List

16import qualified Data.Map as Map

17import qualified Data.Name as Name

18+import qualified Data.Utf8 as Utf8

18−import Data.Word (Word8)

19+import Data.Word (Word8, Word16)

19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

20+import Foreign.Ptr (Ptr, plusPtr)

20−import Foreign.ForeignPtr (ForeignPtr)

21−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

22

21

23import qualified AST.Source as Src

22import qualified AST.Source as Src

24import qualified Elm.ModuleName as ModuleName

23import qualified Elm.ModuleName as ModuleName

25import qualified Elm.Package as Pkg

24import qualified Elm.Package as Pkg

26import qualified Parse.Module as Module

25import qualified Parse.Module as Module

27−import qualified Parse.Space as Space

28import qualified Parse.Variable as Var

26import qualified Parse.Variable as Var

29−import Parse.Primitives hiding (fromByteString)

27+import Parse.Utils

28+import Parse.Primitives hiding (Parser, fromFile)

30import qualified Parse.Primitives as P

29import qualified Parse.Primitives as P

31import qualified Reporting.Annotation as A

30import qualified Reporting.Annotation as A

31+import qualified Reporting.Error.Syntax as E

32

33

34

@@ -36,7 +36,7 @@ import qualified Reporting.Annotation as A

36

37

38data Chunk

39− = JS B.ByteString

39+ = JS (Utf8.VeryLong UNCHECKED)

40 | ElmVar ModuleName.Canonical Name.Name

41 | JsVar Name.Name Name.Name

42 | ElmField Name.Name

@@ -46,6 +46,9 @@ data Chunk

46 | Prod

47

48

49+data UNCHECKED

50+

51+

49

52

50-- COUNT FIELDS

53-- COUNT FIELDS

51

54

@@ -80,58 +83,45 @@ type Foreigns =

80 Map.Map ModuleName.Raw Pkg.Name

83 Map.Map ModuleName.Raw Pkg.Name

81

84

82

85

83−fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content

86+fromFile :: Pkg.Name -> Foreigns -> FilePath -> IO (Maybe Content)

84−fromByteString pkg foreigns bytes =

87+fromFile pkg foreigns path =

85− case P.fromByteString (parser pkg foreigns) toError bytes of

88+ do result <- P.fromFile (parser pkg foreigns) path

86− Right content ->

89+ case result of

87− Just content

90+ P.Ok content _ -> return (Just content)

91+ P.Err _ _ _ _ -> return Nothing

88

92

89− Left () ->

90− Nothing

91

93

92−

93−parser :: Pkg.Name -> Foreigns -> Parser () Content

94+parser :: Pkg.Name -> Foreigns -> Parser Content

94parser pkg foreigns =

95parser pkg foreigns =

95− do word2 0x2F 0x2A {-/*-} toError

96+ do word2 0x2F 0x2A {-/*-} E.XXX

96− Space.chomp ignoreError

97+ Module.freshLine

97− Space.checkFreshLine toError

98− imports <- specialize ignoreError (Module.chompImports [])

98+ imports <- Module.chompImports []

99− word2 0x2A 0x2F {-*/-} toError

99+ word2 0x2A 0x2F {-*/-} E.XXX

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

104

115-- PARSE CHUNKS

105-- PARSE CHUNKS

116

106

117

107

118−parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]

108+parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]

119parseChunks vtable enums fields =

109parseChunks vtable enums fields =

120− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->

110+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr _ ->

121 let

111 let

122 (# chunks, newPos, newRow, newCol #) =

112 (# chunks, newPos, newRow, newCol #) =

123− chompChunks vtable enums fields src pos end row col pos []

113+ chompChunks vtable enums fields pos end row col pos []

124 in

114 in

125 if newPos == end then

115 if newPos == end then

126− cok chunks (P.State src newPos end indent newRow newCol)

116+ cok chunks (P.State newPos end indent newRow newCol ctx)

127 else

117 else

128− cerr row col toError

118+ cerr row col ctx E.XXX

129

119

130

120

131−chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)

121+chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)

132−chompChunks vs es fs src pos end row col lastPos revChunks =

122+chompChunks vs es fs pos end row col lastPos revChunks =

133 if pos >= end then

123 if pos >= end then

134− let !js = toByteString src lastPos end in

124+ let !js = Utf8.fromPtr lastPos end in

135 (# reverse (JS js : revChunks), pos, row, col #)

125 (# reverse (JS js : revChunks), pos, row, col #)

136

126

137 else

127 else

@@ -142,34 +132,24 @@ chompChunks vs es fs src pos end row col lastPos revChunks =

142 !pos3 = plusPtr pos 3

132 !pos3 = plusPtr pos 3

143 in

133 in

144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then

134 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then

145− let !js = toByteString src lastPos pos in

135+ let !js = Utf8.fromPtr lastPos pos in

146− chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)

136+ chompTag vs es fs pos3 end row (col + 3) (JS js : revChunks)

147 else

137 else

148− chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks

138+ chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks

149

139

150 else if word == 0x0A {-\n-} then

140 else if word == 0x0A {-\n-} then

151− chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks

141+ chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks

152

142

153 else

143 else

154 let

144 let

155− !newPos = plusPtr pos (getCharWidth word)

145+ !newPos = plusPtr pos (getCharWidth pos end word)

156 in

146 in

157− chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks

147+ chompChunks vs es fs newPos end row (col + 1) lastPos revChunks

158−

159−

160−toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString

161−toByteString src pos end =

162− let

163− !off = minusPtr pos (unsafeForeignPtrToPtr src)

164− !len = minusPtr end pos

165− in

166− B.PS src off len

167−

168

148

169

149

170-- relies on external checks in chompChunks

150-- 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 #)

151+chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)

172−chompTag vs es fs src pos end row col revChunks =

152+chompTag vs es fs pos end row col revChunks =

173 let

153 let

174 (# newPos, newCol #) = Var.chompInnerChars pos end col

154 (# newPos, newCol #) = Var.chompInnerChars pos end col

175 !tagPos = plusPtr pos (-1)

155 !tagPos = plusPtr pos (-1)

@@ -179,7 +159,7 @@ chompTag vs es fs src pos end row col revChunks =

179 let

159 let

180 !name = Name.fromPtr pos newPos

160 !name = Name.fromPtr pos newPos

181 in

161 in

182− chompChunks vs es fs src newPos end row newCol newPos $

162+ chompChunks vs es fs newPos end row newCol newPos $

183 ElmField name : revChunks

163 ElmField name : revChunks

184 else

164 else

185 let

165 let

@@ -190,7 +170,7 @@ chompTag vs es fs src pos end row col revChunks =

190 (enum, newEnums) =

170 (enum, newEnums) =

191 lookupEnum (word - 0x30) name es

171 lookupEnum (word - 0x30) name es

192 in

172 in

193− chompChunks vs newEnums fs src newPos end row newCol newPos $

173+ chompChunks vs newEnums fs newPos end row newCol newPos $

194 JsEnum enum : revChunks

174 JsEnum enum : revChunks

195

175

196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then

176 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then

@@ -198,19 +178,19 @@ chompTag vs es fs src pos end row col revChunks =

198 (field, newFields) =

178 (field, newFields) =

199 lookupField name fs

179 lookupField name fs

200 in

180 in

201− chompChunks vs es newFields src newPos end row newCol newPos $

181+ chompChunks vs es newFields newPos end row newCol newPos $

202 JsField field : revChunks

182 JsField field : revChunks

203

183

204 else if name == "DEBUG" then

184 else if name == "DEBUG" then

205− chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)

185+ chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)

206

186

207 else if name == "PROD" then

187 else if name == "PROD" then

208− chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)

188+ chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)

209

189

210 else

190 else

211 case Map.lookup name vs of

191 case Map.lookup name vs of

212 Just chunk ->

192 Just chunk ->

213− chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)

193+ chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)

214

194

215 Nothing ->

195 Nothing ->

216 (# revChunks, pos, row, col #)

196 (# revChunks, pos, row, col #)

@@ -319,19 +299,19 @@ toNames exposing =

319 map toName exposedList

299 map toName exposedList

320

300

321

301

322−toName :: Src.Exposed -> Name.Name

302+toName :: A.Located Src.Exposed -> Name.Name

323−toName exposed =

303+toName (A.At _ exposed) =

324 case exposed of

304 case exposed of

325− Src.Lower (A.At _ name) ->

305+ Src.Lower name ->

326 name

306 name

327

307

328− Src.Upper (A.At _ name) Src.Private ->

308+ Src.Upper name Src.Private ->

329 name

309 name

330

310

331− Src.Upper _ (Src.Public _) ->

311+ Src.Upper _ Src.Public ->

332 error "cannot have Maybe(..) syntax in kernel code header"

312 error "cannot have Maybe(..) syntax in kernel code header"

333

313

334− Src.Operator _ _ ->

314+ Src.Operator _ ->

335 error "cannot use binops in kernel code"

315 error "cannot use binops in kernel code"

336

316

337

317

@@ -342,7 +322,7 @@ toName exposed =

342instance Binary Chunk where

322instance Binary Chunk where

343 put chunk =

323 put chunk =

344 case chunk of

324 case chunk of

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

325+ JS a -> putWord8 0 >> put (coerce a :: Utf8.String)

346 ElmVar a b -> putWord8 1 >> put a >> put b

326 ElmVar a b -> putWord8 1 >> put a >> put b

347 JsVar a b -> putWord8 2 >> put a >> put b

327 JsVar a b -> putWord8 2 >> put a >> put b

348 ElmField a -> putWord8 3 >> put a

328 ElmField a -> putWord8 3 >> put a

@@ -354,7 +334,7 @@ instance Binary Chunk where

354 get =

334 get =

355 do word <- getWord8

335 do word <- getWord8

356 case word of

336 case word of

357− 0 -> liftM JS get

337+ 0 -> liftM toJS get

358 1 -> liftM2 ElmVar get get

338 1 -> liftM2 ElmVar get get

359 2 -> liftM2 JsVar get get

339 2 -> liftM2 JsVar get get

360 3 -> liftM ElmField get

340 3 -> liftM ElmField get

@@ -363,3 +343,8 @@ instance Binary Chunk where

363 6 -> return Debug

343 6 -> return Debug

364 7 -> return Prod

344 7 -> return Prod

365 _ -> error "problem deserializing Elm.Kernel.Chunk"

345 _ -> error "problem deserializing Elm.Kernel.Chunk"

346+

347+

348+toJS :: Utf8.String -> Chunk

349+toJS str =

350+ JS (coerce str)

compiler/src/Elm/Licenses.hs+65−48

@@ -9,12 +9,14 @@ module Elm.Licenses

9 where

10

11

12+import Control.Monad (liftM2)

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

14+import Data.Map ((!))

12import qualified Data.Map as Map

15import qualified Data.Map as Map

13import qualified Data.Utf8 as Utf8

16import qualified Data.Utf8 as Utf8

14

17

15import qualified Json.Decode as D

18import qualified Json.Decode as D

16import qualified Json.Encode as E

19import qualified Json.Encode as E

17−import qualified Json.String as Json

18import qualified Reporting.Suggest as Suggest

20import qualified Reporting.Suggest as Suggest

19

21

20

22

@@ -22,21 +24,25 @@ import qualified Reporting.Suggest as Suggest

22-- LICENCES

24-- LICENCES

23

25

24

26

25−newtype License =

27+data License =

26− License Json.String

28+ License

29+ { _name :: Utf8.String

30+ , _code :: Utf8.String

31+ }

32+ deriving (Eq, Ord)

27

33

28

34

29bsd3 :: License

35bsd3 :: License

30bsd3 =

36bsd3 =

31− License (Json.fromChars "BSD-3-Clause")

37+ osiApprovedSpdxLicenses ! "BSD-3-Clause"

32

38

33

39

34encode :: License -> E.Value

40encode :: License -> E.Value

35−encode (License code) =

41+encode (License _ code) =

36 E.string code

42 E.string code

37

43

38

44

39−decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License

45+decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License

40decoder toError =

46decoder toError =

41 do str <- D.string

47 do str <- D.string

42 case check str of

48 case check str of

@@ -51,93 +57,97 @@ decoder toError =

51-- CHECK

57-- CHECK

52

58

53

59

54−check :: Json.String -> Either [Json.String] License

60+check :: Utf8.String -> Either [Utf8.String] License

55−check givenCode =

61+check rawName =

56− if Map.member givenCode osiApprovedSpdxLicenses then

62+ case Map.lookup rawName osiApprovedSpdxLicenses of

57− Right (License givenCode)

63+ Just license ->

64+ Right license

58

65

59− else

66+ Nothing ->

60− let

67+ let

61− pairs =

68+ toPairs (License name code) =

62− map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)

69+ [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]

63− ++

70+

71+ pairs =

64− Map.toList osiApprovedSpdxLicenses

72+ concatMap toPairs (Map.elems osiApprovedSpdxLicenses)

65− in

73+ in

66− Left $ map fst $ take 4 $

74+ Left $ map snd $

67− Suggest.sort (Utf8.toChars givenCode) snd pairs

75+ Suggest.sort (Utf8.toChars rawName) fst pairs

68

76

69

77

70

78

71-- LIST OF LICENCES

79-- LIST OF LICENCES

72

80

73

81

74−(==>) :: [Char] -> [Char] -> (Json.String, [Char])

82+(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)

75−(==>) code fullName =

83+(==>) code name =

76− ( Json.fromChars code, fullName )

84+ ( code, License name code )

77

85

78

86

79--

87--

80-- OSI approved licenses in SPDX format.

88-- OSI approved licenses in SPDX format.

81-- <https://spdx.org/licenses/>

89-- <https://spdx.org/licenses/>

82--

90--

83−osiApprovedSpdxLicenses :: Map.Map Json.String [Char]

91+osiApprovedSpdxLicenses :: Map.Map Utf8.String License

84osiApprovedSpdxLicenses =

92osiApprovedSpdxLicenses =

85 Map.fromList

93 Map.fromList

86− [ "0BSD" ==> "BSD Zero Clause License"

87− , "AAL" ==> "Attribution Assurance License"

88− , "AFL-1.1" ==> "Academic Free License v1.1"

94+ [ "AFL-1.1" ==> "Academic Free License v1.1"

89 , "AFL-1.2" ==> "Academic Free License v1.2"

95 , "AFL-1.2" ==> "Academic Free License v1.2"

90 , "AFL-2.0" ==> "Academic Free License v2.0"

96 , "AFL-2.0" ==> "Academic Free License v2.0"

91 , "AFL-2.1" ==> "Academic Free License v2.1"

97 , "AFL-2.1" ==> "Academic Free License v2.1"

92 , "AFL-3.0" ==> "Academic Free License v3.0"

98 , "AFL-3.0" ==> "Academic Free License v3.0"

93− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"

99+ , "APL-1.0" ==> "Adaptive Public License 1.0"

94 , "Apache-1.1" ==> "Apache License 1.1"

100 , "Apache-1.1" ==> "Apache License 1.1"

95 , "Apache-2.0" ==> "Apache License 2.0"

101 , "Apache-2.0" ==> "Apache License 2.0"

96− , "APL-1.0" ==> "Adaptive Public License 1.0"

97 , "APSL-1.0" ==> "Apple Public Source License 1.0"

102 , "APSL-1.0" ==> "Apple Public Source License 1.0"

98 , "APSL-1.1" ==> "Apple Public Source License 1.1"

103 , "APSL-1.1" ==> "Apple Public Source License 1.1"

99 , "APSL-1.2" ==> "Apple Public Source License 1.2"

104 , "APSL-1.2" ==> "Apple Public Source License 1.2"

100 , "APSL-2.0" ==> "Apple Public Source License 2.0"

105 , "APSL-2.0" ==> "Apple Public Source License 2.0"

101 , "Artistic-1.0" ==> "Artistic License 1.0"

106 , "Artistic-1.0" ==> "Artistic License 1.0"

102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"

103 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"

107 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"

108+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"

104 , "Artistic-2.0" ==> "Artistic License 2.0"

109 , "Artistic-2.0" ==> "Artistic License 2.0"

110+ , "AAL" ==> "Attribution Assurance License"

111+ , "BSL-1.0" ==> "Boost Software License 1.0"

105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"

112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"

106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"

113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"

107− , "BSL-1.0" ==> "Boost Software License 1.0"

114+ , "0BSD" ==> "BSD Zero Clause License"

108− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"

109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"

110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"

115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"

111 , "CNRI-Python" ==> "CNRI Python License"

116 , "CNRI-Python" ==> "CNRI Python License"

117+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"

112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"

118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"

113 , "CPL-1.0" ==> "Common Public License 1.0"

119 , "CPL-1.0" ==> "Common Public License 1.0"

120+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"

114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"

121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"

122+ , "EPL-1.0" ==> "Eclipse Public License 1.0"

115 , "ECL-1.0" ==> "Educational Community License v1.0"

123 , "ECL-1.0" ==> "Educational Community License v1.0"

116 , "ECL-2.0" ==> "Educational Community License v2.0"

124 , "ECL-2.0" ==> "Educational Community License v2.0"

117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"

125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"

118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"

126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"

119 , "Entessa" ==> "Entessa Public License v1.0"

127 , "Entessa" ==> "Entessa Public License v1.0"

120− , "EPL-1.0" ==> "Eclipse Public License 1.0"

121 , "EUDatagrid" ==> "EU DataGrid Software License"

128 , "EUDatagrid" ==> "EU DataGrid Software License"

122 , "EUPL-1.1" ==> "European Union Public License 1.1"

129 , "EUPL-1.1" ==> "European Union Public License 1.1"

123 , "Fair" ==> "Fair License"

130 , "Fair" ==> "Fair License"

124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"

131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"

132+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"

125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"

133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"

126 , "GPL-3.0" ==> "GNU General Public License v3.0 only"

134 , "GPL-3.0" ==> "GNU General Public License v3.0 only"

135+ , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"

136+ , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"

137+ , "LGPL-2.0" ==> "GNU Library General Public License v2 only"

127 , "HPND" ==> "Historic Permission Notice and Disclaimer"

138 , "HPND" ==> "Historic Permission Notice and Disclaimer"

139+ , "IPL-1.0" ==> "IBM Public License v1.0"

128 , "Intel" ==> "Intel Open Source License"

140 , "Intel" ==> "Intel Open Source License"

129 , "IPA" ==> "IPA Font License"

141 , "IPA" ==> "IPA Font License"

130− , "IPL-1.0" ==> "IBM Public License v1.0"

131 , "ISC" ==> "ISC License"

142 , "ISC" ==> "ISC License"

132− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"

143+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

133− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"

134− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"

135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"

144 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"

136− , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"

137 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"

145 , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"

138− , "LPL-1.0" ==> "Lucent Public License Version 1.0"

146+ , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"

139 , "LPL-1.02" ==> "Lucent Public License v1.02"

147 , "LPL-1.02" ==> "Lucent Public License v1.02"

148+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"

140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

149+ , "MS-PL" ==> "Microsoft Public License"

150+ , "MS-RL" ==> "Microsoft Reciprocal License"

141 , "MirOS" ==> "MirOS Licence"

151 , "MirOS" ==> "MirOS Licence"

142 , "MIT" ==> "MIT License"

152 , "MIT" ==> "MIT License"

143 , "Motosoto" ==> "Motosoto License"

153 , "Motosoto" ==> "Motosoto License"

@@ -145,41 +155,48 @@ osiApprovedSpdxLicenses =

145 , "MPL-1.1" ==> "Mozilla Public License 1.1"

155 , "MPL-1.1" ==> "Mozilla Public License 1.1"

146 , "MPL-2.0" ==> "Mozilla Public License 2.0"

156 , "MPL-2.0" ==> "Mozilla Public License 2.0"

147 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"

157 , "MPL-2.0-no-copyleft-exception" ==> "Mozilla Public License 2.0 (no copyleft exception)"

148− , "MS-PL" ==> "Microsoft Public License"

149− , "MS-RL" ==> "Microsoft Reciprocal License"

150 , "Multics" ==> "Multics License"

158 , "Multics" ==> "Multics License"

151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"

159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"

152 , "Naumen" ==> "Naumen Public License"

160 , "Naumen" ==> "Naumen Public License"

153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"

154 , "NGPL" ==> "Nethack General Public License"

161 , "NGPL" ==> "Nethack General Public License"

155 , "Nokia" ==> "Nokia Open Source License"

162 , "Nokia" ==> "Nokia Open Source License"

156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"

163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"

157 , "NTP" ==> "NTP License"

164 , "NTP" ==> "NTP License"

158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"

165 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"

159− , "OFL-1.1" ==> "SIL Open Font License 1.1"

160 , "OGTSL" ==> "Open Group Test Suite License"

166 , "OGTSL" ==> "Open Group Test Suite License"

161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

162 , "OSL-1.0" ==> "Open Software License 1.0"

167 , "OSL-1.0" ==> "Open Software License 1.0"

163 , "OSL-2.0" ==> "Open Software License 2.0"

168 , "OSL-2.0" ==> "Open Software License 2.0"

164 , "OSL-2.1" ==> "Open Software License 2.1"

169 , "OSL-2.1" ==> "Open Software License 2.1"

165 , "OSL-3.0" ==> "Open Software License 3.0"

170 , "OSL-3.0" ==> "Open Software License 3.0"

171+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

166 , "PHP-3.0" ==> "PHP License v3.0"

172 , "PHP-3.0" ==> "PHP License v3.0"

167 , "PostgreSQL" ==> "PostgreSQL License"

173 , "PostgreSQL" ==> "PostgreSQL License"

168 , "Python-2.0" ==> "Python License 2.0"

174 , "Python-2.0" ==> "Python License 2.0"

169 , "QPL-1.0" ==> "Q Public License 1.0"

175 , "QPL-1.0" ==> "Q Public License 1.0"

176+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"

177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"

171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"

178 , "RPL-1.5" ==> "Reciprocal Public License 1.5"

172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

173 , "RSCPL" ==> "Ricoh Source Code Public License"

179 , "RSCPL" ==> "Ricoh Source Code Public License"

180+ , "OFL-1.1" ==> "SIL Open Font License 1.1"

174 , "SimPL-2.0" ==> "Simple Public License 2.0"

181 , "SimPL-2.0" ==> "Simple Public License 2.0"

175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"

176 , "Sleepycat" ==> "Sleepycat License"

182 , "Sleepycat" ==> "Sleepycat License"

183+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"

177 , "SPL-1.0" ==> "Sun Public License v1.0"

184 , "SPL-1.0" ==> "Sun Public License v1.0"

185+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

178 , "UPL-1.0" ==> "Universal Permissive License v1.0"

186 , "UPL-1.0" ==> "Universal Permissive License v1.0"

187+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"

179 , "VSL-1.0" ==> "Vovida Software License v1.0"

188 , "VSL-1.0" ==> "Vovida Software License v1.0"

180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"

189 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"

181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

182 , "Xnet" ==> "X.Net License"

190 , "Xnet" ==> "X.Net License"

183 , "Zlib" ==> "zlib License"

191 , "Zlib" ==> "zlib License"

184 , "ZPL-2.0" ==> "Zope Public License 2.0"

192 , "ZPL-2.0" ==> "Zope Public License 2.0"

185 ]

193 ]

194+

195+

196+

197+-- BINARY

198+

199+

200+instance Binary License where

201+ get = liftM2 License get get

202+ put (License a b) = put a >> put b

compiler/src/Elm/ModuleName.hs+46−72

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

1−{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}

1+{-# LANGUAGE OverloadedStrings #-}

2module Elm.ModuleName

3 ( Raw

4 , toChars

5+ , toString

5 , toFilePath

6 , toFilePath

6 , toHyphenPath

7 , toHyphenPath

7− --

8+ , fromHyphenPath

8 , encode

9 , encode

9 , decoder

10 , decoder

10− , parser

11− --

12 , Canonical(..)

11 , Canonical(..)

12+ , canonicalIsKernel

13 , basics, char, string

14 , maybe, result, list, array, dict, tuple

15 , platform, cmd, sub

16− , debug

16+ , debug, bitwise

17 , virtualDom

18 , jsonDecode, jsonEncode

19 , webgl, texture, vector2, vector3, vector4, matrix4

@@ -23,19 +23,15 @@ module Elm.ModuleName

23

24import Control.Monad (liftM2)

25import Data.Binary (Binary(..))

26+import qualified Data.Char as Char

26import qualified Data.Name as Name

27import qualified Data.Name as Name

27import qualified Data.Utf8 as Utf8

28import qualified Data.Utf8 as Utf8

28−import Data.Word (Word8)

29−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

30import Prelude hiding (maybe)

29import Prelude hiding (maybe)

31import qualified System.FilePath as FP

30import qualified System.FilePath as FP

32

31

33import qualified Elm.Package as Pkg

32import qualified Elm.Package as Pkg

34−import qualified Json.Decode as D

33+import qualified Json.Decode as Decode

35−import qualified Json.Encode as E

34+import qualified Json.Encode as Encode

36−import qualified Parse.Variable as Var

37−import qualified Parse.Primitives as P

38−import Parse.Primitives (Row, Col)

39

35

40

36

41

37

@@ -50,6 +46,11 @@ toChars =

50 Name.toChars

46 Name.toChars

51

47

52

48

49+toString :: Raw -> Utf8.String

50+toString =

51+ Name.toUtf8

52+

53+

53toFilePath :: Raw -> FilePath

54toFilePath :: Raw -> FilePath

54toFilePath name =

55toFilePath name =

55 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)

56 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)

@@ -60,68 +61,38 @@ toHyphenPath name =

60 map (\c -> if c == '.' then '-' else c) (Name.toChars name)

61 map (\c -> if c == '.' then '-' else c) (Name.toChars name)

61

62

63

64+fromHyphenPath :: Utf8.String -> Maybe Raw

65+fromHyphenPath str =

66+ let

67+ chunks =

68+ Utf8.split 0x2D {- - -} str

69+ in

70+ if all isGoodChunk chunks

71+ then Just (Name.fromUtf8 (Utf8.join 0x2E {- . -} chunks))

72+ else Nothing

73+

74+

63

75

64-- JSON

76-- JSON

65

77

66

78

67−encode :: Raw -> E.Value

79+encode :: Raw -> Encode.Value

68encode =

80encode =

69− E.name

81+ Encode.name

70

82

71

83

72−decoder :: D.Decoder (Row, Col) Raw

84+decoder :: Decode.Decoder Utf8.String Raw

73decoder =

85decoder =

74− D.customString parser (,)

86+ do str <- Decode.string

87+ if all isGoodChunk (Utf8.split 0x2E {- . -} str)

88+ then return (Name.fromUtf8 str)

89+ else Decode.failure str

75

90

76

91

77−

92+isGoodChunk :: Utf8.String -> Bool

78−-- PARSER

93+isGoodChunk chunk =

79−

94+ Utf8.startsWithChar Char.isUpper chunk

80−

95+ && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk

81−parser :: P.Parser (Row, Col) Raw

82−parser =

83− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

84− let

85− (# isGood, newPos, newCol #) = chompStart pos end col

86− in

87− if isGood && minusPtr newPos pos < 256 then

88− let !newState = P.State src newPos end indent row newCol in

89− cok (Utf8.fromPtr pos newPos) newState

90−

91− else if col == newCol then

92− eerr row newCol (,)

93−

94− else

95− cerr row newCol (,)

96−

97−

98−chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)

99−chompStart pos end col =

100− let

101− !width = Var.getUpperWidth pos end

102− in

103− if width == 0 then

104− (# False, pos, col #)

105− else

106− chompInner (plusPtr pos width) end (col + 1)

107−

108−

109−chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)

110−chompInner pos end col =

111− if pos >= end then

112− (# True, pos, col #)

113− else

114− let

115− !word = P.unsafeIndex pos

116− !width = Var.getInnerWidthHelp pos end word

117− in

118− if width == 0 then

119− if word == 0x2E {-.-} then

120− chompStart (plusPtr pos 1) end (col + 1)

121− else

122− (# True, pos, col #)

123− else

124− chompInner (plusPtr pos width) end (col + 1)

125

96

126

97

127

98

@@ -133,6 +104,12 @@ data Canonical =

133 { _package :: !Pkg.Name

104 { _package :: !Pkg.Name

134 , _module :: !Name.Name

105 , _module :: !Name.Name

135 }

106 }

107+ deriving (Ord)

108+

109+

110+canonicalIsKernel :: Canonical -> Bool

111+canonicalIsKernel (Canonical _ name) =

112+ Name.isKernel name

136

113

137

114

138

115

@@ -144,14 +121,6 @@ instance Eq Canonical where

144 name1 == name2 && pkg1 == pkg2

121 name1 == name2 && pkg1 == pkg2

145

122

146

123

147−instance Ord Canonical where

148− compare (Canonical pkg1 name1) (Canonical pkg2 name2) =

149− case compare name1 name2 of

150− LT -> LT

151− EQ -> compare pkg1 pkg2

152− GT -> GT

153−

154−

155instance Binary Canonical where

124instance Binary Canonical where

156 put (Canonical a b) = put a >> put b

125 put (Canonical a b) = put a >> put b

157 get = liftM2 Canonical get get

126 get = liftM2 Canonical get get

@@ -226,6 +195,11 @@ debug :: Canonical

226debug = Canonical Pkg.core Name.debug

195debug = Canonical Pkg.core Name.debug

227

196

228

197

198+{-# NOINLINE bitwise #-}

199+bitwise :: Canonical

200+bitwise = Canonical Pkg.core Name.bitwise

201+

202+

229

203

230-- HTML

204-- HTML

231

205

compiler/src/Elm/Package.hs+89−220

@@ -1,52 +1,38 @@

1{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}

2+{-# LANGUAGE OverloadedStrings #-}

3module Elm.Package

4 ( Name(..)

5− , Author

6− , Project

7 , Canonical(..)

5 , Canonical(..)

8 , isKernel

6 , isKernel

7+ , toString

9 , toChars

8 , toChars

10 , toUrl

9 , toUrl

11 , toFilePath

10 , toFilePath

12− , toJsonString

11+ , BadName(..)

13− --

12+ , fromString

14 , dummyName, kernel, core

13 , dummyName, kernel, core

15 , browser, virtualDom, html

14 , browser, virtualDom, html

16 , json, http, url

15 , json, http, url

17 , webgl, linearAlgebra

16 , webgl, linearAlgebra

18− --

19 , suggestions

17 , suggestions

20− , nearbyNames

21− --

22 , decoder

18 , decoder

23 , encode

19 , encode

24− , keyDecoder

25− --

26− , parser

27 )

20 )

28 where

21 where

29

22

30

23

31import Control.Monad (liftM2)

24import Control.Monad (liftM2)

32import Data.Binary (Binary, get, put)

25import Data.Binary (Binary, get, put)

33−import qualified Data.Coerce as Coerce

26+import qualified Data.Char as Char

34−import qualified Data.List as List

35−import qualified Data.Map as Map

36import qualified Data.Name as Name

27import qualified Data.Name as Name

28+import qualified Data.Map as Map

37import Data.Monoid ((<>))

29import Data.Monoid ((<>))

38import qualified Data.Utf8 as Utf8

30import qualified Data.Utf8 as Utf8

39−import Data.Word (Word8)

40−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

41import System.FilePath ((</>))

31import System.FilePath ((</>))

42

32

43import qualified Elm.Version as V

33import qualified Elm.Version as V

44−import qualified Json.Decode as D

34+import qualified Json.Decode as Decode

45−import qualified Json.Encode as E

35+import qualified Json.Encode as Encode

46−import qualified Json.String as Json

47−import qualified Parse.Primitives as P

48−import Parse.Primitives (Row, Col)

49−import qualified Reporting.Suggest as Suggest

50

36

51

37

52

38

@@ -55,17 +41,10 @@ import qualified Reporting.Suggest as Suggest

55

41

56data Name =

42data Name =

57 Name

43 Name

58− { _author :: !Author

44+ { _author :: !Name.Name

59− , _project :: !Project

45+ , _project :: !Name.Name

60 }

46 }

61− deriving (Ord)

47+ deriving (Eq, Ord)

62−

63−

64−type Author = Utf8.Utf8 AUTHOR

65−type Project = Utf8.Utf8 PROJECT

66−

67−data AUTHOR

68−data PROJECT

69

48

70

49

71data Canonical =

50data Canonical =

@@ -73,7 +52,7 @@ data Canonical =

73 { _name :: !Name

52 { _name :: !Name

74 , _version :: !V.Version

53 , _version :: !V.Version

75 }

54 }

76− deriving (Ord)

55+ deriving (Eq, Ord)

77

56

78

57

79

58

@@ -82,114 +61,127 @@ data Canonical =

82

61

83isKernel :: Name -> Bool

62isKernel :: Name -> Bool

84isKernel (Name author _) =

63isKernel (Name author _) =

85− author == elm || author == elm_explorations

64+ author == "elm" || author == "elm-explorations"

65+

66+

67+toString :: Name -> Utf8.String

68+toString (Name author project) =

69+ Utf8.join 0x2F [ Name.toUtf8 author, Name.toUtf8 project ]

86

70

87

71

88toChars :: Name -> String

72toChars :: Name -> String

89toChars (Name author project) =

73toChars (Name author project) =

90− Utf8.toChars author <> "/" <> Utf8.toChars project

74+ Name.toChars author <> "/" <> Name.toChars project

91

75

92

76

93toUrl :: Name -> String

77toUrl :: Name -> String

94toUrl (Name author project) =

78toUrl (Name author project) =

95− Utf8.toChars author ++ "/" ++ Utf8.toChars project

79+ Name.toChars author ++ "/" ++ Name.toChars project

96

80

97

81

98toFilePath :: Name -> FilePath

82toFilePath :: Name -> FilePath

99toFilePath (Name author project) =

83toFilePath (Name author project) =

100− Utf8.toChars author </> Utf8.toChars project

84+ Name.toChars author </> Name.toChars project

101

85

102

86

103−toJsonString :: Name -> Json.String

87+fromString :: Utf8.String -> Either BadName Name

104−toJsonString (Name author project) =

88+fromString str =

89+ case Utf8.split 0x2F {- / -} str of

105− Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]

90+ [author, project]

91+ | Utf8.isEmpty author -> Left BadStructure

92+ | Utf8.isEmpty project -> Left BadStructure

93+ | Utf8.size project >= 256 -> Left TooLong

94+ | Utf8.containsDouble 0x2D {- - -} project -> Left HasDoubleDash

95+ | Utf8.contains 0x5F {- _ -} project -> Left HasUnderscore

96+ | Utf8.contains 0x2E {- . -} project -> Left HasDot

97+ | Utf8.any Char.isUpper project -> Left HasUppercase

98+ | Utf8.endsWithWord 0x2D {- - -} project -> Left HasDashEnd

99+ | Utf8.startsWithChar Char.isLower project -> Right (Name (Name.fromUtf8 author) (Name.fromUtf8 project))

100+ | True -> Left HasNonLowercaseStart

106

101

102+ _ ->

103+ Left BadStructure

107

104

108

105

109−-- COMMON PACKAGE NAMES

106+data BadName

107+ = BadStructure

108+ | TooLong

109+ | HasDoubleDash

110+ | HasUnderscore

111+ | HasDot

112+ | HasUppercase

113+ | HasDashEnd

114+ | HasNonLowercaseStart

115+

110

116

111

117

112−toName :: Author -> [Char] -> Name

118+-- COMMON PACKAGE NAMES

113−toName author project =

114− Name author (Utf8.fromChars project)

115

119

116

120

117{-# NOINLINE dummyName #-}

121{-# NOINLINE dummyName #-}

118dummyName :: Name

122dummyName :: Name

119dummyName =

123dummyName =

120− toName (Utf8.fromChars "author") "project"

124+ Name "author" "project"

121

125

122

126

123{-# NOINLINE kernel #-}

127{-# NOINLINE kernel #-}

124kernel :: Name

128kernel :: Name

125kernel =

129kernel =

126− toName elm "kernel"

130+ Name "elm" "kernel"

127

131

128

132

129{-# NOINLINE core #-}

133{-# NOINLINE core #-}

130core :: Name

134core :: Name

131core =

135core =

132− toName elm "core"

136+ Name "elm" "core"

133

137

134

138

135{-# NOINLINE browser #-}

139{-# NOINLINE browser #-}

136browser :: Name

140browser :: Name

137browser =

141browser =

138− toName elm "browser"

142+ Name "elm" "browser"

139

143

140

144

141{-# NOINLINE virtualDom #-}

145{-# NOINLINE virtualDom #-}

142virtualDom :: Name

146virtualDom :: Name

143virtualDom =

147virtualDom =

144− toName elm "virtual-dom"

148+ Name "elm" "virtual-dom"

145

149

146

150

147{-# NOINLINE html #-}

151{-# NOINLINE html #-}

148html :: Name

152html :: Name

149html =

153html =

150− toName elm "html"

154+ Name "elm" "html"

151

155

152

156

153{-# NOINLINE json #-}

157{-# NOINLINE json #-}

154json :: Name

158json :: Name

155json =

159json =

156− toName elm "json"

160+ Name "elm" "json"

157

161

158

162

159{-# NOINLINE http #-}

163{-# NOINLINE http #-}

160http :: Name

164http :: Name

161http =

165http =

162− toName elm "http"

166+ Name "elm" "http"

163

167

164

168

165{-# NOINLINE url #-}

169{-# NOINLINE url #-}

166url :: Name

170url :: Name

167url =

171url =

168− toName elm "url"

172+ Name "elm" "url"

169

173

170

174

171{-# NOINLINE webgl #-}

175{-# NOINLINE webgl #-}

172webgl :: Name

176webgl :: Name

173webgl =

177webgl =

174− toName elm_explorations "webgl"

178+ Name "elm-explorations" "webgl"

175

179

176

180

177{-# NOINLINE linearAlgebra #-}

181{-# NOINLINE linearAlgebra #-}

178linearAlgebra :: Name

182linearAlgebra :: Name

179linearAlgebra =

183linearAlgebra =

180− toName elm_explorations "linear-algebra"

184+ Name "elm-explorations" "linear-algebra"

181−

182−

183−{-# NOINLINE elm #-}

184−elm :: Author

185−elm =

186− Utf8.fromChars "elm"

187−

188−

189−{-# NOINLINE elm_explorations #-}

190−elm_explorations :: Author

191−elm_explorations =

192− Utf8.fromChars "elm-explorations"

193

185

194

186

195

187

@@ -198,177 +190,54 @@ elm_explorations =

198

190

199suggestions :: Map.Map Name.Name Name

191suggestions :: Map.Map Name.Name Name

200suggestions =

192suggestions =

201− let

202− random = toName elm "random"

203− time = toName elm "time"

204− file = toName elm "file"

205− in

206 Map.fromList

193 Map.fromList

207− [ "Browser" ==> browser

194+ [ ("Browser", browser)

208− , "File" ==> file

209− , "File.Download" ==> file

210− , "File.Select" ==> file

211− , "Html" ==> html

195+ , ("Html", html)

212− , "Html.Attributes" ==> html

213− , "Html.Events" ==> html

214− , "Http" ==> http

196+ , ("Http", http)

215− , "Json.Decode" ==> json

197+ , ("Json.Decode", json)

216− , "Json.Encode" ==> json

198+ , ("Json.Encode", json)

217− , "Random" ==> random

218− , "Time" ==> time

219− , "Url.Parser" ==> url

199+ , ("Url.Parser", url)

220− , "Url" ==> url

200+ , ("Url", url)

221 ]

201 ]

222

202

223

203

224−(==>) :: [Char] -> Name -> (Name.Name, Name)

225−(==>) moduleName package =

226− ( Utf8.fromChars moduleName, package )

227−

228−

229−

230−-- NEARBY NAMES

231−

232−

233−nearbyNames :: Name -> [Name] -> [Name]

234−nearbyNames (Name author1 project1) possibleNames =

235− let

236− authorDist = authorDistance (Utf8.toChars author1)

237− projectDist = projectDistance (Utf8.toChars project1)

238−

239− nameDistance (Name author2 project2) =

240− authorDist author2 + projectDist project2

241− in

242− take 4 $ List.sortOn nameDistance possibleNames

243−

244−

245−authorDistance :: [Char] -> Author -> Int

246−authorDistance given possibility =

247− if possibility == elm || possibility == elm_explorations

248− then 0

249− else abs (Suggest.distance given (Utf8.toChars possibility))

250−

251−

252−projectDistance :: [Char] -> Project -> Int

253−projectDistance given possibility =

254− abs (Suggest.distance given (Utf8.toChars possibility))

255−

256−

257−

258−-- INSTANCES

259−

260−

261−instance Eq Name where

262− (==) (Name author1 project1) (Name author2 project2) =

263− project1 == project2 && author1 == author2

264−

265−

266−instance Eq Canonical where

267− (==) (Canonical package1 version1) (Canonical package2 version2) =

268− version1 == version2 && package1 == package2

269−

270−

271

204

272-- BINARY

205-- BINARY

273

206

274

207

275−instance Binary Name where -- PERF try storing as a Word16

208+instance Binary Name where

276− get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256

209+ get =

277− put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b

210+ liftM2 Name get get

211+

212+ put (Name author project) =

213+ do put author

214+ put project

278

215

279

216

280instance Binary Canonical where

217instance Binary Canonical where

218+ get =

281− get = liftM2 Canonical get get

219+ liftM2 Canonical get get

220+

282− put (Canonical a b) = put a >> put b

221+ put (Canonical name version) =

222+ do put name

223+ put version

283

224

284

225

285

226

286-- JSON

227-- JSON

287

228

288

229

289−decoder :: D.Decoder (Row, Col) Name

230+decoder :: Decode.Decoder BadName Name

290decoder =

231decoder =

291− D.customString parser (,)

232+ do str <- Decode.string

233+ case fromString str of

234+ Right name ->

235+ return name

236+

237+ Left err ->

238+ Decode.failure err

292

239

293

240

294−encode :: Name -> E.Value

241+encode :: Name -> Encode.Value

295encode name =

242encode name =

296− E.chars (toChars name)

243+ Encode.string (toString name)

297−

298−

299−keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name

300−keyDecoder toError =

301− let

302− keyParser =

303− P.specialize (\(r,c) _ _ -> toError r c) parser

304− in

305− D.KeyDecoder keyParser toError

306−

307−

308−

309−-- PARSER

310−

311−

312−parser :: P.Parser (Row, Col) Name

313−parser =

314− do author <- parseName isAlphaOrDigit isAlphaOrDigit

315− P.word1 0x2F {-/-} (,)

316− project <- parseName isLower isLowerOrDigit

317− return (Name author project)

318−

319−

320−parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)

321−parseName isGoodStart isGoodInner =

322− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

323− if pos >= end then

324− eerr row col (,)

325− else

326− let !word = P.unsafeIndex pos in

327− if not (isGoodStart word) then

328− eerr row col (,)

329− else

330− let

331− (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False

332− !len = fromIntegral (minusPtr newPos pos)

333− !newCol = col + len

334− in

335− if isGood && len < 256 then

336− let !newState = P.State src newPos end indent row newCol in

337− cok (Utf8.fromPtr pos newPos) newState

338− else

339− cerr row newCol (,)

340−

341−

342−isLower :: Word8 -> Bool

343−isLower word =

344− 0x61 {-a-} <= word && word <= 0x7A {-z-}

345−

346−

347−isLowerOrDigit :: Word8 -> Bool

348−isLowerOrDigit word =

349− 0x61 {-a-} <= word && word <= 0x7A {-z-}

350− || 0x30 {-0-} <= word && word <= 0x39 {-9-}

351−

352−

353−isAlphaOrDigit :: Word8 -> Bool

354−isAlphaOrDigit word =

355− 0x61 {-a-} <= word && word <= 0x7A {-z-}

356− || 0x41 {-A-} <= word && word <= 0x5A {-Z-}

357− || 0x30 {-0-} <= word && word <= 0x39 {-9-}

358−

359−

360−chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)

361−chompName isGoodChar pos end prevWasDash =

362− if pos >= end then

363− (# not prevWasDash, pos #)

364− else

365− let !word = P.unsafeIndex pos in

366− if isGoodChar word then

367− chompName isGoodChar (plusPtr pos 1) end False

368− else if word == 0x2D {---} then

369− if prevWasDash then

370− (# False, pos #)

371− else

372− chompName isGoodChar (plusPtr pos 1) end True

373− else

374− (# True, pos #)

compiler/src/Elm/String.hsdeleted−133

@@ -1,133 +0,0 @@

1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}

3−module Elm.String

4− ( String

5− , toChars

6− , toBuilder

7− , Chunk(..)

8− , fromChunks

9− )

10− where

11−

12−

13−import Prelude hiding (String)

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

15−import Data.Bits ((.&.), shiftR)

16−import qualified Data.ByteString.Builder as B

17−import qualified Data.Utf8 as Utf8

18−import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

19−import GHC.Exts (RealWorld, Ptr)

20−import GHC.IO (stToIO, unsafeDupablePerformIO)

21−import GHC.ST (ST)

22−import GHC.Word (Word8)

23−

24−

25−

26−-- STRINGS

27−

28−

29−type String =

30− Utf8.Utf8 ELM_STRING

31−

32−

33−data ELM_STRING

34−

35−

36−

37−-- HELPERS

38−

39−

40−toChars :: String -> [Char]

41−toChars =

42− Utf8.toChars

43−

44−

45−{-# INLINE toBuilder #-}

46−toBuilder :: String -> B.Builder

47−toBuilder =

48− Utf8.toBuilder

49−

50−

51−

52−-- FROM CHUNKS

53−

54−

55−data Chunk

56− = Slice (Ptr Word8) Int

57− | Escape Word8

58− | CodePoint Int

59−

60−

61−fromChunks :: [Chunk] -> String

62−fromChunks chunks =

63− unsafeDupablePerformIO (stToIO (

64− do let !len = sum (map chunkToWidth chunks)

65− mba <- newByteArray len

66− writeChunks mba 0 chunks

67− freeze mba

68− ))

69−

70−

71−chunkToWidth :: Chunk -> Int

72−chunkToWidth chunk =

73− case chunk of

74− Slice _ len -> len

75− Escape _ -> 2

76− CodePoint c -> if c < 0xFFFF then 6 else 12

77−

78−

79−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

80−writeChunks mba offset chunks =

81− case chunks of

82− [] ->

83− return ()

84−

85− chunk : chunks ->

86− case chunk of

87− Slice ptr len ->

88− do copyFromPtr ptr mba offset len

89− let !newOffset = offset + len

90− writeChunks mba newOffset chunks

91−

92− Escape word ->

93− do writeWord8 mba offset 0x5C {- \ -}

94− writeWord8 mba (offset + 1) word

95− let !newOffset = offset + 2

96− writeChunks mba newOffset chunks

97−

98− CodePoint code ->

99− if code < 0xFFFF then

100− do writeCode mba offset code

101− let !newOffset = offset + 6

102− writeChunks mba newOffset chunks

103− else

104− do let (hi,lo) = divMod (code - 0x10000) 0x400

105− writeCode mba (offset ) (hi + 0xD800)

106− writeCode mba (offset + 6) (lo + 0xDC00)

107− let !newOffset = offset + 12

108− writeChunks mba newOffset chunks

109−

110−

111−writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

112−writeCode mba offset code =

113− do writeWord8 mba offset 0x5C {- \ -}

114− writeWord8 mba (offset + 1) 0x75 {- u -}

115− writeHex mba (offset + 2) (shiftR code 12)

116− writeHex mba (offset + 3) (shiftR code 8)

117− writeHex mba (offset + 4) (shiftR code 4)

118− writeHex mba (offset + 5) code

119−

120−

121−writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

122−writeHex mba !offset !bits =

123− do let !n = fromIntegral bits .&. 0x0F

124− writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)

125−

126−

127−

128−-- BINARY

129−

130−

131−instance Binary (Utf8.Utf8 ELM_STRING) where

132− get = Utf8.getVeryLong

133− put = Utf8.putVeryLong

compiler/src/Elm/Version.hs+43−73

@@ -1,5 +1,3 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE BangPatterns, UnboxedTuples #-}

3module Elm.Version

1module Elm.Version

4 ( Version(..)

2 ( Version(..)

5 , one

3 , one

@@ -9,11 +7,10 @@ module Elm.Version

9 , bumpMinor

7 , bumpMinor

10 , bumpMajor

8 , bumpMajor

11 , toChars

9 , toChars

12− --

10+ , toString

11+ , fromString

13 , decoder

12 , decoder

14 , encode

13 , encode

15− --

16− , parser

17 )

14 )

18 where

15 where

19

16

@@ -21,15 +18,13 @@ module Elm.Version

21import Prelude hiding (max)

18import Prelude hiding (max)

22import Control.Monad (liftM3)

19import Control.Monad (liftM3)

23import Data.Binary (Binary, get, put, getWord8, putWord8)

20import Data.Binary (Binary, get, put, getWord8, putWord8)

21+import qualified Data.Utf8 as Utf8

24import qualified Data.Version as Version

22import qualified Data.Version as Version

25−import Data.Word (Word8, Word16)

23+import Data.Word (Word16)

26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

27import qualified Paths_elm

24import qualified Paths_elm

28

25

29import qualified Json.Decode as D

26import qualified Json.Decode as D

30import qualified Json.Encode as E

27import qualified Json.Encode as E

31−import qualified Parse.Primitives as P

32−import Parse.Primitives (Row, Col)

33

28

34

29

35

30

@@ -91,26 +86,58 @@ bumpMajor (Version major _minor _patch) =

91

86

92

87

93

88

94−-- TO CHARS

89+-- TO STRING

95

90

96

91

97−toChars :: Version -> [Char]

92+toChars :: Version -> String

93+toChars vsn =

94+ Utf8.toChars (toString vsn)

95+

96+

97+toString :: Version -> Utf8.String

98−toChars (Version major minor patch) =

98+toString (Version major minor patch) =

99− show major ++ '.' : show minor ++ '.' : show patch

99+ Utf8.join 0x2E {- . -}

100+ [ Utf8.fromWord16 major

101+ , Utf8.fromWord16 minor

102+ , Utf8.fromWord16 patch

103+ ]

104+

105+

106+

107+-- FROM STRING

108+

109+

110+fromString :: Utf8.String -> Maybe Version

111+fromString str =

112+ case Utf8.split 0x2E {- . -} str of

113+ [major, minor, patch] ->

114+ Version

115+ <$> Utf8.toWord16 major

116+ <*> Utf8.toWord16 minor

117+ <*> Utf8.toWord16 patch

118+

119+ _ ->

120+ Nothing

100

121

101

122

102

123

103-- JSON

124-- JSON

104

125

105

126

106−decoder :: D.Decoder (Row, Col) Version

127+decoder :: D.Decoder Utf8.String Version

107decoder =

128decoder =

108− D.customString parser (,)

129+ do str <- D.string

130+ case fromString str of

131+ Just version ->

132+ return version

133+

134+ Nothing ->

135+ D.failure str

109

136

110

137

111encode :: Version -> E.Value

138encode :: Version -> E.Value

112encode version =

139encode version =

113− E.chars (toChars version)

140+ E.string (toString version)

114

141

115

142

116

143

@@ -137,60 +164,3 @@ instance Binary Version where

137 put major

164 put major

138 put minor

165 put minor

139 put patch

166 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.hs+10−11

@@ -29,23 +29,22 @@ sandwich moduleName javascript =

29

30<body>

31

32−<pre id="elm"></pre>

32+<pre id="elm">

33+This is a headless program, meaning there is nothing to show here.

34+

35+I started the program anyway though!

36+

37+You can access it as `app` in the developer console.

38+</pre>

33

39

34<script>

40<script>

35−try {

36|] <> javascript <> [r|

41|] <> javascript <> [r|

37

42

43+try {

38 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });

44 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });

39−}

40−catch (e)

45+} catch (e) {

41−{

42 // display initialization errors (e.g. bad flags, infinite recursion)

46 // 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.getElementById("elm").innerText = e;

47− document.body.insertBefore(header, pre);

48− pre.innerText = e;

49 throw e;

48 throw e;

50}

49}

51</script>

50</script>

compiler/src/Generate/JavaScript.hs+55−76

@@ -2,7 +2,6 @@

2module Generate.JavaScript

3 ( generate

4 , generateForRepl

5− , generateForReplEndpoint

6 )

5 )

7 where

6 where

8

7

@@ -86,9 +85,7 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _

86 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

85 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

87 evalState = addGlobal mode graph debugState (Opt.Global home name)

86 evalState = addGlobal mode graph debugState (Opt.Global home name)

88 in

87 in

89− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"

90− <> Functions.functions

91− <> stateToBuilder evalState

88+ stateToBuilder evalState

92 <> print ansi localizer home name tipe

89 <> print ansi localizer home name tipe

93

90

94

91

@@ -100,47 +97,14 @@ print ansi localizer home name tipe =

100 tipeDoc = RT.canToDoc localizer RT.None tipe

97 tipeDoc = RT.canToDoc localizer RT.None tipe

101 bool = if ansi then "true" else "false"

98 bool = if ansi then "true" else "false"

102 in

99 in

103− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\

100+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\

104− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\

101+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\

105− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\

102+ \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\

103+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\

107− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\

104+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\

108− \} else {\n\

105+ \} else {\n\

109− \ _print(' : ' + _type);\n\

106+ \ _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"

107+ \}\n"

144

108

145

109

146

110

@@ -261,7 +225,7 @@ addKernel (State revKernels revBuilders seen) kernel =

261

225

262var :: Opt.Global -> Expr.Code -> JS.Stmt

226var :: Opt.Global -> Expr.Code -> JS.Stmt

263var (Opt.Global home name) code =

227var (Opt.Global home name) code =

264− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)

228+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]

265

229

266

230

267isDebugger :: Opt.Global -> Bool

231isDebugger :: Opt.Global -> Bool

@@ -292,7 +256,7 @@ generateCycle mode (Opt.Global home _) names values functions =

292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"

256 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"

293 <> drawCycle names

257 <> drawCycle names

294 <> "\\n\\nThese errors are very tricky, so read "

258 <> "\\n\\nThese errors are very tricky, so read "

295− <> B.stringUtf8 (D.makeNakedLink "bad-recursion")

259+ <> B.stringUtf8 (D.makeNakedLink "halting-problem")

296 <> " to learn how to fix it!"

260 <> " to learn how to fix it!"

297 ]

261 ]

298

262

@@ -301,10 +265,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt

301generateCycleFunc mode home def =

265generateCycleFunc mode home def =

302 case def of

266 case def of

303 Opt.Def name expr ->

267 Opt.Def name expr ->

304− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))

268+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]

305

269

306 Opt.TailDef name args expr ->

270 Opt.TailDef name args expr ->

307− JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))

271+ JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]

308

272

309

273

310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt

274generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt

@@ -320,9 +284,9 @@ generateRealCycle home (name, _) =

320 realName = JsName.fromGlobal home name

284 realName = JsName.fromGlobal home name

321 in

285 in

322 JS.Block

286 JS.Block

323− [ JS.Var realName (JS.Call (JS.Ref safeName) [])

287+ [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]

324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $

288 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $

325− JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]

289+ JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]

326 ]

290 ]

327

291

328

292

@@ -350,7 +314,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder

350addChunk mode chunk builder =

314addChunk mode chunk builder =

351 case chunk of

315 case chunk of

352 K.JS javascript ->

316 K.JS javascript ->

353− B.byteString javascript <> builder

317+ Utf8.toBuilder javascript <> builder

354

318

355 K.ElmVar home name ->

319 K.ElmVar home name ->

356 JsName.toBuilder (JsName.fromGlobal home name) <> builder

320 JsName.toBuilder (JsName.fromGlobal home name) <> builder

@@ -390,13 +354,16 @@ addChunk mode chunk builder =

390

354

391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt

355generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt

392generateEnum mode global@(Opt.Global home name) index =

356generateEnum mode global@(Opt.Global home name) index =

393− JS.Var (JsName.fromGlobal home name) $

357+ let

358+ definition =

394− case mode of

359+ case mode of

395− Mode.Dev _ ->

360+ Mode.Dev _ ->

396− Expr.codeToExpr (Expr.generateCtor mode global index 0)

361+ Expr.codeToExpr (Expr.generateCtor mode global index 0)

397

362

398− Mode.Prod _ ->

363+ Mode.Prod _ ->

399− JS.Int (Index.toMachine index)

364+ JS.Int (Index.toMachine index)

365+ in

366+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

400

367

401

368

402

369

@@ -405,13 +372,16 @@ generateEnum mode global@(Opt.Global home name) index =

405

372

406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt

373generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt

407generateBox mode global@(Opt.Global home name) =

374generateBox mode global@(Opt.Global home name) =

408− JS.Var (JsName.fromGlobal home name) $

375+ let

376+ definition =

409− case mode of

377+ case mode of

410− Mode.Dev _ ->

378+ Mode.Dev _ ->

411− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

379+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

412

380

413− Mode.Prod _ ->

381+ Mode.Prod _ ->

414− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

382+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

383+ in

384+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

415

385

416

386

417{-# NOINLINE identity #-}

387{-# NOINLINE identity #-}

@@ -426,11 +396,14 @@ identity =

426

396

427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt

397generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt

428generatePort mode (Opt.Global home name) makePort converter =

398generatePort mode (Opt.Global home name) makePort converter =

429− JS.Var (JsName.fromGlobal home name) $

399+ let

400+ definition =

430− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))

401+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))

431− [ JS.String (Name.toBuilder name)

402+ [ JS.String (Name.toBuilder name)

432− , Expr.codeToExpr (Expr.generate mode converter)

403+ , Expr.codeToExpr (Expr.generate mode converter)

433− ]

404+ ]

405+ in

406+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

434

407

435

408

436

409

@@ -458,9 +431,11 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)

458

431

459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt

432generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt

460generateLeaf home@(ModuleName.Canonical _ moduleName) name =

433generateLeaf home@(ModuleName.Canonical _ moduleName) name =

461− JS.Var (JsName.fromGlobal home name) $

434+ let

435+ definition =

462− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

436+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

463−

437+ in

438+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

464

439

465

440

466{-# NOINLINE leaf #-}

441{-# NOINLINE leaf #-}

@@ -534,7 +509,7 @@ generateExports mode (Trie maybeMain subs) =

534 <> List.foldl' (addSubTrie mode) "}" otherSubTries

509 <> List.foldl' (addSubTrie mode) "}" otherSubTries

535

510

536

511

537−addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder

512+addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder

538addSubTrie mode end (name, trie) =

513addSubTrie mode end (name, trie) =

539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end

514 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end

540

515

@@ -546,7 +521,7 @@ addSubTrie mode end (name, trie) =

546data Trie =

521data Trie =

547 Trie

522 Trie

548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)

523 { _main :: Maybe (ModuleName.Canonical, Opt.Main)

549− , _subs :: Map.Map Name.Name Trie

524+ , _subs :: Map.Map Utf8.String Trie

550 }

525 }

551

526

552

527

@@ -557,10 +532,14 @@ emptyTrie =

557

532

558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie

533addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie

559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =

534addToTrie home@(ModuleName.Canonical _ moduleName) main trie =

535+ let

536+ segments =

537+ Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)

538+ in

560− merge trie $ segmentsToTrie home (Name.splitDots moduleName) main

539+ merge trie $ segmentsToTrie home segments main

561

540

562

541

563−segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie

542+segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie

564segmentsToTrie home segments main =

543segmentsToTrie home segments main =

565 case segments of

544 case segments of

566 [] ->

545 [] ->

compiler/src/Generate/JavaScript/Builder.hs+217−207

@@ -16,7 +16,6 @@ module Generate.JavaScript.Builder

16

17import Prelude hiding (lines)

18import qualified Data.List as List

19−import qualified Data.ByteString as BS

20import Data.ByteString.Builder as B

19import Data.ByteString.Builder as B

21import Data.Monoid ((<>))

20import Data.Monoid ((<>))

22import qualified Generate.JavaScript.Name as Name

21import qualified Generate.JavaScript.Name as Name

@@ -28,19 +27,6 @@ import qualified Json.Encode as Json

28-- EXPRESSIONS

27-- EXPRESSIONS

29

28

30

29

31−-- NOTE: I tried making this create a B.Builder directly.

32−--

33−-- The hope was that it'd allocate less and speed things up, but it seemed

34−-- to be neutral for perf.

35−--

36−-- The downside is that Generate.JavaScript.Expression inspects the

37−-- structure of Expr and Stmt on some occassions to try to strip out

38−-- unnecessary closures. I think these closures are already avoided

39−-- by other logic in code gen these days, but I am not 100% certain.

40−--

41−-- For this to be worth it, I think it would be necessary to avoid

42−-- returning tuples when generating expressions.

43−--

44data Expr

30data Expr

45 = String Builder

31 = String Builder

46 | Float Builder

32 | Float Builder

@@ -51,13 +37,13 @@ data Expr

51 | Array [Expr]

37 | Array [Expr]

52 | Object [(Name, Expr)]

38 | Object [(Name, Expr)]

53 | Ref Name

39 | Ref Name

54− | Access Expr Name -- foo.bar

40+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1

55− | Index Expr Expr -- foo[bar]

41+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1

56 | Prefix PrefixOp Expr

42 | Prefix PrefixOp Expr

57 | Infix InfixOp Expr Expr

43 | Infix InfixOp Expr Expr

58 | If Expr Expr Expr

44 | If Expr Expr Expr

59 | Assign LValue Expr

45 | Assign LValue Expr

60− | Call Expr [Expr]

46+ | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3

61 | Function (Maybe Name) [Name] [Stmt]

47 | Function (Maybe Name) [Name] [Stmt]

62

48

63

49

@@ -72,21 +58,20 @@ data LValue

72

58

73

59

74data Stmt

60data Stmt

75− = Block [Stmt]

61+ = Block [Stmt] -- {stmts}

76− | EmptyStmt

62+ | EmptyStmt -- ;

77− | ExprStmt Expr

63+ | ExprStmt Expr -- expr;

78− | IfStmt Expr Stmt Stmt

64+ | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2

79− | Switch Expr [Case]

65+ | Switch Expr [Case] -- switch (e) clauses

80− | While Expr Stmt

66+ | While Expr Stmt -- while (e) do stmt

81− | Break (Maybe Name)

67+ | Break (Maybe Name) -- break lab;

82− | Continue (Maybe Name)

68+ | Continue (Maybe Name) -- continue lab;

83− | Labelled Name Stmt

69+ | Labelled Name Stmt -- lab: stmt

84− | Try Stmt Name Stmt

70+ | Try Stmt Name Stmt -- try stmt catch (x) stmt

85− | Throw Expr

71+ | Throw Expr -- throw expr;

86− | Return Expr

72+ | Return (Maybe Expr) -- return expr;

87− | Var Name Expr

88− | Vars [(Name, Expr)]

73+ | Var [(Name, Maybe Expr)] -- var x, y=42;

89− | FunctionStmt Name [Name] [Stmt]

74+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}

90

75

91

76

92data Case

77data Case

@@ -99,31 +84,37 @@ data Case

99

84

100

85

101data InfixOp

86data InfixOp

102− = OpAdd -- +

87+ = OpLT -- <

103− | OpSub -- -

88+ | OpLEq -- <=

89+ | OpGT -- >

90+ | OpGEq -- >=

91+ | OpIn -- in

92+ | OpInstanceof -- instanceof

93+ | OpEq -- ==

94+ | OpNEq -- !=

95+ | OpStrictEq -- ===

96+ | OpStrictNEq -- !==

97+ | OpLAnd -- &&

98+ | OpLOr -- ||

104 | OpMul -- *

99 | OpMul -- *

105 | OpDiv -- /

100 | OpDiv -- /

106 | OpMod -- %

101 | OpMod -- %

107− | OpEq -- ===

102+ | OpSub -- -

108− | OpNe -- !==

109− | OpLt -- <

110− | OpLe -- <=

111− | OpGt -- >

112− | OpGe -- >=

113− | OpAnd -- &&

114− | OpOr -- ||

115− | OpBitwiseAnd -- &

116− | OpBitwiseXor -- ^

117− | OpBitwiseOr -- |

118− | OpLShift -- <<

103+ | OpLShift -- <<

119− | OpSpRShift -- >>

104+ | OpSpRShift -- >>

120− | OpZfRShift -- >>>

105+ | OpZfRShift -- >>>

106+ | OpBAnd -- &

107+ | OpBXor -- ^

108+ | OpBOr -- |

109+ | OpAdd -- +

121

110

122

111

123data PrefixOp

112data PrefixOp

124− = PrefixNot -- !

113+ = PrefixLNot -- !

125− | PrefixNegate -- -

114+ | PrefixBNot -- ~

126− | PrefixComplement -- ~

115+ | PrefixPlus -- +

116+ | PrefixMinus -- -

117+ | PrefixTypeof -- typeof

127

118

128

119

129

120

@@ -132,40 +123,21 @@ data PrefixOp

132

123

133stmtToBuilder :: Stmt -> Builder

124stmtToBuilder :: Stmt -> Builder

134stmtToBuilder stmts =

125stmtToBuilder stmts =

135− fromStmt levelZero stmts

126+ fromStmt "" stmts

136

127

137

128

138exprToBuilder :: Expr -> Builder

129exprToBuilder :: Expr -> Builder

139exprToBuilder expr =

130exprToBuilder expr =

140− snd $ fromExpr levelZero Whatever expr

131+ snd $ fromExpr "" Whatever expr

141−

142−

143−

144−-- INDENT LEVEL

145−

146−

147−data Level =

148− Level Builder Level

149−

150

132

151−levelZero :: Level

152−levelZero =

153− Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))

154

133

155

134

156−makeLevel :: Int -> BS.ByteString -> Level

135+-- HELPERS

157−makeLevel level oldTabs =

158− let

159− tabs =

160− if level <= BS.length oldTabs

161− then oldTabs

162− else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}

163− in

164− Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)

165−

166

136

167

137

168−-- HELPERS

138+deeper :: Builder -> Builder

139+deeper indent =

140+ "\t" <> indent

169

141

170

142

171commaSep :: [Builder] -> Builder

143commaSep :: [Builder] -> Builder

@@ -173,52 +145,52 @@ commaSep builders =

173 mconcat (List.intersperse ", " builders)

145 mconcat (List.intersperse ", " builders)

174

146

175

147

176−commaNewlineSep :: Level -> [Builder] -> Builder

148+commaNewlineSep :: Builder -> [Builder] -> Builder

177−commaNewlineSep (Level _ (Level deeperIndent _)) builders =

149+commaNewlineSep indent builders =

178− mconcat (List.intersperse (",\n" <> deeperIndent) builders)

150+ mconcat (List.intersperse (",\n" <> deeper indent) builders)

179

151

180

152

181

153

182-- STATEMENTS

154-- STATEMENTS

183

155

184

156

185−fromStmtBlock :: Level -> [Stmt] -> Builder

157+fromStmtBlock :: Builder -> [Stmt] -> Builder

186−fromStmtBlock level stmts =

158+fromStmtBlock indent stmts =

187− mconcat (map (fromStmt level) stmts)

159+ mconcat (map (fromStmt indent) stmts)

188

160

189

161

190−fromStmt :: Level -> Stmt -> Builder

162+fromStmt :: Builder -> Stmt -> Builder

191−fromStmt level@(Level indent nextLevel) statement =

163+fromStmt indent statement =

192 case statement of

164 case statement of

193 Block stmts ->

165 Block stmts ->

194− fromStmtBlock level stmts

166+ fromStmtBlock indent stmts

195

167

196 EmptyStmt ->

168 EmptyStmt ->

197 mempty

169 mempty

198

170

199 ExprStmt expr ->

171 ExprStmt expr ->

200− indent <> snd (fromExpr level Whatever expr) <> ";\n"

172+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"

201

173

202 IfStmt condition thenStmt elseStmt ->

174 IfStmt condition thenStmt elseStmt ->

203 mconcat

175 mconcat

204− [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"

176+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"

205− , fromStmt nextLevel thenStmt

177+ , fromStmt (deeper indent) thenStmt

206 , indent, "} else {\n"

178 , indent, "} else {\n"

207− , fromStmt nextLevel elseStmt

179+ , fromStmt (deeper indent) elseStmt

208 , indent, "}\n"

180 , indent, "}\n"

209 ]

181 ]

210

182

211 Switch expr clauses ->

183 Switch expr clauses ->

212 mconcat

184 mconcat

213− [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"

185+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"

214− , mconcat (map (fromClause nextLevel) clauses)

186+ , mconcat (map (fromClause (deeper indent)) clauses)

215 , indent, "}\n"

187 , indent, "}\n"

216 ]

188 ]

217

189

218 While expr stmt ->

190 While expr stmt ->

219 mconcat

191 mconcat

220− [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"

192+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"

221− , fromStmt nextLevel stmt

193+ , fromStmt (deeper indent) stmt

222 , indent, "}\n"

194 , indent, "}\n"

223 ]

195 ]

224

196

@@ -237,37 +209,37 @@ fromStmt level@(Level indent nextLevel) statement =

237 Labelled label stmt ->

209 Labelled label stmt ->

238 mconcat

210 mconcat

239 [ indent, Name.toBuilder label, ":\n"

211 [ indent, Name.toBuilder label, ":\n"

240− , fromStmt level stmt

212+ , fromStmt indent stmt

241 ]

213 ]

242

214

243 Try tryStmt errorName catchStmt ->

215 Try tryStmt errorName catchStmt ->

244 mconcat

216 mconcat

245 [ indent, "try {\n"

217 [ indent, "try {\n"

246− , fromStmt nextLevel tryStmt

218+ , fromStmt (deeper indent) tryStmt

247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"

219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"

248− , fromStmt nextLevel catchStmt

220+ , fromStmt (deeper indent) catchStmt

249 , indent, "}\n"

221 , indent, "}\n"

250 ]

222 ]

251

223

252 Throw expr ->

224 Throw expr ->

253− indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"

225+ "throw " <> snd (fromExpr indent Whatever expr) <> ";"

254

226

255− Return expr ->

227+ Return Nothing ->

256− indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"

228+ indent <> "return;\n"

257

229

258− Var name expr ->

230+ Return (Just expr) ->

259− indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"

231+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"

260

232

261− Vars [] ->

233+ Var [] ->

262 mempty

234 mempty

263

235

264− Vars vars ->

236+ Var vars ->

265− indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"

237+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"

266

238

267 FunctionStmt name args stmts ->

239 FunctionStmt name args stmts ->

268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

269 <>

241 <>

270− fromStmtBlock nextLevel stmts

242+ fromStmtBlock (deeper indent) stmts

271 <>

243 <>

272 indent <> "}\n"

244 indent <> "}\n"

273

245

@@ -276,25 +248,30 @@ fromStmt level@(Level indent nextLevel) statement =

276-- SWITCH CLAUSES

248-- SWITCH CLAUSES

277

249

278

250

279−fromClause :: Level -> Case -> Builder

251+fromClause :: Builder -> Case -> Builder

280−fromClause level@(Level indent nextLevel) clause =

252+fromClause indent clause =

281 case clause of

253 case clause of

282 Case expr stmts ->

254 Case expr stmts ->

283− indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"

255+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"

284− <> fromStmtBlock nextLevel stmts

256+ <> fromStmtBlock (deeper indent) stmts

285

257

286 Default stmts ->

258 Default stmts ->

287 indent <> "default:\n"

259 indent <> "default:\n"

288− <> fromStmtBlock nextLevel stmts

260+ <> fromStmtBlock (deeper indent) stmts

289

261

290

262

291

263

292-- VAR DECLS

264-- VAR DECLS

293

265

294

266

295−varToBuilder :: Level -> (Name, Expr) -> Builder

267+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder

296−varToBuilder level (name, expr) =

268+varToBuilder indent (name, maybeExpr) =

269+ case maybeExpr of

270+ Nothing ->

271+ Name.toBuilder name

272+

273+ Just expr ->

297− Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)

274+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)

298

275

299

276

300

277

@@ -312,11 +289,12 @@ merge a b =

312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])

289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])

313linesMap func xs =

290linesMap func xs =

314 let

291 let

292+ pairs =

315− pairs = map func xs

293+ map func xs

316 in

294 in

317− ( any ((==) Many . fst) pairs

295+ ( any ((==) Many . fst) pairs

318− , map snd pairs

296+ , map snd pairs

319− )

297+ )

320

298

321

299

322data Grouping = Atomic | Whatever

300data Grouping = Atomic | Whatever

@@ -332,23 +310,23 @@ parensFor grouping builder =

332 builder

310 builder

333

311

334

312

335−fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)

313+fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)

336−fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =

314+fromExpr indent grouping expression =

337 case expression of

315 case expression of

338 String string ->

316 String string ->

339− ( One, "'" <> string <> "'" )

317+ (One, "'" <> string <> "'")

340

318

341 Float float ->

319 Float float ->

342− ( One, float )

320+ (One, float)

343

321

344 Int n ->

322 Int n ->

345− ( One, B.intDec n )

323+ (One, B.intDec n)

346

324

347 Bool bool ->

325 Bool bool ->

348− ( One, if bool then "true" else "false" )

326+ (One, if bool then "true" else "false")

349

327

350 Null ->

328 Null ->

351− ( One, "null" )

329+ (One, "null")

352

330

353 Json json ->

331 Json json ->

354 ( One, Json.encodeUgly json )

332 ( One, Json.encodeUgly json )

@@ -356,90 +334,111 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi

356 Array exprs ->

334 Array exprs ->

357 (,) Many $

335 (,) Many $

358 let

336 let

337+ (anyMany, builders) =

359− (anyMany, builders) = linesMap (fromExpr level Whatever) exprs

338+ linesMap (fromExpr indent Whatever) exprs

360 in

339 in

361− if anyMany then

340+ if anyMany then

362− "[\n"

341+ "[\n"

363− <> deeperIndent

342+ <> deeper indent

364− <> commaNewlineSep level builders

343+ <> commaNewlineSep indent builders

365− <> "\n" <> indent <> "]"

344+ <> "\n" <> indent <> "]"

345+

366− else

346+ else

367− "[" <> commaSep builders <> "]"

347+ "[" <> commaSep builders <> "]"

368

348

369 Object fields ->

349 Object fields ->

370 (,) Many $

350 (,) Many $

371 let

351 let

352+ deeperIndent =

353+ deeper indent

354+

355+ (anyMany, builders) =

372− (anyMany, builders) = linesMap (fromField nextLevel) fields

356+ linesMap (fromField deeperIndent) fields

373 in

357 in

374− if anyMany then

358+ if anyMany then

375− "{\n"

359+ "{\n"

376− <> deeperIndent

360+ <> deeperIndent

377− <> commaNewlineSep level builders

361+ <> commaNewlineSep indent builders

378− <> "\n" <> indent <> "}"

362+ <> "\n" <> indent <> "}"

363+

379− else

364+ else

380− "{" <> commaSep builders <> "}"

365+ "{" <> commaSep builders <> "}"

381

366

382 Ref name ->

367 Ref name ->

383− ( One, Name.toBuilder name )

368+ (One, Name.toBuilder name)

384

369

385 Access expr field ->

370 Access expr field ->

386− makeDot level expr field

371+ makeDot indent expr field

387

372

388 Index expr bracketedExpr ->

373 Index expr bracketedExpr ->

389− makeBracketed level expr bracketedExpr

374+ makeBracketed indent expr bracketedExpr

390

375

391 Prefix op expr ->

376 Prefix op expr ->

392 let

377 let

378+ (lines, builder) =

393− (lines, builder) = fromExpr level Atomic expr

379+ fromExpr indent Atomic expr

394 in

380 in

395− ( lines

381+ ( lines

396− , parensFor grouping (fromPrefix op <> builder)

382+ , parensFor grouping (fromPrefix op <> builder)

397− )

383+ )

398

384

399 Infix op leftExpr rightExpr ->

385 Infix op leftExpr rightExpr ->

400 let

386 let

387+ (leftLines, left) =

401− (leftLines , left ) = fromExpr level Atomic leftExpr

388+ fromExpr indent Atomic leftExpr

389+

390+ (rightLines, right) =

402− (rightLines, right) = fromExpr level Atomic rightExpr

391+ fromExpr indent Atomic rightExpr

403 in

392 in

404− ( merge leftLines rightLines

393+ ( merge leftLines rightLines

405− , parensFor grouping (left <> fromInfix op <> right)

394+ , parensFor grouping (left <> fromInfix op <> right)

406− )

395+ )

407

396

408 If condExpr thenExpr elseExpr ->

397 If condExpr thenExpr elseExpr ->

409 let

398 let

410− condB = snd (fromExpr level Atomic condExpr)

399+ condB = snd (fromExpr indent Atomic condExpr)

411− thenB = snd (fromExpr level Atomic thenExpr)

400+ thenB = snd (fromExpr indent Atomic thenExpr)

412− elseB = snd (fromExpr level Atomic elseExpr)

401+ elseB = snd (fromExpr indent Atomic elseExpr)

413 in

402 in

414− ( Many

403+ ( Many

415− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

404+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

416− )

405+ )

417

406

418 Assign lValue expr ->

407 Assign lValue expr ->

419 let

408 let

409+ (leftLines, left) =

420− (leftLines , left ) = fromLValue level lValue

410+ fromLValue indent lValue

411+

412+ (rightLines, right) =

421− (rightLines, right) = fromExpr level Whatever expr

413+ fromExpr indent Whatever expr

422 in

414 in

423− ( merge leftLines rightLines

415+ ( merge leftLines rightLines

424− , parensFor grouping (left <> " = " <> right)

416+ , parensFor grouping (left <> " = " <> right)

425− )

417+ )

426

418

427 Call function args ->

419 Call function args ->

428 (,) Many $

420 (,) Many $

429 let

421 let

422+ deeperIndent =

423+ deeper indent

424+

425+ funcB =

430− (_ , funcB) = fromExpr level Atomic function

426+ snd (fromExpr indent Atomic function)

427+

428+ (anyMany, argsB) =

431− (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args

429+ linesMap (fromExpr deeperIndent Whatever) args

432 in

430 in

433− if anyMany then

431+ if anyMany then

434− funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"

432+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"

433+

435− else

434+ else

436− funcB <> "(" <> commaSep argsB <> ")"

435+ funcB <> "(" <> commaSep argsB <> ")"

437

436

438 Function maybeName args stmts ->

437 Function maybeName args stmts ->

439 (,) Many $

438 (,) Many $

440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

441 <>

440 <>

442− fromStmtBlock nextLevel stmts

441+ fromStmtBlock (deeper indent) stmts

443 <>

442 <>

444 indent <> "}"

443 indent <> "}"

445

444

@@ -448,50 +447,55 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi

448-- FIELDS

447-- FIELDS

449

448

450

449

451−fromField :: Level -> (Name, Expr) -> (Lines, Builder)

450+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)

452−fromField level (field, expr) =

451+fromField indent (field, expr) =

453 let

452 let

453+ (lines, builder) =

454− (lines, builder) = fromExpr level Whatever expr

454+ fromExpr indent Whatever expr

455 in

456− ( lines

456+ ( lines

457− , Name.toBuilder field <> ": " <> builder

457+ , Name.toBuilder field <> ": " <> builder

458− )

458+ )

459

460

461

462-- VALUES

463

464

465−fromLValue :: Level -> LValue -> (Lines, Builder)

465+fromLValue :: Builder -> LValue -> (Lines, Builder)

466−fromLValue level lValue =

466+fromLValue indent lValue =

467 case lValue of

468 LRef name ->

469 (One, Name.toBuilder name)

470

471 LDot expr field ->

472− makeDot level expr field

472+ makeDot indent expr field

473

474 LBracket expr bracketedExpr ->

475− makeBracketed level expr bracketedExpr

475+ makeBracketed indent expr bracketedExpr

476

477

478−makeDot :: Level -> Expr -> Name -> (Lines, Builder)

478+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)

479−makeDot level expr field =

479+makeDot indent expr field =

480 let

481+ (lines, builder) =

481− (lines, builder) = fromExpr level Atomic expr

482+ fromExpr indent Atomic expr

482 in

483 in

483− (lines, builder <> "." <> Name.toBuilder field)

484+ (lines, builder <> "." <> Name.toBuilder field)

484

485

486

486−makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)

487+makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)

487−makeBracketed level expr bracketedExpr =

488+makeBracketed indent expr bracketedExpr =

488 let

489 let

490+ (lines, builder) =

489− (lines , builder ) = fromExpr level Atomic expr

491+ fromExpr indent Atomic expr

492+

490− (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr

493+ (bracketedLines, bracketedBuilder) =

494+ fromExpr indent Whatever bracketedExpr

491 in

495 in

492− ( merge lines bracketedLines

496+ ( merge lines bracketedLines

493− , builder <> "[" <> bracketedBuilder <> "]"

497+ , builder <> "[" <> bracketedBuilder <> "]"

494− )

498+ )

495

499

496

500

497

501

@@ -501,30 +505,36 @@ makeBracketed level expr bracketedExpr =

501fromPrefix :: PrefixOp -> Builder

505fromPrefix :: PrefixOp -> Builder

502fromPrefix op =

506fromPrefix op =

503 case op of

507 case op of

504− PrefixNot -> "!"

508+ PrefixLNot -> "!"

505− PrefixNegate -> "-"

509+ PrefixBNot -> "~"

506− PrefixComplement -> "~"

510+ PrefixPlus -> "+"

511+ PrefixMinus -> "-"

512+ PrefixTypeof -> "typeof "

507

513

508

514

509fromInfix :: InfixOp -> Builder

515fromInfix :: InfixOp -> Builder

510fromInfix op =

516fromInfix op =

511 case op of

517 case op of

512− OpAdd -> " + "

518+ OpLT -> " < "

513− OpSub -> " - "

519+ OpLEq -> " <= "

520+ OpGT -> " > "

521+ OpGEq -> " >= "

522+ OpIn -> " in "

523+ OpInstanceof -> " instanceof "

524+ OpEq -> " == "

525+ OpNEq -> " != "

526+ OpStrictEq -> " === "

527+ OpStrictNEq -> " !== "

528+ OpLAnd -> " && "

529+ OpLOr -> " || "

514 OpMul -> " * "

530 OpMul -> " * "

515 OpDiv -> " / "

531 OpDiv -> " / "

516 OpMod -> " % "

532 OpMod -> " % "

517− OpEq -> " === "

533+ OpSub -> " - "

518− OpNe -> " !== "

519− OpLt -> " < "

520− OpLe -> " <= "

521− OpGt -> " > "

522− OpGe -> " >= "

523− OpAnd -> " && "

524− OpOr -> " || "

525− OpBitwiseAnd -> " & "

526− OpBitwiseXor -> " ^ "

527− OpBitwiseOr -> " | "

528 OpLShift -> " << "

534 OpLShift -> " << "

529 OpSpRShift -> " >> "

535 OpSpRShift -> " >> "

530 OpZfRShift -> " >>> "

536 OpZfRShift -> " >>> "

537+ OpBAnd -> " & "

538+ OpBXor -> " ^ "

539+ OpBOr -> " | "

540+ OpAdd -> " + "

compiler/src/Generate/JavaScript/Expression.hs+45−46

@@ -22,7 +22,6 @@ import qualified Data.Utf8 as Utf8

22

23import qualified AST.Canonical as Can

24import qualified AST.Optimized as Opt

25−import qualified AST.Utils.Shader as Shader

26import qualified Data.Index as Index

25import qualified Data.Index as Index

27import qualified Elm.Compiler.Type as Type

26import qualified Elm.Compiler.Type as Type

28import qualified Elm.Compiler.Type.Extract as Extract

27import qualified Elm.Compiler.Type.Extract as Extract

@@ -33,7 +32,6 @@ import qualified Generate.JavaScript.Builder as JS

33import qualified Generate.JavaScript.Name as JsName

32import qualified Generate.JavaScript.Name as JsName

34import qualified Generate.Mode as Mode

33import qualified Generate.Mode as Mode

35import qualified Json.Encode as Encode

34import qualified Json.Encode as Encode

36−import Json.Encode ((==>))

37import qualified Optimize.DecisionTree as DT

35import qualified Optimize.DecisionTree as DT

38import qualified Reporting.Annotation as A

36import qualified Reporting.Annotation as A

39

37

@@ -130,7 +128,8 @@ generate mode expression =

130

128

131 Opt.Destruct (Opt.Destructor name path) body ->

129 Opt.Destruct (Opt.Destructor name path) body ->

132 let

130 let

131+ pathExpr = generatePath mode path

133− pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)

132+ pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]

134 in

133 in

135 JsBlock $ pathDef : codeToStmtList (generate mode body)

134 JsBlock $ pathDef : codeToStmtList (generate mode body)

136

135

@@ -139,7 +138,7 @@ generate mode expression =

139

138

140 Opt.Accessor field ->

139 Opt.Accessor field ->

141 JsExpr $ JS.Function Nothing [JsName.dollar]

140 JsExpr $ JS.Function Nothing [JsName.dollar]

142− [ JS.Return $

141+ [ JS.Return $ Just $

143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)

142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)

144 ]

143 ]

145

144

@@ -191,7 +190,7 @@ generate mode expression =

191 JS.Object (map toTranlation (Set.toList fields))

190 JS.Object (map toTranlation (Set.toList fields))

192 in

191 in

193 JsExpr $ JS.Object $

192 JsExpr $ JS.Object $

194− [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )

193+ [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )

195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )

194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )

196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )

195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )

197 ]

196 ]

@@ -212,7 +211,7 @@ codeToExpr code =

212 JsExpr expr ->

211 JsExpr expr ->

213 expr

212 expr

214

213

215− JsBlock [ JS.Return expr ] ->

214+ JsBlock [ JS.Return (Just expr) ] ->

216 expr

215 expr

217

216

218 JsBlock stmts ->

217 JsBlock stmts ->

@@ -226,7 +225,7 @@ codeToStmtList code =

226 stmts

225 stmts

227

226

228 JsExpr expr ->

227 JsExpr expr ->

229− [ JS.Return expr ]

228+ [ JS.Return (Just expr) ]

230

229

231 JsBlock stmts ->

230 JsBlock stmts ->

232 stmts

231 stmts

@@ -239,7 +238,7 @@ codeToStmt code =

239 JS.Block stmts

238 JS.Block stmts

240

239

241 JsExpr expr ->

240 JsExpr expr ->

242− JS.Return expr

241+ JS.Return (Just expr)

243

242

244 JsBlock [stmt] ->

243 JsBlock [stmt] ->

245 stmt

244 stmt

@@ -483,17 +482,17 @@ generateBitwiseCall home name args =

483 case args of

482 case args of

484 [arg] ->

483 [arg] ->

485 case name of

484 case name of

486− "complement" -> JS.Prefix JS.PrefixComplement arg

485+ "complement" -> JS.Prefix JS.PrefixBNot arg

487 _ -> generateGlobalCall home name args

486 _ -> generateGlobalCall home name args

488

487

489 [left,right] ->

488 [left,right] ->

490 case name of

489 case name of

491− "and" -> JS.Infix JS.OpBitwiseAnd left right

490+ "and" -> JS.Infix JS.OpBAnd left right

492− "or" -> JS.Infix JS.OpBitwiseOr left right

491+ "or" -> JS.Infix JS.OpBOr left right

493− "xor" -> JS.Infix JS.OpBitwiseXor left right

492+ "xor" -> JS.Infix JS.OpBXor left right

494− "shiftLeftBy" -> JS.Infix JS.OpLShift right left

493+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left

495− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

494+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

496− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

495+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

497 _ -> generateGlobalCall home name args

496 _ -> generateGlobalCall home name args

498

497

499 _ ->

498 _ ->

@@ -506,10 +505,10 @@ generateBasicsCall mode home name args =

506 [elmArg] ->

505 [elmArg] ->

507 let arg = generateJsExpr mode elmArg in

506 let arg = generateJsExpr mode elmArg in

508 case name of

507 case name of

509− "not" -> JS.Prefix JS.PrefixNot arg

508+ "not" -> JS.Prefix JS.PrefixLNot arg

510− "negate" -> JS.Prefix JS.PrefixNegate arg

509+ "negate" -> JS.Prefix JS.PrefixMinus arg

511 "toFloat" -> arg

510 "toFloat" -> arg

512− "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)

511+ "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)

513 _ -> generateGlobalCall home name [arg]

512 _ -> generateGlobalCall home name [arg]

514

513

515 [elmLeft, elmRight] ->

514 [elmLeft, elmRight] ->

@@ -529,16 +528,16 @@ generateBasicsCall mode home name args =

529 "sub" -> JS.Infix JS.OpSub left right

528 "sub" -> JS.Infix JS.OpSub left right

530 "mul" -> JS.Infix JS.OpMul left right

529 "mul" -> JS.Infix JS.OpMul left right

531 "fdiv" -> JS.Infix JS.OpDiv left right

530 "fdiv" -> JS.Infix JS.OpDiv left right

532− "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

531+ "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

533 "eq" -> equal left right

532 "eq" -> equal left right

534 "neq" -> notEqual left right

533 "neq" -> notEqual left right

535− "lt" -> cmp JS.OpLt JS.OpLt 0 left right

534+ "lt" -> cmp JS.OpLT JS.OpLT 0 left right

536− "gt" -> cmp JS.OpGt JS.OpGt 0 left right

535+ "gt" -> cmp JS.OpGT JS.OpGT 0 left right

537− "le" -> cmp JS.OpLe JS.OpLt 1 left right

536+ "le" -> cmp JS.OpLEq JS.OpLT 1 left right

538− "ge" -> cmp JS.OpGe JS.OpGt (-1) left right

537+ "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right

539− "or" -> JS.Infix JS.OpOr left right

538+ "or" -> JS.Infix JS.OpLOr left right

540− "and" -> JS.Infix JS.OpAnd left right

539+ "and" -> JS.Infix JS.OpLAnd left right

541− "xor" -> JS.Infix JS.OpNe left right

540+ "xor" -> JS.Infix JS.OpStrictNEq left right

542 "remainderBy" -> JS.Infix JS.OpMod right left

541 "remainderBy" -> JS.Infix JS.OpMod right left

543 _ -> generateGlobalCall home name [left, right]

542 _ -> generateGlobalCall home name [left, right]

544

543

@@ -559,7 +558,7 @@ notEqual left right =

559 if isLiteral left || isLiteral right then

558 if isLiteral left || isLiteral right then

560 strictNEq left right

559 strictNEq left right

561 else

560 else

562− JS.Prefix JS.PrefixNot $

561+ JS.Prefix JS.PrefixLNot $

563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]

562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]

564

563

565

564

@@ -648,42 +647,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr

648strictEq left right =

647strictEq left right =

649 case left of

648 case left of

650 JS.Int 0 ->

649 JS.Int 0 ->

651− JS.Prefix JS.PrefixNot right

650+ JS.Prefix JS.PrefixLNot right

652

651

653 JS.Bool bool ->

652 JS.Bool bool ->

654− if bool then right else JS.Prefix JS.PrefixNot right

653+ if bool then right else JS.Prefix JS.PrefixLNot right

655

654

656 _ ->

655 _ ->

657 case right of

656 case right of

658 JS.Int 0 ->

657 JS.Int 0 ->

659− JS.Prefix JS.PrefixNot left

658+ JS.Prefix JS.PrefixLNot left

660

659

661 JS.Bool bool ->

660 JS.Bool bool ->

662− if bool then left else JS.Prefix JS.PrefixNot left

661+ if bool then left else JS.Prefix JS.PrefixLNot left

663

662

664 _ ->

663 _ ->

665− JS.Infix JS.OpEq left right

664+ JS.Infix JS.OpStrictEq left right

666

665

667

666

668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr

667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr

669strictNEq left right =

668strictNEq left right =

670 case left of

669 case left of

671 JS.Int 0 ->

670 JS.Int 0 ->

672− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)

671+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)

673

672

674 JS.Bool bool ->

673 JS.Bool bool ->

675− if bool then JS.Prefix JS.PrefixNot right else right

674+ if bool then JS.Prefix JS.PrefixLNot right else right

676

675

677 _ ->

676 _ ->

678 case right of

677 case right of

679 JS.Int 0 ->

678 JS.Int 0 ->

680− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)

679+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)

681

680

682 JS.Bool bool ->

681 JS.Bool bool ->

683− if bool then JS.Prefix JS.PrefixNot left else left

682+ if bool then JS.Prefix JS.PrefixLNot left else left

684

683

685 _ ->

684 _ ->

686− JS.Infix JS.OpNe left right

685+ JS.Infix JS.OpStrictNEq left right

687

686

688

687

689

688

@@ -696,13 +695,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm

696generateTailCall mode name args =

695generateTailCall mode name args =

697 let

696 let

698 toTempVars (argName, arg) =

697 toTempVars (argName, arg) =

699− ( JsName.makeTemp argName, generateJsExpr mode arg )

698+ ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )

700

699

701 toRealVars (argName, _) =

700 toRealVars (argName, _) =

702 JS.ExprStmt $

701 JS.ExprStmt $

703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))

702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))

704 in

703 in

705− JS.Vars (map toTempVars args)

704+ JS.Var (map toTempVars args)

706 : map toRealVars args

705 : map toRealVars args

707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]

706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]

708

707

@@ -715,10 +714,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt

715generateDef mode def =

714generateDef mode def =

716 case def of

715 case def of

717 Opt.Def name body ->

716 Opt.Def name body ->

718− JS.Var (JsName.fromLocal name) (generateJsExpr mode body)

717+ JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]

719

718

720 Opt.TailDef name argNames body ->

719 Opt.TailDef name argNames body ->

721− JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))

720+ JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]

722

721

723

722

724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code

723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code

@@ -851,7 +850,7 @@ generateDecider mode label root decisionTree =

851

850

852 Opt.Chain testChain success failure ->

851 Opt.Chain testChain success failure ->

853 [ JS.IfStmt

852 [ JS.IfStmt

854− (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))

853+ (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))

855 (JS.Block $ generateDecider mode label root success)

854 (JS.Block $ generateDecider mode label root success)

856 (JS.Block $ generateDecider mode label root failure)

855 (JS.Block $ generateDecider mode label root failure)

857 ]

856 ]

@@ -893,7 +892,7 @@ generateIfTest mode root (path, test) =

893 value

892 value

894

893

895 DT.IsBool False ->

894 DT.IsBool False ->

896− JS.Prefix JS.PrefixNot value

895+ JS.Prefix JS.PrefixLNot value

897

896

898 DT.IsInt int ->

897 DT.IsInt int ->

899 strictEq value (JS.Int int)

898 strictEq value (JS.Int int)

@@ -911,7 +910,7 @@ generateIfTest mode root (path, test) =

911 JS.Access value (JsName.fromLocal "b")

910 JS.Access value (JsName.fromLocal "b")

912

911

913 DT.IsNil ->

912 DT.IsNil ->

914− JS.Prefix JS.PrefixNot $

913+ JS.Prefix JS.PrefixLNot $

915 JS.Access value (JsName.fromLocal "b")

914 JS.Access value (JsName.fromLocal "b")

916

915

917 DT.IsTuple ->

916 DT.IsTuple ->

@@ -1065,6 +1064,6 @@ toDebugMetadata mode msgType =

1065

1064

1066 Mode.Dev (Just interfaces) ->

1065 Mode.Dev (Just interfaces) ->

1067 JS.Json $ Encode.object $

1066 JS.Json $ Encode.object $

1068− [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]

1067+ [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])

1069− , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)

1068+ , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))

1070 ]

1069 ]

compiler/src/Generate/JavaScript/Name.hs+12−22

@@ -62,13 +62,19 @@ fromLocal name =

62

63

64fromGlobal :: ModuleName.Canonical -> Name.Name -> Name

65−fromGlobal home name =

65+fromGlobal (ModuleName.Canonical (Pkg.Name author project) home) name =

66+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author

67+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project

68+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home

66− Name $ homeToBuilder home <> usd <> Name.toBuilder name

69+ <> "$" <> Name.toBuilder name

67

70

68

71

69fromCycle :: ModuleName.Canonical -> Name.Name -> Name

72fromCycle :: ModuleName.Canonical -> Name.Name -> Name

70−fromCycle home name =

73+fromCycle (ModuleName.Canonical (Pkg.Name author project) home) name =

74+ Name $ Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author

75+ <> "$" <> Name.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project

76+ <> "$" <> Name.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home

71− Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name

77+ <> "$cyclic$" <> Name.toBuilder name

72

78

73

79

74fromKernel :: Name.Name -> Name.Name -> Name

80fromKernel :: Name.Name -> Name.Name -> Name

@@ -76,17 +82,6 @@ fromKernel home name =

76 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)

82 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)

77

83

78

84

79−{-# INLINE homeToBuilder #-}

80−homeToBuilder :: ModuleName.Canonical -> B.Builder

81−homeToBuilder (ModuleName.Canonical (Pkg.Name author project) home) =

82− usd <>

83− Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} author

84− <> usd <>

85− Utf8.toEscapedBuilder 0x2D {- - -} 0x5F {- _ -} project

86− <> usd <>

87− Utf8.toEscapedBuilder 0x2E {- . -} 0x24 {- $ -} home

88−

89−

90

85

91-- TEMPORARY NAMES

86-- TEMPORARY NAMES

92

87

@@ -103,7 +98,7 @@ makeA n =

103

98

104makeLabel :: Name.Name -> Int -> Name

99makeLabel :: Name.Name -> Int -> Name

105makeLabel name index =

100makeLabel name index =

106− Name (Name.toBuilder name <> usd <> B.intDec index)

101+ Name (Name.toBuilder name <> "$" <> B.intDec index)

107

102

108

103

109makeTemp :: Name.Name -> Name

104makeTemp :: Name.Name -> Name

@@ -113,12 +108,7 @@ makeTemp name =

113

108

114dollar :: Name

109dollar :: Name

115dollar =

110dollar =

116− Name usd

117−

118−

119−usd :: B.Builder

120−usd =

121− Name.toBuilder Name.dollar

111+ Name (Name.toBuilder Name.dollar)

122

112

123

113

124

114

compiler/src/Generate/Mode.hs+1

@@ -49,6 +49,7 @@ shortenFieldNames (Opt.GlobalGraph _ frequencies) =

49

50addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]

51addToBuckets field frequency buckets =

52+ -- TODO try using an IntMap for buckets

52 Map.insertWith (++) frequency [field] buckets

53 Map.insertWith (++) frequency [field] buckets

53

54

55

compiler/src/Json/Decode.hs+176−335

@@ -4,110 +4,61 @@ module Json.Decode

4 ( fromByteString

5 , Decoder

6 , string

7− , customString

8 , bool

7 , bool

9 , int

8 , int

10− , list

9+ , list, pair

11− , nonEmptyList

12− , pair

13− --

14− , KeyDecoder(..)

15− , dict

16− , pairs

10+ , dict, pairs, field

17− , field

18− --

19 , oneOf

11 , oneOf

20 , failure

12 , failure

21 , mapError

13 , mapError

22− --

23− , Error(..)

24− , Problem(..)

25− , DecodeExpectation(..)

26− , ParseError(..)

27− , StringProblem(..)

28 )

14 )

29 where

15 where

30

16

31

17

32−import qualified Data.ByteString.Internal as B

18+import qualified Data.ByteString as B

19+import qualified Data.List as List

33import qualified Data.Map as Map

20import qualified Data.Map as Map

34−import qualified Data.NonEmptyList as NE

21+import qualified Data.Utf8 as Utf8

35−import Data.Word (Word8)

22+import Data.Word (Word8, Word16)

36import Foreign.Ptr (Ptr, plusPtr, minusPtr)

23import Foreign.Ptr (Ptr, plusPtr, minusPtr)

37−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

38

24

39−import qualified Json.String as Json

40import qualified Parse.Keyword as K

25import qualified Parse.Keyword as K

41import qualified Parse.Primitives as P

26import qualified Parse.Primitives as P

42−import Parse.Primitives (Row, Col)

43−import qualified Reporting.Annotation as A

27+import qualified Reporting.Error.Json as E

44

28

45

29

46

30

47-- RUNNERS

31-- RUNNERS

48

32

49

33

50−fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a

34+fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a

51−fromByteString (Decoder decode) src =

35+fromByteString decoder src =

52− case P.fromByteString pFile BadEnd src of

36+ fromAST decoder (P.fromByteString pFile src)

53− Right ast ->

54− decode ast Right (Left . DecodeProblem src)

55

37

56− Left problem ->

57− Left (ParseProblem src problem)

58

38

39+fromAST :: Decoder e a -> P.Result E.Context E.ParseExpectation AST -> Either (E.Error e) a

40+fromAST (Decoder decode) parserResult =

41+ case parserResult of

42+ P.Ok ast _ ->

43+ decode ast Right (Left . E.DecodeProblem)

59

44

45+ P.Err row col ctx expectation ->

46+ Left (E.ParseProblem row col ctx expectation)

60

47

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

48

83

49

84−

50+-- DECODERS

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

51

95

52

96−data DecodeExpectation

53+newtype Decoder e a =

97− = TObject

54+ Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)

98− | TArray

99− | TString

100− | TBool

101− | TInt

102− | TObjectWith B.ByteString

103− | TArrayPair Int

104

55

105

56

106

57

107-- INSTANCES

58-- INSTANCES

108

59

109

60

110−instance Functor (Decoder x) where

61+instance Functor (Decoder e) where

111 {-# INLINE fmap #-}

62 {-# INLINE fmap #-}

112 fmap func (Decoder decodeA) =

63 fmap func (Decoder decodeA) =

113 Decoder $ \ast ok err ->

64 Decoder $ \ast ok err ->

@@ -117,7 +68,7 @@ instance Functor (Decoder x) where

117 decodeA ast ok' err

68 decodeA ast ok' err

118

69

119

70

120−instance Applicative (Decoder x) where

71+instance Applicative (Decoder e) where

121 {-# INLINE pure #-}

72 {-# INLINE pure #-}

122 pure = return

73 pure = return

123

74

@@ -134,7 +85,7 @@ instance Applicative (Decoder x) where

134 decodeFunc ast okF err

85 decodeFunc ast okF err

135

86

136

87

137−instance Monad (Decoder x) where

88+instance Monad (Decoder e) where

138 {-# INLINE return #-}

89 {-# INLINE return #-}

139 return a =

90 return a =

140 Decoder $ \_ ok _ ->

91 Decoder $ \_ ok _ ->

@@ -155,37 +106,24 @@ instance Monad (Decoder x) where

155-- STRINGS

106-- STRINGS

156

107

157

108

158−string :: Decoder x Json.String

109+string :: Decoder e Utf8.String

159string =

110string =

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

111+ Decoder $ \ast ok err ->

172 case ast of

112 case ast of

173− String snippet ->

113+ String bits ->

174− case P.fromSnippet parser toBadEnd snippet of

114+ ok bits

175− Right a -> ok a

176− Left x -> err (Failure region x)

177

115

178 _ ->

116 _ ->

179− err (Expecting region TString)

117+ err (E.Expecting E.TString)

180

118

181

119

182

120

183-- BOOL

121-- BOOL

184

122

185

123

186−bool :: Decoder x Bool

124+bool :: Decoder e Bool

187bool =

125bool =

188− Decoder $ \(A.At region ast) ok err ->

126+ Decoder $ \ast ok err ->

189 case ast of

127 case ast of

190 TRUE ->

128 TRUE ->

191 ok True

129 ok True

@@ -194,40 +132,40 @@ bool =

194 ok False

132 ok False

195

133

196 _ ->

134 _ ->

197− err (Expecting region TBool)

135+ err (E.Expecting E.TBool)

198

136

199

137

200

138

201-- INT

139-- INT

202

140

203

141

204−int :: Decoder x Int

142+int :: Decoder e Int

205int =

143int =

206− Decoder $ \(A.At region ast) ok err ->

144+ Decoder $ \ast ok err ->

207 case ast of

145 case ast of

208 Int n ->

146 Int n ->

209 ok n

147 ok n

210

148

211 _ ->

149 _ ->

212− err (Expecting region TInt)

150+ err (E.Expecting E.TInt)

213

151

214

152

215

153

216−-- LISTS

154+-- ARRAYS

217

155

218

156

219−list :: Decoder x a -> Decoder x [a]

157+list :: Decoder e a -> Decoder e [a]

220list decoder =

158list decoder =

221− Decoder $ \(A.At region ast) ok err ->

159+ Decoder $ \ast ok err ->

222 case ast of

160 case ast of

223 Array asts ->

161 Array asts ->

224 listHelp decoder ok err 0 asts []

162 listHelp decoder ok err 0 asts []

225

163

226 _ ->

164 _ ->

227− err (Expecting region TArray)

165+ err (E.Expecting E.TArray)

228

166

229

167

230−listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b

168+listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b

231listHelp decoder@(Decoder decodeA) ok err !i asts revs =

169listHelp decoder@(Decoder decodeA) ok err !i asts revs =

232 case asts of

170 case asts of

233 [] ->

171 [] ->

@@ -235,40 +173,24 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =

235

173

236 ast:asts ->

174 ast:asts ->

237 let

175 let

238− ok' value = listHelp decoder ok err (i+1) asts (value:revs)

176+ ok' a = listHelp decoder ok err (i+1) asts (a:revs)

239− err' prob = err (Index i prob)

177+ err' e = err (E.Index i e)

240 in

178 in

241 decodeA ast ok' err'

179 decodeA ast ok' err'

242

180

243

181

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)

182+pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)

261pair (Decoder decodeA) (Decoder decodeB) =

183pair (Decoder decodeA) (Decoder decodeB) =

262− Decoder $ \(A.At region ast) ok err ->

184+ Decoder $ \ast ok err ->

263 case ast of

185 case ast of

264 Array vs ->

186 Array vs ->

265 case vs of

187 case vs of

266 [astA,astB] ->

188 [astA,astB] ->

267 let

189 let

268− err0 e = err (Index 0 e)

190+ err0 e = err (E.Index 0 e)

269 ok0 a =

191 ok0 a =

270 let

192 let

271− err1 e = err (Index 1 e)

193+ err1 e = err (E.Index 1 e)

272 ok1 b = ok (a,b)

194 ok1 b = ok (a,b)

273 in

195 in

274 decodeB astB ok1 err1

196 decodeB astB ok1 err1

@@ -276,103 +198,70 @@ pair (Decoder decodeA) (Decoder decodeB) =

276 decodeA astA ok0 err0

198 decodeA astA ok0 err0

277

199

278 _ ->

200 _ ->

279− err (Expecting region (TArrayPair (length vs)))

201+ err (E.Expecting (E.TArrayPair (length vs)))

280

202

281 _ ->

203 _ ->

282− err (Expecting region TArray)

204+ err (E.Expecting E.TArray)

283−

284

205

285

206

286−-- OBJECTS

287

207

288−

208+-- OBJECT

289−data KeyDecoder x a =

290− KeyDecoder (P.Parser x a) (Row -> Col -> x)

291

209

292

210

293−dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)

211+dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)

294−dict keyDecoder valueDecoder =

212+dict decoder =

295− Map.fromList <$> pairs keyDecoder valueDecoder

213+ Map.fromList <$> pairs decoder

296

214

297

215

298−pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]

216+pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]

299−pairs keyDecoder valueDecoder =

217+pairs decoder =

300− Decoder $ \(A.At region ast) ok err ->

218+ Decoder $ \ast ok err ->

301 case ast of

219 case ast of

302 Object kvs ->

220 Object kvs ->

303− pairsHelp keyDecoder valueDecoder ok err kvs []

221+ pairsHelp decoder ok err kvs []

304

222

305 _ ->

223 _ ->

306− err (Expecting region TObject)

224+ err (E.Expecting E.TObject)

307

225

308

226

309−pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b

227+pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b

310−pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =

228+pairsHelp decoder@(Decoder decodeA) ok err kvs revs =

311 case kvs of

229 case kvs of

312 [] ->

230 [] ->

313 ok (reverse revs)

231 ok (reverse revs)

314

232

315− (snippet, ast) : kvs ->

233+ (key, ast) : kvs ->

316− case P.fromSnippet keyParser toBadEnd snippet of

317− Left x ->

318− err (Failure (snippetToRegion snippet) x)

319−

320− Right key ->

321− let

234+ let

322− ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)

235+ ok' a = pairsHelp decoder ok err kvs ((key,a):revs)

323− err' prob =

236+ err' e = err (E.Field key e)

324− let (P.Snippet fptr off len _ _) = snippet in

325− err (Field (B.PS fptr off len) prob)

326− in

237+ in

327− decodeA ast ok' err'

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

239

338

240

339−field :: B.ByteString -> Decoder x a -> Decoder x a

241+field :: Utf8.String -> Decoder e a -> Decoder e a

340field key (Decoder decodeA) =

242field key (Decoder decodeA) =

341− Decoder $ \(A.At region ast) ok err ->

243+ Decoder $ \ast ok err ->

342 case ast of

244 case ast of

343 Object kvs ->

245 Object kvs ->

344− case findField key kvs of

246+ case List.lookup key kvs of

345− Just value ->

247+ Just v ->

346 let

248 let

347− err' prob =

348− err (Field key prob)

249+ err' e = err (E.Field key e)

349 in

250 in

350− decodeA value ok err'

251+ decodeA v ok err'

351

252

352 Nothing ->

253 Nothing ->

353− err (Expecting region (TObjectWith key))

254+ err (E.Expecting (E.TObjectWith key))

354

255

355 _ ->

256 _ ->

356− err (Expecting region TObject)

257+ err (E.Expecting E.TObject)

357−

358−

359−findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST

360−findField key pairs =

361− case pairs of

362− [] ->

363− Nothing

364−

365− (P.Snippet fptr off len _ _, value) : remainingPairs ->

366− if key == B.PS fptr off len

367− then Just value

368− else findField key remainingPairs

369

258

370

259

371

260

372-- ONE OF

261-- ONE OF

373

262

374

263

375−oneOf :: [Decoder x a] -> Decoder x a

264+oneOf :: [Decoder e a] -> Decoder e a

376oneOf decoders =

265oneOf decoders =

377 Decoder $ \ast ok err ->

266 Decoder $ \ast ok err ->

378 case decoders of

267 case decoders of

@@ -387,75 +276,71 @@ oneOf decoders =

387 error "Ran into (Json.Decode.oneOf [])"

276 error "Ran into (Json.Decode.oneOf [])"

388

277

389

278

390−oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b

279+oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b

391−oneOfHelp ast ok err decoders p ps =

280+oneOfHelp ast ok err decoders e es =

392 case decoders of

281 case decoders of

393 Decoder decodeA : decoders ->

282 Decoder decodeA : decoders ->

394 let

283 let

395− err' p' =

284+ err' e' =

396− oneOfHelp ast ok err decoders p' (p:ps)

285+ oneOfHelp ast ok err decoders e' (e:es)

397 in

286 in

398 decodeA ast ok err'

287 decodeA ast ok err'

399

288

400 [] ->

289 [] ->

401− err (oneOfError [] p ps)

290+ err (oneOfError [] e es)

402

291

403

292

404−oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x

293+oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e

405−oneOfError problems prob ps =

294+oneOfError errors err es =

406− case ps of

295+ case es of

407 [] ->

296 [] ->

408− OneOf prob problems

297+ E.OneOf err errors

409

298

410− p:ps ->

299+ e:es ->

411− oneOfError (prob:problems) p ps

300+ oneOfError (err:errors) e es

412

301

413

302

414

303

415-- FAILURE

304-- FAILURE

416

305

417

306

418−failure :: x -> Decoder x a

307+failure :: e -> Decoder e a

419−failure x =

308+failure e =

420− Decoder $ \(A.At region _) _ err ->

309+ Decoder $ \_ _ err ->

421− err (Failure region x)

310+ err (E.Failure e)

422

311

423

312

424

313

425-- ERRORS

314-- ERRORS

426

315

427

316

428−mapError :: (x -> y) -> Decoder x a -> Decoder y a

317+mapError :: (e -> e') -> Decoder e a -> Decoder e' a

429mapError func (Decoder decodeA) =

318mapError func (Decoder decodeA) =

430 Decoder $ \ast ok err ->

319 Decoder $ \ast ok err ->

431 let

320 let

432− err' prob = err (mapErrorHelp func prob)

321+ err' e = err (mapErrorHelp func e)

433 in

322 in

434 decodeA ast ok err'

323 decodeA ast ok err'

435

324

436

325

437−mapErrorHelp :: (x -> y) -> Problem x -> Problem y

326+mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'

438−mapErrorHelp func problem =

327+mapErrorHelp func err =

439− case problem of

328+ case err of

440− Field k p -> Field k (mapErrorHelp func p)

329+ E.Field k e -> E.Field k (mapErrorHelp func e)

441− Index i p -> Index i (mapErrorHelp func p)

330+ E.Index i e -> E.Index i (mapErrorHelp func e)

442− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)

331+ E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)

443− Failure r x -> Failure r (func x)

332+ E.Failure e -> E.Failure (func e)

444− Expecting r e -> Expecting r e

333+ E.Expecting e -> E.Expecting e

445

334

446

335

447

336

448-- AST

337-- AST

449

338

450

339

451−type AST =

452− A.Located AST_

453−

454−

455−data AST_

340+data AST

456 = Array [AST]

341 = Array [AST]

457− | Object [(P.Snippet, AST)]

342+ | Object [(Utf8.String, AST)]

458− | String P.Snippet

343+ | String Utf8.String

459 | Int Int

344 | Int Int

460 | TRUE

345 | TRUE

461 | FALSE

346 | FALSE

@@ -467,33 +352,7 @@ data AST_

467

352

468

353

469type Parser a =

354type Parser a =

470− P.Parser ParseError a

355+ P.Parser E.Context E.ParseExpectation a

471−

472−

473−data ParseError

474− = Start Row Col

475− | ObjectField Row Col

476− | ObjectColon Row Col

477− | ObjectEnd Row Col

478− | ArrayEnd Row Col

479− | StringProblem StringProblem Row Col

480− | NoLeadingZeros Row Col

481− | NoFloats Row Col

482− | BadEnd Row Col

483−

484−-- PIndex Int ParseError Row Col

485−-- PField Json.String ParseError Row Col

486−

487−

488−data StringProblem

489− = BadStringEnd

490− | BadStringControlChar

491− | BadStringEscapeChar

492− | BadStringEscapeHex

493−

494−

495−

496−-- PARSE AST

497

356

498

357

499pFile :: Parser AST

358pFile :: Parser AST

@@ -501,60 +360,69 @@ pFile =

501 do spaces

360 do spaces

502 value <- pValue

361 value <- pValue

503 spaces

362 spaces

363+ endOfFile

504 return value

364 return value

505

365

506

366

507pValue :: Parser AST

367pValue :: Parser AST

508pValue =

368pValue =

509− P.addLocation $

510− P.oneOf Start

369+ P.oneOf E.Value

511− [ String <$> pString Start

370+ [ fmap String pString

512 , pObject

371 , pObject

513 , pArray

372 , pArray

514 , pInt

373 , pInt

515− , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE

374+ , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE

516− , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE

375+ , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE

517− , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL

376+ , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL

518 ]

377 ]

519

378

520

379

380+endOfFile :: Parser ()

381+endOfFile =

382+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->

383+ if pos < end then

384+ eerr row col ctx E.EndOfFile

385+ else

386+ eok () state

387+

388+

521

389

522-- OBJECT

390-- OBJECT

523

391

524

392

525−pObject :: Parser AST_

393+pObject :: Parser AST

526pObject =

394pObject =

527− do P.word1 0x7B {- { -} Start

395+ do P.word1 0x7B {- { -} E.ObjectStart

528 spaces

396 spaces

529− P.oneOf ObjectField

397+ P.oneOf E.ObjectMore

530 [ do entry <- pField

398 [ do entry <- pField

531 spaces

399 spaces

532 pObjectHelp [entry]

400 pObjectHelp [entry]

533− , do P.word1 0x7D {-}-} ObjectEnd

401+ , do P.word1 0x7D {-}-} E.ObjectEnd

534 return (Object [])

402 return (Object [])

535 ]

403 ]

536

404

537

405

538−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_

406+pObjectHelp :: [(Utf8.String, AST)] -> Parser AST

539pObjectHelp revEntries =

407pObjectHelp revEntries =

540− P.oneOf ObjectEnd

408+ P.oneOf E.ObjectMore

541 [

409 [

542− do P.word1 0x2C {-,-} ObjectEnd

410+ do P.word1 0x2C {-,-} E.ObjectMore

543 spaces

411 spaces

544 entry <- pField

412 entry <- pField

545 spaces

413 spaces

546 pObjectHelp (entry:revEntries)

414 pObjectHelp (entry:revEntries)

547 ,

415 ,

548− do P.word1 0x7D {-}-} ObjectEnd

416+ do P.word1 0x7D {-}-} E.ObjectEnd

549 return (Object (reverse revEntries))

417 return (Object (reverse revEntries))

550 ]

418 ]

551

419

552

420

553−pField :: Parser (P.Snippet, AST)

421+pField :: Parser (Utf8.String, AST)

554pField =

422pField =

555− do key <- pString ObjectField

423+ do key <- pString

556 spaces

424 spaces

557− P.word1 0x3A {-:-} ObjectColon

425+ P.word1 0x3A {-:-} E.Colon

558 spaces

426 spaces

559 value <- pValue

427 value <- pValue

560 return (key, value)

428 return (key, value)

@@ -564,30 +432,30 @@ pField =

564-- ARRAY

432-- ARRAY

565

433

566

434

567−pArray :: Parser AST_

435+pArray :: Parser AST

568pArray =

436pArray =

569− do P.word1 0x5B {-[-} Start

437+ do P.word1 0x5B {-[-} E.ArrayStart

570 spaces

438 spaces

571− P.oneOf Start

439+ P.oneOf E.ArrayMore

572 [ do entry <- pValue

440 [ do entry <- pValue

573 spaces

441 spaces

574 pArrayHelp 1 [entry]

442 pArrayHelp 1 [entry]

575− , do P.word1 0x5D {-]-} ArrayEnd

443+ , do P.word1 0x5D {-]-} E.ArrayEnd

576 return (Array [])

444 return (Array [])

577 ]

445 ]

578

446

579

447

580−pArrayHelp :: Int -> [AST] -> Parser AST_

448+pArrayHelp :: Int -> [AST] -> Parser AST

581pArrayHelp !len revEntries =

449pArrayHelp !len revEntries =

582− P.oneOf ArrayEnd

450+ P.oneOf E.ArrayMore

583 [

451 [

584− do P.word1 0x2C {-,-} ArrayEnd

452+ do P.word1 0x2C {-,-} E.ArrayMore

585 spaces

453 spaces

586 entry <- pValue

454 entry <- pValue

587 spaces

455 spaces

588 pArrayHelp (len + 1) (entry:revEntries)

456 pArrayHelp (len + 1) (entry:revEntries)

589 ,

457 ,

590− do P.word1 0x5D {-]-} ArrayEnd

458+ do P.word1 0x5D {-]-} E.ArrayEnd

591 return (Array (reverse revEntries))

459 return (Array (reverse revEntries))

592 ]

460 ]

593

461

@@ -596,44 +464,41 @@ pArrayHelp !len revEntries =

596-- STRING

464-- STRING

597

465

598

466

599−pString :: (Row -> Col -> ParseError) -> Parser P.Snippet

467+pString :: Parser Utf8.String

600−pString start =

468+pString =

601− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

469+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then

470 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then

603

471

604 let

472 let

605 !pos1 = plusPtr pos 1

473 !pos1 = plusPtr pos 1

606− !col1 = col + 1

607

474

608 (# status, newPos, newRow, newCol #) =

475 (# status, newPos, newRow, newCol #) =

609− pStringHelp pos1 end row col1

476+ pStringHelp pos1 end row (col + 1)

610 in

477 in

611 case status of

478 case status of

612 GoodString ->

479 GoodString ->

613 let

480 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

481+ !newState = P.State newPos end indent newRow newCol ctx

482+ !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))

618 in

483 in

619− cok snp newState

484+ cok content newState

620

485

621− BadString problem ->

486+ BadStringEnd ->

622− cerr newRow newCol (StringProblem problem)

487+ cerr newRow newCol ctx E.StringEnd

623

488

624 else

489 else

625− eerr row col start

490+ eerr row col ctx E.StringStart

626

491

627

492

628data StringStatus

493data StringStatus

629 = GoodString

494 = GoodString

630− | BadString StringProblem

495+ | BadStringEnd

631

496

632

497

633−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)

498+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)

634pStringHelp pos end row col =

499pStringHelp pos end row col =

635 if pos >= end then

500 if pos >= end then

636− (# BadString BadStringEnd, pos, row, col #)

501+ (# BadStringEnd, pos, row, col #)

637

502

638 else

503 else

639 case P.unsafeIndex pos of

504 case P.unsafeIndex pos of

@@ -641,50 +506,26 @@ pStringHelp pos end row col =

641 (# GoodString, plusPtr pos 1, row, col + 1 #)

506 (# GoodString, plusPtr pos 1, row, col + 1 #)

642

507

643 0x0A {-\n-} ->

508 0x0A {-\n-} ->

644− (# BadString BadStringEnd, pos, row, col #)

509+ (# BadStringEnd, pos, row, col #)

645

510

646 0x5C {-\-} ->

511 0x5C {-\-} ->

512+ let

647− let !pos1 = plusPtr pos 1 in

513+ !pos1 = plusPtr pos 1

648− if pos1 >= end then

514+ in

649− (# BadString BadStringEnd, pos1, row + 1, col #)

650− else

651− case P.unsafeIndex pos1 of

652− 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

653− 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

654− 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

655− 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

656− 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

657− 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

658− 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

659− 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

660− 0x75 {-u-} ->

661− let !pos6 = plusPtr pos 6 in

662− if pos6 <= end

663− && isHex (P.unsafeIndex (plusPtr pos 2))

664− && isHex (P.unsafeIndex (plusPtr pos 3))

665− && isHex (P.unsafeIndex (plusPtr pos 4))

666− && isHex (P.unsafeIndex (plusPtr pos 5))

667− then

515+ if pos1 < end then

668− pStringHelp pos6 end row (col + 6)

669− else

670− (# BadString BadStringEscapeHex, pos, row, col #)

671−

672− _ ->

673− (# BadString BadStringEscapeChar, pos, row, col #)

674

516

675− word ->

517+ let

676− if word < 0x20 then

518+ !word = P.unsafeIndex pos1

677− (# BadString BadStringControlChar, pos, row, col #)

678− else

679− let !newPos = plusPtr pos (P.getCharWidth word) in

519+ !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)

520+ in

680− pStringHelp newPos end row (col + 1)

521+ pStringHelp newPos end row (col + 2)

681

522

523+ else

524+ (# BadStringEnd, pos1, row + 1, col #)

682

525

683−isHex :: Word8 -> Bool

526+ word ->

684−isHex word =

527+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in

685− 0x30 {-0-} <= word && word <= 0x39 {-9-}

528+ pStringHelp newPos end row (col + 1)

686− || 0x61 {-a-} <= word && word <= 0x66 {-f-}

687− || 0x41 {-A-} <= word && word <= 0x46 {-F-}

688

529

689

530

690

531

@@ -693,7 +534,7 @@ isHex word =

693

534

694spaces :: Parser ()

535spaces :: Parser ()

695spaces =

536spaces =

696− P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->

537+ P.Parser $ \state@(P.State pos end indent row col ctx) cok eok _ _ ->

697 let

538 let

698 (# newPos, newRow, newCol #) =

539 (# newPos, newRow, newCol #) =

699 eatSpaces pos end row col

540 eatSpaces pos end row col

@@ -703,12 +544,12 @@ spaces =

703 else

544 else

704 let

545 let

705 !newState =

546 !newState =

706− P.State src newPos end indent newRow newCol

547+ P.State newPos end indent newRow newCol ctx

707 in

548 in

708 cok () newState

549 cok () newState

709

550

710

551

711−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)

552+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)

712eatSpaces pos end row col =

553eatSpaces pos end row col =

713 if pos >= end then

554 if pos >= end then

714 (# pos, row, col #)

555 (# pos, row, col #)

@@ -727,29 +568,29 @@ eatSpaces pos end row col =

727-- INTS

568-- INTS

728

569

729

570

730−pInt :: Parser AST_

571+pInt :: Parser AST

731pInt =

572pInt =

732− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

573+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

733 if pos >= end then

574 if pos >= end then

734− eerr row col Start

575+ eerr row col ctx E.IntStart

735

576

736 else

577 else

737 let !word = P.unsafeIndex pos in

578 let !word = P.unsafeIndex pos in

738 if not (isDecimalDigit word) then

579 if not (isDecimalDigit word) then

739− eerr row col Start

580+ eerr row col ctx E.IntStart

740

581

741 else if word == 0x30 {-0-} then

582 else if word == 0x30 {-0-} then

742

583

743 let

584 let

744 !pos1 = plusPtr pos 1

585 !pos1 = plusPtr pos 1

745− !newState = P.State src pos1 end indent row (col + 1)

586+ !newState = P.State pos1 end indent row (col + 1) ctx

746 in

587 in

747 if pos1 < end then

588 if pos1 < end then

748 let !word1 = P.unsafeIndex pos1 in

589 let !word1 = P.unsafeIndex pos1 in

749 if isDecimalDigit word1 then

590 if isDecimalDigit word1 then

750− cerr row (col + 1) NoLeadingZeros

591+ cerr row (col + 1) ctx E.NoLeadingZeros

751 else if word1 == 0x2E {-.-} then

592 else if word1 == 0x2E {-.-} then

752− cerr row (col + 1) NoFloats

593+ cerr row (col + 1) ctx E.NoFloats

753 else

594 else

754 cok (Int 0) newState

595 cok (Int 0) newState

755 else

596 else

@@ -766,12 +607,12 @@ pInt =

766 GoodInt ->

607 GoodInt ->

767 let

608 let

768 !newState =

609 !newState =

769− P.State src newPos end indent row (col + len)

610+ P.State newPos end indent row (col + len) ctx

770 in

611 in

771 cok (Int n) newState

612 cok (Int n) newState

772

613

773 BadIntEnd ->

614 BadIntEnd ->

774− cerr row (col + len) NoFloats

615+ cerr row (col + len) ctx E.NoFloats

775

616

776

617

777data IntStatus = GoodInt | BadIntEnd

618data IntStatus = GoodInt | BadIntEnd

compiler/src/Json/Encode.hs+21−37

@@ -10,7 +10,6 @@ module Json.Encode

10 , object

11 , string

12 , name

13− , chars

14 , bool

13 , bool

15 , int

14 , int

16 , number

15 , number

@@ -33,7 +32,6 @@ import qualified Data.Name as Name

33import qualified Data.Utf8 as Utf8

32import qualified Data.Utf8 as Utf8

34

33

35import qualified File

34import qualified File

36−import qualified Json.String as Json

37

35

38

36

39

37

@@ -42,7 +40,7 @@ import qualified Json.String as Json

42

40

43data Value

41data Value

44 = Array [Value]

42 = Array [Value]

45− | Object [(Json.String, Value)]

43+ | Object [(Utf8.String, Value)]

46 | String B.Builder

44 | String B.Builder

47 | Boolean Bool

45 | Boolean Bool

48 | Integer Int

46 | Integer Int

@@ -55,14 +53,14 @@ array =

55 Array

53 Array

56

54

57

55

58−object :: [(Json.String, Value)] -> Value

56+object :: [(Utf8.String,Value)] -> Value

59object =

57object =

60 Object

58 Object

61

59

62

60

63−string :: Json.String -> Value

61+string :: Utf8.String -> Value

64string str =

62string str =

65− String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')

63+ String (encodeUtf8 str)

66

64

67

65

68name :: Name.Name -> Value

66name :: Name.Name -> Value

@@ -90,7 +88,7 @@ null =

90 Null

88 Null

91

89

92

90

93−dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value

91+dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value

94dict encodeKey encodeValue pairs =

92dict encodeKey encodeValue pairs =

95 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)

93 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)

96

94

@@ -101,35 +99,12 @@ list encodeEntry entries =

101

99

102

100

103

101

104−-- CHARS

105−

106−

107−chars :: [Char] -> Value -- PERF can this be done better? Look for examples.

108−chars chrs =

109− String (B.char7 '"' <> B.stringUtf8 (escape chrs) <> B.char7 '"')

110−

111−

112−escape :: [Char] -> [Char]

113−escape chrs =

114− case chrs of

115− [] ->

116− []

117−

118− c:cs

119− | c == '\r' -> '\\' : 'r' : escape cs

120− | c == '\n' -> '\\' : 'n' : escape cs

121− | c == '\"' -> '\\' : '"' : escape cs

122− | c == '\\' -> '\\' : '\\' : escape cs

123− | otherwise -> c : escape cs

124−

125−

126−

127-- HELPERS

102-- HELPERS

128

103

129

104

130−(==>) :: [Char] -> value -> (Json.String, value)

105+(==>) :: a -> b -> (a, b)

131−(==>) key value =

106+(==>) a b =

132− (Json.fromChars key, value)

107+ (a, b)

133

108

134

109

135

110

@@ -169,7 +144,7 @@ encodeUgly value =

169 Object (first : rest) ->

144 Object (first : rest) ->

170 let

145 let

171 encodeEntry char (key, entry) =

146 encodeEntry char (key, entry) =

172− B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry

147+ B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry

173 in

148 in

174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'

149 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'

175

150

@@ -230,6 +205,15 @@ encodeHelp indent value =

230

205

231

206

232

207

208+-- ENCODE UTF-8

209+

210+

211+encodeUtf8 :: Utf8.String -> B.Builder

212+encodeUtf8 str =

213+ B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'

214+

215+

216+

233-- ENCODE ARRAY

217-- ENCODE ARRAY

234

218

235

219

@@ -252,7 +236,7 @@ arrayClose =

252-- ENCODE OBJECT

236-- ENCODE OBJECT

253

237

254

238

255−encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder

239+encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder

256encodeObject =

240encodeObject =

257 encodeSequence objectOpen objectClose encodeField

241 encodeSequence objectOpen objectClose encodeField

258

242

@@ -267,9 +251,9 @@ objectClose =

267 B.char7 '}'

251 B.char7 '}'

268

252

269

253

270−encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder

254+encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder

271encodeField indent (key, value) =

255encodeField indent (key, value) =

272− B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value

256+ encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value

273

257

274

258

275

259

compiler/src/Json/String.hsdeleted−192

@@ -1,192 +0,0 @@

1−{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls #-}

3−module Json.String

4− ( String

5− , isEmpty

6− --

7− , fromPtr

8− , fromName

9− , fromChars

10− , fromSnippet

11− , fromComment

12− --

13− , toChars

14− , toBuilder

15− )

16− where

17−

18−

19−import Prelude hiding (String)

20−import qualified Data.ByteString.Builder as B

21−import qualified Data.Coerce as Coerce

22−import qualified Data.Name as Name

23−import qualified Data.Utf8 as Utf8

24−import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

25−import Data.Word (Word8)

26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

27−import Foreign.ForeignPtr (withForeignPtr)

28−import GHC.Exts (RealWorld)

29−import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)

30−import GHC.ST (ST)

31−

32−import qualified Parse.Primitives as P

33−

34−

35−

36−-- JSON STRINGS

37−

38−

39−-- INVARIANT: any Json.String is appropriately escaped already

40−-- PERF: is this the right representation for Json.String? Maybe ByteString instead?

41−--

42−type String =

43− Utf8.Utf8 JSON_STRING

44−

45−

46−data JSON_STRING

47−

48−

49−isEmpty :: String -> Bool

50−isEmpty =

51− Utf8.isEmpty

52−

53−

54−

55−-- FROM

56−

57−

58−fromPtr :: Ptr Word8 -> Ptr Word8 -> String

59−fromPtr =

60− Utf8.fromPtr

61−

62−

63−fromChars :: [Char] -> String

64−fromChars =

65− Utf8.fromChars

66−

67−

68−fromSnippet :: P.Snippet -> String

69−fromSnippet =

70− Utf8.fromSnippet

71−

72−

73−fromName :: Name.Name -> String

74−fromName =

75− Coerce.coerce

76−

77−

78−

79−-- TO

80−

81−

82−toChars :: String -> [Char]

83−toChars =

84− Utf8.toChars

85−

86−

87−{-# INLINE toBuilder #-}

88−toBuilder :: String -> B.Builder

89−toBuilder =

90− Utf8.toBuilder

91−

92−

93−

94−-- FROM COMMENT

95−

96−

97−fromComment :: P.Snippet -> String

98−fromComment (P.Snippet fptr off len _ _) =

99− unsafePerformIO $ withForeignPtr fptr $ \ptr ->

100− let

101− !pos = plusPtr ptr off

102− !end = plusPtr pos len

103− !str = fromChunks (chompChunks pos end pos [])

104− in

105− return str

106−

107−

108−chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

109−chompChunks pos end start revChunks =

110− if pos >= end then

111− reverse (addSlice start end revChunks)

112− else

113− let

114− !word = P.unsafeIndex pos

115− in

116− case word of

117− 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks

118− 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks

119− 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks

120− 0x0D {-\r-} ->

121− let

122− !newPos = plusPtr pos 1

123− in

124− chompChunks newPos end newPos (addSlice start pos revChunks)

125−

126− _ ->

127− let

128− !width = P.getCharWidth word

129− !newPos = plusPtr pos width

130− in

131− chompChunks newPos end start revChunks

132−

133−

134−chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

135−chompEscape escape pos end start revChunks =

136− let

137− !pos1 = plusPtr pos 1

138− in

139− chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)

140−

141−

142−addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

143−addSlice start end revChunks =

144− if start == end

145− then revChunks

146− else Slice start (minusPtr end start) : revChunks

147−

148−

149−

150−-- FROM CHUNKS

151−

152−

153−data Chunk

154− = Slice (Ptr Word8) Int

155− | Escape Word8

156−

157−

158−fromChunks :: [Chunk] -> String

159−fromChunks chunks =

160− unsafeDupablePerformIO (stToIO (

161− do let !len = sum (map chunkToWidth chunks)

162− mba <- newByteArray len

163− writeChunks mba 0 chunks

164− freeze mba

165− ))

166−

167−

168−chunkToWidth :: Chunk -> Int

169−chunkToWidth chunk =

170− case chunk of

171− Slice _ len -> len

172− Escape _ -> 2

173−

174−

175−writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

176−writeChunks mba offset chunks =

177− case chunks of

178− [] ->

179− return ()

180−

181− chunk : chunks ->

182− case chunk of

183− Slice ptr len ->

184− do copyFromPtr ptr mba offset len

185− let !newOffset = offset + len

186− writeChunks mba newOffset chunks

187−

188− Escape word ->

189− do writeWord8 mba offset 0x5C {- \ -}

190− writeWord8 mba (offset + 1) word

191− let !newOffset = offset + 2

192− writeChunks mba newOffset chunks

compiler/src/Nitpick/PatternMatches.hs+7−8

@@ -21,12 +21,11 @@ import qualified Data.List as List

21import qualified Data.Map as Map

22import qualified Data.Maybe as Maybe

23import qualified Data.Name as Name

24−import qualified Data.NonEmptyList as NE

24+import qualified Data.Utf8 as Utf8

25

26import qualified AST.Canonical as Can

27import qualified Data.Index as Index

28import qualified Elm.ModuleName as ModuleName

29−import qualified Elm.String as ES

30import qualified Reporting.Annotation as A

29import qualified Reporting.Annotation as A

31

30

32

31

@@ -41,8 +40,8 @@ data Pattern

41

40

42

41

43data Literal

42data Literal

44− = Chr ES.String

43+ = Chr Utf8.String

45− | Str ES.String

44+ | Str Utf8.String

46 | Int Int

45 | Int Int

47 deriving (Eq)

46 deriving (Eq)

48

47

@@ -203,14 +202,14 @@ data Context

203-- CHECK

202-- CHECK

204

203

205

204

206−check :: Can.Module -> Either (NE.List Error) ()

205+check :: Can.Module -> Either [Error] ()

207−check (Can.Module _ _ _ decls _ _ _ _) =

206+check (Can.Module _ _ decls _ _ _ _) =

208 case checkDecls decls [] of

207 case checkDecls decls [] of

209 [] ->

208 [] ->

210 Right ()

209 Right ()

211

210

212− e:es ->

211+ errors ->

213− Left (NE.List e es)

212+ Left errors

214

213

215

214

216

215

compiler/src/Optimize/DecisionTree.hs+5−5

@@ -27,11 +27,11 @@ import qualified Data.List as List

27import qualified Data.Maybe as Maybe

28import qualified Data.Name as Name

29import qualified Data.Set as Set

30+import qualified Data.Utf8 as Utf8

30

31

31import qualified AST.Canonical as Can

32import qualified AST.Canonical as Can

32import qualified Data.Index as Index

33import qualified Data.Index as Index

33import qualified Elm.ModuleName as ModuleName

34import qualified Elm.ModuleName as ModuleName

34−import qualified Elm.String as ES

35import qualified Reporting.Annotation as A

36

37

@@ -77,8 +77,8 @@ data Test

77 | IsNil

78 | IsTuple

79 | IsInt Int

80− | IsChr ES.String

80+ | IsChr Utf8.String

81− | IsStr ES.String

81+ | IsStr Utf8.String

82 | IsBool Bool

83 deriving (Eq, Ord)

84

@@ -618,7 +618,7 @@ instance Binary Test where

618 5 -> liftM IsStr get

619 6 -> liftM IsInt get

620 7 -> liftM IsBool get

621− _ -> fail "problem getting DecisionTree.Test binary"

621+ _ -> error "problem getting DecisionTree.Test binary"

622

623

624instance Binary Path where

@@ -634,4 +634,4 @@ instance Binary Path where

634 0 -> liftM2 Index get get

635 1 -> liftM Unbox get

636 2 -> pure Empty

637− _ -> fail "problem getting DecisionTree.Path binary"

637+ _ -> error "problem getting DecisionTree.Path binary"

compiler/src/Optimize/Module.hs+4−4

@@ -41,7 +41,7 @@ type Annotations =

41

42

43optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph

44−optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =

44+optimize annotations (Can.Module home _ decls unions aliases _ effects) =

45 addDecls home annotations decls $

46 addEffects home effects $

47 addUnions home unions $

@@ -213,10 +213,10 @@ findMain defs =

213 def:rest ->

214 case def of

215 Can.Def (A.At region name) _ _ ->

216− if name == Name._main then Just region else findMain rest

216+ if name == Name.main then Just region else findMain rest

217

218 Can.TypedDef (A.At region name) _ _ _ _ ->

219− if name == Name._main then Just region else findMain rest

219+ if name == Name.main then Just region else findMain rest

220

221

222defToName :: Can.Def -> Name.Name

@@ -244,7 +244,7 @@ addDef home annotations def graph =

244

245addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph

246addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =

247− if name /= Name._main then

247+ if name /= Name.main then

248 Result.ok (addDefNode home name args body Set.empty graph)

249 else

250 let

compiler/src/Optimize/Port.hs+3−3

@@ -58,7 +58,7 @@ toEncoder tipe =

58 | name == Name.array -> encodeArray arg

59

60 _ ->

61− error "toEncoder: bad custom type"

61+ error "toEncoder: bad union type"

62

63 Can.TRecord _ (Just _) ->

64 error "toEncoder: bad record"

@@ -68,7 +68,7 @@ toEncoder tipe =

68 encodeField (name, Can.FieldType _ fieldType) =

69 do encoder <- toEncoder fieldType

70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]

71− return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing

71+ return $ Opt.Tuple (Opt.Str (Name.toUtf8 name)) value Nothing

72 in

73 do object <- encode "object"

74 keyValuePairs <- traverse encodeField (Map.toList fields)

@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =

309 return $

310 Opt.Call andThen

311 [ Opt.Function [key] decoder

312− , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]

312+ , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]

313 ]

314

315

compiler/src/Parse/Declaration.hs+131−180

@@ -16,11 +16,11 @@ import qualified Parse.Expression as Expr

16import qualified Parse.Pattern as Pattern

17import qualified Parse.Keyword as Keyword

18import qualified Parse.Number as Number

19−import qualified Parse.Space as Space

20import qualified Parse.Symbol as Symbol

19import qualified Parse.Symbol as Symbol

21import qualified Parse.Type as Type

20import qualified Parse.Type as Type

22import qualified Parse.Variable as Var

21import qualified Parse.Variable as Var

22+import Parse.Utils

23−import Parse.Primitives hiding (State)

23+import Parse.Primitives hiding (Parser, State)

24import qualified Parse.Primitives as P

25import qualified Reporting.Annotation as A

26import qualified Reporting.Error.Syntax as E

@@ -31,182 +31,141 @@ import qualified Reporting.Error.Syntax as E

31

32

33data Decl

34− = Value (Maybe Src.Comment) (A.Located Src.Value)

34+ = Value (A.Located Src.Value)

35− | Union (Maybe Src.Comment) (A.Located Src.Union)

35+ | Union (A.Located Src.Union)

36− | Alias (Maybe Src.Comment) (A.Located Src.Alias)

36+ | Alias (A.Located Src.Alias)

37− | Port (Maybe Src.Comment) Src.Port

37+ | Port Src.Port

38

39

40−declaration :: Space.Parser E.Decl Decl

40+declaration :: SParser Decl

41declaration =

42− do maybeDocs <- chompDocComment

43− start <- getPosition

42+ do start <- getPosition

44− oneOf E.DeclStart

43+ oneOf E.XXX

45− [ typeDecl maybeDocs start

44+ [ typeDecl start

46− , portDecl maybeDocs

45+ , portDecl

47− , valueDecl maybeDocs start

46+ , valueDecl start

48 ]

47 ]

49

48

50

49

51

50

52−-- DOC COMMENT

53−

54−

55−chompDocComment :: Parser E.Decl (Maybe Src.Comment)

56−chompDocComment =

57− oneOfWithFallback

58− [

59− do docComment <- Space.docComment E.DeclStart E.DeclSpace

60− Space.chomp E.DeclSpace

61− Space.checkFreshLine E.DeclFreshLineAfterDocComment

62− return (Just docComment)

63− ]

64− Nothing

65−

66−

67−

68-- DEFINITION and ANNOTATION

51-- DEFINITION and ANNOTATION

69

52

70

53

71{-# INLINE valueDecl #-}

54{-# INLINE valueDecl #-}

72−valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl

55+valueDecl :: A.Position -> SParser Decl

73−valueDecl maybeDocs start =

56+valueDecl start =

74− do name <- Var.lower E.DeclStart

57+ do name <- Var.lower

75 end <- getPosition

58 end <- getPosition

76− specialize (E.DeclDef name) $

59+ spaces

77− do Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals

78− oneOf E.DeclDefEquals

60+ oneOf E.XXX

79− [

61+ [

80− do word1 0x3A {-:-} E.DeclDefEquals

62+ do word1 0x3A {-:-} E.XXX

81− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType

63+ pushContext start (E.Annotation name)

64+ spaces

82− (tipe, _) <- specialize E.DeclDefType Type.expression

65+ (tipe, _, space) <- Type.expression

83− Space.checkFreshLine E.DeclDefNameRepeat

66+ popContext ()

67+ checkAligned space

84− defName <- chompMatchingName name

68+ defName <- matchingName name

85− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals

69+ let (A.At (A.Region defStart _) _) = defName

70+ pushContext defStart (E.Definition name)

71+ spaces

86− chompDefArgsAndBody maybeDocs start defName (Just tipe) []

72+ decl <- valueHelp start defName (Just tipe) []

73+ popContext decl

87− ,

74+ ,

75+ do pushContext start (E.Definition name)

88− chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []

76+ decl <- valueHelp start (A.at start end name) Nothing []

77+ popContext decl

89− ]

78+ ]

90−

79+

91−

80+

92−chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl

81+valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl

93−chompDefArgsAndBody maybeDocs start name tipe revArgs =

82+valueHelp start name tipe revArgs =

94− oneOf E.DeclDefEquals

83+ oneOf E.XXX

95− [ do arg <- specialize E.DeclDefArg Pattern.term

84+ [ do arg <- Pattern.term

96− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals

85+ spaces

97− chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs)

86+ valueHelp start name tipe (arg : revArgs)

98− , do word1 0x3D {-=-} E.DeclDefEquals

87+ , do word1 0x3D {-=-} E.XXX

99− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody

88+ spaces

100− (body, end) <- specialize E.DeclDefBody Expr.expression

89+ (body, end, space) <- Expr.expression

101− let value = Src.Value name (reverse revArgs) body tipe

90+ let value = A.at start end (Src.Value name (reverse revArgs) body tipe)

102− let avalue = A.at start end value

91+ return ( Value value, end, space )

103− return (Value maybeDocs avalue, end)

104 ]

92 ]

105

93

106

94

107−chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)

95+matchingName :: Name.Name -> Parser (A.Located Name.Name)

108−chompMatchingName expectedName =

96+matchingName expectedName =

109− let

110− (P.Parser parserL) = Var.lower E.DeclDefNameRepeat

97+ let (P.Parser parserL) = Var.lower in

111− in

112− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->

98+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->

113 let

99 let

114− cokL name newState@(P.State _ _ _ _ er ec) =

100+ cokL name newState@(P.State _ _ _ er ec _) =

115 if expectedName == name

101 if expectedName == name

116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

102 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

117− else cerr sr sc (E.DeclDefNameMatch name)

103+ else cerr sr sc ctx (E.MatchingName expectedName)

118

104

119− eokL name newState@(P.State _ _ _ _ er ec) =

105+ eokL name newState@(P.State _ _ _ er ec _) =

120 if expectedName == name

106 if expectedName == name

121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

107 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

122− else eerr sr sc (E.DeclDefNameMatch name)

108+ else eerr sr sc ctx (E.MatchingName expectedName)

123 in

109 in

124 parserL state cokL eokL cerr eerr

110 parserL state cokL eokL cerr eerr

125

111

126

112

127

113

128−-- TYPE DECLARATIONS

114+-- TYPE ALIAS and UNION TYPES

129

115

130

116

131{-# INLINE typeDecl #-}

117{-# INLINE typeDecl #-}

132−typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl

118+typeDecl :: A.Position -> SParser Decl

133−typeDecl maybeDocs start =

119+typeDecl start =

134− inContext E.DeclType (Keyword.type_ E.DeclStart) $

120+ do Keyword.type_

135− do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName

121+ spaces

136− oneOf E.DT_Name

122+ oneOf E.XXX

137− [

123+ [

138− inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $

124+ inContext E.TypeAlias Keyword.alias_ $

139− do Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals

125+ do spaces

140− (name, args) <- chompAliasNameToEquals

126+ (name, args) <- nameArgsEquals

141− (tipe, end) <- specialize E.AliasBody Type.expression

127+ (tipe, end, pos) <- Type.expression

142− let alias = A.at start end (Src.Alias name args tipe)

128+ let alias = A.at start end (Src.Alias name args tipe)

143− return (Alias maybeDocs alias, end)

129+ return (Alias alias, end, pos)

144− ,

130+ ,

145− specialize E.DT_Union $

131+ do pushContext start E.TypeUnion

146− do (name, args) <- chompCustomNameToEquals

132+ (name, args) <- nameArgsEquals

147− (firstVariant, firstEnd) <- Type.variant

133+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor

148− (variants, end) <- chompVariants [firstVariant] firstEnd

134+ (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace

149− let union = A.at start end (Src.Union name args variants)

135+ let union = A.at start end (Src.Union name args ctors)

150− return (Union maybeDocs union, end)

136+ popContext (Union union, end, pos)

151− ]

152−

153−

154−

155−-- TYPE ALIASES

156−

157−

158−chompAliasNameToEquals :: Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])

159−chompAliasNameToEquals =

160− do name <- addLocation (Var.upper E.AliasName)

161− Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals

162− chompAliasNameToEqualsHelp name []

163−

164−

165−chompAliasNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.TypeAlias (A.Located Name.Name, [A.Located Name.Name])

166−chompAliasNameToEqualsHelp name args =

167− oneOf E.AliasEquals

168− [ do arg <- addLocation (Var.lower E.AliasEquals)

169− Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals

170− chompAliasNameToEqualsHelp name (arg:args)

171− , do word1 0x3D {-=-} E.AliasEquals

172− Space.chompAndCheckIndent E.AliasSpace E.AliasIndentBody

173− return ( name, reverse args )

174− ]

137+ ]

175−

176−

177−

178−-- CUSTOM TYPES

179

138

180

139

181−chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])

140+nameArgsEquals :: Parser (A.Located Name.Name, [A.Located Name.Name])

182−chompCustomNameToEquals =

141+nameArgsEquals =

183− do name <- addLocation (Var.upper E.CT_Name)

142+ do name <- addLocation Var.upper

184− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals

143+ spaces

185− chompCustomNameToEqualsHelp name []

144+ nameArgsEqualsHelp name []

186

145

187

146

188−chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])

147+nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])

189−chompCustomNameToEqualsHelp name args =

148+nameArgsEqualsHelp name args =

190− oneOf E.CT_Equals

149+ oneOf E.XXX

191− [ do arg <- addLocation (Var.lower E.CT_Equals)

150+ [ do arg <- addLocation Var.lower

192− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals

151+ spaces

193− chompCustomNameToEqualsHelp name (arg:args)

152+ nameArgsEqualsHelp name (arg:args)

194− , do word1 0x3D {-=-} E.CT_Equals

153+ , do word1 0x3D {-=-} E.XXX

195− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals

154+ spaces

196 return ( name, reverse args )

155 return ( name, reverse args )

197 ]

156 ]

198

157

199

158

200−chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])]

159+chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]

201−chompVariants variants end =

160+chompConstructors ctors end pos =

202− oneOfWithFallback

161+ oneOf E.XXX

203− [ do Space.checkIndent end E.CT_IndentBar

162+ [ do checkSpace pos

204− word1 0x7C {-|-} E.CT_Bar

163+ word1 0x7C {-|-} E.XXX

205− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar

164+ spaces

206− (variant, newEnd) <- Type.variant

165+ (ctor, newEnd, newSpace) <- Type.unionConstructor

207− chompVariants (variant:variants) newEnd

166+ chompConstructors (ctor:ctors) newEnd newSpace

167+ , return ( reverse ctors, end, pos )

208 ]

168 ]

209− (reverse variants, end)

210

169

211

170

212

171

@@ -214,19 +173,16 @@ chompVariants variants end =

214

173

215

174

216{-# INLINE portDecl #-}

175{-# INLINE portDecl #-}

217−portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl

176+portDecl :: SParser Decl

218−portDecl maybeDocs =

177+portDecl =

219− inContext E.Port (Keyword.port_ E.DeclStart) $

178+ inContext E.Port Keyword.port_ $

220− do Space.chompAndCheckIndent E.PortSpace E.PortIndentName

179+ do spaces

221− name <- addLocation (Var.lower E.PortName)

180+ name <- addLocation Var.lower

222− Space.chompAndCheckIndent E.PortSpace E.PortIndentColon

181+ spaces

223− word1 0x3A {-:-} E.PortColon

182+ word1 0x3A {-:-} E.XXX

224− Space.chompAndCheckIndent E.PortSpace E.PortIndentType

183+ spaces

225− (tipe, end) <- specialize E.PortType Type.expression

184+ (tipe, end, pos) <- Type.expression

226− return

227− ( Port maybeDocs (Src.Port name tipe)

185+ return ( Port (Src.Port name tipe), end, pos )

228− , end

229− )

230

186

231

187

232

188

@@ -235,32 +191,27 @@ portDecl maybeDocs =

235

191

236-- INVARIANT: always chomps to a freshline

192-- INVARIANT: always chomps to a freshline

237--

193--

238−infix_ :: Parser E.Module (A.Located Src.Infix)

194+infix_ :: Parser (A.Located Src.Binop)

239infix_ =

195infix_ =

240− let

241− err = E.Infix

242− _err = \_ -> E.Infix

243− in

244 do start <- getPosition

196 do start <- getPosition

245− Keyword.infix_ err

197+ inContext E.Infix Keyword.infix_ $

246− Space.chompAndCheckIndent _err err

198+ do spaces

247− associativity <-

199+ associativity <-

248− oneOf err

200+ oneOf E.XXX

249− [ Keyword.left_ err >> return Binop.Left

201+ [ Keyword.left_ >> return Binop.Left

250− , Keyword.right_ err >> return Binop.Right

202+ , Keyword.right_ >> return Binop.Right

251− , Keyword.non_ err >> return Binop.Non

203+ , Keyword.non_ >> return Binop.Non

252− ]

204+ ]

253− Space.chompAndCheckIndent _err err

205+ spaces

254− precedence <- Number.precedence err

206+ precedence <- Number.precedence

255− Space.chompAndCheckIndent _err err

207+ spaces

256− word1 0x28 {-(-} err

208+ word1 0x28 {-(-} E.XXX

257− op <- Symbol.operator err _err

209+ op <- Symbol.binop

258− word1 0x29 {-)-} err

210+ word1 0x29 {-)-} E.XXX

259− Space.chompAndCheckIndent _err err

211+ spaces

260− word1 0x3D {-=-} err

212+ word1 0x3D {-=-} E.XXX

261− Space.chompAndCheckIndent _err err

213+ spaces

262− name <- Var.lower err

214+ name <- Var.lower

263− end <- getPosition

215+ end <- getPosition

264− Space.chomp _err

265− Space.checkFreshLine err

216+ checkFreshLine =<< whitespace

266− return (A.at start end (Src.Infix op associativity precedence name))

217+ return (A.at start end (Src.Binop op associativity precedence name))

compiler/src/Parse/Docs.hsnew file+275

@@ -0,0 +1,275 @@

1+module Parse.Docs

2+ ( Docs(..)

3+ , parser

4+ )

5+ where

6+

7+

8+

9+-- DOCS

10+

11+

12+data Docs =

13+ Docs

14+ { _exposed :: [A.Located Name.Name]

15+ , _overview :: Utf8.String

16+ , _listed :: [A.Located Name.Name]

17+ , _comments :: Map.Map Name.Name Utf8.String

18+ }

19+

20+

21+

22+-- PARSER

23+

24+

25+parser :: Parser Docs

26+parser =

27+ error "TODO implement docs parser"

28+

29+

30+chompUntilDocs :: Parser Bool

31+chompUntilDocs =

32+ P.Parser $ \(P.State fp offset terminal indent row col ctx) cok _ _ _ ->

33+ let

34+ (# isStart, newOffset, newRow, newCol #) =

35+ eatDocs fp offset terminal row col

36+

37+ !newState =

38+ P.State fp newOffset terminal indent newRow newCol ctx

39+ in

40+ cok isStart newState

41+

42+

43+eatDocs :: ForeignPtr Word8 -> Int -> Int -> Word16 -> Word16 -> (# Bool, Int, Word16, Word16 #)

44+eatDocs fp offset terminal row col =

45+ if offset >= terminal then

46+ (# False, offset, row, col #)

47+

48+ else if isDocsStart fp offset terminal then

49+ (# True, offset + 5, row, col + 5 #)

50+

51+ else

52+ let !word = P.unsafeIndex fp offset in

53+ if word == 0x0A {- \n -} then

54+ eatDocs fp (offset + 1) terminal (row + 1) 1

55+

56+ else

57+ let !newOffset = offset + P.getCharWidth fp offset terminal word in

58+ eatDocs fp newOffset terminal row (col + 1)

59+

60+

61+isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool

62+isDocsStart =

63+ let (B.PS dfp doff dlen) = docsStart in

64+ P.isSubstring dfp doff dlen

65+

66+

67+{-# NOINLINE docsStart #-}

68+docsStart :: B.ByteString

69+docsStart =

70+ "@docs"

71+

72+

73+chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

74+chompOverview names =

75+ do isDocs <- chompUntilDocs

76+ if isDocs

77+ then chompOverviewHelp names

78+ else return names

79+

80+

81+chompOverviewHelp :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

82+chompOverviewHelp names =

83+ do pos <- getPosition

84+ (SPos spos) <- whitespace

85+ if pos == spos

86+ then chompOverview names

87+ else chompOverview =<< chompDocs names

88+

89+

90+chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

91+chompDocs names =

92+ do name <- addLocation (oneOf SE.XXX [ Var.lower, Var.upper, chompBinop ])

93+ spos <- whitespace

94+ oneOf SE.XXX

95+ [ do checkSpace spos

96+ word1 0x2C {-,-} SE.XXX

97+ spaces

98+ chompDocs (name:names)

99+ , return (name:names)

100+ ]

101+

102+

103+chompBinop :: Parser Name.Name

104+chompBinop =

105+ do word1 0x28 {-(-} SE.XXX

106+ name <- Symbol.binop

107+ word1 0x29 {-)-} SE.XXX

108+ return name

109+

110+

111+

112+

113+-- CHECK NAMES

114+

115+

116+type Result i w a =

117+ Result.Result i w E.Error a

118+

119+

120+type Dups =

121+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)

122+

123+

124+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()

125+checkNames exports names =

126+ do docs <- Map.traverseWithKey isUnique (List.foldl' addName Map.empty names)

127+ let overlap = Map.size (Map.intersection docs exports)

128+ if Map.size exports == overlap && overlap == Map.size docs

129+ then Result.ok ()

130+ else

131+ do _ <- Map.traverseWithKey onlyInDocs (Map.difference docs exports)

132+ _ <- Map.traverseWithKey onlyInExports (Map.difference exports docs)

133+ Result.ok ()

134+

135+

136+addName :: Dups -> A.Located Name.Name -> Dups

137+addName dict (A.At region name) =

138+ Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

139+

140+

141+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result i w A.Region

142+isUnique name regions =

143+ case regions of

144+ OneOrMore.One region ->

145+ Result.ok region

146+

147+ OneOrMore.More _ _ ->

148+ let (r1:r2:_) = OneOrMore.toList regions in

149+ Result.throw (E.Duplicate name r1 r2)

150+

151+

152+onlyInDocs :: Name.Name -> A.Region -> Result i w a

153+onlyInDocs name region =

154+ Result.throw $ E.OnlyInDocs name region

155+

156+

157+onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a

158+onlyInExports name (A.At region _) =

159+ Result.throw $ E.OnlyInExports name region

160+

161+

162+

163+-- CHECK EXPORTS

164+

165+

166+data Info =

167+ Info

168+ { _iComments :: Map.Map Name.Name Comment

169+ , _iValues :: Types

170+ , _iUnions :: Map.Map Name.Name Can.Union

171+ , _iAliases :: Map.Map Name.Name Can.Alias

172+ , _iBinops :: Map.Map Name.Name Can.Binop

173+ , _iEffects :: Can.Effects

174+ }

175+

176+

177+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)

178+checkExport info name (A.At region export) =

179+ case export of

180+ Can.ExportValue ->

181+ do tipe <- getType name info

182+ comment <- getComment region name info

183+ Result.ok $ \m ->

184+ m { _values = Map.insert name (Value comment tipe) (_values m) }

185+

186+ Can.ExportBinop ->

187+ do let (Can.Binop_ assoc prec realName) = _iBinops info ! name

188+ tipe <- getType realName info

189+ comment <- getComment region realName info

190+ Result.ok $ \m ->

191+ m { _binops = Map.insert name (Binop comment tipe assoc prec) (_binops m) }

192+

193+ Can.ExportAlias ->

194+ do let (Can.Alias tvars tipe) = _iAliases info ! name

195+ comment <- getComment region name info

196+ Result.ok $ \m ->

197+ m { _aliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) (_aliases m) }

198+

199+ Can.ExportUnionOpen ->

200+ do let (Can.Union tvars ctors _ _) = _iUnions info ! name

201+ comment <- getComment region name info

202+ Result.ok $ \m ->

203+ m { _unions = Map.insert name (Union comment tvars (map dector ctors)) (_unions m) }

204+

205+ Can.ExportUnionClosed ->

206+ do let (Can.Union tvars _ _ _) = _iUnions info ! name

207+ comment <- getComment region name info

208+ Result.ok $ \m ->

209+ m { _unions = Map.insert name (Union comment tvars []) (_unions m) }

210+

211+ Can.ExportPort ->

212+ do tipe <- getType name info

213+ comment <- getComment region name info

214+ Result.ok $ \m ->

215+ m { _values = Map.insert name (Value comment tipe) (_values m) }

216+

217+

218+getComment :: A.Region -> Name.Name -> Info -> Result i w Comment

219+getComment region name info =

220+ case Map.lookup name (_iComments info) of

221+ Nothing ->

222+ Result.throw (E.NoComment name region)

223+

224+ Just comment ->

225+ Result.ok comment

226+

227+

228+getType :: Name.Name -> Info -> Result i w Type.Type

229+getType name info =

230+ case _iValues info ! name of

231+ A.At defRegion Nothing ->

232+ Result.throw (E.NoAnnotation name defRegion)

233+

234+ A.At _ (Just tipe) ->

235+ Result.ok (Extract.fromType tipe)

236+

237+

238+dector :: Can.Ctor -> (Name.Name, [Type.Type])

239+dector (Can.Ctor name _ _ args) =

240+ ( name, map Extract.fromType args )

241+

242+

243+

244+-- GATHER TYPES

245+

246+

247+type Types =

248+ Map.Map Name.Name (A.Located (Maybe Can.Type))

249+

250+

251+gatherTypes :: Can.Decls -> Types -> Types

252+gatherTypes decls types =

253+ case decls of

254+ Can.Declare def subDecls ->

255+ gatherTypes subDecls (addDef types def)

256+

257+ Can.DeclareRec defs subDecls ->

258+ gatherTypes subDecls (List.foldl' addDef types defs)

259+

260+ Can.SaveTheEnvironment ->

261+ types

262+

263+

264+addDef :: Types -> Can.Def -> Types

265+addDef types def =

266+ case def of

267+ Can.Def (A.At region name) _ _ ->

268+ Map.insert name (A.At region Nothing) types

269+

270+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->

271+ let

272+ tipe =

273+ foldr Can.TLambda resultType (map snd typedArgs)

274+ in

275+ Map.insert name (A.At region (Just tipe)) types

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

@@ -7,18 +7,19 @@ module Parse.Expression

7

8

9import qualified Data.Name as Name

10+import Data.Word (Word16)

10

11

11import qualified AST.Source as Src

12import qualified AST.Source as Src

12import qualified Parse.Keyword as Keyword

13import qualified Parse.Keyword as Keyword

13import qualified Parse.Number as Number

14import qualified Parse.Number as Number

14import qualified Parse.Pattern as Pattern

15import qualified Parse.Pattern as Pattern

15import qualified Parse.Shader as Shader

16import qualified Parse.Shader as Shader

16−import qualified Parse.Space as Space

17import qualified Parse.Symbol as Symbol

18import qualified Parse.Type as Type

19−import qualified Parse.String as String

19+import qualified Parse.Utf8 as Utf8

20import qualified Parse.Variable as Var

21+import Parse.Utils

21−import Parse.Primitives hiding (State)

22+import Parse.Primitives hiding (Parser, State)

22import qualified Parse.Primitives as P

23import qualified Parse.Primitives as P

23import qualified Reporting.Annotation as A

24import qualified Reporting.Annotation as A

24import qualified Reporting.Error.Syntax as E

25import qualified Reporting.Error.Syntax as E

@@ -28,10 +29,10 @@ import qualified Reporting.Error.Syntax as E

28-- TERMS

29-- TERMS

29

30

31

31−term :: Parser E.Expr Src.Expr

32+term :: Parser Src.Expr

32term =

33term =

33 do start <- getPosition

34 do start <- getPosition

34− oneOf E.Start

35+ oneOf E.XXX

35 [ variable start >>= accessible start

36 [ variable start >>= accessible start

36 , string start

37 , string start

37 , number start

38 , number start

@@ -44,80 +45,90 @@ term =

44 ]

45 ]

45

46

47

47−string :: A.Position -> Parser E.Expr Src.Expr

48+string :: A.Position -> Parser Src.Expr

48string start =

49string start =

49− do str <- String.string E.Start E.String

50+ do str <- Utf8.string

51+ end <- getPosition

50− addEnd start (Src.Str str)

52+ return (A.at start end (Src.Str str))

51

53

52

54

53−character :: A.Position -> Parser E.Expr Src.Expr

55+character :: A.Position -> Parser Src.Expr

54character start =

56character start =

55− do chr <- String.character E.Start E.Char

57+ do chr <- Utf8.character

58+ end <- getPosition

56− addEnd start (Src.Chr chr)

59+ return (A.at start end (Src.Chr chr))

57

60

58

61

59−number :: A.Position -> Parser E.Expr Src.Expr

62+number :: A.Position -> Parser Src.Expr

60number start =

63number start =

61− do nmbr <- Number.number E.Start E.Number

64+ do nmbr <- Number.number

62− addEnd start $

65+ end <- getPosition

66+ return $ A.at start end $

63 case nmbr of

67 case nmbr of

64− Number.Int int -> Src.Int int

68+ Number.Int int ->

65− Number.Float float -> Src.Float float

69+ Src.Int int

66

70

71+ Number.Float float ->

72+ Src.Float float

67

73

74+

68−accessor :: A.Position -> Parser E.Expr Src.Expr

75+accessor :: A.Position -> Parser Src.Expr

69accessor start =

76accessor start =

70− do word1 0x2E {-.-} E.Dot

77+ do word1 0x2E {-.-} E.XXX

71− field <- Var.lower E.Access

78+ field <- Var.lower

79+ end <- getPosition

72− addEnd start (Src.Accessor field)

80+ return (A.at start end (Src.Accessor field))

73

81

74

82

75−variable :: A.Position -> Parser E.Expr Src.Expr

83+variable :: A.Position -> Parser Src.Expr

76variable start =

84variable start =

77− do var <- Var.foreignAlpha E.Start

85+ do var <- Var.foreignAlpha

86+ end <- getPosition

78− addEnd start var

87+ return (A.at start end var)

79

88

80

89

81−accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr

90+accessible :: A.Position -> Src.Expr -> Parser Src.Expr

82accessible start expr =

91accessible start expr =

83− oneOfWithFallback

92+ oneOf E.XXX

84− [ do word1 0x2E {-.-} E.Dot

93+ [ do word1 0x2E {-.-} E.XXX

85 pos <- getPosition

94 pos <- getPosition

86− field <- Var.lower E.Access

95+ field <- Var.lower

87 end <- getPosition

96 end <- getPosition

88− accessible start $

89− A.at start end (Src.Access expr (A.at pos end field))

97+ let newExpr = A.at start end (Src.Access expr (A.at pos end field))

98+ accessible start newExpr

99+ , return expr

90 ]

100 ]

91− expr

92

101

93

102

94

103

95-- LISTS

104-- LISTS

96

105

97

106

98−list :: A.Position -> Parser E.Expr Src.Expr

107+list :: A.Position -> Parser Src.Expr

99list start =

108list start =

100− inContext E.List (word1 0x5B {-[-} E.Start) $

109+ inContext E.ExprList (word1 0x5B {-[-} E.XXX) $

101− do Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen

110+ do spaces

102− oneOf E.ListOpen

111+ oneOf E.XXX

103− [ do (entry, end) <- specialize E.ListExpr expression

112+ [ do (entry, _, pos) <- expression

104− Space.checkIndent end E.ListIndentEnd

113+ checkSpace pos

105− chompListEnd start [entry]

114+ listHelp start [entry]

106− , do word1 0x5D {-]-} E.ListOpen

115+ , do word1 0x5D {-]-} E.XXX

116+ end <- getPosition

107− addEnd start (Src.List [])

117+ return (A.at start end (Src.List []))

108 ]

118 ]

109

119

110

120

111−chompListEnd :: A.Position -> [Src.Expr] -> Parser E.List Src.Expr

121+listHelp :: A.Position -> [Src.Expr] -> Parser Src.Expr

112−chompListEnd start entries =

122+listHelp start entries =

113− oneOf E.ListEnd

123+ oneOf E.XXX

114− [ do word1 0x2C {-,-} E.ListEnd

124+ [ do word1 0x2C {-,-} E.XXX

115− Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr

125+ spaces

116− (entry, end) <- specialize E.ListExpr expression

126+ (entry, _, pos) <- expression

117− Space.checkIndent end E.ListIndentEnd

127+ checkSpace pos

118− chompListEnd start (entry:entries)

128+ listHelp start (entry:entries)

119− , do word1 0x5D {-]-} E.ListEnd

129+ , do word1 0x5D {-]-} E.XXX

130+ end <- getPosition

120− addEnd start (Src.List (reverse entries))

131+ return (A.at start end (Src.List (reverse entries)))

121 ]

132 ]

122

133

123

134

@@ -125,66 +136,52 @@ chompListEnd start entries =

125-- TUPLES

136-- TUPLES

126

137

127

138

128−tuple :: A.Position -> Parser E.Expr Src.Expr

139+tuple :: A.Position -> Parser Src.Expr

129−tuple start@(A.Position row col) =

140+tuple start =

130− inContext E.Tuple (word1 0x28 {-(-} E.Start) $

141+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $

131− do before <- getPosition

142+ do pos <- getPosition

132− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1

143+ spos <- whitespace

144+ oneOf E.XXX

145+ [ do noSpace pos spos

146+ word2 0x2D 0x29 {--)-} E.XXX

133− after <- getPosition

147+ end <- getPosition

134− if before /= after

148+ return $ A.at start end (Src.Op "-")

135− then

149+

150+ , do checkSpace spos

136− do (entry, end) <- specialize E.TupleExpr expression

151+ (entry, _, spos2) <- expression

137− Space.checkIndent end E.TupleIndentEnd

152+ checkSpace spos2

138− chompTupleEnd start entry []

153+ tupleHelp start entry []

139− else

154+

140− oneOf E.TupleIndentExpr1

155+ , do noSpace pos spos

141− [

156+ op <- Symbol.binop

142− do op <- Symbol.operator E.TupleIndentExpr1 E.TupleOperatorReserved

143− if op == "-"

144− then

145− oneOf E.TupleOperatorClose

146− [

147− do word1 0x29 {-)-} E.TupleOperatorClose

157+ word1 0x29 {-)-} E.XXX

148− addEnd start (Src.Op op)

158+ end <- getPosition

149− ,

159+ return $ A.at start end (Src.Op op)

150− do (entry, end) <-

160+

151− specialize E.TupleExpr $

161+ , do noSpace pos spos

152− do negatedExpr@(A.At (A.Region _ end) _) <- term

153− Space.chomp E.Space

154− let exprStart = A.Position row (col + 2)

155− let expr = A.at exprStart end (Src.Negate negatedExpr)

156− chompExprEnd exprStart (State [] expr [] end)

157− Space.checkIndent end E.TupleIndentEnd

158− chompTupleEnd start entry []

159− ]

160− else

161− do word1 0x29 {-)-} E.TupleOperatorClose

162+ word1 0x29 {-)-} E.XXX

162− addEnd start (Src.Op op)

163+ end <- getPosition

163− ,

164− do word1 0x29 {-)-} E.TupleIndentExpr1

165− addEnd start Src.Unit

164+ return (A.at start end Src.Unit)

166− ,

165+

167− do (entry, end) <- specialize E.TupleExpr expression

168− Space.checkIndent end E.TupleIndentEnd

169− chompTupleEnd start entry []

170− ]

166+ ]

171−

167+

172−

168+

173−chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr

169+tupleHelp :: A.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr

174−chompTupleEnd start firstExpr revExprs =

170+tupleHelp start firstExpr revExprs =

175− oneOf E.TupleEnd

171+ oneOf E.XXX

176− [ do word1 0x2C {-,-} E.TupleEnd

172+ [ do word1 0x2C {-,-} E.XXX

177− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN

173+ spaces

178− (entry, end) <- specialize E.TupleExpr expression

174+ (entry, _, pos) <- expression

179− Space.checkIndent end E.TupleIndentEnd

175+ checkSpace pos

180− chompTupleEnd start firstExpr (entry : revExprs)

176+ tupleHelp start firstExpr (entry : revExprs)

181− , do word1 0x29 {-)-} E.TupleEnd

177+ , do word1 0x29 {-)-} E.XXX

178+ end <- getPosition

182 case reverse revExprs of

179 case reverse revExprs of

183 [] ->

180 [] ->

184 return firstExpr

181 return firstExpr

185

182

186− secondExpr : otherExprs ->

183+ secondExpr : others ->

187− addEnd start (Src.Tuple firstExpr secondExpr otherExprs)

184+ return (A.at start end (Src.Tuple firstExpr secondExpr others))

188 ]

185 ]

189

186

190

187

@@ -192,27 +189,30 @@ chompTupleEnd start firstExpr revExprs =

192-- RECORDS

189-- RECORDS

193

190

194

191

195−record :: A.Position -> Parser E.Expr Src.Expr

192+record :: A.Position -> Parser Src.Expr

196record start =

193record start =

197− inContext E.Record (word1 0x7B {- { -} E.Start) $

194+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $

198− do Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen

195+ do spaces

199− oneOf E.RecordOpen

196+ oneOf E.XXX

200− [ do word1 0x7D {-}-} E.RecordOpen

197+ [ do word1 0x7D {-}-} E.XXX

198+ end <- getPosition

201− addEnd start (Src.Record [])

199+ return (A.at start end (Src.Record []))

202− , do starter <- addLocation (Var.lower E.RecordField)

200+ , do starter <- addLocation Var.lower

203− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals

201+ spaces

204− oneOf E.RecordEquals

202+ oneOf E.XXX

205− [ do word1 0x7C {-|-} E.RecordEquals

203+ [ do word1 0x7C {-|-} E.XXX

206− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField

204+ spaces

207 firstField <- chompField

205 firstField <- chompField

208 fields <- chompFields [firstField]

206 fields <- chompFields [firstField]

207+ end <- getPosition

209− addEnd start (Src.Update starter fields)

208+ return (A.at start end (Src.Update starter fields))

210− , do word1 0x3D {-=-} E.RecordEquals

209+ , do word1 0x3D {-=-} E.XXX

211− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr

210+ spaces

212− (value, end) <- specialize E.RecordExpr expression

211+ (value, _, nextPos) <- expression

213− Space.checkIndent end E.RecordIndentEnd

212+ checkSpace nextPos

214 fields <- chompFields [(starter, value)]

213 fields <- chompFields [(starter, value)]

214+ end <- getPosition

215− addEnd start (Src.Record fields)

215+ return (A.at start end (Src.Record fields))

216 ]

217 ]

218

@@ -220,26 +220,26 @@ record start =

220type Field = ( A.Located Name.Name, Src.Expr )

221

222

223−chompFields :: [Field] -> Parser E.Record [Field]

223+chompFields :: [Field] -> Parser [Field]

224chompFields fields =

225− oneOf E.RecordEnd

225+ oneOf E.XXX

226− [ do word1 0x2C {-,-} E.RecordEnd

226+ [ do word1 0x2C {-,-} E.XXX

227− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField

227+ spaces

228 f <- chompField

229 chompFields (f : fields)

230− , do word1 0x7D {-}-} E.RecordEnd

230+ , do word1 0x7D {-}-} E.XXX

231 return (reverse fields)

232 ]

233

234

235−chompField :: Parser E.Record Field

235+chompField :: Parser Field

236chompField =

237− do key <- addLocation (Var.lower E.RecordField)

237+ do key <- addLocation Var.lower

238− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals

238+ spaces

239− word1 0x3D {-=-} E.RecordEquals

239+ word1 0x3D {-=-} E.XXX

240− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr

240+ spaces

241− (value, end) <- specialize E.RecordExpr expression

241+ (value, _, pos) <- expression

242− Space.checkIndent end E.RecordIndentEnd

242+ checkSpace pos

243 return (key, value)

244

245

@@ -247,18 +247,22 @@ chompField =

247-- EXPRESSIONS

248

249

250−expression :: Space.Parser E.Expr Src.Expr

250+type ExprParser =

251+ SParser Src.Expr

252+

253+

254+expression :: ExprParser

251expression =

255expression =

252 do start <- getPosition

256 do start <- getPosition

253− oneOf E.Start

257+ oneOf E.XXX

254 [ let_ start

258 [ let_ start

255 , if_ start

259 , if_ start

256 , case_ start

260 , case_ start

257 , function start

261 , function start

258 , do expr <- possiblyNegativeTerm start

262 , do expr <- possiblyNegativeTerm start

259 end <- getPosition

263 end <- getPosition

260− Space.chomp E.Space

264+ space <- whitespace

261− chompExprEnd start (State [] expr [] end)

265+ exprHelp start (State [] expr [] end space)

262 ]

266 ]

263

267

264

268

@@ -268,77 +272,77 @@ data State =

268 , _expr :: !Src.Expr

272 , _expr :: !Src.Expr

269 , _args :: ![Src.Expr]

273 , _args :: ![Src.Expr]

270 , _end :: !A.Position

274 , _end :: !A.Position

275+ , _pos :: !SPos

271 }

276 }

272

277

273

278

274−chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr

279+exprHelp :: A.Position -> State -> ExprParser

275−chompExprEnd start (State ops expr args end) =

280+exprHelp start (State ops expr args end pos) =

276− oneOfWithFallback

281+ oneOf E.XXX

277 [ -- argument

282 [ -- argument

278− do Space.checkIndent end E.Start

283+ do checkSpace pos

279 arg <- term

284 arg <- term

280 newEnd <- getPosition

285 newEnd <- getPosition

281− Space.chomp E.Space

286+ newPos <- whitespace

282− chompExprEnd start (State ops expr (arg:args) newEnd)

287+ exprHelp start (State ops expr (arg:args) newEnd newPos)

283−

288+

284− , -- operator

289+ , -- infix operator

285− do Space.checkIndent end E.Start

290+ do checkSpace pos

286− op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)

291+ opStart <- getPosition

287− Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)

292+ opName <- Symbol.binop

293+ opEnd <- getPosition

294+ let op = A.at opStart opEnd opName

295+ spos <- whitespace

296+ checkSpace spos

288 newStart <- getPosition

297 newStart <- getPosition

289 if "-" == opName && end /= opStart && opEnd == newStart

298 if "-" == opName && end /= opStart && opEnd == newStart

290 then

299 then

291 -- negative terms

300 -- negative terms

292− do negatedExpr <- term

301+ do rawTerm <- term

293 newEnd <- getPosition

302 newEnd <- getPosition

294− Space.chomp E.Space

303+ newPos <- whitespace

295− let arg = A.at opStart newEnd (Src.Negate negatedExpr)

304+ let arg = A.at opStart newEnd (Src.Negate rawTerm)

296− chompExprEnd start (State ops expr (arg:args) newEnd)

305+ exprHelp start (State ops expr (arg:args) newEnd newPos)

297 else

306 else

298− let err = E.OperatorRight opName in

307+ oneOf E.XXX

299− oneOf err

300 [ -- term

308 [ -- term

301 do newExpr <- possiblyNegativeTerm newStart

309 do newExpr <- possiblyNegativeTerm newStart

302 newEnd <- getPosition

310 newEnd <- getPosition

303− Space.chomp E.Space

311+ newPos <- whitespace

304 let newOps = (toCall expr args, op) : ops

312 let newOps = (toCall expr args, op) : ops

305− chompExprEnd start (State newOps newExpr [] newEnd)

313+ exprHelp start (State newOps newExpr [] newEnd newPos)

306

314

307 , -- final term

315 , -- final term

308− do (newLast, newEnd) <-

316+ do (newLast, newEnd, newPos) <-

309− oneOf err

317+ oneOf E.XXX

310 [ let_ newStart

318 [ let_ newStart

311 , case_ newStart

319 , case_ newStart

312 , if_ newStart

320 , if_ newStart

313 , function newStart

321 , function newStart

314 ]

322 ]

315 let newOps = (toCall expr args, op) : ops

323 let newOps = (toCall expr args, op) : ops

316− let finalExpr = Src.Binops (reverse newOps) newLast

324+ let finalExpr = A.at start newEnd (Src.Binops (reverse newOps) newLast)

317− return ( A.at start newEnd finalExpr, newEnd )

325+ return ( finalExpr, newEnd, newPos )

318 ]

326 ]

319

327

320− ]

321− -- done

328+ , -- done

322− (

329+ let finalExpr = toCall expr args in

323 case ops of

330 case ops of

324 [] ->

331 [] ->

325− ( toCall expr args

332+ return ( finalExpr, end, pos )

326− , end

327− )

328

333

329 _ ->

334 _ ->

330− ( A.at start end (Src.Binops (reverse ops) (toCall expr args))

335+ return ( A.at start end (Src.Binops (reverse ops) finalExpr), end, pos )

331− , end

336+ ]

332− )

333− )

334

337

335

338

336−possiblyNegativeTerm :: A.Position -> Parser E.Expr Src.Expr

339+possiblyNegativeTerm :: A.Position -> Parser Src.Expr

337possiblyNegativeTerm start =

340possiblyNegativeTerm start =

338− oneOf E.Start

341+ oneOf E.XXX

339− [ do word1 0x2D {---} E.Start

342+ [ do word1 0x2D {---} E.XXX

340 expr <- term

343 expr <- term

344+ end <- getPosition

341− addEnd start (Src.Negate expr)

345+ return (A.at start end (Src.Negate expr))

342 , term

346 , term

343 ]

347 ]

344

348

@@ -357,32 +361,30 @@ toCall func revArgs =

357-- IF EXPRESSION

361-- IF EXPRESSION

358

362

359

363

360−if_ :: A.Position -> Space.Parser E.Expr Src.Expr

364+if_ :: A.Position -> ExprParser

361if_ start =

365if_ start =

362− inContext E.If (Keyword.if_ E.Start) $

366+ inContext E.ExprIf Keyword.if_ $

363− chompIfEnd start []

367+ ifHelp start []

364−

368+

365−

369+

366−chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr

370+ifHelp :: A.Position -> [(Src.Expr, Src.Expr)] -> ExprParser

367−chompIfEnd start branches =

371+ifHelp start branches =

368− do Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition

372+ do spaces

369− (condition, condEnd) <- specialize E.IfCondition expression

373+ (condition, _, condPos) <- expression

370− Space.checkIndent condEnd E.IfIndentThen

374+ checkSpace condPos

371− Keyword.then_ E.IfThen

375+ Keyword.then_

372− Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch

376+ spaces

373− (thenBranch, thenEnd) <- specialize E.IfThenBranch expression

377+ (thenBranch, _, thenPos) <- expression

374− Space.checkIndent thenEnd E.IfIndentElse

378+ checkSpace thenPos

375− Keyword.else_ E.IfElse

379+ Keyword.else_

376− Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch

380+ spaces

377 let newBranches = (condition, thenBranch) : branches

381 let newBranches = (condition, thenBranch) : branches

378− oneOf E.IfElseBranchStart

382+ oneOf E.XXX

379− [

380− do Keyword.if_ E.IfElseBranchStart

383+ [ do Keyword.if_

381− chompIfEnd start newBranches

384+ ifHelp start newBranches

382− ,

383− do (elseBranch, elseEnd) <- specialize E.IfElseBranch expression

385+ , do (elseBranch, elseEnd, elseSpace) <- expression

384− let ifExpr = Src.If (reverse newBranches) elseBranch

386+ let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)

385− return ( A.at start elseEnd ifExpr, elseEnd )

387+ return ( ifExpr, elseEnd, elseSpace )

386 ]

388 ]

387

389

388

390

@@ -390,27 +392,27 @@ chompIfEnd start branches =

390-- LAMBDA EXPRESSION

392-- LAMBDA EXPRESSION

391

393

392

394

393−function :: A.Position -> Space.Parser E.Expr Src.Expr

395+function :: A.Position -> ExprParser

394function start =

396function start =

395− inContext E.Func (word1 0x5C {-\-} E.Start) $

397+ inContext E.ExprFunc (word1 0x5C {-\-} E.XXX) $

396− do Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg

398+ do spaces

397− arg <- specialize E.FuncArg Pattern.term

399+ arg <- Pattern.term

398− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow

400+ spaces

399− revArgs <- chompArgs [arg]

401+ revArgs <- gatherArgs [arg]

400− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody

402+ spaces

401− (body, end) <- specialize E.FuncBody expression

403+ (body, end, space) <- expression

402− let funcExpr = Src.Lambda (reverse revArgs) body

404+ let func = A.at start end (Src.Lambda (reverse revArgs) body)

403− return (A.at start end funcExpr, end)

405+ return ( func, end, space )

404−

406+

405−

407+

406−chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern]

408+gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]

407−chompArgs revArgs =

409+gatherArgs args =

408− oneOf E.FuncArrow

410+ oneOf E.XXX

409− [ do arg <- specialize E.FuncArg Pattern.term

411+ [ do arg <- Pattern.term

410− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow

412+ spaces

411− chompArgs (arg:revArgs)

413+ gatherArgs (arg:args)

412− , do word2 0x2D 0x3E {-->-} E.FuncArrow

414+ , do word2 0x2D 0x3E {-->-} E.XXX

413− return revArgs

415+ return args

414 ]

416 ]

415

417

416

418

@@ -418,84 +420,90 @@ chompArgs revArgs =

418-- CASE EXPRESSIONS

420-- CASE EXPRESSIONS

419

421

420

422

421−case_ :: A.Position -> Space.Parser E.Expr Src.Expr

423+case_ :: A.Position -> ExprParser

422case_ start =

424case_ start =

423− inContext E.Case (Keyword.case_ E.Start) $

425+ inContext E.ExprCase Keyword.case_ $

424− do Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr

426+ do spaces

425− (expr, exprEnd) <- specialize E.CaseExpr expression

427+ (switcher, _, switcherPos) <- expression

426− Space.checkIndent exprEnd E.CaseIndentOf

428+ checkSpace switcherPos

427− Keyword.of_ E.CaseOf

429+ Keyword.of_

428− Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern

430+ spaces

429− withIndent $

431+ oldIndent <- getIndent

432+ newIndent <- getCol

433+ setIndent newIndent

430− do (firstBranch, firstEnd) <- chompBranch

434+ (firstBranch, firstEnd, firstPos) <- branchHelp

431− (branches, end) <- chompCaseEnd [firstBranch] firstEnd

435+ (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos

436+ setIndent oldIndent

432− return

437+ return

433− ( A.at start end (Src.Case expr branches)

438+ ( A.at start end (Src.Case switcher branches)

434− , end

439+ , end

440+ , pos

435− )

441+ )

436−

442+

437−

443+

438−chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr)

444+branchHelp :: SParser (Src.Pattern, Src.Expr)

439−chompBranch =

445+branchHelp =

440− do (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression

446+ do (pattern, patternPos) <- Pattern.expression

441− Space.checkIndent patternEnd E.CaseIndentArrow

447+ checkSpace patternPos

442− word2 0x2D 0x3E {-->-} E.CaseArrow

448+ word2 0x2D 0x3E {-->-} E.XXX

443− Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch

449+ spaces

444− (branchExpr, end) <- specialize E.CaseBranch expression

450+ (branchExpr, end, pos) <- expression

445− return ( (pattern, branchExpr), end )

451+ return ( (pattern, branchExpr), end, pos )

446−

452+

447−

453+

448−chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)]

454+caseHelp :: [(Src.Pattern, Src.Expr)] -> A.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]

449−chompCaseEnd branches end =

455+caseHelp branches end pos =

450− oneOfWithFallback

456+ oneOf E.XXX

451− [ do Space.checkAligned E.CasePatternAlignment

457+ [ do checkAligned pos

452− (branch, newEnd) <- chompBranch

458+ (branch, newEnd, newPos) <- branchHelp

453− chompCaseEnd (branch:branches) newEnd

459+ caseHelp (branch:branches) newEnd newPos

460+ , return ( reverse branches, end, pos )

454 ]

461 ]

455− (reverse branches, end)

456

462

457

463

458

464

459-- LET EXPRESSION

465-- LET EXPRESSION

460

466

461

467

462−let_ :: A.Position -> Space.Parser E.Expr Src.Expr

468+let_ :: A.Position -> ExprParser

463let_ start =

469let_ start =

470+ do oldIndent <- getIndent

471+ letIndent <- getCol

464− inContext E.Let (Keyword.let_ E.Start) $

472+ Keyword.let_

465− do (defs, defsEnd) <-

473+ pushContext start E.ExprLet

466− withBacksetIndent 3 $

474+ setIndent letIndent

467− do Space.chompAndCheckIndent E.LetSpace E.LetIndentDef

475+ spaces

468− withIndent $

476+ defIndent <- getCol

469− do (def, end) <- chompLetDef

477+ setIndent defIndent

470− chompLetDefs [def] end

478+ (def, end, space) <- letDef

471−

479+ letHelp start oldIndent [def] end space

472− Space.checkIndent defsEnd E.LetIndentIn

480+

473− Keyword.in_ E.LetIn

481+

474− Space.chompAndCheckIndent E.LetSpace E.LetIndentBody

482+letHelp :: A.Position -> Word16 -> [A.Located Src.Def] -> A.Position -> SPos -> ExprParser

475− (body, end) <- specialize E.LetBody expression

483+letHelp start oldIndent revDefs end pos =

476− return

484+ oneOf E.XXX

477− ( A.at start end (Src.Let defs body)

478− , end

479− )

480−

481−

482−chompLetDefs :: [A.Located Src.Def] -> A.Position -> Space.Parser E.Let [A.Located Src.Def]

483−chompLetDefs revDefs end =

484− oneOfWithFallback

485− [ do Space.checkAligned E.LetDefAlignment

485+ [ do checkAligned pos

486− (def, newEnd) <- chompLetDef

486+ (def, newEnd, newPos) <- letDef

487− chompLetDefs (def:revDefs) newEnd

487+ letHelp start oldIndent (def:revDefs) newEnd newPos

488+

489+ , do setIndent oldIndent

490+ checkSpace pos

491+ Keyword.in_

492+ popContext ()

493+ spaces

494+ (body, newEnd, newPos) <- expression

495+ let letExpr = A.at start end (Src.Let (reverse revDefs) body)

496+ return ( letExpr, newEnd, newPos )

488 ]

497 ]

489− (reverse revDefs, end)

490

498

491

499

492

500

493-- LET DEFINITIONS

501-- LET DEFINITIONS

494

502

495

503

496−chompLetDef :: Space.Parser E.Let (A.Located Src.Def)

504+letDef :: SParser (A.Located Src.Def)

497−chompLetDef =

505+letDef =

498− oneOf E.LetDefName

506+ oneOf E.XXX

499 [ definition

507 [ definition

500 , destructure

508 , destructure

501 ]

509 ]

@@ -505,57 +513,61 @@ chompLetDef =

505-- DEFINITION

513-- DEFINITION

506

514

507

515

508−definition :: Space.Parser E.Let (A.Located Src.Def)

516+definition :: SParser (A.Located Src.Def)

509definition =

517definition =

510− do aname@(A.At (A.Region start _) name) <- addLocation (Var.lower E.LetDefName)

518+ do start <- getPosition

511− specialize (E.LetDef name) $

519+ name <- Var.lower

512− do Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals

520+ end <- getPosition

521+ spaces

513− oneOf E.DefEquals

522+ oneOf E.XXX

514− [

523+ [

515− do word1 0x3A {-:-} E.DefEquals

524+ do word1 0x3A {-:-} E.XXX

516− Space.chompAndCheckIndent E.DefSpace E.DefIndentType

525+ pushContext start (E.Annotation name)

526+ spaces

517− (tipe, _) <- specialize E.DefType Type.expression

527+ (tipe, _, space) <- Type.expression

528+ popContext ()

518− Space.checkAligned E.DefAlignment

529+ checkAligned space

519− defName <- chompMatchingName name

530+ defName <- matchingName name

520− Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals

531+ let (A.At (A.Region defStart _) _) = defName

532+ pushContext defStart (E.Definition name)

533+ spaces

521− chompDefArgsAndBody start defName (Just tipe) []

534+ def <- definitionHelp start defName (Just tipe) []

535+ popContext def

522− ,

536+ ,

523− chompDefArgsAndBody start aname Nothing []

537+ do pushContext start (E.Definition name)

538+ def <- definitionHelp start (A.at start end name) Nothing []

539+ popContext def

524− ]

540+ ]

525−

541+

526−

542+

527−chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.Def (A.Located Src.Def)

543+definitionHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser (A.Located Src.Def)

528−chompDefArgsAndBody start name tipe revArgs =

544+definitionHelp start name tipe revArgs =

529− oneOf E.DefEquals

545+ oneOf E.XXX

530− [ do arg <- specialize E.DefArg Pattern.term

546+ [ do arg <- Pattern.term

531− Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals

547+ spaces

532− chompDefArgsAndBody start name tipe (arg : revArgs)

548+ definitionHelp start name tipe (arg : revArgs)

533− , do word1 0x3D {-=-} E.DefEquals

549+ , do word1 0x3D {-=-} E.XXX

534− Space.chompAndCheckIndent E.DefSpace E.DefIndentBody

550+ spaces

535− (body, end) <- specialize E.DefBody expression

551+ (body, end, space) <- expression

536− return

537− ( A.at start end (Src.Define name (reverse revArgs) body tipe)

552+ let def = A.at start end (Src.Define name (reverse revArgs) body tipe)

538− , end

553+ return ( def, end, space )

539− )

540 ]

554 ]

541

555

542

556

543−chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)

557+matchingName :: Name.Name -> Parser (A.Located Name.Name)

544−chompMatchingName expectedName =

558+matchingName expectedName =

545− let

546− (P.Parser parserL) = Var.lower E.DefNameRepeat

559+ let (P.Parser parserL) = Var.lower in

547− in

548− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->

560+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->

549 let

561 let

550− cokL name newState@(P.State _ _ _ _ er ec) =

562+ cokL name newState@(P.State _ _ _ er ec _) =

551 if expectedName == name

563 if expectedName == name

552 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

564 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

553− else cerr sr sc (E.DefNameMatch name)

565+ else cerr sr sc ctx (E.MatchingName expectedName)

554

566

555− eokL name newState@(P.State _ _ _ _ er ec) =

567+ eokL name newState@(P.State _ _ _ er ec _) =

556 if expectedName == name

568 if expectedName == name

557 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

569 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

558− else eerr sr sc (E.DefNameMatch name)

570+ else eerr sr sc ctx (E.MatchingName expectedName)

559 in

571 in

560 parserL state cokL eokL cerr eerr

572 parserL state cokL eokL cerr eerr

561

573

@@ -565,13 +577,12 @@ chompMatchingName expectedName =

565-- DESTRUCTURE

577-- DESTRUCTURE

566

578

567

579

568−destructure :: Space.Parser E.Let (A.Located Src.Def)

580+destructure :: SParser (A.Located Src.Def)

569destructure =

581destructure =

570− specialize E.LetDestruct $

571 do start <- getPosition

582 do start <- getPosition

572− pattern <- specialize E.DestructPattern Pattern.term

583+ pattern <- Pattern.term

573− Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals

584+ spaces

574− word1 0x3D {-=-} E.DestructEquals

585+ word1 0x3D {-=-} E.XXX

575− Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody

586+ spaces

576− (expr, end) <- specialize E.DestructBody expression

587+ (expr, end, space) <- expression

577− return ( A.at start end (Src.Destruct pattern expr), end )

588+ return ( A.at start end (Src.Destruct pattern expr), end, space )

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

@@ -16,111 +16,112 @@ module Parse.Keyword

16import Foreign.Ptr (plusPtr)

17import Data.Word (Word8)

18

19−import Parse.Primitives (Parser, Row, Col)

19+import Parse.Utils (Parser)

20import qualified Parse.Variable as Var

21import qualified Parse.Primitives as P

22+import qualified Reporting.Error.Syntax as E

22

23

24

25

25-- DECLARATIONS

26-- DECLARATIONS

26

27

28

28−type_ :: (Row -> Col -> x) -> Parser x ()

29+type_ :: Parser ()

29−type_ tx = k4 0x74 0x79 0x70 0x65 tx

30+type_ = k4 0x74 0x79 0x70 0x65 E.KeywordType

30

31

31−alias_ :: (Row -> Col -> x) -> Parser x ()

32+alias_ :: Parser ()

32−alias_ tx = k5 0x61 0x6C 0x69 0x61 0x73 tx

33+alias_ = k5 0x61 0x6C 0x69 0x61 0x73 E.KeywordAlias

33

34

34−port_ :: (Row -> Col -> x) -> Parser x ()

35+port_ :: Parser ()

35−port_ tx = k4 0x70 0x6F 0x72 0x74 tx

36+port_ = k4 0x70 0x6F 0x72 0x74 E.KeywordPort

36

37

38

39

39-- IF EXPRESSIONS

40-- IF EXPRESSIONS

40

41

42

42−if_ :: (Row -> Col -> x) -> Parser x ()

43+if_ :: Parser ()

43−if_ tx = k2 0x69 0x66 tx

44+if_ = k2 0x69 0x66 E.KeywordIf

44

45

45−then_ :: (Row -> Col -> x) -> Parser x ()

46+then_ :: Parser ()

46−then_ tx = k4 0x74 0x68 0x65 0x6E tx

47+then_ = k4 0x74 0x68 0x65 0x6E E.KeywordThen

47

48

48−else_ :: (Row -> Col -> x) -> Parser x ()

49+else_ :: Parser ()

49−else_ tx = k4 0x65 0x6C 0x73 0x65 tx

50+else_ = k4 0x65 0x6C 0x73 0x65 E.KeywordElse

50

51

52

53

53-- CASE EXPRESSIONS

54-- CASE EXPRESSIONS

54

55

56

56−case_ :: (Row -> Col -> x) -> Parser x ()

57+case_ :: Parser ()

57−case_ tx = k4 0x63 0x61 0x73 0x65 tx

58+case_ = k4 0x63 0x61 0x73 0x65 E.KeywordCase

58

59

59−of_ :: (Row -> Col -> x) -> Parser x ()

60+of_ :: Parser ()

60−of_ tx = k2 0x6F 0x66 tx

61+of_ = k2 0x6F 0x66 E.KeywordOf

61

62

63

64

64-- LET EXPRESSIONS

65-- LET EXPRESSIONS

65

66

67

67−let_ :: (Row -> Col -> x) -> Parser x ()

68+let_ :: Parser ()

68−let_ tx = k3 0x6C 0x65 0x74 tx

69+let_ = k3 0x6C 0x65 0x74 E.KeywordLet

69

70

70−in_ :: (Row -> Col -> x) -> Parser x ()

71+in_ :: Parser ()

71−in_ tx = k2 0x69 0x6E tx

72+in_ = k2 0x69 0x6E E.KeywordIn

72

73

74

75

75-- INFIXES

76-- INFIXES

76

77

78

78−infix_ :: (Row -> Col -> x) -> Parser x ()

79+infix_ :: Parser ()

79−infix_ tx = k5 0x69 0x6E 0x66 0x69 0x78 tx

80+infix_ = k5 0x69 0x6E 0x66 0x69 0x78 E.KeywordInfix

80

81

81−left_ :: (Row -> Col -> x) -> Parser x ()

82+left_ :: Parser ()

82−left_ tx = k4 0x6C 0x65 0x66 0x74 tx

83+left_ = k4 0x6C 0x65 0x66 0x74 E.Associativity

83

84

84−right_ :: (Row -> Col -> x) -> Parser x ()

85+right_ :: Parser ()

85−right_ tx = k5 0x72 0x69 0x67 0x68 0x74 tx

86+right_ = k5 0x72 0x69 0x67 0x68 0x74 E.Associativity

86

87

87−non_ :: (Row -> Col -> x) -> Parser x ()

88+non_ :: Parser ()

88−non_ tx = k3 0x6E 0x6F 0x6E tx

89+non_ = k3 0x6E 0x6F 0x6E E.Associativity

89

90

91

92

92-- IMPORTS

93-- IMPORTS

93

94

95

95−module_ :: (Row -> Col -> x) -> Parser x ()

96+module_ :: Parser ()

96−module_ tx = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 tx

97+module_ = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 E.KeywordModule

97

98

98−import_ :: (Row -> Col -> x) -> Parser x ()

99+import_ :: Parser ()

99−import_ tx = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 tx

100+import_ = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 E.KeywordImport

100

101

101−exposing_ :: (Row -> Col -> x) -> Parser x ()

102+exposing_ :: Parser ()

102−exposing_ tx = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 tx

103+exposing_ = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 E.KeywordExposing

103

104

104−as_ :: (Row -> Col -> x) -> Parser x ()

105+as_ :: Parser ()

105−as_ tx = k2 0x61 0x73 tx

106+as_ = k2 0x61 0x73 E.KeywordAs

106

107

108

109

109-- EFFECTS

110-- EFFECTS

110

111

112

112−effect_ :: (Row -> Col -> x) -> Parser x ()

113+effect_ :: Parser ()

113−effect_ tx = k6 0x65 0x66 0x66 0x65 0x63 0x74 tx

114+effect_ = k6 0x65 0x66 0x66 0x65 0x63 0x74 E.EffectStuff

114

115

115−where_ :: (Row -> Col -> x) -> Parser x ()

116+where_ :: Parser ()

116−where_ tx = k5 0x77 0x68 0x65 0x72 0x65 tx

117+where_ = k5 0x77 0x68 0x65 0x72 0x65 E.EffectStuff

117

118

118−command_ :: (Row -> Col -> x) -> Parser x ()

119+command_ :: Parser ()

119−command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx

120+command_ = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 E.EffectStuff

120

121

121−subscription_ :: (Row -> Col -> x) -> Parser x ()

122+subscription_ :: Parser ()

122−subscription_ toError =

123+subscription_ =

123− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

124+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

124 let !pos12 = plusPtr pos 12 in

125 let !pos12 = plusPtr pos 12 in

125 if pos12 <= end

126 if pos12 <= end

126 && P.unsafeIndex ( pos ) == 0x73

127 && P.unsafeIndex ( pos ) == 0x73

@@ -137,32 +138,32 @@ subscription_ toError =

137 && P.unsafeIndex (plusPtr pos 11) == 0x6E

138 && P.unsafeIndex (plusPtr pos 11) == 0x6E

138 && Var.getInnerWidth pos12 end == 0

139 && Var.getInnerWidth pos12 end == 0

139 then

140 then

140− let !s = P.State src pos12 end indent row (col + 12) in cok () s

141+ let !s = P.State pos12 end indent row (col + 12) ctx in cok () s

141 else

142 else

142− eerr row col toError

143+ eerr row col ctx E.EffectStuff

143

144

145

146

146-- KEYWORDS

147-- KEYWORDS

147

148

149

149−k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

150+k2 :: Word8 -> Word8 -> x -> P.Parser c x ()

150−k2 w1 w2 toError =

151+k2 w1 w2 x =

151− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

152+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

152 let !pos2 = plusPtr pos 2 in

153 let !pos2 = plusPtr pos 2 in

153 if pos2 <= end

154 if pos2 <= end

154 && P.unsafeIndex ( pos ) == w1

155 && P.unsafeIndex ( pos ) == w1

155 && P.unsafeIndex (plusPtr pos 1) == w2

156 && P.unsafeIndex (plusPtr pos 1) == w2

156 && Var.getInnerWidth pos2 end == 0

157 && Var.getInnerWidth pos2 end == 0

157 then

158 then

158− let !s = P.State src pos2 end indent row (col + 2) in cok () s

159+ let !s = P.State pos2 end indent row (col + 2) ctx in cok () s

159 else

160 else

160− eerr row col toError

161+ eerr row col ctx x

161

162

163

163−k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

164+k3 :: Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

164−k3 w1 w2 w3 toError =

165+k3 w1 w2 w3 x =

165− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

166+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

166 let !pos3 = plusPtr pos 3 in

167 let !pos3 = plusPtr pos 3 in

167 if pos3 <= end

168 if pos3 <= end

168 && P.unsafeIndex ( pos ) == w1

169 && P.unsafeIndex ( pos ) == w1

@@ -170,14 +171,14 @@ k3 w1 w2 w3 toError =

170 && P.unsafeIndex (plusPtr pos 2) == w3

171 && P.unsafeIndex (plusPtr pos 2) == w3

171 && Var.getInnerWidth pos3 end == 0

172 && Var.getInnerWidth pos3 end == 0

172 then

173 then

173− let !s = P.State src pos3 end indent row (col + 3) in cok () s

174+ let !s = P.State pos3 end indent row (col + 3) ctx in cok () s

174 else

175 else

175− eerr row col toError

176+ eerr row col ctx x

176

177

178

178−k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

179+k4 :: Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

179−k4 w1 w2 w3 w4 toError =

180+k4 w1 w2 w3 w4 x =

180− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

181+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

181 let !pos4 = plusPtr pos 4 in

182 let !pos4 = plusPtr pos 4 in

182 if pos4 <= end

183 if pos4 <= end

183 && P.unsafeIndex ( pos ) == w1

184 && P.unsafeIndex ( pos ) == w1

@@ -186,14 +187,14 @@ k4 w1 w2 w3 w4 toError =

186 && P.unsafeIndex (plusPtr pos 3) == w4

187 && P.unsafeIndex (plusPtr pos 3) == w4

187 && Var.getInnerWidth pos4 end == 0

188 && Var.getInnerWidth pos4 end == 0

188 then

189 then

189− let !s = P.State src pos4 end indent row (col + 4) in cok () s

190+ let !s = P.State pos4 end indent row (col + 4) ctx in cok () s

190 else

191 else

191− eerr row col toError

192+ eerr row col ctx x

192

193

194

194−k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

195+k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

195−k5 w1 w2 w3 w4 w5 toError =

196+k5 w1 w2 w3 w4 w5 x =

196− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

197+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

197 let !pos5 = plusPtr pos 5 in

198 let !pos5 = plusPtr pos 5 in

198 if pos5 <= end

199 if pos5 <= end

199 && P.unsafeIndex ( pos ) == w1

200 && P.unsafeIndex ( pos ) == w1

@@ -203,14 +204,14 @@ k5 w1 w2 w3 w4 w5 toError =

203 && P.unsafeIndex (plusPtr pos 4) == w5

204 && P.unsafeIndex (plusPtr pos 4) == w5

204 && Var.getInnerWidth pos5 end == 0

205 && Var.getInnerWidth pos5 end == 0

205 then

206 then

206− let !s = P.State src pos5 end indent row (col + 5) in cok () s

207+ let !s = P.State pos5 end indent row (col + 5) ctx in cok () s

207 else

208 else

208− eerr row col toError

209+ eerr row col ctx x

209

210

211

211−k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

212+k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

212−k6 w1 w2 w3 w4 w5 w6 toError =

213+k6 w1 w2 w3 w4 w5 w6 x =

213− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

214+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

214 let !pos6 = plusPtr pos 6 in

215 let !pos6 = plusPtr pos 6 in

215 if pos6 <= end

216 if pos6 <= end

216 && P.unsafeIndex ( pos ) == w1

217 && P.unsafeIndex ( pos ) == w1

@@ -221,14 +222,14 @@ k6 w1 w2 w3 w4 w5 w6 toError =

221 && P.unsafeIndex (plusPtr pos 5) == w6

222 && P.unsafeIndex (plusPtr pos 5) == w6

222 && Var.getInnerWidth pos6 end == 0

223 && Var.getInnerWidth pos6 end == 0

223 then

224 then

224− let !s = P.State src pos6 end indent row (col + 6) in cok () s

225+ let !s = P.State pos6 end indent row (col + 6) ctx in cok () s

225 else

226 else

226− eerr row col toError

227+ eerr row col ctx x

227

228

229

229−k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

230+k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

230−k7 w1 w2 w3 w4 w5 w6 w7 toError =

231+k7 w1 w2 w3 w4 w5 w6 w7 x =

231− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

232+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

232 let !pos7 = plusPtr pos 7 in

233 let !pos7 = plusPtr pos 7 in

233 if pos7 <= end

234 if pos7 <= end

234 && P.unsafeIndex ( pos ) == w1

235 && P.unsafeIndex ( pos ) == w1

@@ -240,14 +241,14 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError =

240 && P.unsafeIndex (plusPtr pos 6) == w7

241 && P.unsafeIndex (plusPtr pos 6) == w7

241 && Var.getInnerWidth pos7 end == 0

242 && Var.getInnerWidth pos7 end == 0

242 then

243 then

243− let !s = P.State src pos7 end indent row (col + 7) in cok () s

244+ let !s = P.State pos7 end indent row (col + 7) ctx in cok () s

244 else

245 else

245− eerr row col toError

246+ eerr row col ctx x

246

247

248

248−k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

249+k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

249−k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =

250+k8 w1 w2 w3 w4 w5 w6 w7 w8 x =

250− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

251+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

251 let !pos8 = plusPtr pos 8 in

252 let !pos8 = plusPtr pos 8 in

252 if pos8 <= end

253 if pos8 <= end

253 && P.unsafeIndex ( pos ) == w1

254 && P.unsafeIndex ( pos ) == w1

@@ -260,6 +261,6 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =

260 && P.unsafeIndex (plusPtr pos 7) == w8

261 && P.unsafeIndex (plusPtr pos 7) == w8

261 && Var.getInnerWidth pos8 end == 0

262 && Var.getInnerWidth pos8 end == 0

262 then

263 then

263− let !s = P.State src pos8 end indent row (col + 8) in cok () s

264+ let !s = P.State pos8 end indent row (col + 8) ctx in cok () s

264 else

265 else

265− eerr row col toError

266+ eerr row col ctx x

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

@@ -2,15 +2,16 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Parse.Module

4 ( fromByteString

5− , ProjectType(..)

5+ , Header(..)

6− , isKernel

6+ , Effects(..)

7+ , chompHeader

7 , chompImports

8 , chompImports

8− , chompImport

9+ , freshLine

9 )

10 )

10 where

11 where

11

12

13

13−import qualified Data.ByteString as BS

14+import qualified Data.ByteString as B

14import qualified Data.Name as Name

15import qualified Data.Name as Name

15

16

16import qualified AST.Source as Src

17import qualified AST.Source as Src

@@ -18,124 +19,105 @@ import qualified Elm.Compiler.Imports as Imports

18import qualified Elm.Package as Pkg

19import qualified Elm.Package as Pkg

19import qualified Parse.Declaration as Decl

20import qualified Parse.Declaration as Decl

20import qualified Parse.Keyword as Keyword

21import qualified Parse.Keyword as Keyword

21−import qualified Parse.Space as Space

22import qualified Parse.Symbol as Symbol

23import qualified Parse.Variable as Var

24import qualified Parse.Primitives as P

25−import Parse.Primitives hiding (State, fromByteString)

25+import Parse.Primitives hiding (Parser, State, fromByteString)

26+import Parse.Utils

26import qualified Reporting.Annotation as A

27import qualified Reporting.Annotation as A

27import qualified Reporting.Error.Syntax as E

28import qualified Reporting.Error.Syntax as E

29+import qualified Reporting.Result as Result

28

30

29

31

30

32

31-- FROM BYTE STRING

33-- FROM BYTE STRING

32

34

33

35

34−fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module

36+fromByteString :: Pkg.Name -> B.ByteString -> Result.Result i w E.Error Src.Module

35−fromByteString projectType source =

37+fromByteString pkg source =

38+ let

39+ parser

40+ | pkg == Pkg.core = core

41+ | Pkg.isKernel pkg = platform

42+ | otherwise = normal

43+ in

36− case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of

44+ case P.fromByteString parser source of

45+ P.Ok outcome _ ->

46+ case outcome of

37− Right modul -> checkModule projectType modul

47+ Right modul -> Result.ok modul

38− Left err -> Left (E.ParseError err)

48+ Left err -> Result.throw err

39−

40−

41−

42−-- PROJECT TYPE

43−

44−

45−data ProjectType

46− = Package Pkg.Name

47− | Application

48−

49

50−isCore :: ProjectType -> Bool

50+ P.Err row col ctx err ->

51−isCore projectType =

51+ Result.throw (E.ParseError row col ctx err)

52− case projectType of

53− Package pkg -> pkg == Pkg.core

54− Application -> False

55

52

56

53

57−isKernel :: ProjectType -> Bool

58−isKernel projectType =

59− case projectType of

60− Package pkg -> Pkg.isKernel pkg

61− Application -> False

62

54

55+-- MODULE

63

56

64

57

65−-- MODULE

58+normal :: Parser (Either E.Error Src.Module)

59+normal =

60+ do freshLine

61+ header <- chompHeader

62+ imports <- chompImports []

63+ decls <- chompDecls []

64+ endOfFile

65+ return (checkModule header (Imports.addDefaults imports) [] decls)

66

67

68−data Module =

68+core :: Parser (Either E.Error Src.Module)

69− Module

69+core =

70− { _header :: Maybe Header

70+ do freshLine

71− , _imports :: [Src.Import]

71+ header <- chompHeader

72− , _infixes :: [A.Located Src.Infix]

72+ imports <- chompImports []

73− , _decls :: [Decl.Decl]

73+ binops <- chompBinops []

74− }

74+ decls <- chompDecls []

75+ endOfFile

76+ return (checkModule header imports binops decls)

75

77

76

78

77−chompModule :: ProjectType -> Parser E.Module Module

79+platform :: Parser (Either E.Error Src.Module)

78−chompModule projectType =

80+platform =

81+ do freshLine

79− do header <- chompHeader

82+ header <- chompHeader

80− imports <- chompImports (if isCore projectType then [] else Imports.defaults)

83+ imports <- chompImports []

81− infixes <- if isKernel projectType then chompInfixes [] else return []

84+ binops <- chompBinops []

82− decls <- specialize E.Declarations $ chompDecls []

85+ decls <- chompDecls []

83− return (Module header imports infixes decls)

86+ endOfFile

87+ return (checkModule header (Imports.addDefaults imports) binops decls)

84

88

85

89

86

90

87-- CHECK MODULE

91-- CHECK MODULE

88

92

89

93

90−checkModule :: ProjectType -> Module -> Either E.Error Src.Module

94+checkModule :: Maybe Header -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module

91−checkModule projectType (Module maybeHeader imports infixes decls) =

95+checkModule maybeHeader imports binops decls =

92 let

96 let

97+ (Header name effects exports) = maybe (Header "Main" NoEffects (A.At A.one Src.Open)) id maybeHeader

93 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls

98 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls

94 in

99 in

95− case maybeHeader of

96− Just (Header name effects exports docs) ->

97− Src.Module (Just name) exports (toDocs docs decls) imports values unions aliases infixes

100+ Src.Module name exports imports values unions aliases binops

98− <$> checkEffects projectType ports effects

101+ <$> checkEffects ports effects

99

102

100− Nothing ->

101− Right $

102− Src.Module Nothing (A.At A.one Src.Open) (Src.NoDocs A.one) imports values unions aliases infixes $

103− case ports of

104− [] -> Src.NoEffects

105− _:_ -> Src.Ports ports

106

103

107−

108−checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects

104+checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects

109−checkEffects projectType ports effects =

105+checkEffects ports effects =

110 case effects of

106 case effects of

111− NoEffects region ->

107+ NoEffects ->

112 case ports of

108 case ports of

113− [] ->

114− Right Src.NoEffects

109+ [] -> Right Src.NoEffects

115−

110+ _:_ -> Left (error "TODO no ports")

116− Src.Port name _ : _ ->

117− case projectType of

118− Package _ -> Left (E.NoPortsInPackage name)

119− Application -> Left (E.UnexpectedPort region)

120

111

121 Ports region ->

112 Ports region ->

122− case projectType of

123− Package _ ->

124− Left (E.NoPortModulesInPackage region)

125−

126− Application ->

127− case ports of

113+ case ports of

128− [] -> Left (E.NoPorts region)

114+ [] -> Left (error "TODO no ports in port module" region)

129− _:_ -> Right (Src.Ports ports)

115+ _:_ -> Right (Src.Ports ports)

130

116

131 Manager region manager ->

117 Manager region manager ->

132− if isKernel projectType then

133− case ports of

118+ case ports of

134− [] -> Right (Src.Manager region manager)

119+ [] -> Right (Src.Manager region manager)

135− _:_ -> Left (E.UnexpectedPort region)

120+ _:_ -> Left (error "TODO ports in effect manager")

136− else

137− Left (E.NoEffectsOutsideKernel region)

138−

139

121

140

122

141categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ( [A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port] )

123categorizeDecls :: [A.Located Src.Value] -> [A.Located Src.Union] -> [A.Located Src.Alias] -> [Src.Port] -> [Decl.Decl] -> ( [A.Located Src.Value], [A.Located Src.Union], [A.Located Src.Alias], [Src.Port] )

@@ -146,95 +128,51 @@ categorizeDecls values unions aliases ports decls =

146

128

147 decl:otherDecls ->

129 decl:otherDecls ->

148 case decl of

130 case decl of

149− Decl.Value _ value -> categorizeDecls (value:values) unions aliases ports otherDecls

131+ Decl.Value value -> categorizeDecls (value:values) unions aliases ports otherDecls

150− Decl.Union _ union -> categorizeDecls values (union:unions) aliases ports otherDecls

132+ Decl.Union union -> categorizeDecls values (union:unions) aliases ports otherDecls

151− Decl.Alias _ alias -> categorizeDecls values unions (alias:aliases) ports otherDecls

133+ Decl.Alias alias -> categorizeDecls values unions (alias:aliases) ports otherDecls

152− Decl.Port _ port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls

134+ Decl.Port port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls

153−

154−

155−

156−-- TO DOCS

157−

158−

159−toDocs :: Either A.Region Src.Comment -> [Decl.Decl] -> Src.Docs

160−toDocs comment decls =

161− case comment of

162− Right overview ->

163− Src.YesDocs overview (getComments decls [])

164−

165− Left region ->

166− Src.NoDocs region

167−

168−

169−getComments :: [Decl.Decl] -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]

170−getComments decls comments =

171− case decls of

172− [] ->

173− comments

174−

175− decl:otherDecls ->

176− case decl of

177− Decl.Value c (A.At _ (Src.Value n _ _ _)) -> getComments otherDecls (addComment c n comments)

178− Decl.Union c (A.At _ (Src.Union n _ _ )) -> getComments otherDecls (addComment c n comments)

179− Decl.Alias c (A.At _ (Src.Alias n _ _ )) -> getComments otherDecls (addComment c n comments)

180− Decl.Port c (Src.Port n _ ) -> getComments otherDecls (addComment c n comments)

181

135

182

136

183−addComment :: Maybe Src.Comment -> A.Located Name.Name -> [(Name.Name,Src.Comment)] -> [(Name.Name,Src.Comment)]

184−addComment maybeComment (A.At _ name) comments =

185− case maybeComment of

186− Just comment -> (name, comment) : comments

187− Nothing -> comments

188

137

138+-- FRESH LINES

189

139

190

140

191−-- FRESH LINES

141+freshLine :: Parser ()

142+freshLine =

143+ checkFreshLine =<< whitespace

192

144

193

145

194−freshLine :: (Row -> Col -> E.Module) -> Parser E.Module ()

146+endOfFile :: Parser ()

195−freshLine toFreshLineError =

147+endOfFile =

196− do Space.chomp E.ModuleSpace

148+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->

197− Space.checkFreshLine toFreshLineError

149+ if pos < end then

150+ eerr row col ctx E.EndOfFile

151+ else

152+ eok () state

198

153

199

154

200

155

201-- CHOMP DECLARATIONS

156-- CHOMP DECLARATIONS

202

157

203

158

204−chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]

159+chompDecls :: [Decl.Decl] -> Parser [Decl.Decl]

205chompDecls decls =

160chompDecls decls =

206− do (decl, _) <- Decl.declaration

161+ do (decl, _, pos) <- Decl.declaration

207− oneOfWithFallback

162+ oneOf E.XXX

208− [ do Space.checkFreshLine E.DeclStart

163+ [ do checkFreshLine pos

209 chompDecls (decl:decls)

164 chompDecls (decl:decls)

165+ , return (reverse (decl:decls))

210 ]

166 ]

211− (reverse (decl:decls))

212

167

213

168

214−chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]

169+chompBinops :: [A.Located Src.Binop] -> Parser [A.Located Src.Binop]

215−chompInfixes infixes =

170+chompBinops binops =

216− oneOfWithFallback

171+ oneOf E.XXX

217 [ do binop <- Decl.infix_

172 [ do binop <- Decl.infix_

218− chompInfixes (binop:infixes)

173+ chompBinops (binop:binops)

174+ , return binops

219 ]

175 ]

220− infixes

221−

222−

223−

224−-- MODULE DOC COMMENT

225−

226−

227−chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment)

228−chompModuleDocCommentSpace =

229− do (A.At region ()) <- addLocation (freshLine E.FreshLine)

230− oneOfWithFallback

231− [

232− do docComment <- Space.docComment E.ImportStart E.ModuleSpace

233− Space.chomp E.ModuleSpace

234− Space.checkFreshLine E.FreshLine

235− return (Right docComment)

236− ]

237− (Left region)

238

176

239

177

240

178

@@ -242,246 +180,237 @@ chompModuleDocCommentSpace =

242

180

243

181

244data Header =

182data Header =

245− Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment)

183+ Header Name.Name Effects (A.Located Src.Exposing)

246

184

247

185

248data Effects

186data Effects

249− = NoEffects A.Region

187+ = NoEffects

250 | Ports A.Region

188 | Ports A.Region

251 | Manager A.Region Src.Manager

189 | Manager A.Region Src.Manager

252

190

253

191

254−chompHeader :: Parser E.Module (Maybe Header)

192+chompHeader :: Parser (Maybe Header)

255chompHeader =

193chompHeader =

256− do freshLine E.FreshLine

257− start <- getPosition

194+ do start <- getPosition

258− oneOfWithFallback

195+ oneOf E.XXX

259 [

196 [

260 -- module MyThing exposing (..)

197 -- module MyThing exposing (..)

261− do Keyword.module_ E.ModuleProblem

198+ do Keyword.module_

262− effectEnd <- getPosition

199+ pushContext start E.Module

263− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem

200+ spaces

264− name <- addLocation (Var.moduleName E.ModuleName)

201+ name <- Var.moduleName

265− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem

202+ spaces

266− Keyword.exposing_ E.ModuleProblem

203+ Keyword.exposing_

267− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem

204+ spaces

268− exports <- addLocation (specialize E.ModuleExposing exposing)

205+ exports <- addLocation exposing

269− comment <- chompModuleDocCommentSpace

206+ popContext ()

207+ freshLine

270− return $ Just $

208+ return (Just (Header name NoEffects exports))

271− Header name (NoEffects (A.Region start effectEnd)) exports comment

272 ,

209 ,

273 -- port module MyThing exposing (..)

210 -- port module MyThing exposing (..)

274− do Keyword.port_ E.PortModuleProblem

211+ do Keyword.port_

275− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

212+ pushContext start E.Module

213+ spaces

276− Keyword.module_ E.PortModuleProblem

214+ Keyword.module_

277− effectEnd <- getPosition

215+ end <- getPosition

278− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

216+ spaces

279− name <- addLocation (Var.moduleName E.PortModuleName)

217+ name <- Var.moduleName

280− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

218+ spaces

281− Keyword.exposing_ E.PortModuleProblem

219+ Keyword.exposing_

282− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

220+ spaces

283− exports <- addLocation (specialize E.PortModuleExposing exposing)

221+ exports <- addLocation exposing

284− comment <- chompModuleDocCommentSpace

222+ popContext ()

285− return $ Just $

223+ freshLine

286− Header name (Ports (A.Region start effectEnd)) exports comment

224+ return (Just (Header name (Ports (A.Region start end)) exports))

287 ,

225 ,

288 -- effect module MyThing where { command = MyCmd } exposing (..)

226 -- effect module MyThing where { command = MyCmd } exposing (..)

289− do Keyword.effect_ E.Effect

227+ do Keyword.effect_

290− Space.chompAndCheckIndent E.ModuleSpace E.Effect

228+ pushContext start E.Module

229+ spaces

291− Keyword.module_ E.Effect

230+ Keyword.module_

292− effectEnd <- getPosition

231+ end <- getPosition

293− Space.chompAndCheckIndent E.ModuleSpace E.Effect

232+ spaces

294− name <- addLocation (Var.moduleName E.ModuleName)

233+ name <- Var.moduleName

295− Space.chompAndCheckIndent E.ModuleSpace E.Effect

234+ spaces

296− Keyword.where_ E.Effect

235+ Keyword.where_

297− Space.chompAndCheckIndent E.ModuleSpace E.Effect

236+ spaces

298 manager <- chompManager

237 manager <- chompManager

299− Space.chompAndCheckIndent E.ModuleSpace E.Effect

238+ spaces

300− Keyword.exposing_ E.Effect

239+ Keyword.exposing_

301− Space.chompAndCheckIndent E.ModuleSpace E.Effect

240+ spaces

302− exports <- addLocation (specialize (const E.Effect) exposing)

241+ exports <- addLocation exposing

303− comment <- chompModuleDocCommentSpace

242+ popContext ()

304− return $ Just $

243+ freshLine

305− Header name (Manager (A.Region start effectEnd) manager) exports comment

244+ return (Just (Header name (Manager (A.Region start end) manager) exports))

245+ ,

246+ -- default header

247+ return Nothing

306 ]

248 ]

307− -- default header

308− Nothing

309

249

310

250

311−chompManager :: Parser E.Module Src.Manager

251+chompManager :: Parser Src.Manager

312chompManager =

252chompManager =

313− do word1 0x7B {- { -} E.Effect

253+ do word1 0x7B {- { -} E.XXX

314− spaces_em

254+ spaces

315− oneOf E.Effect

255+ oneOf E.XXX

316 [ do cmd <- chompCommand

256 [ do cmd <- chompCommand

317− spaces_em

257+ spaces

318− oneOf E.Effect

258+ oneOf E.XXX

319− [ do word1 0x7D {-}-} E.Effect

259+ [ do word1 0x7D {-}-} E.XXX

320− spaces_em

260+ spaces

321 return (Src.Cmd cmd)

261 return (Src.Cmd cmd)

322− , do word1 0x2C {-,-} E.Effect

262+ , do word1 0x2C {-,-} E.XXX

323− spaces_em

263+ spaces

324 sub <- chompSubscription

264 sub <- chompSubscription

325− spaces_em

265+ spaces

326− word1 0x7D {-}-} E.Effect

266+ word1 0x7D {-}-} E.XXX

327− spaces_em

267+ spaces

328 return (Src.Fx cmd sub)

268 return (Src.Fx cmd sub)

329 ]

269 ]

330 , do sub <- chompSubscription

270 , do sub <- chompSubscription

331− spaces_em

271+ spaces

332− oneOf E.Effect

272+ oneOf E.XXX

333− [ do word1 0x7D {-}-} E.Effect

273+ [ do word1 0x7D {-}-} E.XXX

334− spaces_em

274+ spaces

335 return (Src.Sub sub)

275 return (Src.Sub sub)

336− , do word1 0x2C {-,-} E.Effect

276+ , do word1 0x2C {-,-} E.XXX

337− spaces_em

277+ spaces

338 cmd <- chompCommand

278 cmd <- chompCommand

339− spaces_em

279+ spaces

340− word1 0x7D {-}-} E.Effect

280+ word1 0x7D {-}-} E.XXX

341− spaces_em

281+ spaces

342 return (Src.Fx cmd sub)

282 return (Src.Fx cmd sub)

343 ]

283 ]

344 ]

284 ]

345

285

346

286

347−chompCommand :: Parser E.Module (A.Located Name.Name)

287+chompCommand :: Parser (A.Located Name.Name)

348chompCommand =

288chompCommand =

349− do Keyword.command_ E.Effect

289+ do Keyword.command_

350− spaces_em

290+ spaces

351− word1 0x3D {-=-} E.Effect

291+ word1 0x3D {-=-} E.XXX

352− spaces_em

292+ spaces

353− addLocation (Var.upper E.Effect)

293+ addLocation Var.upper

354

294

355

295

356−chompSubscription :: Parser E.Module (A.Located Name.Name)

296+chompSubscription :: Parser (A.Located Name.Name)

357chompSubscription =

297chompSubscription =

358− do Keyword.subscription_ E.Effect

298+ do Keyword.subscription_

359− spaces_em

299+ spaces

360− word1 0x3D {-=-} E.Effect

300+ word1 0x3D {-=-} E.XXX

361− spaces_em

301+ spaces

362− addLocation (Var.upper E.Effect)

302+ addLocation Var.upper

363−

364−

365−spaces_em :: Parser E.Module ()

366−spaces_em =

367− Space.chompAndCheckIndent E.ModuleSpace E.Effect

368

303

369

304

370

305

371-- IMPORTS

306-- IMPORTS

372

307

373

308

374−chompImports :: [Src.Import] -> Parser E.Module [Src.Import]

309+chompImports :: [Src.Import] -> Parser [Src.Import]

375−chompImports is =

310+chompImports imports =

376− oneOfWithFallback

311+ oneOf E.XXX

377− [ do i <- chompImport

312+ [ do start <- getPosition

313+ Keyword.import_

314+ pushContext start E.Import

315+ spaces

316+ name <- addLocation Var.moduleName

317+ pos <- whitespace

318+ oneOf E.XXX

319+ [ do checkFreshLine pos

320+ popContext ()

378− chompImports (i:is)

321+ chompImports $

322+ Src.Import name Nothing (Src.Explicit []) : imports

323+ , do checkSpace pos

324+ oneOf E.XXX

325+ [ chompAs name imports

326+ , chompExposing name Nothing imports

327+ ]

328+ ]

329+ , return (reverse imports)

379 ]

330 ]

380− (reverse is)

381−

382−

383−chompImport :: Parser E.Module Src.Import

384−chompImport =

385− do Keyword.import_ E.ImportStart

386− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentName

387− name@(A.At (A.Region _ end) _) <- addLocation (Var.moduleName E.ImportName)

388− Space.chomp E.ModuleSpace

389− oneOf E.ImportEnd

390− [ do Space.checkFreshLine E.ImportEnd

391− return $ Src.Import name Nothing (Src.Explicit [])

392− , do Space.checkIndent end E.ImportEnd

393− oneOf E.ImportAs

394− [ chompAs name

395− , chompExposing name Nothing

396− ]

397− ]

398

331

399

332

400−chompAs :: A.Located Name.Name -> Parser E.Module Src.Import

333+chompAs :: A.Located Name.Name -> [Src.Import] -> Parser [Src.Import]

401−chompAs name =

334+chompAs name imports =

402− do Keyword.as_ E.ImportAs

335+ do Keyword.as_

403− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias

336+ spaces

404− alias <- Var.upper E.ImportAlias

337+ alias <- Var.upper

405− end <- getPosition

338+ pos <- whitespace

406− Space.chomp E.ModuleSpace

407− oneOf E.ImportEnd

339+ oneOf E.XXX

408− [ do Space.checkFreshLine E.ImportEnd

340+ [ do checkFreshLine pos

341+ popContext ()

342+ chompImports $

409− return $ Src.Import name (Just alias) (Src.Explicit [])

343+ Src.Import name (Just alias) (Src.Explicit []) : imports

410− , do Space.checkIndent end E.ImportEnd

344+ , do checkSpace pos

411− chompExposing name (Just alias)

345+ chompExposing name (Just alias) imports

412 ]

346 ]

413

347

414

348

415−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import

349+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser [Src.Import]

416−chompExposing name maybeAlias =

350+chompExposing name maybeAlias imports =

417− do Keyword.exposing_ E.ImportExposing

351+ do Keyword.exposing_

418− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList

352+ spaces

419− exposed <- specialize E.ImportExposingList exposing

353+ exposed <- exposing

420− freshLine E.ImportEnd

354+ freshLine

355+ popContext ()

356+ chompImports $

421− return $ Src.Import name maybeAlias exposed

357+ Src.Import name maybeAlias exposed : imports

422

358

423

359

424

360

425-- LISTING

361-- LISTING

426

362

427

363

428−exposing :: Parser E.Exposing Src.Exposing

364+exposing :: Parser Src.Exposing

429exposing =

365exposing =

430− do word1 0x28 {-(-} E.ExposingStart

366+ do word1 0x28 {-(-} E.XXX

431− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue

367+ spaces

432− oneOf E.ExposingValue

368+ oneOf E.XXX

433− [ do word2 0x2E 0x2E {-..-} E.ExposingValue

369+ [ do word2 0x2E 0x2E {-..-} E.XXX

434− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

370+ spaces

435− word1 0x29 {-)-} E.ExposingEnd

371+ word1 0x29 {-)-} E.XXX

436 return Src.Open

372 return Src.Open

437− , do exposed <- chompExposed

373+ , do entry <- addLocation chompEntry

438− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

374+ spaces

439− exposingHelp [exposed]

375+ exposingHelp [entry]

440 ]

376 ]

441

377

442

378

443−exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing

379+exposingHelp :: [A.Located Src.Exposed] -> Parser Src.Exposing

444−exposingHelp revExposed =

380+exposingHelp revEntries =

445− oneOf E.ExposingEnd

381+ oneOf E.XXX

446− [ do word1 0x2C {-,-} E.ExposingEnd

382+ [ do word1 0x2C {-,-} E.XXX

447− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue

383+ spaces

448− exposed <- chompExposed

384+ entry <- addLocation chompEntry

449− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

385+ spaces

450− exposingHelp (exposed:revExposed)

386+ exposingHelp (entry:revEntries)

451− , do word1 0x29 {-)-} E.ExposingEnd

387+ , do word1 0x29 {-)-} E.XXX

452− return (Src.Explicit (reverse revExposed))

388+ return (Src.Explicit (reverse revEntries))

453 ]

389 ]

454

390

455

391

456−chompExposed :: Parser E.Exposing Src.Exposed

392+chompEntry :: Parser Src.Exposed

457−chompExposed =

393+chompEntry =

458− do start <- getPosition

459− oneOf E.ExposingValue

394+ oneOf E.XXX

460− [ do name <- Var.lower E.ExposingValue

395+ [ Src.Lower <$> Var.lower

461− end <- getPosition

462− return $ Src.Lower $ A.at start end name

463− , do word1 0x28 {-(-} E.ExposingValue

396+ , do word1 0x28 {-(-} E.XXX

464− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved

397+ op <- Symbol.binop

465− word1 0x29 {-)-} E.ExposingOperatorRightParen

398+ word1 0x29 {-)-} E.XXX

466− end <- getPosition

467− return $ Src.Operator (A.Region start end) op

399+ return (Src.Operator op)

468− , do name <- Var.upper E.ExposingValue

400+ , do name <- Var.upper

469− end <- getPosition

401+ spaces

470− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

471− Src.Upper (A.at start end name) <$> privacy

402+ Src.Upper name <$> privacy

472− ]

403+ ]

473

404

474

405

475−privacy :: Parser E.Exposing Src.Privacy

406+privacy :: Parser Src.Privacy

476privacy =

407privacy =

477− oneOfWithFallback

408+ oneOf E.XXX

478− [ do word1 0x28 {-(-} E.ExposingTypePrivacy

409+ [ do word1 0x28 {-(-} E.XXX

479− Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy

410+ spaces

480− start <- getPosition

481− word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy

411+ word2 0x2E 0x2E {-..-} E.XXX

482− end <- getPosition

412+ spaces

483− Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy

484− word1 0x29 {-)-} E.ExposingTypePrivacy

413+ word1 0x29 {-)-} E.XXX

485− return $ Src.Public (A.Region start end)

414+ return Src.Public

415+ , return Src.Private

486 ]

416 ]

487− Src.Private

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

@@ -11,12 +11,12 @@ module Parse.Number

11 where

12

13

14+import qualified Data.Utf8 as Utf8

14import Data.Word (Word8)

15import Data.Word (Word8)

15import Foreign.Ptr (Ptr, plusPtr, minusPtr)

16import Foreign.Ptr (Ptr, plusPtr, minusPtr)

16

17

17import qualified AST.Utils.Binop as Binop

18import qualified AST.Utils.Binop as Binop

18−import qualified Elm.Float as EF

19−import Parse.Primitives (Parser, Row, Col)

19+import Parse.Utils (Parser)

20import qualified Parse.Variable as Var

21import qualified Parse.Primitives as P

22import qualified Reporting.Error.Syntax as E

@@ -43,19 +43,19 @@ isDecimalDigit word =

43

44data Number

45 = Int Int

46− | Float EF.Float

46+ | Float (Utf8.Under256 Float)

47

48

49−number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number

49+number :: Parser Number

50−number toExpectation toError =

50+number =

51− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

51+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

52 if pos >= end then

53− eerr row col toExpectation

53+ eerr row col ctx E.Number_Start

54

55 else

56 let !word = P.unsafeIndex pos in

57 if not (isDecimalDigit word) then

58− eerr row col toExpectation

58+ eerr row col ctx E.Number_Start

59

60 else

61 let

@@ -70,22 +70,22 @@ number toExpectation toError =

70 let

71 !newCol = col + fromIntegral (minusPtr newPos pos)

72 in

73− cerr row newCol (toError problem)

73+ cerr row newCol ctx problem

74

75 OkInt newPos n ->

76 let

77 !newCol = col + fromIntegral (minusPtr newPos pos)

78 !integer = Int n

79− !newState = P.State src newPos end indent row newCol

79+ !newState = P.State newPos end indent row newCol ctx

80 in

81 cok integer newState

82

83 OkFloat newPos ->

84 let

85 !newCol = col + fromIntegral (minusPtr newPos pos)

86− !copy = EF.fromPtr pos newPos

86+ !copy = Utf8.fromPtr pos newPos

87 !float = Float copy

88− !newState = P.State src newPos end indent row newCol

88+ !newState = P.State newPos end indent row newCol ctx

89 in

90 cok float newState

91

@@ -97,7 +97,7 @@ number toExpectation toError =

97-- first Int is newPos

98--

99data Outcome

100− = Err (Ptr Word8) E.Number

100+ = Err (Ptr Word8) E.Expectation

101 | OkInt (Ptr Word8) Int

102 | OkFloat (Ptr Word8)

103

@@ -121,13 +121,13 @@ chompInt !pos end !n =

121 chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))

122

123 else if word == 0x2E {-.-} then

124− chompFraction pos end n

124+ chompFraction (plusPtr pos 1) end n

125

126 else if word == 0x65 {-e-} || word == 0x45 {-E-} then

127 chompExponent (plusPtr pos 1) end

128

129 else if isDirtyEnd pos end word then

130− Err pos E.NumberEnd

130+ Err pos E.Number_End

131

132 else

133 OkInt pos n

@@ -139,17 +139,14 @@ chompInt !pos end !n =

139

140chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome

141chompFraction pos end n =

142− let

143− !pos1 = plusPtr pos 1

144− in

145− if pos1 >= end then

142+ if pos >= end then

146− Err pos (E.NumberDot n)

143+ Err pos (E.Number_Dot n)

147

144

148− else if isDecimalDigit (P.unsafeIndex pos1) then

145+ else if isDecimalDigit (P.unsafeIndex pos) then

149− chompFractionHelp (plusPtr pos1 1) end

146+ chompFractionHelp (plusPtr pos 1) end

150

147

151 else

148 else

152− Err pos (E.NumberDot n)

149+ Err pos (E.Number_Dot n)

153

150

154

151

155chompFractionHelp :: Ptr Word8 -> Ptr Word8 -> Outcome

152chompFractionHelp :: Ptr Word8 -> Ptr Word8 -> Outcome

@@ -166,7 +163,7 @@ chompFractionHelp pos end =

166 chompExponent (plusPtr pos 1) end

163 chompExponent (plusPtr pos 1) end

167

164

168 else if isDirtyEnd pos end word then

165 else if isDirtyEnd pos end word then

169− Err pos E.NumberEnd

166+ Err pos E.Number_End

170

167

171 else

168 else

172 OkFloat pos

169 OkFloat pos

@@ -179,7 +176,7 @@ chompFractionHelp pos end =

179chompExponent :: Ptr Word8 -> Ptr Word8 -> Outcome

176chompExponent :: Ptr Word8 -> Ptr Word8 -> Outcome

180chompExponent pos end =

177chompExponent pos end =

181 if pos >= end then

178 if pos >= end then

182− Err pos E.NumberEnd

179+ Err pos E.Number_End

183

180

184 else

181 else

185 let !word = P.unsafeIndex pos in

182 let !word = P.unsafeIndex pos in

@@ -192,10 +189,10 @@ chompExponent pos end =

192 if pos1 < end && isDecimalDigit (P.unsafeIndex pos1) then

189 if pos1 < end && isDecimalDigit (P.unsafeIndex pos1) then

193 chompExponentHelp (plusPtr pos 2) end

190 chompExponentHelp (plusPtr pos 2) end

194 else

191 else

195− Err pos E.NumberEnd

192+ Err pos E.Number_End

196

193

197 else

194 else

198− Err pos E.NumberEnd

195+ Err pos E.Number_End

199

196

200

197

201chompExponentHelp :: Ptr Word8 -> Ptr Word8 -> Outcome

198chompExponentHelp :: Ptr Word8 -> Ptr Word8 -> Outcome

@@ -225,13 +222,13 @@ chompZero pos end =

225 chompHexInt (plusPtr pos 1) end

222 chompHexInt (plusPtr pos 1) end

226

223

227 else if word == 0x2E {-.-} then

224 else if word == 0x2E {-.-} then

228− chompFraction pos end 0

225+ chompFraction (plusPtr pos 1) end 0

229

226

230 else if isDecimalDigit word then

227 else if isDecimalDigit word then

231− Err pos E.NumberNoLeadingZero

228+ Err pos E.Number_NoLeadingZero

232

229

233 else if isDirtyEnd pos end word then

230 else if isDirtyEnd pos end word then

234− Err pos E.NumberEnd

231+ Err pos E.Number_End

235

232

236 else

233 else

237 OkInt pos 0

234 OkInt pos 0

@@ -241,7 +238,7 @@ chompHexInt :: Ptr Word8 -> Ptr Word8 -> Outcome

241chompHexInt pos end =

238chompHexInt pos end =

242 let (# newPos, answer #) = chompHex pos end in

239 let (# newPos, answer #) = chompHex pos end in

243 if answer < 0 then

240 if answer < 0 then

244− Err newPos E.NumberHexDigit

241+ Err newPos E.Number_HexDigit

245 else

242 else

246 OkInt newPos answer

243 OkInt newPos answer

247

244

@@ -288,18 +285,18 @@ stepHex pos end word acc

288-- PRECEDENCE

285-- PRECEDENCE

289

286

290

287

291−precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence

288+precedence :: Parser Binop.Precedence

292−precedence toExpectation =

289+precedence =

293− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

290+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

294 if pos >= end then

291 if pos >= end then

295− eerr row col toExpectation

292+ eerr row col ctx E.Precedence

296

293

297 else

294 else

298 let !word = P.unsafeIndex pos in

295 let !word = P.unsafeIndex pos in

299 if isDecimalDigit word then

296 if isDecimalDigit word then

300 cok

297 cok

301 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))

298 (Binop.Precedence (fromIntegral (word - 0x30 {-0-})))

302− (P.State src (plusPtr pos 1) end indent row (col + 1))

299+ (P.State (plusPtr pos 1) end indent row (col + 1) ctx)

303

300

304 else

301 else

305− eerr row col toExpectation

302+ eerr row col ctx E.Precedence

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

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

1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}

2+{-# LANGUAGE OverloadedStrings #-}

3module Parse.Pattern

4 ( term

5 , expression

@@ -9,17 +9,16 @@ module Parse.Pattern

9

10import qualified Data.List as List

11import qualified Data.Name as Name

12−import qualified Data.Utf8 as Utf8

13−import Foreign.Ptr (plusPtr)

14

12

15import qualified AST.Source as Src

13import qualified AST.Source as Src

14+import Parse.Utils (Parser, SParser, SPos, checkSpace, spaces, whitespace)

16import qualified Parse.Keyword as Keyword

15import qualified Parse.Keyword as Keyword

17import qualified Parse.Number as Number

16import qualified Parse.Number as Number

18−import qualified Parse.Space as Space

17+import qualified Parse.Symbol as Symbol

19−import qualified Parse.String as String

18+import qualified Parse.Utf8 as Utf8

20import qualified Parse.Variable as Var

19import qualified Parse.Variable as Var

21import qualified Parse.Primitives as P

20import qualified Parse.Primitives as P

22−import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2)

21+import Parse.Primitives (addLocation, getPosition, inContext, oneOf, word1)

23import qualified Reporting.Annotation as A

22import qualified Reporting.Annotation as A

24import qualified Reporting.Error.Syntax as E

23import qualified Reporting.Error.Syntax as E

25

24

@@ -28,10 +27,10 @@ import qualified Reporting.Error.Syntax as E

28-- TERM

27-- TERM

29

28

30

29

31−term :: Parser E.Pattern Src.Pattern

30+term :: Parser Src.Pattern

32term =

31term =

33 do start <- getPosition

32 do start <- getPosition

34− oneOf E.PStart

33+ oneOf E.XXX

35 [ record start

34 [ record start

36 , tuple start

35 , tuple start

37 , list start

36 , list start

@@ -39,17 +38,19 @@ term =

39 ]

38 ]

40

39

41

40

42−termHelp :: A.Position -> Parser E.Pattern Src.Pattern

41+termHelp :: A.Position -> Parser Src.Pattern

43termHelp start =

42termHelp start =

44− oneOf E.PStart

43+ oneOf E.XXX

45 [

44 [

46− do wildcard

45+ do Symbol.underscore

46+ end <- getPosition

47− addEnd start Src.PAnything

47+ return (A.at start end Src.PAnything)

48 ,

49− do name <- Var.lower E.PStart

49+ do name <- Var.lower

50+ end <- getPosition

50− addEnd start (Src.PVar name)

51+ return (A.at start end (Src.PVar name))

51 ,

52 ,

52− do upper <- Var.foreignUpper E.PStart

53+ do upper <- Var.foreignUpper

53 end <- getPosition

54 end <- getPosition

54 let region = A.Region start end

55 let region = A.Region start end

55 return $ A.at start end $

56 return $ A.at start end $

@@ -60,76 +61,60 @@ termHelp start =

60 Var.Qualified home name ->

61 Var.Qualified home name ->

61 Src.PCtorQual region home name []

62 Src.PCtorQual region home name []

62 ,

63 ,

63− do number <- Number.number E.PStart E.PNumber

64+ do number <- Number.number

64 end <- getPosition

65 end <- getPosition

65 case number of

66 case number of

66 Number.Int int ->

67 Number.Int int ->

67 return (A.at start end (Src.PInt int))

68 return (A.at start end (Src.PInt int))

68

69

69− Number.Float float ->

70+ Number.Float _ ->

70− P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->

71+ noFloatsAllowedInPatterns

71− let

72− width = fromIntegral (Utf8.size float)

73− in

74− cerr row (col - width) (E.PFloat width)

75 ,

72 ,

76− do str <- String.string E.PStart E.PString

73+ do str <- Utf8.string

74+ end <- getPosition

77− addEnd start (Src.PStr str)

75+ return (A.at start end (Src.PStr str))

78 ,

76 ,

79− do chr <- String.character E.PStart E.PChar

77+ do chr <- Utf8.character

78+ end <- getPosition

80− addEnd start (Src.PChr chr)

79+ return (A.at start end (Src.PChr chr))

81 ]

80 ]

82

81

83

82

84−

83+noFloatsAllowedInPatterns :: Parser a

85−-- WILDCARD

84+noFloatsAllowedInPatterns =

86−

87−

88−wildcard :: Parser E.Pattern ()

89−wildcard =

90− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

85+ P.Parser $ \(P.State _ _ _ row col ctx) _ _ cerr _ ->

91− if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then

86+ cerr row col ctx E.FloatInPattern

92− eerr row col E.PStart

93− else

94− let

95− !newPos = plusPtr pos 1

96− !newCol = col + 1

97− in

98− if Var.getInnerWidth newPos end > 0 then

99− let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in

100− cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))

101− else

102− let !newState = P.State src newPos end indent row newCol in

103− cok () newState

104

87

105

88

106

89

107-- RECORDS

90-- RECORDS

108

91

109

92

110−record :: A.Position -> Parser E.Pattern Src.Pattern

93+record :: A.Position -> Parser Src.Pattern

111record start =

94record start =

112− inContext E.PRecord (word1 0x7B {- { -} E.PStart) $

95+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $

113− do Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen

96+ do spaces

114− oneOf E.PRecordOpen

97+ oneOf E.XXX

115− [ do var <- addLocation (Var.lower E.PRecordField)

98+ [ do var <- addLocation Var.lower

116− Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd

99+ spaces

117 recordHelp start [var]

100 recordHelp start [var]

118− , do word1 0x7D {-}-} E.PRecordEnd

101+ , do word1 0x7D {-}-} E.XXX

102+ end <- getPosition

119− addEnd start (Src.PRecord [])

103+ return (A.at start end (Src.PRecord []))

120 ]

104 ]

121

105

122

106

123−recordHelp :: A.Position -> [A.Located Name.Name] -> Parser E.PRecord Src.Pattern

107+recordHelp :: A.Position -> [A.Located Name.Name] -> Parser Src.Pattern

124recordHelp start vars =

108recordHelp start vars =

125− oneOf E.PRecordEnd

109+ oneOf E.XXX

126− [ do word1 0x2C {-,-} E.PRecordEnd

110+ [ do word1 0x2C {-,-} E.XXX

127− Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField

111+ spaces

128− var <- addLocation (Var.lower E.PRecordField)

112+ var <- addLocation Var.lower

129− Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd

113+ spaces

130 recordHelp start (var:vars)

114 recordHelp start (var:vars)

131− , do word1 0x7D {-}-} E.PRecordEnd

115+ , do word1 0x7D {-}-} E.XXX

116+ end <- getPosition

132− addEnd start (Src.PRecord (reverse vars))

117+ return (A.at start end (Src.PRecord vars))

133 ]

118 ]

134

119

135

120

@@ -137,34 +122,36 @@ recordHelp start vars =

137-- TUPLES

122-- TUPLES

138

123

139

124

140−tuple :: A.Position -> Parser E.Pattern Src.Pattern

125+tuple :: A.Position -> Parser Src.Pattern

141tuple start =

126tuple start =

142− inContext E.PTuple (word1 0x28 {-(-} E.PStart) $

127+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $

143− do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1

128+ do spaces

144− oneOf E.PTupleOpen

129+ oneOf E.XXX

145− [ do (pattern, end) <- P.specialize E.PTupleExpr expression

130+ [ do (pattern, sPos) <- expression

146− Space.checkIndent end E.PTupleIndentEnd

131+ checkSpace sPos

147 tupleHelp start pattern []

132 tupleHelp start pattern []

148− , do word1 0x29 {-)-} E.PTupleEnd

133+ , do word1 0x29 {-)-} E.XXX

134+ end <- getPosition

149− addEnd start Src.PUnit

135+ return (A.at start end Src.PUnit)

150 ]

136 ]

151

137

152

138

153−tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.Pattern

139+tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern

154tupleHelp start firstPattern revPatterns =

140tupleHelp start firstPattern revPatterns =

155− oneOf E.PTupleEnd

141+ oneOf E.XXX

156− [ do word1 0x2C {-,-} E.PTupleEnd

142+ [ do word1 0x2C {-,-} E.XXX

157− Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN

143+ spaces

158− (pattern, end) <- P.specialize E.PTupleExpr expression

144+ (pattern, sPos) <- expression

159− Space.checkIndent end E.PTupleIndentEnd

145+ checkSpace sPos

160 tupleHelp start firstPattern (pattern : revPatterns)

146 tupleHelp start firstPattern (pattern : revPatterns)

161− , do word1 0x29 {-)-} E.PTupleEnd

147+ , do word1 0x29 {-)-} E.XXX

162 case reverse revPatterns of

148 case reverse revPatterns of

163 [] ->

149 [] ->

164 return firstPattern

150 return firstPattern

165

151

166 secondPattern : otherPatterns ->

152 secondPattern : otherPatterns ->

153+ do end <- getPosition

167− addEnd start (Src.PTuple firstPattern secondPattern otherPatterns)

154+ return (A.at start end (Src.PTuple firstPattern secondPattern otherPatterns))

168 ]

155 ]

169

156

170

157

@@ -172,29 +159,31 @@ tupleHelp start firstPattern revPatterns =

172-- LIST

159-- LIST

173

160

174

161

175−list :: A.Position -> Parser E.Pattern Src.Pattern

162+list :: A.Position -> Parser Src.Pattern

176list start =

163list start =

177− inContext E.PList (word1 0x5B {-[-} E.PStart) $

164+ inContext E.PatternList (word1 0x5B {-[-} E.XXX) $

178− do Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen

165+ do spaces

179− oneOf E.PListOpen

166+ oneOf E.XXX

180− [ do (pattern, end) <- P.specialize E.PListExpr expression

167+ [ do (pattern, sPos) <- expression

181− Space.checkIndent end E.PListIndentEnd

168+ checkSpace sPos

182 listHelp start [pattern]

169 listHelp start [pattern]

183− , do word1 0x5D {-]-} E.PListEnd

170+ , do word1 0x5D {-]-} E.XXX

171+ end <- getPosition

184− addEnd start (Src.PList [])

172+ return (A.at start end (Src.PList []))

185 ]

173 ]

186

174

187

175

188−listHelp :: A.Position -> [Src.Pattern] -> Parser E.PList Src.Pattern

176+listHelp :: A.Position -> [Src.Pattern] -> Parser Src.Pattern

189listHelp start patterns =

177listHelp start patterns =

190− oneOf E.PListEnd

178+ oneOf E.XXX

191− [ do word1 0x2C {-,-} E.PListEnd

179+ [ do word1 0x2C {-,-} E.XXX

192− Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr

180+ spaces

193− (pattern, end) <- P.specialize E.PListExpr expression

181+ (pattern, sPos) <- expression

194− Space.checkIndent end E.PListIndentEnd

182+ checkSpace sPos

195 listHelp start (pattern:patterns)

183 listHelp start (pattern:patterns)

196− , do word1 0x5D {-]-} E.PListEnd

184+ , do word1 0x5D {-]-} E.XXX

185+ end <- getPosition

197− addEnd start (Src.PList (reverse patterns))

186+ return (A.at start end (Src.PList (reverse patterns)))

198 ]

187 ]

199

188

200

189

@@ -202,37 +191,38 @@ listHelp start patterns =

202-- EXPRESSION

191-- EXPRESSION

203

192

204

193

205−expression :: Space.Parser E.Pattern Src.Pattern

194+expression :: Parser (Src.Pattern, SPos)

206expression =

195expression =

207 do start <- getPosition

196 do start <- getPosition

208− ePart <- exprPart

197+ cTerm <- exprTerm

209− exprHelp start [] ePart

198+ exprHelp start [] cTerm

210−

199+

211−

200+

212−exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern

201+exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position, SPos) -> Parser (Src.Pattern, SPos)

213−exprHelp start revPatterns (pattern, end) =

202+exprHelp start patterns (pattern, _end, sPos) =

214− oneOfWithFallback

203+ oneOf E.XXX

215− [ do Space.checkIndent end E.PIndentStart

204+ [ do checkSpace sPos

216− word2 0x3A 0x3A {-::-} E.PStart

205+ word1 0x3A {-:-} E.XXX

217− Space.chompAndCheckIndent E.PSpace E.PIndentStart

206+ spaces

218− ePart <- exprPart

207+ cTerm <- exprTerm

219− exprHelp start (pattern:revPatterns) ePart

208+ exprHelp start (pattern:patterns) cTerm

220− , do Space.checkIndent end E.PIndentStart

209+ , do checkSpace sPos

221− Keyword.as_ E.PStart

210+ Keyword.as_

222− Space.chompAndCheckIndent E.PSpace E.PIndentAlias

211+ spaces

223 nameStart <- getPosition

212 nameStart <- getPosition

224− name <- Var.lower E.PAlias

213+ name <- Var.lower

225 newEnd <- getPosition

214 newEnd <- getPosition

226− Space.chomp E.PSpace

215+ newSpace <- whitespace

227 let alias = A.at nameStart newEnd name

216 let alias = A.at nameStart newEnd name

228 return

217 return

229− ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)

218+ ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)

230− , newEnd

219+ , newSpace

231 )

220 )

221+ , return

222+ ( List.foldl' cons pattern patterns

223+ , sPos

224+ )

232 ]

225 ]

233− ( List.foldl' cons pattern revPatterns

234− , end

235− )

236

226

237

227

238cons :: Src.Pattern -> Src.Pattern -> Src.Pattern

228cons :: Src.Pattern -> Src.Pattern -> Src.Pattern

@@ -241,39 +231,41 @@ cons tl hd =

241

231

242

232

243

233

244−-- EXPRESSION PART

234+-- EXPRESSION TERM

245

235

246

236

247−exprPart :: Space.Parser E.Pattern Src.Pattern

237+exprTerm :: SParser Src.Pattern

248−exprPart =

238+exprTerm =

249− oneOf E.PStart

239+ oneOf E.XXX

250 [

240 [

251 do start <- getPosition

241 do start <- getPosition

252− upper <- Var.foreignUpper E.PStart

242+ upper <- Var.foreignUpper

253 end <- getPosition

243 end <- getPosition

254 exprTermHelp (A.Region start end) upper start []

244 exprTermHelp (A.Region start end) upper start []

255 ,

245 ,

256− do eterm@(A.At (A.Region _ end) _) <- term

246+ do t@(A.At (A.Region _ end) _) <- term

257− Space.chomp E.PSpace

247+ pos <- whitespace

258− return (eterm, end)

248+ return (t, end, pos)

259 ]

249 ]

260

250

261

251

262−exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> Space.Parser E.Pattern Src.Pattern

252+exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> SParser Src.Pattern

263exprTermHelp region upper start revArgs =

253exprTermHelp region upper start revArgs =

264 do end <- getPosition

254 do end <- getPosition

265− Space.chomp E.PSpace

255+ sPos <- whitespace

266− oneOfWithFallback

256+ oneOf E.XXX

267− [ do Space.checkIndent end E.PIndentStart

257+ [ do checkSpace sPos

268 arg <- term

258 arg <- term

269 exprTermHelp region upper start (arg:revArgs)

259 exprTermHelp region upper start (arg:revArgs)

260+ , return

261+ ( A.at start end $

262+ case upper of

263+ Var.Unqualified name ->

264+ Src.PCtor region name (reverse revArgs)

265+

266+ Var.Qualified home name ->

267+ Src.PCtorQual region home name (reverse revArgs)

268+ , end

269+ , sPos

270+ )

270 ]

271 ]

271− ( A.at start end $

272− case upper of

273− Var.Unqualified name ->

274− Src.PCtor region name (reverse revArgs)

275−

276− Var.Qualified home name ->

277− Src.PCtorQual region home name (reverse revArgs)

278− , end

279− )

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

@@ -1,31 +1,29 @@

1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}

3module Parse.Primitives

4+ ( Result(..)

4− ( fromByteString

5+ , fromByteString

5 , Parser(..)

6 , Parser(..)

6 , State(..)

7 , State(..)

7− , Row

8+ , Context(..)

8− , Col

9+ , oneOf

9− , oneOf, oneOfWithFallback

10+ , pushContext, popContext, inContext

10− , inContext, specialize

11− , getPosition, getCol, addLocation, addEnd

11+ , getPosition, getCol, addLocation

12− , getIndent, setIndent, withIndent, withBacksetIndent

12+ , getIndent, setIndent

13 , word1, word2

14 , unsafeIndex, isWord, getCharWidth

15− , Snippet(..)

16− , fromSnippet

17 )

15 )

18 where

16 where

19

17

20

18

21import Prelude hiding (length)

19import Prelude hiding (length)

22import qualified Control.Applicative as Applicative (Applicative(..))

20import qualified Control.Applicative as Applicative (Applicative(..))

21+import Control.Monad

23import qualified Data.ByteString.Internal as B

22import qualified Data.ByteString.Internal as B

24import Data.Word (Word8, Word16)

23import Data.Word (Word8, Word16)

25import Foreign.Ptr (Ptr, plusPtr)

24import Foreign.Ptr (Ptr, plusPtr)

26import Foreign.Storable (peek)

25import Foreign.Storable (peek)

27−import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)

26+import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)

28−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

29

27

30import qualified Reporting.Annotation as A

28import qualified Reporting.Annotation as A

31

29

@@ -34,38 +32,39 @@ import qualified Reporting.Annotation as A

34-- PARSER

32-- PARSER

35

33

36

34

37−newtype Parser x a =

35+newtype Parser c x a =

38 Parser (

36 Parser (

39 forall b.

37 forall b.

40− State

38+ State c

41− -> (a -> State -> b) -- consumed ok

39+ -> (a -> State c -> b) -- consumed ok

42− -> (a -> State -> b) -- empty ok

40+ -> (a -> State c -> b) -- empty ok

43− -> (Row -> Col -> (Row -> Col -> x) -> b) -- consumed err

41+ -> (Word16 -> Word16 -> Context c -> x -> b) -- consumed err

44− -> (Row -> Col -> (Row -> Col -> x) -> b) -- empty err

42+ -> (Word16 -> Word16 -> Context c -> x -> b) -- empty err

45 -> b

43 -> b

46 )

44 )

47

45

48

46

49−data State = -- PERF try taking some out to avoid allocation

47+data State c =

50 State

48 State

51− { _src :: ForeignPtr Word8

52− , _pos :: !(Ptr Word8)

49+ { _pos :: !(Ptr Word8)

53 , _end :: !(Ptr Word8)

50 , _end :: !(Ptr Word8)

54 , _indent :: !Word16

51 , _indent :: !Word16

55− , _row :: !Row

52+ , _row :: !Word16

56− , _col :: !Col

53+ , _col :: !Word16

54+ , _context :: Context c

57 }

55 }

58

56

59

57

60−type Row = Word16

58+data Context c

61−type Col = Word16

59+ = NoContext

60+ | Frame {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16 c (Context c)

62

61

63

62

64

63

65-- FUNCTOR

64-- FUNCTOR

66

65

67

66

68−instance Functor (Parser x) where

67+instance Functor (Parser c x) where

69 {-# INLINE fmap #-}

68 {-# INLINE fmap #-}

70 fmap f (Parser parser) =

69 fmap f (Parser parser) =

71 Parser $ \state cok eok cerr eerr ->

70 Parser $ \state cok eok cerr eerr ->

@@ -80,28 +79,12 @@ instance Functor (Parser x) where

80-- APPLICATIVE

79-- APPLICATIVE

81

80

82

81

83−instance Applicative.Applicative (Parser x) where

82+instance Applicative.Applicative (Parser c x) where

84 {-# INLINE pure #-}

83 {-# INLINE pure #-}

85 pure = return

84 pure = return

86

85

87 {-# INLINE (<*>) #-}

86 {-# INLINE (<*>) #-}

88− (<*>) (Parser parserFunc) (Parser parserArg) =

87+ (<*>) = ap

89− Parser $ \state cok eok cerr eerr ->

90− let

91− cokF func s1 =

92− let

93− cokA arg s2 = cok (func arg) s2

94− in

95− parserArg s1 cokA cokA cerr cerr

96−

97− eokF func s1 =

98− let

99− cokA arg s2 = cok (func arg) s2

100− eokA arg s2 = eok (func arg) s2

101− in

102− parserArg s1 cokA eokA cerr eerr

103− in

104− parserFunc state cokF eokF cerr eerr

105

88

106

89

107

90

@@ -109,74 +92,42 @@ instance Applicative.Applicative (Parser x) where

109

92

110

93

111{-# INLINE oneOf #-}

94{-# INLINE oneOf #-}

112−oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a

95+oneOf :: x -> [Parser c x a] -> Parser c x a

113−oneOf toError parsers =

96+oneOf x parsers =

114 Parser $ \state cok eok cerr eerr ->

97 Parser $ \state cok eok cerr eerr ->

115− oneOfHelp state cok eok cerr eerr toError parsers

98+ oneOfHelp state cok eok cerr eerr x parsers

116

99

117

100

118oneOfHelp

101oneOfHelp

119− :: State

102+ :: State c

120− -> (a -> State -> b)

103+ -> (a -> State c -> b)

121− -> (a -> State -> b)

104+ -> (a -> State c -> b)

122− -> (Row -> Col -> (Row -> Col -> x) -> b)

105+ -> (Word16 -> Word16 -> Context c -> x -> b)

123− -> (Row -> Col -> (Row -> Col -> x) -> b)

106+ -> (Word16 -> Word16 -> Context c -> x -> b)

124− -> (Row -> Col -> x)

107+ -> x

125− -> [Parser x a]

108+ -> [Parser c x a]

126 -> b

109 -> b

127−oneOfHelp state cok eok cerr eerr toError parsers =

110+oneOfHelp state cok eok cerr eerr x parsers =

128 case parsers of

111 case parsers of

129 Parser parser : parsers ->

112 Parser parser : parsers ->

130 let

113 let

131− eerr' _ _ _ =

114+ eerr' _ _ _ _ =

132− oneOfHelp state cok eok cerr eerr toError parsers

115+ oneOfHelp state cok eok cerr eerr x parsers

133 in

116 in

134 parser state cok eok cerr eerr'

117 parser state cok eok cerr eerr'

135

118

136 [] ->

119 [] ->

137 let

120 let

138− (State _ _ _ _ row col) = state

121+ (State _ _ _ row col ctx) = state

139 in

122 in

140− eerr row col toError

123+ eerr row col ctx x

141−

142−

143−

144−-- ONE OF WITH FALLBACK

145−

146−

147−{-# INLINE oneOfWithFallback #-}

148−oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- PERF is this function okay? Worried about allocation/laziness with fallback values.

149−oneOfWithFallback parsers fallback =

150− Parser $ \state cok eok cerr _ ->

151− oowfHelp state cok eok cerr parsers fallback

152−

153−

154−oowfHelp

155− :: State

156− -> (a -> State -> b)

157− -> (a -> State -> b)

158− -> (Row -> Col -> (Row -> Col -> x) -> b)

159− -> [Parser x a]

160− -> a

161− -> b

162−oowfHelp state cok eok cerr parsers fallback =

163− case parsers of

164− [] ->

165− eok fallback state

166−

167− Parser parser : parsers ->

168− let

169− eerr' _ _ _ =

170− oowfHelp state cok eok cerr parsers fallback

171− in

172− parser state cok eok cerr eerr'

173

124

174

125

175

126

176-- MONAD

127-- MONAD

177

128

178

129

179−instance Monad (Parser x) where

130+instance Monad (Parser c x) where

180 {-# INLINE return #-}

131 {-# INLINE return #-}

181 return value =

132 return value =

182 Parser $ \state _ eok _ _ ->

133 Parser $ \state _ eok _ _ ->

@@ -201,55 +152,20 @@ instance Monad (Parser x) where

201-- FROM BYTESTRING

152-- FROM BYTESTRING

202

153

203

154

204−fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a

155+data Result c x a

205−fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) =

156+ = Ok !a (State c)

206− B.accursedUnutterablePerformIO $

157+ | Err Word16 Word16 (Context c) x

207− let

208− toOk' = toOk toBadEnd

209− !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset

210− !end = plusPtr pos length

211− !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr

212− in

213− do touchForeignPtr fptr

214− return result

215−

216−

217−toOk :: (Row -> Col -> x) -> a -> State -> Either x a

218−toOk toBadEnd !a (State _ pos end _ row col) =

219− if pos == end

220− then Right a

221− else Left (toBadEnd row col)

222−

223−

224−toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a

225−toErr row col toError =

226− Left (toError row col)

227−

228−

229

158

230−-- FROM SNIPPET

231

159

232−

160+fromByteString :: Parser c x a -> B.ByteString -> Result c x a

233−data Snippet =

234− Snippet

235− { _fptr :: ForeignPtr Word8

236− , _offset :: Int

237− , _length :: Int

238− , _offRow :: Row

239− , _offCol :: Col

240− }

241−

242−

243−fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a

244−fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =

161+fromByteString (Parser parser) (B.PS fp offset length) =

245 B.accursedUnutterablePerformIO $

162 B.accursedUnutterablePerformIO $

246 let

163 let

247− toOk' = toOk toBadEnd

248− !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset

164+ !pos = plusPtr (unsafeForeignPtrToPtr fp) offset

249 !end = plusPtr pos length

165 !end = plusPtr pos length

250− !result = parser (State fptr pos end 0 row col) toOk' toOk' toErr toErr

166+ !result = parser (State pos end 0 1 1 NoContext) Ok Ok Err Err

251 in

167 in

252− do touchForeignPtr fptr

168+ do touchForeignPtr fp

253 return result

169 return result

254

170

255

171

@@ -257,126 +173,127 @@ fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =

257-- POSITION

173-- POSITION

258

174

259

175

260−getCol :: Parser x Word16

176+getCol :: Parser c x Word16

261getCol =

177getCol =

262− Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ ->

178+ Parser $ \state@(State _ _ _ _ col _) _ eok _ _ ->

263 eok col state

179 eok col state

264

180

265

181

266{-# INLINE getPosition #-}

182{-# INLINE getPosition #-}

267−getPosition :: Parser x A.Position

183+getPosition :: Parser c x A.Position

268getPosition =

184getPosition =

269− Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->

185+ Parser $ \state@(State _ _ _ row col _) _ eok _ _ ->

270 eok (A.Position row col) state

186 eok (A.Position row col) state

271

187

272

188

273−addLocation :: Parser x a -> Parser x (A.Located a)

189+addLocation :: Parser c x a -> Parser c x (A.Located a)

274addLocation (Parser parser) =

190addLocation (Parser parser) =

275− Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr ->

191+ Parser $ \state@(State _ _ _ srow scol _) cok eok cerr eerr ->

276 let

192 let

277− cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s

193+ cok' a s@(State _ _ _ erow ecol _) = cok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s

278− eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s

194+ eok' a s@(State _ _ _ erow ecol _) = eok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s

279 in

195 in

280 parser state cok' eok' cerr eerr

196 parser state cok' eok' cerr eerr

281

197

282

198

283−addEnd :: A.Position -> a -> Parser x (A.Located a)

284−addEnd start value =

285− Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->

286− eok (A.at start (A.Position row col) value) state

287−

288−

289

199

290-- INDENT

200-- INDENT

291

201

292

202

293−getIndent :: Parser x Word16

203+getIndent :: Parser c x Word16

294getIndent =

204getIndent =

295− Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ ->

205+ Parser $ \state@(State _ _ indent _ _ _) _ eok _ _ ->

296 eok indent state

206 eok indent state

297

207

298

208

299−setIndent :: Word16 -> Parser x ()

209+setIndent :: Word16 -> Parser c x ()

300setIndent indent =

210setIndent indent =

301− Parser $ \(State src pos end _ row col) _ eok _ _ ->

211+ Parser $ \(State pos end _ row col context) _ eok _ _ ->

302 let

212 let

213+ !newState =

303− !newState = State src pos end indent row col

214+ State pos end indent row col context

304 in

215 in

305 eok () newState

216 eok () newState

306

217

307

218

308−withIndent :: Parser x a -> Parser x a

219+

309−withIndent (Parser parser) =

220+-- CONTEXT

310− Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->

311− let

312− cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)

313− eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)

314− in

315− parser (State src pos end col row col) cok' eok' cerr eerr

316

221

317

222

318−withBacksetIndent :: Word16 -> Parser x a -> Parser x a

223+pushContext :: A.Position -> c -> Parser c x ()

319−withBacksetIndent backset (Parser parser) =

224+pushContext (A.Position r c) ctx =

320− Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->

225+ Parser $ \(State pos end indent row col context) _ eok _ _ ->

321 let

226 let

322− cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)

227+ !newContext = Frame r c ctx context

323− eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)

228+ !newState = State pos end indent row col newContext

324 in

229 in

325− parser (State src pos end (col - backset) row col) cok' eok' cerr eerr

230+ eok () newState

326

231

327

232

233+popContext :: a -> Parser c x a

234+popContext value =

235+ Parser $ \(State pos end indent row col context) _ eok _ _ ->

236+ case context of

237+ Frame _ _ _ context ->

238+ let

239+ !newState =

240+ State pos end indent row col context

241+ in

242+ eok value newState

328

243

329−-- CONTEXT

244+ NoContext ->

245+ error "compiler error, trying to popContext on NoContext"

330

246

331

247

332−inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a

248+inContext :: c -> Parser c x start -> Parser c x a -> Parser c x a

333−inContext addContext (Parser parserStart) (Parser parserA) =

249+inContext tag (Parser parserStart) (Parser parserA) =

334− Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->

250+ Parser $ \state@(State _ _ _ frow fcol _) cok eok cerr eerr ->

335 let

251 let

336− cerrA r c tx = cerr row col (addContext (tx r c))

252+ cokS _ (State pos end indent row col ctx) =

337− eerrA r c tx = eerr row col (addContext (tx r c))

253+ let

338−

254+ !newContext = Frame frow fcol tag ctx

339− cokS _ s = parserA s cok cok cerrA cerrA

255+ !newState = State pos end indent row col newContext

340− eokS _ s = parserA s cok eok cerrA eerrA

256+ cokA a s = cok a (s { _context = ctx })

257+ in

258+ parserA newState cokA cokA cerr cerr

259+

260+ eokS _ (State pos end indent row col ctx) =

261+ let

262+ !newContext = Frame frow fcol tag ctx

263+ !newState = State pos end indent row col newContext

264+ cokA a s = cok a (s { _context = ctx })

265+ eokA a s = eok a (s { _context = ctx })

266+ in

267+ parserA newState cokA eokA cerr eerr

341 in

268 in

342 parserStart state cokS eokS cerr eerr

269 parserStart state cokS eokS cerr eerr

343

270

344

271

345−specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a

346−specialize addContext (Parser parser) =

347− Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->

348− let

349− cerr' r c tx = cerr row col (addContext (tx r c))

350− eerr' r c tx = eerr row col (addContext (tx r c))

351− in

352− parser state cok eok cerr' eerr'

353−

354−

355

272

356-- SYMBOLS

273-- SYMBOLS

357

274

358

275

359−word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()

276+word1 :: Word8 -> x -> Parser c x ()

360−word1 word toError =

277+word1 word x =

361− Parser $ \(State src pos end indent row col) cok _ _ eerr ->

278+ Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->

362 if pos < end && unsafeIndex pos == word then

279 if pos < end && unsafeIndex pos == word then

363− let !newState = State src (plusPtr pos 1) end indent row (col + 1) in

280+ let !newState = State (plusPtr pos 1) end indent row (col + 1) ctx in

364 cok () newState

281 cok () newState

365 else

282 else

366− eerr row col toError

283+ eerr row col ctx x

367

284

368

285

369−word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

286+word2 :: Word8 -> Word8 -> x -> Parser c x ()

370−word2 w1 w2 toError =

287+word2 w1 w2 x =

371− Parser $ \(State src pos end indent row col) cok _ _ eerr ->

288+ Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->

372 let

289 let

373 !pos1 = plusPtr pos 1

290 !pos1 = plusPtr pos 1

374 in

291 in

375 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then

292 if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then

376− let !newState = State src (plusPtr pos 2) end indent row (col + 2) in

293+ let !newState = State (plusPtr pos 2) end indent row (col + 2) ctx in

377 cok () newState

294 cok () newState

378 else

295 else

379− eerr row col toError

296+ eerr row col ctx x

380

297

381

298

382

299

@@ -394,8 +311,8 @@ isWord pos end word =

394 pos < end && unsafeIndex pos == word

311 pos < end && unsafeIndex pos == word

395

312

396

313

397−getCharWidth :: Word8 -> Int

314+getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int

398−getCharWidth word

315+getCharWidth _pos _end word

399 | word < 0x80 = 1

316 | word < 0x80 = 1

400 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."

317 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."

401 | word < 0xe0 = 2

318 | word < 0xe0 = 2

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

@@ -0,0 +1,117 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Parse.Repl

4+ ( Entry(..)

5+ , parseEntry

6+ )

7+ where

8+

9+

10+import qualified Data.ByteString.UTF8 as BS_UTF8

11+import Data.Name (Name)

12+

13+import qualified AST.Source as Src

14+import qualified Parse.Primitives as P

15+import Parse.Utils

16+

17+

18+

19+-- ENTRY

20+

21+

22+data Entry

23+ = Import Name (Maybe Name) Src.Exposing String

24+ | Type Name String

25+ | Def (Maybe Name) String

26+ | Other String

27+ | Annotation

28+ | Port

29+

30+

31+

32+-- PARSE

33+

34+

35+parseEntry :: String -> Entry

36+parseEntry source =

37+ case P.fromByteString parser (BS_UTF8.fromString source) of

38+ P.Ok entry _ ->

39+ entry

40+

41+ P.Err _ _ _ _ ->

42+ Other source

43+

44+

45+parser :: Parser Entry

46+parser =

47+ error "TODO parse the REPL stuff"

48+

49+{-

50+ oneOf

51+ [

52+ do Keyword.import_

53+ spaces

54+ name <- Var.moduleName

55+ alias <- tryAlias

56+ exposing <-

57+ oneOf

58+ [ do spaces

59+ Keyword.exposing_

60+ spaces

61+ Module.exposing

62+ , return (Src.Explicit [])

63+ ]

64+ return (Import name alias exposing source)

65+ ,

66+ do Keyword.port_

67+ return Port

68+ ,

69+ do Keyword.type_

70+ spaces

71+ oneOf

72+ [ do Keyword.alias_

73+ spaces

74+ , return ()

75+ ]

76+ name <- Var.upper

77+ return (Type name source)

78+ ,

79+ do root <- Pattern.term

80+ spaces

81+ case A.toValue root of

82+ Src.PVar name ->

83+ oneOf

84+ [ do word1 0x3A {-:-} E.XXX

85+ return Annotation

86+ , do chompArgs

87+ return (Def (Just name) source)

88+ ]

89+

90+ _ ->

91+ do word1 0x3D {-=-} E.XXX

92+ return (Def Nothing source)

93+ ]

94+

95+

96+chompArgs :: Parser ()

97+chompArgs =

98+ oneOf

99+ [ do Pattern.term

100+ spaces

101+ chompArgs

102+ , do word1 0x3D {-=-} E.XXX

103+ return ()

104+ ]

105+

106+

107+tryAlias :: Parser (Maybe Name)

108+tryAlias =

109+ oneOf

110+ [ try $

111+ do spaces

112+ Keyword.as_

113+ spaces

114+ Just <$> Var.upper

115+ , return Nothing

116+ ]

117+-}

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

@@ -6,13 +6,12 @@ module Parse.Shader

6 where

7

8

9−import qualified Data.ByteString.Internal as B

9+import qualified Data.List as List

10−import qualified Data.ByteString.UTF8 as BS_UTF8

11import qualified Data.Map as Map

10import qualified Data.Map as Map

12import qualified Data.Name as Name

11import qualified Data.Name as Name

12+import qualified Data.Utf8 as Utf8

13−import Data.Word (Word8)

13+import Data.Word (Word8, Word16)

14import Foreign.Ptr (Ptr, plusPtr, minusPtr)

15−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

16import qualified Language.GLSL.Parser as GLP

15import qualified Language.GLSL.Parser as GLP

17import qualified Language.GLSL.Syntax as GLS

16import qualified Language.GLSL.Syntax as GLS

18import qualified Text.Parsec as Parsec

17import qualified Text.Parsec as Parsec

@@ -20,7 +19,7 @@ import qualified Text.Parsec.Error as Parsec

20

19

21import qualified AST.Source as Src

20import qualified AST.Source as Src

22import qualified AST.Utils.Shader as Shader

21import qualified AST.Utils.Shader as Shader

23−import Parse.Primitives (Parser, Row, Col)

22+import Parse.Utils (Parser)

24import qualified Parse.Primitives as P

23import qualified Parse.Primitives as P

25import qualified Reporting.Annotation as A

24import qualified Reporting.Annotation as A

26import qualified Reporting.Error.Syntax as E

25import qualified Reporting.Error.Syntax as E

@@ -30,21 +29,22 @@ import qualified Reporting.Error.Syntax as E

30-- SHADER

29-- SHADER

31

30

32

31

33−shader :: A.Position -> Parser E.Expr Src.Expr

32+shader :: A.Position -> Parser Src.Expr

34shader start@(A.Position row col) =

33shader start@(A.Position row col) =

35 do block <- parseBlock

34 do block <- parseBlock

36 shdr <- parseGlsl row col block

35 shdr <- parseGlsl row col block

37 end <- P.getPosition

36 end <- P.getPosition

37+ let src = List.intercalate "\\n" (lines block)

38− return (A.at start end (Src.Shader (Shader.fromChars block) shdr))

38+ return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))

39

40

41

42-- BLOCK

43

44

45−parseBlock :: Parser E.Expr [Char]

45+parseBlock :: Parser String

46parseBlock =

47− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

47+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

48 let

49 !pos6 = plusPtr pos 6

50 in

@@ -58,23 +58,22 @@ parseBlock =

58 then

59 let

60 (# status, newPos, newRow, newCol #) =

61− eatShader pos6 end row (col + 6)

61+ eatShader pos6 end row col

62 in

63 case status of

64 Good ->

65 let

66− !off = minusPtr pos6 (unsafeForeignPtrToPtr src)

66+ !size = minusPtr newPos pos

67− !len = minusPtr newPos pos6

67+ !block = error "TODO get a GLSL block" size

68− !block = BS_UTF8.toString (B.PS src off len)

69− !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)

68+ !newState = P.State (plusPtr newPos 2) end indent newRow newCol ctx

70 in

69 in

71 cok block newState

70 cok block newState

72

71

73 Unending ->

72 Unending ->

74− cerr row col E.EndlessShader

73+ cerr row col ctx (E.ShaderEnd col (col + 6))

75

74

76 else

75 else

77− eerr row col E.Start

76+ eerr row col ctx E.ShaderStart

78

77

79

78

80data Status

79data Status

@@ -82,7 +81,7 @@ data Status

82 | Unending

81 | Unending

83

82

84

83

85−eatShader :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)

84+eatShader :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Status, Ptr Word8, Word16, Word16 #)

86eatShader pos end row col =

85eatShader pos end row col =

87 if pos >= end then

86 if pos >= end then

88 (# Unending, pos, row, col #)

87 (# Unending, pos, row, col #)

@@ -90,13 +89,13 @@ eatShader pos end row col =

90 else

89 else

91 let !word = P.unsafeIndex pos in

90 let !word = P.unsafeIndex pos in

92 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then

91 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then

93− (# Good, pos, row, col #)

92+ (# Good, pos, row, col + 2 #)

94

93

95 else if word == 0x0A {- \n -} then

94 else if word == 0x0A {- \n -} then

96 eatShader (plusPtr pos 1) end (row + 1) 1

95 eatShader (plusPtr pos 1) end (row + 1) 1

97

96

98 else

97 else

99− let !newPos = plusPtr pos (P.getCharWidth word) in

98+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in

100 eatShader newPos end row (col + 1)

99 eatShader newPos end row (col + 1)

101

100

102

101

@@ -104,7 +103,7 @@ eatShader pos end row col =

104-- GLSL

103-- GLSL

105

104

106

105

107−parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types

106+parseGlsl :: Word16 -> Word16 -> String -> Parser Shader.Types

108parseGlsl startRow startCol src =

107parseGlsl startRow startCol src =

109 case GLP.parse src of

108 case GLP.parse src of

110 Right (GLS.TranslationUnit decls) ->

109 Right (GLS.TranslationUnit decls) ->

@@ -129,10 +128,10 @@ parseGlsl startRow startCol src =

129 else failure (startRow + row - 1) col msg

128 else failure (startRow + row - 1) col msg

130

129

131

130

132−failure :: Row -> Col -> [Char] -> Parser E.Expr a

131+failure :: Word16 -> Word16 -> String -> Parser a

133failure row col msg =

132failure row col msg =

134− P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->

133+ P.Parser $ \(P.State _ _ _ _ _ ctx) _ _ cerr _ ->

135− cerr row col (E.ShaderProblem msg)

134+ cerr row col ctx (E.ShaderProblem msg)

136

135

137

136

138

137

@@ -144,7 +143,7 @@ emptyTypes =

144 Shader.Types Map.empty Map.empty Map.empty

143 Shader.Types Map.empty Map.empty Map.empty

145

144

146

145

147−addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types

146+addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types

148addInput (qual, tipe, name) glDecls =

147addInput (qual, tipe, name) glDecls =

149 case qual of

148 case qual of

150 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }

149 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }

@@ -153,7 +152,7 @@ addInput (qual, tipe, name) glDecls =

153 _ -> error "Should never happen due to `extractInputs` function"

152 _ -> error "Should never happen due to `extractInputs` function"

154

153

155

154

156−extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]

155+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)]

157extractInputs decl =

156extractInputs decl =

158 case decl of

157 case decl of

159 GLS.Declaration

158 GLS.Declaration

compiler/src/Parse/Space.hsdeleted−273

@@ -1,273 +0,0 @@

1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2−{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}

3−module Parse.Space

4− ( Parser

5− --

6− , chomp

7− , chompAndCheckIndent

8− --

9− , checkIndent

10− , checkAligned

11− , checkFreshLine

12− --

13− , docComment

14− )

15− where

16−

17−

18−import Data.Word (Word8, Word16)

19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

20−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

21−

22−import qualified AST.Source as Src

23−import Parse.Primitives (Row, Col)

24−import qualified Parse.Primitives as P

25−import qualified Reporting.Annotation as A

26−import qualified Reporting.Error.Syntax as E

27−

28−

29−

30−-- SPACE PARSING

31−

32−

33−type Parser x a =

34− P.Parser x (a, A.Position)

35−

36−

37−

38−-- CHOMP

39−

40−

41−chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()

42−chomp toError =

43− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->

44− let

45− (# status, newPos, newRow, newCol #) = eatSpaces pos end row col

46− in

47− case status of

48− Good ->

49− let

50− !newState = P.State src newPos end indent newRow newCol

51− in

52− cok () newState

53−

54− HasTab -> cerr newRow newCol (toError E.HasTab)

55− EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment)

56−

57−

58−

59−-- CHECKS -- to be called right after a `chomp`

60−

61−

62−checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()

63−checkIndent (A.Position endRow endCol) toError =

64− P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr ->

65− if col > indent && col > 1

66− then eok () state

67− else eerr endRow endCol toError

68−

69−

70−checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()

71−checkAligned toError =

72− P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr ->

73− if col == indent

74− then eok () state

75− else eerr row col (toError indent)

76−

77−

78−checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()

79−checkFreshLine toError =

80− P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->

81− if col == 1

82− then eok () state

83− else eerr row col toError

84−

85−

86−

87−-- CHOMP AND CHECK

88−

89−

90−chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()

91−chompAndCheckIndent toSpaceError toIndentError =

92− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->

93− let

94− (# status, newPos, newRow, newCol #) = eatSpaces pos end row col

95− in

96− case status of

97− Good ->

98− if newCol > indent && newCol > 1

99− then

100−

101− let

102− !newState = P.State src newPos end indent newRow newCol

103− in

104− cok () newState

105−

106− else

107− cerr row col toIndentError

108−

109− HasTab -> cerr newRow newCol (toSpaceError E.HasTab)

110− EndlessMultiComment -> cerr newRow newCol (toSpaceError E.EndlessMultiComment)

111−

112−

113−

114−-- EAT SPACES

115−

116−

117−data Status

118− = Good

119− | HasTab

120− | EndlessMultiComment

121−

122−

123−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)

124−eatSpaces pos end row col =

125− if pos >= end then

126− (# Good, pos, row, col #)

127−

128− else

129− case P.unsafeIndex pos of

130− 0x20 {- -} ->

131− eatSpaces (plusPtr pos 1) end row (col + 1)

132−

133− 0x0A {- \n -} ->

134− eatSpaces (plusPtr pos 1) end (row + 1) 1

135−

136− 0x7B {- { -} ->

137− eatMultiComment pos end row col

138−

139− 0x2D {- - -} ->

140− let !pos1 = plusPtr pos 1 in

141− if pos1 < end && P.unsafeIndex pos1 == 0x2D {- - -} then

142− eatLineComment (plusPtr pos 2) end row (col + 2)

143− else

144− (# Good, pos, row, col #)

145−

146− 0x0D {- \r -} ->

147− eatSpaces (plusPtr pos 1) end row col

148−

149− 0x09 {- \t -} ->

150− (# HasTab, pos, row, col #)

151−

152− _ ->

153− (# Good, pos, row, col #)

154−

155−

156−

157−-- LINE COMMENTS

158−

159−

160−eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)

161−eatLineComment pos end row col =

162− if pos >= end then

163− (# Good, pos, row, col #)

164−

165− else

166− let !word = P.unsafeIndex pos in

167− if word == 0x0A {- \n -} then

168− eatSpaces (plusPtr pos 1) end (row + 1) 1

169− else

170− let !newPos = plusPtr pos (P.getCharWidth word) in

171− eatLineComment newPos end row (col + 1)

172−

173−

174−

175−-- MULTI COMMENTS

176−

177−

178−eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)

179−eatMultiComment pos end row col =

180− let

181− !pos1 = plusPtr pos 1

182− !pos2 = plusPtr pos 2

183− in

184− if pos2 >= end then

185− (# Good, pos, row, col #)

186−

187− else if P.unsafeIndex pos1 == 0x2D {- - -} then

188−

189− if P.unsafeIndex pos2 == 0x7C {- | -} then

190− (# Good, pos, row, col #)

191− else

192− let

193− (# status, newPos, newRow, newCol #) =

194− eatMultiCommentHelp pos2 end row (col + 2) 1

195− in

196− case status of

197− MultiGood -> eatSpaces newPos end newRow newCol

198− MultiTab -> (# HasTab, newPos, newRow, newCol #)

199− MultiEndless -> (# EndlessMultiComment, pos, row, col #)

200−

201− else

202− (# Good, pos, row, col #)

203−

204−

205−data MultiStatus

206− = MultiGood

207− | MultiTab

208− | MultiEndless

209−

210−

211−eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)

212−eatMultiCommentHelp pos end row col openComments =

213− if pos >= end then

214− (# MultiEndless, pos, row, col #)

215−

216− else

217− let !word = P.unsafeIndex pos in

218− if word == 0x0A {- \n -} then

219− eatMultiCommentHelp (plusPtr pos 1) end (row + 1) 1 openComments

220−

221− else if word == 0x09 {- \t -} then

222− (# MultiTab, pos, row, col #)

223−

224− else if word == 0x2D {- - -} && P.isWord (plusPtr pos 1) end 0x7D {- } -} then

225− if openComments == 1 then

226− (# MultiGood, plusPtr pos 2, row, col + 2 #)

227− else

228− eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments - 1)

229−

230− else if word == 0x7B {- { -} && P.isWord (plusPtr pos 1) end 0x2D {- - -} then

231− eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)

232−

233− else

234− let !newPos = plusPtr pos (P.getCharWidth word) in

235− eatMultiCommentHelp newPos end row (col + 1) openComments

236−

237−

238−

239−-- DOCUMENTATION COMMENT

240−

241−

242−docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment

243−docComment toExpectation toSpaceError =

244− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

245− let

246− !pos3 = plusPtr pos 3

247− in

248− if pos3 <= end

249− && P.unsafeIndex ( pos ) == 0x7B {- { -}

250− && P.unsafeIndex (plusPtr pos 1) == 0x2D {- - -}

251− && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}

252− then

253− let

254− !col3 = col + 3

255−

256− (# status, newPos, newRow, newCol #) =

257− eatMultiCommentHelp pos3 end row col3 1

258− in

259− case status of

260− MultiGood ->

261− let

262− !off = minusPtr pos3 (unsafeForeignPtrToPtr src)

263− !len = minusPtr newPos pos3 - 2

264− !snippet = P.Snippet src off len row col3

265− !comment = Src.Comment snippet

266− !newState = P.State src newPos end indent newRow newCol

267− in

268− cok comment newState

269−

270− MultiTab -> cerr newRow newCol (toSpaceError E.HasTab)

271− MultiEndless -> cerr row col (toSpaceError E.EndlessMultiComment)

272− else

273− eerr row col toExpectation

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

@@ -1,9 +1,8 @@

1{-# OPTIONS_GHC -Wall #-}

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

2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}

3module Parse.Symbol

4− ( operator

4+ ( wildcard

5− , BadOperator(..)

5+ , binop

6− , binopCharSet

7 )

6 )

8 where

7 where

9

8

@@ -15,40 +14,56 @@ import qualified Data.Vector as Vector

15import Foreign.Ptr (Ptr, plusPtr, minusPtr)

14import Foreign.Ptr (Ptr, plusPtr, minusPtr)

16import GHC.Word (Word8)

15import GHC.Word (Word8)

17

16

18−import Parse.Primitives (Parser, Row, Col)

17+import Parse.Utils

18+import qualified Parse.Variable as Var

19import qualified Parse.Primitives as P

20+import qualified Reporting.Error.Syntax as E

20

21

22

23

23−-- OPERATOR

24+-- UNDERSCORE

24

25

26

26−data BadOperator

27+wildcard :: Parser ()

27− = BadDot

28+wildcard =

28− | BadPipe

29+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

29− | BadArrow

30+ if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then

30− | BadEquals

31+ eerr row col ctx E.Wildcard

31− | BadHasType

32+ else

33+ let

34+ !newPos = plusPtr pos 1

35+ !newCol = col + 1

36+ in

37+ if Var.getInnerWidth newPos end > 0 then

38+ let (# _, badCol #) = Var.chompInnerChars newPos end newCol in

39+ cerr row col ctx (E.WildcardNotVar newCol badCol)

40+ else

41+ let !newState = P.State newPos end indent row newCol ctx in

42+ cok () newState

43+

44+

45+

46+-- BINOP

32

47

33

48

34−operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name

49+binop :: Parser Name.Name

35−operator toExpectation toError =

50+binop =

36− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

51+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

37 let !newPos = chompOps pos end in

52 let !newPos = chompOps pos end in

38 if pos == newPos then

53 if pos == newPos then

39− eerr row col toExpectation

54+ eerr row col ctx E.XXX

40

55

41 else

56 else

42 case Name.fromPtr pos newPos of

57 case Name.fromPtr pos newPos of

43− "." -> eerr row col (toError BadDot)

58+ "." -> cerr row col ctx (E.ReservedOperator E.Dot)

44− "|" -> cerr row col (toError BadPipe)

59+ "|" -> cerr row col ctx (E.ReservedOperator E.Pipe)

45− "->" -> cerr row col (toError BadArrow)

60+ "->" -> cerr row col ctx (E.ReservedOperator E.Arrow)

46− "=" -> cerr row col (toError BadEquals)

61+ "=" -> cerr row col ctx (E.ReservedOperator E.Equals)

47− ":" -> cerr row col (toError BadHasType)

62+ ":" -> cerr row col ctx (E.ReservedOperator E.HasType)

48 op ->

63 op ->

49 let

64 let

50 !newCol = col + fromIntegral (minusPtr newPos pos)

65 !newCol = col + fromIntegral (minusPtr newPos pos)

51− !newState = P.State src newPos end indent row newCol

66+ !newState = P.State newPos end indent row newCol ctx

52 in

67 in

53 cok op newState

68 cok op newState

54

69

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Annotation.hs+1−1

This diff is too big to show here.

compiler/src/Reporting/Doc.hs+47−79

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Error/Canonicalize.hs+73−74

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hs+3−3

This diff is too big to show here.

compiler/src/Reporting/Error/Pattern.hs+8−9

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+26−6

This diff is too big to show here.

compiler/src/Reporting/Report.hs+63

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

docs/upgrade-instructions/0.19.1.mddeleted−60

This diff is too big to show here.

elm.cabal+16−34

This diff is too big to show here.

hints/bad-recursion.mddeleted−133

This diff is too big to show here.

hints/comparing-custom-types.mddeleted−98

This diff is too big to show here.

hints/comparing-records.mddeleted−85

This diff is too big to show here.

hints/implicit-casts.mddeleted−50

This diff is too big to show here.

hints/import-cycles.mddeleted−184

This diff is too big to show here.

hints/imports.mddeleted−126

This diff is too big to show here.

hints/infinite-type.mddeleted−42

This diff is too big to show here.

hints/init.mddeleted−55

This diff is too big to show here.

hints/missing-patterns.mddeleted−139

This diff is too big to show here.

hints/optimize.mddeleted−59

This diff is too big to show here.

hints/port-modules.mddeleted−32

This diff is too big to show here.

hints/recursive-alias.mddeleted−162

This diff is too big to show here.

hints/repl.mddeleted−73

This diff is too big to show here.

hints/shadowing.mddeleted−70

This diff is too big to show here.

hints/tuples.mddeleted−19

This diff is too big to show here.

hints/type-annotations.mddeleted−60

This diff is too big to show here.

installers/README.mddeleted−32

This diff is too big to show here.

installers/linux/Dockerfiledeleted−39

This diff is too big to show here.

installers/linux/README.mddeleted−93

This diff is too big to show here.

installers/mac/Distribution.xml+3−5

This diff is too big to show here.

installers/mac/README.mddeleted−93

This diff is too big to show here.

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

Binary file not shown.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/PUBLISHING.md+141−29

This diff is too big to show here.

installers/npm/README.md+23−30

This diff is too big to show here.

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

This diff is too big to show here.

installers/npm/download.jsdeleted−114

This diff is too big to show here.

installers/npm/index.jsnew file+21

This diff is too big to show here.

installers/npm/install.jsdeleted−4

This diff is too big to show here.

installers/npm/package.json+15−13

This diff is too big to show here.

installers/npm/troubleshooting.mddeleted−76

This diff is too big to show here.

installers/win/Nsisfile.nsi+16−16

This diff is too big to show here.

installers/win/README.md+3−18

This diff is too big to show here.

installers/win/file.iconew file

Binary file not shown.

installers/win/inst.dat+2−1

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+2−1

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifnew file

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+15−20

This diff is too big to show here.

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

This diff is too big to show here.

roadmap.mddeleted−29

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsdeleted−148

This diff is too big to show here.

terminal/src/Bump.hs+8−158

This diff is too big to show here.

terminal/src/Develop.hs+77−70

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

terminal/src/Diff.hs+6−348

This diff is too big to show here.

terminal/src/Init.hs+16−17

This diff is too big to show here.

terminal/src/Install.hs+14−401

This diff is too big to show here.

terminal/src/Main.hs+36−32

This diff is too big to show here.

terminal/src/Make.hs+32−257

This diff is too big to show here.

terminal/src/Publish.hs+8−529

This diff is too big to show here.

terminal/src/Repl.hs+197−522

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

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

The content is the same.

worker/elm.cabaldeleted−210

This diff is too big to show here.

worker/elm.jsondeleted−26

This diff is too big to show here.

worker/nginx.confdeleted−22

This diff is too big to show here.

worker/outlines/compile/elm.jsondeleted−32

This diff is too big to show here.

worker/outlines/repl/elm.jsondeleted−19

This diff is too big to show here.

worker/src/Artifacts.hsdeleted−155

This diff is too big to show here.

worker/src/Cors.hsdeleted−48

This diff is too big to show here.

worker/src/Endpoint/Compile.hsdeleted−323

This diff is too big to show here.

worker/src/Endpoint/Quotes.hsdeleted−114

This diff is too big to show here.

worker/src/Endpoint/Repl.hsdeleted−244

This diff is too big to show here.

worker/src/Errors.elmdeleted−217

This diff is too big to show here.

worker/src/Main.hsdeleted−73

This diff is too big to show here.