master..c911618 · elk · git.iko.soy

.github/CONTRIBUTING.md+20−18

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

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

55possible.

66

7+## Licensing

78

8−## Expectations

9−

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

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

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

13−

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

15−

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

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

1611

1712## Style Guide

1813

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

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

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

2419

25−

2620## Branches

2721

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

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

30−should target this branch!

31−

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

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

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

24+ should target this branch!

3325

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.

3429

35−## Licensing

36−

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

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

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

3832

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.

4037

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.

4142

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

55cabal.sandbox.config

66.DS_Store

77*~

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

22

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

44

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

67

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.

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

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

810

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.

1015

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

22

3−A delightful language for reliable webapps.

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

44

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

6−

7−

8−<br>

95

106## Install

117

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

8+Follow [these instructions][installer]!

139

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

1511

16−<br>

1712

1813## Help

1914

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

2116

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

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

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

2+{-# LANGUAGE BangPatterns #-}

33module Build

44 ( fromExposed

5− , fromPaths

6− , fromRepl

5+ , fromMains

76 , Artifacts(..)

8− , Root(..)

7+ , Main(..)

98 , Module(..)

109 , CachedInterface(..)

11− , ReplArtifacts(..)

12− , DocsGoal(..)

13− , getRootNames

1410 )

1511 where

1612

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

1814import Control.Concurrent (forkIO)

1915import Control.Concurrent.MVar

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

21−import qualified Data.ByteString as B

2217import qualified Data.Char as Char

18+import qualified Data.Either as Either

2319import qualified Data.Graph as Graph

2420import qualified Data.List as List

2521import qualified Data.Map.Utils as Map

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

2925import qualified Data.Name as Name

3026import qualified Data.NonEmptyList as NE

3127import qualified Data.OneOrMore as OneOrMore

32−import qualified Data.Set as Set

3328import qualified System.Directory as Dir

3429import qualified System.FilePath as FP

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

3631

37−import qualified AST.Canonical as Can

3832import qualified AST.Source as Src

3933import qualified AST.Optimized as Opt

4034import qualified Compile

4135import qualified Elm.Details as Details

42−import qualified Elm.Docs as Docs

4336import qualified Elm.Interface as I

4437import qualified Elm.ModuleName as ModuleName

4538import qualified Elm.Outline as Outline

4639import qualified Elm.Package as Pkg

4740import qualified File

48−import qualified Json.Encode as E

4941import qualified Parse.Module as Parse

5042import qualified Reporting

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

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

5847import qualified Stuff

5948

6049

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

6655 Env

6756 { _key :: Reporting.BKey

6857 , _root :: FilePath

69− , _project :: Parse.ProjectType

70− , _srcDirs :: [AbsoluteSrcDir]

71− , _buildID :: Details.BuildID

58+ , _pkg :: Pkg.Name

59+ , _srcDirs :: [FilePath]

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

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

7462 }

7563

7664

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

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

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

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

7967 case validOutline of

80− Details.ValidApp givenSrcDirs ->

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

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

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

69+ Env key root Pkg.dummyName srcDirs locals foreigns

8370

84− Details.ValidPkg pkg _ _ ->

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

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

87−

88−

89−

90−-- SOURCE DIRECTORY

91−

92−

93−newtype AbsoluteSrcDir =

94− AbsoluteSrcDir FilePath

95−

96−

97−toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir

98−toAbsoluteSrcDir root srcDir =

99− AbsoluteSrcDir <$> Dir.canonicalizePath

100− (

101− case srcDir of

102− Outline.AbsoluteSrcDir dir -> dir

103− Outline.RelativeSrcDir dir -> root </> dir

104− )

105−

106−

107−addRelative :: AbsoluteSrcDir -> FilePath -> FilePath

108−addRelative (AbsoluteSrcDir srcDir) path =

109− srcDir </> path

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

72+ Env key root pkg ["src"] locals foreigns

11073

11174

11275

11376-- FORK

11477

11578

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

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

12180fork work =

12281 do mvar <- newEmptyMVar

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

13493-- FROM EXPOSED

13594

13695

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

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

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

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

13998 Reporting.trackBuild style $ \key ->

140− do env <- makeEnv key root details

99+ do let env = makeEnv key root details

141100 dmvar <- Details.loadInterfaces root details

142101

143102 -- crawl

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

147105 putMVar mvar roots

148106 mapM_ readMVar roots

149107 statuses <- traverse readMVar =<< readMVar mvar

150108

151109 -- compile

152− midpoint <- checkMidpoint dmvar statuses

110+ midpoint <- checkExposedMidpoint dmvar statuses

153111 case midpoint of

154112 Left problem ->

155113 return (Left (Exit.BuildProjectProblem problem))

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

160118 putMVar rmvar resultMVars

161119 results <- traverse readMVar resultMVars

162120 writeDetails root details results

163− finalizeExposed root docsGoal exposed results

121+ return (detectProblems results)

164122

165123

166124

167−-- FROM PATHS

125+-- FROM MAINS

168126

169127

170128data Artifacts =

171129 Artifacts

172130 { _name :: Pkg.Name

173131 , _deps :: Dependencies

174− , _roots :: NE.List Root

132+ , _mains :: NE.List Main

175133 , _modules :: [Module]

176134 }

177135

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

185143 Map.Map ModuleName.Canonical I.DependencyInterface

186144

187145

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

189−fromPaths style root details paths =

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

147+fromMains style root details paths =

190148 Reporting.trackBuild style $ \key ->

191− do env <- makeEnv key root details

149+ do let env = makeEnv key root details

192150

193− elroots <- findRoots env paths

194− case elroots of

151+ elmains <- findMains env paths

152+ case elmains of

195153 Left problem ->

196154 return (Left (Exit.BuildProjectProblem problem))

197155

198− Right lroots ->

156+ Right lmains ->

199157 do -- crawl

200158 dmvar <- Details.loadInterfaces root details

201159 smvar <- newMVar Map.empty

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

203− sroots <- traverse readMVar srootMVars

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

161+ smains <- traverse readMVar smainMVars

204162 statuses <- traverse readMVar =<< readMVar smvar

205163

206− midpoint <- checkMidpointAndRoots dmvar statuses sroots

164+ midpoint <- checkMainsMidpoint dmvar statuses smains

207165 case midpoint of

208166 Left problem ->

209167 return (Left (Exit.BuildProjectProblem problem))

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

213171 rmvar <- newEmptyMVar

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

215173 putMVar rmvar resultsMVars

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

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

217175 results <- traverse readMVar resultsMVars

218176 writeDetails root details results

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

220−

221−

222−

223−-- GET ROOT NAMES

224−

225−

226−getRootNames :: Artifacts -> NE.List ModuleName.Raw

227−getRootNames (Artifacts _ _ roots _) =

228− fmap getRootName roots

229−

230−

231−getRootName :: Root -> ModuleName.Raw

232−getRootName root =

233− case root of

234− Inside name -> name

235− Outside name _ _ -> name

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

236178

237179

238180

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

245187

246188data Status

247189 = SCached Details.Local

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

249− | SBadImport Import.Problem

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

190+ | SChanged Details.Local Src.Module

191+ | SNotFound Problem.Find

192+ | SNotValid Problem.Syntax

251193 | SForeign Pkg.Name

252194 | SKernel

253195

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

262204 mapM_ readMVar statuses

263205 return blockedValue

264206 where

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

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

266208

267209

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

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

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

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

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

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

271214

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

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

273216

274217 case paths of

275218 [path] ->

276219 case Map.lookup name foreigns of

277220 Just (Details.Foreign dep deps) ->

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

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

279222

280223 Nothing ->

281− do newTime <- File.getTime path

282− case Map.lookup name locals of

283− Nothing ->

284− crawlFile env mvar docsNeed name path newTime buildID

224+ case Map.lookup name locals of

225+ Nothing ->

226+ crawlFile env mvar name path

285227

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

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

288− then crawlFile env mvar docsNeed name path newTime lastChange

289− else crawlDeps env mvar deps (SCached local)

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

229+ if path /= oldPath

230+ then crawlFile env mvar name path

231+ else

232+ do newTime <- File.getTime path

233+ if oldTime < newTime

234+ then crawlFile env mvar name path

235+ else crawlDeps env mvar deps (SCached local)

290236

291237 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

293239

294240 [] ->

295241 case Map.lookup name foreigns of

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

299245 return $ SForeign dep

300246

301247 d:ds ->

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

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

303249

304250 Nothing ->

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

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

306252 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

308254 else

309− return $ SBadImport Import.NotFound

255+ return $ SNotFound Problem.NotFound

310256

311257

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

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

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

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

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

260+ do time <- File.getTime path

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

315262

316− case Parse.fromByteString projectType source of

317− Left err ->

318− return $ SBadSyntax path time source err

319−

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

263+ case Parse.fromByteString pkg bytes of

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

321265 case maybeActualName of

322− Nothing ->

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

324−

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

266+ Just actualName ->

326267 if expectedName == actualName then

327268 let

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

330271 in

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

272+ crawlDeps env mvar deps (SChanged local modul)

332273 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

334281

335282

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

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

338− name == Name._main

285+ name == Name.main

339286

340287

341288

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

347294

348295

349296data Result

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

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

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

353− | RNotFound Import.Problem

354− | RProblem Error.Module

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

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

299+ | RCached Bool (MVar CachedInterface)

300+ | RProblem Problem.Problem

355301 | RBlocked

356302 | RForeign I.Interface

357303 | RKernel

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

364310

365311

366312checkModule :: 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 =

368314 case status of

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

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

370316 do results <- readMVar resultsMVar

371− depsStatus <- checkDeps root results deps lastCompile

317+ depsStatus <- checkDeps root results deps

372318 case depsStatus of

373319 DepsChange ifaces ->

374− do source <- File.readUtf8 path

375− case Parse.fromByteString projectType source of

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

377− Left err ->

378− return $ RProblem $

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

320+ do bytes <- File.readUtf8 path

321+ case Parse.fromByteString pkg bytes of

322+ Right modul -> compile env local ifaces modul

323+ Left syntaxError ->

324+ return $ RProblem $ Problem.BadSyntax $

325+ Problem.SyntaxProblem path time syntaxError

380326

381327 DepsSame _ _ ->

382328 do mvar <- newMVar Unneeded

383− return (RCached hasMain lastChange mvar)

329+ return (RCached hasMain mvar)

384330

385331 DepsBlock ->

386332 return RBlocked

387333

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

399335 do results <- readMVar resultsMVar

400− depsStatus <- checkDeps root results deps lastCompile

336+ depsStatus <- checkDeps root results deps

401337 case depsStatus of

402338 DepsChange ifaces ->

403− compile env docsNeed local source ifaces modul

339+ compile env local ifaces modul

404340

405341 DepsSame same cached ->

406− do maybeLoaded <- loadInterfaces root same cached

342+ do maybeLoaded <- checkCachedInterfaces root cached

407343 case maybeLoaded of

408− Nothing -> return RBlocked

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

344+ Nothing ->

345+ return RBlocked

346+

347+ Just loaded ->

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

349+ compile env local ifaces modul

410350

411351 DepsBlock ->

412352 return RBlocked

413353

414− DepsNotFound problems ->

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

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

417−

418− SBadImport importProblem ->

419− return (RNotFound importProblem)

354+ SNotFound findProblem ->

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

420356

421− SBadSyntax path time source err ->

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

423− Error.BadSyntax err

357+ SNotValid syntaxProblem ->

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

424359

425360 SForeign home ->

426361 case foreigns ! ModuleName.Canonical home name of

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

429364

430365 SKernel ->

431366 return RKernel

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

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

440375 | DepsSame [Dep] [CDep]

441376 | DepsBlock

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

443377

444378

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

446−checkDeps root results deps lastCompile =

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

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

380+checkDeps root results deps =

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

448382

449383

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

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

452386

453387

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

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

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

389+checkDepsHelp root results deps new same cached =

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

457404 dep:otherDeps ->

458405 do result <- readMVar (results ! dep)

459406 case result of

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

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

407+ RNew _ iface _ ->

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

462409

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

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

410+ RSame _ iface _ ->

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

465412

466− RCached _ lastChange mvar ->

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

468−

469− RNotFound prob ->

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

413+ RCached _ mvar ->

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

471415

472416 RProblem _ ->

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

417+ return DepsBlock

474418

475419 RBlocked ->

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

420+ return DepsBlock

477421

478422 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

480424

481425 RKernel ->

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

483−

484−

485− [] ->

486− case reverse importProblems of

487− p:ps ->

488− return $ DepsNotFound (NE.List p ps)

489−

490− [] ->

491− if isBlocked then

492− return $ DepsBlock

493−

494− else if null new && lastDepChange <= lastCompile then

495− return $ DepsSame same cached

496−

497− else

498− do maybeLoaded <- loadInterfaces root same cached

499− case maybeLoaded of

500− Nothing -> return DepsBlock

501− Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces

502−

503−

504−

505−-- TO IMPORT ERROR

506−

507−

508−toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error

509−toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =

510− let

511− knownModules =

512− Set.unions

513− [ Map.keysSet foreigns

514− , Map.keysSet locals

515− , Map.keysSet results

516− ]

517−

518− unimportedModules =

519− Set.difference knownModules (Set.fromList (map Src.getImportName imports))

520−

521− regionDict =

522− Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)

523−

524− toError (name, problem) =

525− Import.Error (regionDict ! name) name unimportedModules problem

526− in

527− fmap toError problems

426+ checkDepsHelp root results otherDeps new same cached

528427

529428

530429

531−-- LOAD CACHED INTERFACES

430+-- CACHED INTERFACE

532431

533432

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

535−loadInterfaces root same cached =

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

537− maybeLoaded <- traverse readMVar loading

538− case sequence maybeLoaded of

539− Nothing ->

540− return Nothing

541−

542− Just loaded ->

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

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

434+checkCachedInterfaces root deps =

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

436+ loaded <- traverse readMVar loading

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

544438

545439

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

547−loadInterface root (name, ciMvar) =

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

441+checkCache root (name, ciMvar) =

548442 do cachedInterface <- takeMVar ciMvar

549443 case cachedInterface of

550444 Corrupted ->

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

571465-- CHECK PROJECT

572466

573467

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

575−checkMidpoint dmvar statuses =

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

469+checkExposedMidpoint dmvar statuses =

576470 case checkForCycles statuses of

577471 Nothing ->

578472 do maybeForeigns <- readMVar dmvar

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

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

586480

587481

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

589−checkMidpointAndRoots dmvar statuses sroots =

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

483+checkMainsMidpoint dmvar statuses smains =

590484 case checkForCycles statuses of

591485 Nothing ->

592− case checkUniqueRoots statuses sroots of

486+ case checkUniqueMains statuses smains of

593487 Nothing ->

594488 do maybeForeigns <- readMVar dmvar

595489 case maybeForeigns of

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

640534 let

641535 dependencies =

642536 case status of

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

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

645− SBadImport _ -> []

646− SBadSyntax _ _ _ _ -> []

647− SForeign _ -> []

648− SKernel -> []

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

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

539+ SNotFound _ -> []

540+ SNotValid _ -> []

541+ SForeign _ -> []

542+ SKernel -> []

649543 in

650544 (name, name, dependencies) : graph

651545

652546

653547

654−-- CHECK UNIQUE ROOTS

548+-- CHECK UNIQUE MAINS

655549

656550

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

658−checkUniqueRoots insides sroots =

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

552+checkUniqueMains insides smains =

659553 let

660554 outsidesDict =

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

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

662556 in

663557 case Map.traverseWithKey checkOutside outsidesDict of

664558 Left problem ->

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

670564 Left problem -> Just problem

671565

672566

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

674−rootStatusToNamePathPair sroot =

675− case sroot of

676− SInside _ -> Nothing

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

678− SOutsideErr _ -> Nothing

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

568+mainStatusToNamePathPair smain =

569+ case smain of

570+ SInside _ -> Nothing

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

572+ SOutsideErr _ -> Nothing

679573

680574

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

682576checkOutside name paths =

683577 case OneOrMore.destruct NE.List paths of

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

686580

687581

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

689583checkInside name p1 status =

690584 case status of

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

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

693− SBadImport _ -> Right ()

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

695− SForeign _ -> Right ()

696− SKernel -> Right ()

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

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

587+ SNotFound _ -> Right ()

588+ SNotValid _ -> Right ()

589+ SForeign _ -> Right ()

590+ SKernel -> Right ()

697591

698592

699593

700594-- COMPILE MODULE

701595

702596

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

704−compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =

705− let

706− pkg = projectTypeToPkg projectType

707− in

597+compile :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result

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

708599 case Compile.compile pkg ifaces modul of

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

710− case makeDocs docsNeed canonical of

711− Left err ->

712− return $ RProblem $

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

714−

715− Right docs ->

716− do let name = Src.getName modul

717− let iface = I.fromModule pkg canonical annotations

718− let elmi = Stuff.elmi root name

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

720− maybeOldi <- File.readBinary elmi

721− case maybeOldi of

722− Just oldi | oldi == iface ->

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

724− Reporting.report key Reporting.BDone

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

726− return (RSame local iface objects docs)

727−

728− _ ->

729− do -- iface may be lazy still

730− File.writeBinary elmi iface

731− Reporting.report key Reporting.BDone

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

733− return (RNew local iface objects docs)

734−

735− Left err ->

736− return $ RProblem $

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

738−

739−

740−projectTypeToPkg :: Parse.ProjectType -> Pkg.Name

741−projectTypeToPkg projectType =

742− case projectType of

743− Parse.Package pkg -> pkg

744− Parse.Application -> Pkg.dummyName

601+ do let name = Src.getName modul

602+ let iface = I.fromModule pkg canonical annotations

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

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

605+ case maybeOldi of

606+ Just oldi | oldi == iface ->

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

608+ Reporting.report key Reporting.BDone

609+ return (RSame local iface objects)

610+

611+ _ ->

612+ do -- iface may be lazy still

613+ -- TODO try adding forkIO here

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

615+ Reporting.report key Reporting.BDone

616+ return (RNew local iface objects)

617+

618+ Left errors ->

619+ do Reporting.report key Reporting.BDone

620+ return $ RProblem $ Problem.BadContent $

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

745622

746623

747624

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

749626

750627

751628writeDetails :: 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 =

753630 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

755632

756633

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

758635addNewLocal name result locals =

759636 case result of

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

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

762− RCached _ _ _ -> locals

763− RNotFound _ -> locals

764− RProblem _ -> locals

765− RBlocked -> locals

766− RForeign _ -> locals

767− RKernel -> locals

768−

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

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

639+ RCached _ _ -> locals

640+ RProblem _ -> locals

641+ RBlocked -> locals

642+ RForeign _ -> locals

643+ RKernel -> locals

769644

770645

771−-- FINALIZE EXPOSED

772646

647+-- DETECT PROBLEMS

773648

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

779649

780− [] ->

781− case Map.foldr addErrors [] results of

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

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

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

651+detectProblems results =

652+ case Map.foldr addProblem [] results of

653+ [] -> Right ()

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

784655

785656

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

787−addErrors result errors =

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

658+addProblem result problems =

788659 case result of

789− RNew _ _ _ _ -> errors

790− RSame _ _ _ _ -> errors

791− RCached _ _ _ -> errors

792− RNotFound _ -> errors

793− RProblem e -> e:errors

794− RBlocked -> errors

795− RForeign _ -> errors

796− RKernel -> errors

797−

798−

799−addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]

800−addImportProblems results name problems =

801− case results ! name of

802− RNew _ _ _ _ -> problems

803− RSame _ _ _ _ -> problems

804− RCached _ _ _ -> problems

805− RNotFound p -> (name, p) : problems

806− RProblem _ -> problems

807− RBlocked -> problems

808− RForeign _ -> problems

809− RKernel -> problems

810−

811−

812−

813−-- DOCS

814−

815−

816−data DocsGoal a where

817− KeepDocs :: DocsGoal Docs.Documentation

818− WriteDocs :: FilePath -> DocsGoal ()

819− IgnoreDocs :: DocsGoal ()

820−

821−

822−newtype DocsNeed =

823− DocsNeed { needsDocs :: Bool }

824−

825−

826−toDocsNeed :: DocsGoal a -> DocsNeed

827−toDocsNeed goal =

828− case goal of

829− IgnoreDocs -> DocsNeed False

830− WriteDocs _ -> DocsNeed True

831− KeepDocs -> DocsNeed True

832−

833−

834−makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)

835−makeDocs (DocsNeed isNeeded) modul =

836− if isNeeded then

837− case Docs.fromModule modul of

838− Right docs -> Right (Just docs)

839− Left err -> Left err

840− else

841− Right Nothing

842−

843−

844−finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs

845−finalizeDocs goal results =

846− case goal of

847− KeepDocs ->

848− return $ Map.mapMaybe toDocs results

849−

850− WriteDocs path ->

851− E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results

852−

853− IgnoreDocs ->

854− return ()

855−

856−

857−toDocs :: Result -> Maybe Docs.Module

858−toDocs result =

859− case result of

860− RNew _ _ _ d -> d

861− RSame _ _ _ d -> d

862− RCached _ _ _ -> Nothing

863− RNotFound _ -> Nothing

864− RProblem _ -> Nothing

865− RBlocked -> Nothing

866− RForeign _ -> Nothing

867− RKernel -> Nothing

868−

869−

870−

871−--------------------------------------------------------------------------------

872−------ NOW FOR SOME REPL STUFF -------------------------------------------------

873−--------------------------------------------------------------------------------

874−

875−

876−-- FROM REPL

877−

878−

879−data ReplArtifacts =

880− ReplArtifacts

881− { _repl_home :: ModuleName.Canonical

882− , _repl_modules :: [Module]

883− , _repl_localizer :: L.Localizer

884− , _repl_annotations :: Map.Map Name.Name Can.Annotation

885− }

886−

887−

888−fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)

889−fromRepl root details source =

890− do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details

891− case Parse.fromByteString projectType source of

892− Left syntaxError ->

893− return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError

894−

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

896− do dmvar <- Details.loadInterfaces root details

897−

898− let deps = map Src.getImportName imports

899− mvar <- newMVar Map.empty

900− crawlDeps env mvar deps ()

901−

902− statuses <- traverse readMVar =<< readMVar mvar

903− midpoint <- checkMidpoint dmvar statuses

904−

905− case midpoint of

906− Left problem ->

907− return $ Left $ Exit.ReplProjectProblem problem

908−

909− Right foreigns ->

910− do rmvar <- newEmptyMVar

911− resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses

912− putMVar rmvar resultMVars

913− results <- traverse readMVar resultMVars

914− writeDetails root details results

915− depsStatus <- checkDeps root resultMVars deps 0

916− finalizeReplArtifacts env source modul depsStatus resultMVars results

917−

918−

919−finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)

920−finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =

921− let

922− pkg =

923− projectTypeToPkg projectType

924−

925− compileInput ifaces =

926− case Compile.compile pkg ifaces modul of

927− Right (Compile.Artifacts canonical annotations objects) ->

928− let

929− h = Can._name canonical

930− m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects

931− ms = Map.foldrWithKey addInside [] results

932− in

933− return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations

934−

935− Left errors ->

936− return $ Left $ Exit.ReplBadInput source errors

937− in

938− case depsStatus of

939− DepsChange ifaces ->

940− compileInput ifaces

941−

942− DepsSame same cached ->

943− do maybeLoaded <- loadInterfaces root same cached

944− case maybeLoaded of

945− Just ifaces -> compileInput ifaces

946− Nothing -> return $ Left $ Exit.ReplBadCache

947−

948− DepsBlock ->

949− case Map.foldr addErrors [] results of

950− [] -> return $ Left $ Exit.ReplBlocked

951− e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es

952−

953− DepsNotFound problems ->

954− return $ Left $ Exit.ReplBadInput source $ Error.BadImports $

955− toImportErrors env resultMVars imports problems

660+ RNew _ _ _ -> problems

661+ RSame _ _ _ -> problems

662+ RCached _ _ -> problems

663+ RProblem p -> p:problems

664+ RBlocked -> problems

665+ RForeign _ -> problems

666+ RKernel -> problems

956667

957668

958669

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

964675

965676

966677

967−-- FIND ROOT

678+-- FIND MAIN

968679

969680

970−data RootLocation

681+data MainLocation

971682 = LInside ModuleName.Raw

972683 | LOutside FilePath

973684

974685

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

976−findRoots env paths =

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

978− einfos <- traverse readMVar mvars

979− return $ checkRoots =<< sequence einfos

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

687+findMains env paths =

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

689+ elocs <- traverse readMVar mvars

690+ return $ checkLocations =<< sequence elocs

980691

981692

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

983−checkRoots infos =

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

694+checkLocations locations =

984695 let

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

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

986697 (absolute, OneOrMore.one loc)

987698

988699 fromOneOrMore loc locs =

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

990701 [] -> Right ()

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

992703 in

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

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

994705 traverse (OneOrMore.destruct fromOneOrMore) $

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

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

996707

997708

998709

999−-- ROOT INFO

710+-- LOCATIONS

1000711

1001712

1002−data RootInfo =

1003− RootInfo

713+data Location =

714+ Location

1004715 { _absolute :: FilePath

1005716 , _relative :: FilePath

1006− , _location :: RootLocation

717+ , _location :: MainLocation

1007718 }

1008719

1009720

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

1011−getRootInfo env path =

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

722+findLocation env path =

1012723 do exists <- File.exists path

1013724 if exists

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

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

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

1016727

1017728

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

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

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

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

1020731 let

1021732 (dirs, file) = FP.splitFileName absolutePath

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

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

1023734 in

1024735 if ext /= ".elm"

1025− then

1026− return $ Left $ Exit.BP_WithBadExtension path

736+ then Left (Exit.BP_WithBadExtension path)

1027737 else

1028738 let

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

739+ roots = FP.splitDirectories root

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

1030741 in

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

1032− [] ->

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

1034−

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

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

1037− matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs

1038− case matchingDirs of

1039− d1:d2:_ ->

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

1041− let p2 = addRelative d2 (FP.joinPath names <.> "elm")

1042− return $ Left $ Exit.BP_RootNameDuplicate name p1 p2

1043−

1044− _ ->

1045− return $ Right $ RootInfo absolutePath path (LInside name)

1046−

1047− [(s, Left names)] ->

1048− return $ Left $ Exit.BP_RootNameInvalid path s names

1049−

1050− (s1,_):(s2,_):_ ->

1051− return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2

1052−

1053−

1054−

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

1056−isInsideSrcDirByName names srcDir =

1057− File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))

1058−

1059−

1060−isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])

1061−isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =

742+ case dropPrefix roots segments of

743+ Nothing ->

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

745+

746+ Just relativeSegments ->

747+ let

748+ (exits, maybes) =

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

750+ in

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

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

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

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

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

756+

757+

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

759+isInsideSrcDirsHelp segments srcDir =

1062760 case dropPrefix (FP.splitDirectories srcDir) segments of

1063761 Nothing ->

1064− Nothing

762+ Right Nothing

1065763

1066764 Just names ->

1067765 if all isGoodName names

1068− then Just (srcDir, Right names)

1069− else Just (srcDir, Left names)

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

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

1070768

1071769

1072770isGoodName :: [Char] -> Bool

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

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

1080778

1081779

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

1083−--

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

1085781dropPrefix roots paths =

1086782 case roots of

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

1089785

1090786 r:rs ->

1091787 case paths of

1092− [] -> Nothing

788+ [] -> Nothing

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

1094790

1095791

1096792

1097−-- CRAWL ROOTS

793+-- CRAWL MAINS

1098794

1099795

1100−data RootStatus

796+data MainStatus

1101797 = SInside ModuleName.Raw

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

1103− | SOutsideErr Error.Module

798+ | SOutsideOk Details.Local Src.Module

799+ | SOutsideErr Problem.Syntax

1104800

1105801

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

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

1108− case root of

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

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

804+ case given of

1109805 LInside name ->

1110806 do statusMVar <- newEmptyMVar

1111807 statusDict <- takeMVar mvar

1112808 putMVar mvar (Map.insert name statusMVar statusDict)

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

809+ putMVar statusMVar =<< crawlModule env mvar name

1114810 return (SInside name)

1115811

1116812 LOutside path ->

1117813 do time <- File.getTime path

1118− source <- File.readUtf8 path

1119− case Parse.fromByteString projectType source of

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

814+ bytes <- File.readUtf8 path

815+ case Parse.fromByteString pkg bytes of

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

1121817 do let deps = map Src.getImportName imports

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

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

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

819+ crawlDeps env mvar deps (SOutsideOk local modul)

1124820

1125821 Left syntaxError ->

1126− return $ SOutsideErr $

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

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

1128823

1129824

1130825

1131−-- CHECK ROOTS

826+-- CHECK MAINS

1132827

1133828

1134−data RootResult

829+data MainResult

1135830 = RInside ModuleName.Raw

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

1137− | ROutsideErr Error.Module

832+ | ROutsideErr Problem.Problem

1138833 | ROutsideBlocked

1139834

1140835

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

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

1143− case rootStatus of

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

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

838+ case pendingMain of

1144839 SInside name ->

1145840 return (RInside name)

1146841

1147− SOutsideErr err ->

1148− return (ROutsideErr err)

842+ SOutsideErr syntaxProblem ->

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

1149844

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

1151− do depsStatus <- checkDeps root results deps lastCompile

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

846+ do depsStatus <- checkDeps root results deps

1152847 case depsStatus of

1153848 DepsChange ifaces ->

1154− compileOutside env local source ifaces modul

849+ return $ compileOutside env local ifaces modul

1155850

1156851 DepsSame same cached ->

1157− do maybeLoaded <- loadInterfaces root same cached

852+ do maybeLoaded <- checkCachedInterfaces root cached

1158853 case maybeLoaded of

1159− Nothing -> return ROutsideBlocked

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

854+ Nothing ->

855+ return ROutsideBlocked

856+

857+ Just loaded ->

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

859+ return $ compileOutside env local ifaces modul

1161860

1162861 DepsBlock ->

1163862 return ROutsideBlocked

1164863

1165− DepsNotFound problems ->

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

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

1168−

1169864

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

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

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

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

1172867 let

1173− pkg = projectTypeToPkg projectType

1174868 name = Src.getName modul

1175869 in

1176870 case Compile.compile pkg ifaces modul of

1177871 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

1180873

1181874 Left errors ->

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

875+ ROutsideErr $ Problem.BadContent $

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

1183877

1184878

1185879

1186880-- TO ARTIFACTS

1187881

1188882

1189−data Root

883+data Main

1190884 = Inside ModuleName.Raw

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

1192886

1193887

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

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

1196− case gatherProblemsOrMains results rootResults of

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

1198− Left (Exit.BuildBadModules root e es)

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

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

890+ case gatherProblemsOrMains results mainResults of

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

892+ Left (Exit.BuildModuleProblems p ps)

1199893

1200− Right roots ->

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

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

894+ Right mains ->

895+ Right $ Artifacts pkg foreigns mains $

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

1203897

1204898

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

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

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

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

1207901 let

1208− addResult result (es, roots) =

902+ sortMain result (ps, mains) =

1209903 case result of

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

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

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

1213− ROutsideBlocked -> ( es, roots)

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

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

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

907+ ROutsideBlocked -> ( ps, mains)

1214908

1215− errors = Map.foldr addErrors [] results

909+ problems = Map.foldr addProblem [] results

1216910 in

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

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

1218912 (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)

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

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

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

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

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

1223917 (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)

1225919

1226920

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

1228922addInside name result modules =

1229923 case result of

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

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

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

1233− RNotFound _ -> error (badInside name)

1234− RProblem _ -> error (badInside name)

1235− RBlocked -> error (badInside name)

1236− RForeign _ -> modules

1237− RKernel -> modules

1238−

1239−

1240−badInside :: ModuleName.Raw -> [Char]

1241−badInside name =

1242− "Error from `" ++ Name.toChars name ++ "` should have been reported already."

1243−

1244−

1245−addOutside :: RootResult -> [Module] -> [Module]

1246−addOutside root modules =

1247− case root of

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

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

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

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

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

929+ RForeign _ -> modules

930+ RKernel -> modules

931+

932+

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

934+addOutside main modules =

935+ case main of

1248936 RInside _ -> modules

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

1250938 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

1818import qualified Data.Map as Map

1919import qualified Data.Name as Name

2020import qualified Data.Set as Set

21−import qualified System.Directory as Dir

21+import qualified Data.Utf8 as Utf8

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

2323

2424import qualified Deps.Website as Website

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

204204isSameName oldFullName newFullName =

205205 let

206206 dedot name =

207− reverse (Name.splitDots name)

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

208208 in

209209 case ( dedot oldFullName, dedot newFullName ) of

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

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

357357

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

359359getDocs cache manager name version =

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

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

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

362361 exists <- File.exists path

363362 if exists

364363 then

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

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

376375 case D.fromByteString Docs.decoder body of

377376 Right docs ->

378− do Dir.createDirectoryIfMissing True home

379− File.writeUtf8 path body

377+ do File.writeUtf8 path body

380378 return $ Right docs

381379

382380 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

1616import Prelude hiding (read)

1717import Control.Monad (liftM2)

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

19+import Data.Function (on)

1920import qualified Data.List as List

2021import qualified Data.Map.Strict as Map

22+import qualified Data.Name as Name

23+import qualified Data.Utf8 as Utf8

2124

2225import qualified Deps.Website as Website

2326import qualified Elm.Package as Pkg

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

2528import qualified File

2629import qualified Http

2730import qualified Json.Decode as D

28−import qualified Parse.Primitives as P

2931import qualified Reporting.Exit as Exit

32+import qualified Reporting.Suggest as Suggest

3033import qualified Stuff

3134

3235

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

5457

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

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

5865

5966

6067

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

7986

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

8188allPkgsDecoder =

82− let

83− keyDecoder =

84− Pkg.keyDecoder bail

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

90+ checkKeys pairs Map.empty

91+ where

92+ checkKeys pairs pkgs =

93+ case pairs of

94+ [] ->

95+ return pkgs

8596

86− versionsDecoder =

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

97+ (key, versions) : rest ->

98+ case Pkg.fromString key of

99+ Right pkg ->

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

101+ [] ->

102+ D.failure ()

88103

89− toKnownVersions versions =

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

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

92− [] -> D.failure ()

93− in

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

104+ v:vs ->

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

106+

107+ Left _ ->

108+ D.failure ()

95109

96110

97111

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

130144 Map.alter (Just . add) name versions

131145

132146

133−

134−-- NEW PACKAGE DECODER

135−

136−

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

138148newPkgDecoder =

139− D.customString newPkgParser bail

140−

149+ do str <- D.string

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

141157

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

143−newPkgParser =

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

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

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

147− return (pkg, vsn)

158+ Left _ ->

159+ D.failure ()

148160

149−

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

151−bail _ _ =

152− ()

161+ _ ->

162+ D.failure ()

153163

154164

155165

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

180190getVersions' name (Registry _ versions) =

181191 case Map.lookup name versions of

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

184220

185221

186222

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

189225

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

191227post 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 $

196229 \body ->

197230 case D.fromByteString decoder body of

198231 Right a -> Right <$> callback a

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

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

200233

201234

202235

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

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

9494

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

9696verify cache connection registry constraints =

97− Stuff.withRegistryLock cache $

9897 case try constraints of

9998 Solver solver ->

10099 solver (State cache connection registry Map.empty)

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

131130

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

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

134− Stuff.withRegistryLock cache $

135133 let

136134 allIndirects = Map.union indirect testIndirect

137135 allDirects = Map.union direct testDirect

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

313311 back state

314312

315313 Online manager ->

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

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

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

318315 case result of

319316 Left httpProblem ->

320− err (Exit.SolverBadHttp pkg vsn httpProblem)

317+ err (Exit.SolverBadHttp httpProblem)

321318

322319 Right body ->

323320 case D.fromByteString constraintsDecoder body of

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

327324 ok (toNewState cs) cs back

328325

329326 Left _ ->

330− err (Exit.SolverBadHttpData pkg vsn url)

327+ err (Exit.SolverBadHttpData pkg vsn)

331328

332329

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

331+--

333332constraintsDecoder :: D.Decoder () Constraints

334333constraintsDecoder =

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

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

351350

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

353352initEnv =

354− do mvar <- newEmptyMVar

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

356− cache <- Stuff.getPackageCache

357− Stuff.withRegistryLock cache $

358− do maybeRegistry <- Registry.read cache

359− manager <- readMVar mvar

360−

361− case maybeRegistry of

362− Nothing ->

363− do eitherRegistry <- Registry.fetch manager cache

364− case eitherRegistry of

365− Right latestRegistry ->

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

367−

368− Left problem ->

369− return $ Left $ problem

370−

371− Just cachedRegistry ->

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

373− case eitherRegistry of

374− Right latestRegistry ->

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

376−

377− Left _ ->

378− return $ Right $ Env cache manager Offline cachedRegistry

353+ do mvar <- newEmptyMVar

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

355+ cache <- Stuff.getPackageCache

356+ maybeRegistry <- Registry.read cache

357+ manager <- readMVar mvar

358+

359+ case maybeRegistry of

360+ Nothing ->

361+ do eitherRegistry <- Registry.fetch manager cache

362+ case eitherRegistry of

363+ Right latestRegistry ->

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

365+

366+ Left problem ->

367+ return $ Left $ problem

368+

369+ Just cachedRegistry ->

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

371+ case eitherRegistry of

372+ Right latestRegistry ->

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

374+

375+ Left _ ->

376+ return $ Right $ Env cache manager Offline cachedRegistry

379377

380378

381379

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

22{-# LANGUAGE BangPatterns, OverloadedStrings #-}

33module Elm.Details

44 ( Details(..)

5− , BuildID

65 , ValidOutline(..)

76 , Local(..)

87 , Foreign(..)

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

1615

1716import Control.Concurrent (forkIO)

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

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

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

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

21−import qualified Data.Either as Either

2220import qualified Data.Map as Map

2321import qualified Data.Map.Utils as Map

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

25−import qualified Data.Maybe as Maybe

2623import qualified Data.Name as Name

27−import qualified Data.NonEmptyList as NE

2824import qualified Data.OneOrMore as OneOrMore

2925import qualified Data.Set as Set

3026import qualified Data.Utf8 as Utf8

31−import Data.Word (Word64)

3227import qualified System.Directory as Dir

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

3429

35−import qualified AST.Canonical as Can

3630import qualified AST.Source as Src

3731import qualified AST.Optimized as Opt

38−import qualified BackgroundWriter as BW

3932import qualified Compile

4033import qualified Deps.Registry as Registry

4134import qualified Deps.Solver as Solver

4235import qualified Deps.Website as Website

4336import qualified Elm.Constraint as Con

44−import qualified Elm.Docs as Docs

4537import qualified Elm.Interface as I

4638import qualified Elm.Kernel as Kernel

4739import qualified Elm.ModuleName as ModuleName

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

5143import qualified File

5244import qualified Http

5345import qualified Json.Decode as D

54−import qualified Json.Encode as E

5546import qualified Parse.Module as Parse

5647import qualified Reporting

57−import qualified Reporting.Annotation as A

5848import qualified Reporting.Exit as Exit

5949import qualified Reporting.Task as Task

6050import qualified Stuff

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

6858 Details

6959 { _outlineTime :: File.Time

7060 , _outline :: ValidOutline

71− , _buildID :: BuildID

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

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

7463 , _extras :: Extras

7564 }

7665

7766

78−type BuildID = Word64

67+data ValidOutline

68+ = ValidApp Outline.AppOutline

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

7970

8071

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

9972data Local =

10073 Local

10174 { _path :: FilePath

10275 , _time :: File.Time

10376 , _deps :: [ModuleName.Raw]

10477 , _main :: Bool

105− , _lastChange :: BuildID

106− , _lastCompile :: BuildID

10778 }

10879

10980

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

12596

12697

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

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

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

129100 case extras of

130101 ArtifactsFresh _ o -> newMVar (Just o)

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

132103

133104

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

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

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

136107 case extras of

137108 ArtifactsFresh i _ -> newMVar (Just i)

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

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

142113-- VERIFY INSTALL -- used by Install

143114

144115

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

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

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

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

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

148119 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

150121 case outline of

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

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

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

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

157128

158129

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

160−load style scope root =

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

131+load style root =

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

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

163134 case maybeDetails of

164135 Nothing ->

165− generate style scope root newTime

136+ generate style root newTime

166137

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

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

168139 if oldTime == newTime

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

170− else generate style scope root newTime

140+ then return (Right details)

141+ else generate style root newTime

171142

172143

173144

174145-- GENERATE

175146

176147

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

178−generate style scope root time =

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

149+generate style root time =

179150 Reporting.trackDetails style $ \key ->

180− do result <- initEnv key scope root

151+ do result <- initEnv key root

181152 case result of

182153 Left exit ->

183154 return (Left exit)

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

195166data Env =

196167 Env

197168 { _key :: Reporting.DKey

198− , _scope :: BW.Scope

199169 , _root :: FilePath

200170 , _cache :: Stuff.PackageCache

201171 , _manager :: Http.Manager

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

204174 }

205175

206176

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

208−initEnv key scope root =

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

178+initEnv key root =

209179 do mvar <- fork Solver.initEnv

210180 eitherOutline <- Outline.read root

211181 case eitherOutline of

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

219189 return $ Left $ Exit.DetailsCannotGetRegistry problem

220190

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

223193

224194

225195

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

230200

231201

232202verifyPkg :: 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) =

234204 if Con.goodElm elm

235205 then

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

237− let exposedList = Outline.flattenExposed exposed

238− let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor

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

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

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

240209 else

241210 Task.throw $ Exit.DetailsBadElmInPkg elm

242211

243212

244213verifyApp :: 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 _ _ _) =

246215 if elmVersion == V.compiler

247216 then

248217 do stated <- checkAppDeps outline

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

250219 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

252221 else Task.throw $ Exit.DetailsHandEditedDependencies

253222 else

254223 Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion

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

266235

267236

268237verifyConstraints :: 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 =

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

271240 case result of

272241 Solver.Ok details -> return details

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

312281

313282

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

316285 Task.eio id $

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

318287 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

321289 putMVar mvar mvars

322290 deps <- traverse readMVar mvars

323291 case sequence deps of

324− Left _ ->

325− do home <- Stuff.getElmHome

326− return $ Left $ Exit.DetailsBadDeps home $

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

292+ Left problem ->

293+ error "TODO verifyDependencies" problem

328294

329295 Right artifacts ->

330296 let

331297 objs = Map.foldr addObjects Opt.empty artifacts

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

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

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

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

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

335301 in

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

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

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

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

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

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

339305 return (Right details)

340306

341307

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

375341

376342

377343type Dep =

378− Either (Maybe Exit.DetailsBadDep) Artifacts

344+ Either Problem Artifacts

345+

346+

347+data Problem

348+ = BadDownload Exit.PackageProblem

349+ | BadBuild

350+ | BadDependency

379351

380352

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

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

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

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

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

355+ let

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

357+ in

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

385359 if exists

386360 then

387361 do Reporting.report key Reporting.DCached

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

389363 case maybeCache of

390364 Nothing ->

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

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

392366

393367 Just (ArtifactCache fingerprints artifacts) ->

394368 if Set.member fingerprint fingerprints

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

397371 else

398372 do Reporting.report key Reporting.DRequested

399373 result <- downloadPackage cache manager pkg vsn

400374 case result of

401− Left problem ->

375+ Left p ->

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

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

377+ return (Left (BadDownload p))

404378

405379 Right () ->

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

408382

409383

410384

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

426400-- BUILD

427401

428402

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

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

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

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

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

432406 case eitherOutline of

433407 Left _ ->

434408 do Reporting.report key Reporting.DBroken

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

409+ return (Left BadBuild)

436410

437411 Right (Outline.App _) ->

438412 do Reporting.report key Reporting.DBroken

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

413+ return (Left BadBuild)

440414

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

442416 do allDeps <- readMVar depsMVar

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

444418 case sequence directDeps of

445419 Left _ ->

446420 do Reporting.report key Reporting.DBroken

447− return $ Left $ Nothing

421+ return (Left BadDependency)

448422

449423 Right directArtifacts ->

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

451425 let foreignDeps = gatherForeignInterfaces directArtifacts

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

453− docsStatus <- getDocsStatus cache pkg vsn

454427 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

456429 putMVar mvar mvars

457430 mapM_ readMVar mvars

458431 maybeStatuses <- traverse readMVar =<< readMVar mvar

459432 case sequence maybeStatuses of

460433 Nothing ->

461434 do Reporting.report key Reporting.DBroken

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

435+ return (Left BadBuild)

463436

464437 Just statuses ->

465438 do rmvar <- newEmptyMVar

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

469442 case sequence maybeResults of

470443 Nothing ->

471444 do Reporting.report key Reporting.DBroken

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

445+ return (Left BadBuild)

473446

474447 Just results ->

475448 let

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

477450 ifaces = gatherInterfaces exposedDict results

478451 objects = gatherObjects results

479452 artifacts = Artifacts ifaces objects

480− fingerprints = Set.insert f fs

481453 in

482− do writeDocs cache pkg vsn docsStatus results

483− File.writeBinary path (ArtifactCache fingerprints artifacts)

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

484455 Reporting.report key Reporting.DBuilt

485456 return (Right artifacts)

486457

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

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

498469addLocalGraph name status graph =

499470 case status of

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

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

501472 RForeign _ -> graph

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

503474 RKernelForeign -> graph

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

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

517488toLocalInterface func result =

518489 case result of

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

520− RForeign _ -> Nothing

521− RKernelLocal _ -> Nothing

522− RKernelForeign -> Nothing

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

491+ RForeign _ -> Nothing

492+ RKernelLocal _ -> Nothing

493+ RKernelForeign -> Nothing

523494

524495

525496

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

562533

563534

564535data Status

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

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

566537 | SForeign I.Interface

567538 | SKernelLocal [Kernel.Chunk]

568539 | SKernelForeign

569540

570541

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

572−crawlModule foreignDeps mvar pkg src docsStatus name =

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

543+crawlModule foreignDeps mvar pkg src name =

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

574545 exists <- File.exists path

575546 case Map.lookup name foreignDeps of

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

583554

584555 Nothing ->

585556 if exists then

586− crawlFile foreignDeps mvar pkg src docsStatus name path

557+ crawlFile foreignDeps mvar pkg src name path

587558

588559 else if Pkg.isKernel pkg && Name.isKernel name then

589560 crawlKernel foreignDeps mvar pkg src name

@@ -592,13 +563,13 @@ crawlModule foreignDeps mvar pkg src docsStatus name =

592563 return Nothing

593564

594565

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

596−crawlFile foreignDeps mvar pkg src docsStatus expectedName path =

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

567+crawlFile foreignDeps mvar pkg src name path =

597568 do bytes <- File.readUtf8 path

598− case Parse.fromByteString (Parse.Package pkg) bytes of

599− Right modul@(Src.Module (Just (A.At _ actualName)) _ _ imports _ _ _ _ _) | expectedName == actualName ->

569+ case Parse.fromByteString pkg bytes of

570+ Right modul@(Src.Module (Just actualName) _ imports _ _ _ _ _) | name == actualName ->

600571 do deps <- crawlImports foreignDeps mvar pkg src imports

601− return (Just (SLocal docsStatus deps modul))

572+ return (Just (SLocal deps modul))

602573

603574 _ ->

604575 return Nothing

@@ -609,7 +580,7 @@ crawlImports foreignDeps mvar pkg src imports =

609580 do statusDict <- takeMVar mvar

610581 let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)

611582 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

613584 putMVar mvar (Map.union mvars statusDict)

614585 mapM_ readMVar mvars

615586 return deps

@@ -645,7 +616,7 @@ getDepHome fi =

645616

646617

647618data Result

648− = RLocal !I.Interface !Opt.LocalGraph (Maybe Docs.Module)

619+ = RLocal !I.Interface !Opt.LocalGraph

649620 | RForeign I.Interface

650621 | RKernelLocal [Kernel.Chunk]

651622 | RKernelForeign

@@ -654,7 +625,7 @@ data Result

654625compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)

655626compile pkg mvar status =

656627 case status of

657− SLocal docsStatus deps modul ->

628+ SLocal deps modul ->

658629 do resultsDict <- readMVar mvar

659630 maybeResults <- traverse readMVar (Map.intersection resultsDict deps)

660631 case sequence maybeResults of

@@ -667,11 +638,7 @@ compile pkg mvar status =

667638 return Nothing

668639

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

670− let

671− ifaces = I.fromModule pkg canonical annotations

672− docs = makeDocs docsStatus canonical

673− in

674− return (Just (RLocal ifaces objects docs))

641+ return (Just (RLocal (I.fromModule pkg canonical annotations) objects))

675642

676643 SForeign iface ->

677644 return (Just (RForeign iface))

@@ -686,59 +653,10 @@ compile pkg mvar status =

686653getInterface :: Result -> Maybe I.Interface

687654getInterface result =

688655 case result of

689− RLocal iface _ _ -> Just iface

690− RForeign iface -> Just iface

691− RKernelLocal _ -> Nothing

692− RKernelForeign -> Nothing

693−

694−

695−

696−-- MAKE DOCS

697−

698−

699−data DocsStatus

700− = DocsNeeded

701− | DocsNotNeeded

702−

703−

704−getDocsStatus :: Stuff.PackageCache -> Pkg.Name -> V.Version -> IO DocsStatus

705−getDocsStatus cache pkg vsn =

706− do exists <- File.exists (Stuff.package cache pkg vsn </> "docs.json")

707− if exists

708− then return DocsNotNeeded

709− else return DocsNeeded

710−

711−

712−makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module

713−makeDocs status modul =

714− case status of

715− DocsNeeded ->

716− case Docs.fromModule modul of

717− Right docs -> Just docs

718− Left _ -> Nothing

719−

720− DocsNotNeeded ->

721− Nothing

722−

723−

724−writeDocs :: Stuff.PackageCache -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO ()

725−writeDocs cache pkg vsn status results =

726− case status of

727− DocsNeeded ->

728− E.writeUgly (Stuff.package cache pkg vsn </> "docs.json") $

729− Docs.encode $ Map.mapMaybe toDocs results

730−

731− DocsNotNeeded ->

732− return ()

733−

734−

735−toDocs :: Result -> Maybe Docs.Module

736−toDocs result =

737− case result of

738− RLocal _ _ docs -> docs

739− RForeign _ -> Nothing

740− RKernelLocal _ -> Nothing

741− RKernelForeign -> Nothing

656+ RLocal iface _ -> Just iface

657+ RForeign iface -> Just iface

658+ RKernelLocal _ -> Nothing

659+ RKernelForeign -> Nothing

742660

743661

744662

@@ -747,27 +665,24 @@ toDocs result =

747665

748666downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())

749667downloadPackage cache manager pkg vsn =

750− let

751− url = Website.metadata pkg vsn "endpoint.json"

752− in

753668 do eitherByteString <-

754− Http.get manager url [] id (return . Right)

669+ Http.get manager (Website.metadata pkg vsn "endpoint.json") [] id (return . Right)

755670

756671 case eitherByteString of

757672 Left err ->

758− return $ Left $ Exit.PP_BadEndpointRequest err

673+ return (Left (Exit.PP_BadEndpointRequest err))

759674

760675 Right byteString ->

761676 case D.fromByteString endpointDecoder byteString of

762677 Left _ ->

763− return $ Left $ Exit.PP_BadEndpointContent url

678+ return (Left Exit.PP_BadEndpointContent)

764679

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

767682 \(sha, archive) ->

768683 if expectedHash == Http.shaToChars sha

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

771686

772687

773688endpointDecoder :: D.Decoder e (String, String)

@@ -782,40 +697,27 @@ endpointDecoder =

782697

783698

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

793702

794703

795704instance Binary ValidOutline where

796705 put outline =

797706 case outline of

798− ValidApp a -> putWord8 0 >> put a

799− ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c

707+ ValidApp a -> putWord8 0 >> put a

708+ ValidPkg a b -> putWord8 1 >> put a >> put b

800709

801710 get =

802711 do n <- getWord8

803712 case n of

804713 0 -> liftM ValidApp get

805− 1 -> liftM3 ValidPkg get get get

806− _ -> fail "binary encoding of ValidOutline was corrupted"

714+ 1 -> liftM2 ValidPkg get get

715+ _ -> error "binary encoding of ValidOutline was corrupted"

807716

808717

809718instance Binary Local where

810− put (Local a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f

811− get =

812− do a <- get

813− b <- get

814− c <- get

815− d <- get

816− e <- get

817− f <- get

818− return (Local a b c d e f)

719+ get = liftM4 Local get get get get

720+ put (Local a b c d) = put a >> put b >> put c >> put d

819721

820722

821723instance 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/Outline.hs+115−148

@@ -1,11 +1,10 @@

11{-# OPTIONS_GHC -Wall #-}

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

2+{-# LANGUAGE OverloadedStrings #-}

33module Elm.Outline

44 ( Outline(..)

55 , AppOutline(..)

66 , PkgOutline(..)

77 , Exposed(..)

8− , SrcDir(..)

98 , read

109 , write

1110 , encode

@@ -19,12 +18,10 @@ module Elm.Outline

1918import Prelude hiding (read)

2019import Control.Monad (filterM, liftM)

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

21+import Data.Foldable (traverse_)

2222import qualified Data.Map as Map

23−import qualified Data.NonEmptyList as NE

24−import qualified Data.OneOrMore as OneOrMore

25−import Foreign.Ptr (minusPtr)

23+import qualified Data.Utf8 as Utf8

2624import qualified System.Directory as Dir

27−import qualified System.FilePath as FP

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

2926

3027import qualified Elm.Constraint as Con

@@ -35,9 +32,6 @@ import qualified Elm.Version as V

3532import qualified File

3633import qualified Json.Decode as D

3734import qualified Json.Encode as E

38−import Json.Encode ((==>))

39−import qualified Json.String as Json

40−import qualified Parse.Primitives as P

4135import qualified Reporting.Exit as Exit

4236

4337

@@ -53,7 +47,7 @@ data Outline

5347data AppOutline =

5448 AppOutline

5549 { _app_elm_version :: V.Version

56− , _app_source_dirs :: NE.List SrcDir

50+ , _app_source_dirs :: [FilePath]

5751 , _app_deps_direct :: Map.Map Pkg.Name V.Version

5852 , _app_deps_indirect :: Map.Map Pkg.Name V.Version

5953 , _app_test_direct :: Map.Map Pkg.Name V.Version

@@ -64,7 +58,7 @@ data AppOutline =

6458data PkgOutline =

6559 PkgOutline

6660 { _pkg_name :: Pkg.Name

67− , _pkg_summary :: Json.String

61+ , _pkg_summary :: Utf8.String

6862 , _pkg_license :: Licenses.License

6963 , _pkg_version :: V.Version

7064 , _pkg_exposed :: Exposed

@@ -76,21 +70,16 @@ data PkgOutline =

7670

7771data Exposed

7872 = ExposedList [ModuleName.Raw]

79− | ExposedDict [(Json.String, [ModuleName.Raw])]

80−

81−

82−data SrcDir

83− = AbsoluteSrcDir FilePath

84− | RelativeSrcDir FilePath

73+ | ExposedDict [(Utf8.String, [ModuleName.Raw])]

8574

8675

8776

8877-- DEFAULTS

8978

9079

91−defaultSummary :: Json.String

80+defaultSummary :: Utf8.String

9281defaultSummary =

93− Json.fromChars "helpful summary of your project, less than 80 characters"

82+ "helpful summary of your project, less than 80 characters"

9483

9584

9685

@@ -125,8 +114,8 @@ encode outline =

125114 case outline of

126115 App (AppOutline elm srcDirs depsDirect depsTrans testDirect testTrans) ->

127116 E.object

128− [ "type" ==> E.chars "application"

129− , "source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs)

117+ [ "type" ==> E.string "application"

118+ , "source-directories" ==> E.list (E.string . Utf8.fromChars) srcDirs

130119 , "elm-version" ==> V.encode elm

131120 , "dependencies" ==>

132121 E.object

@@ -142,7 +131,7 @@ encode outline =

142131

143132 Pkg (PkgOutline name summary license version exposed deps tests elm) ->

144133 E.object

145− [ "type" ==> E.string (Json.fromChars "package")

134+ [ "type" ==> E.string "package"

146135 , "name" ==> Pkg.encode name

147136 , "summary" ==> E.string summary

148137 , "license" ==> Licenses.encode license

@@ -154,6 +143,11 @@ encode outline =

154143 ]

155144

156145

146+(==>) :: a -> b -> (a, b)

147+(==>) a b =

148+ (a, b)

149+

150+

157151encodeExposed :: Exposed -> E.Value

158152encodeExposed exposed =

159153 case exposed of

@@ -171,14 +165,7 @@ encodeModule name =

171165

172166encodeDeps :: (a -> E.Value) -> Map.Map Pkg.Name a -> E.Value

173167encodeDeps encodeValue deps =

174− E.dict Pkg.toJsonString encodeValue deps

175−

176−

177−encodeSrcDir :: SrcDir -> E.Value

178−encodeSrcDir srcDir =

179− case srcDir of

180− AbsoluteSrcDir dir -> E.chars dir

181− RelativeSrcDir dir -> E.chars dir

168+ E.dict Pkg.toString encodeValue deps

182169

183170

184171

@@ -194,72 +181,19 @@ read root =

194181

195182 Right outline ->

196183 case outline of

197− Pkg (PkgOutline pkg _ _ _ _ deps _ _) ->

198− return $

199− if Map.notMember Pkg.core deps && pkg /= Pkg.core

200− then Left Exit.OutlineNoPkgCore

201− else Right outline

202−

203− App (AppOutline _ srcDirs direct indirect _ _)

204− | Map.notMember Pkg.core direct ->

205− return $ Left Exit.OutlineNoAppCore

206−

207− | Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->

208− return $ Left Exit.OutlineNoAppJson

209−

210− | otherwise ->

211− do badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)

212− case map toGiven badDirs of

213− d:ds ->

214− return $ Left (Exit.OutlineHasMissingSrcDirs d ds)

215−

216− [] ->

217− do maybeDups <- detectDuplicates root (NE.toList srcDirs)

218− case maybeDups of

219− Nothing ->

220− return $ Right outline

221−

222− Just (canonicalDir, (dir1,dir2)) ->

223− return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2)

224−

225−

226−isSrcDirMissing :: FilePath -> SrcDir -> IO Bool

227−isSrcDirMissing root srcDir =

228− not <$> Dir.doesDirectoryExist (toAbsolute root srcDir)

229−

230−

231−toGiven :: SrcDir -> FilePath

232−toGiven srcDir =

233− case srcDir of

234− AbsoluteSrcDir dir -> dir

235− RelativeSrcDir dir -> dir

236−

237−

238−toAbsolute :: FilePath -> SrcDir -> FilePath

239−toAbsolute root srcDir =

240− case srcDir of

241− AbsoluteSrcDir dir -> dir

242− RelativeSrcDir dir -> root </> dir

243−

244−

245−detectDuplicates :: FilePath -> [SrcDir] -> IO (Maybe (FilePath, (FilePath, FilePath)))

246−detectDuplicates root srcDirs =

247− do pairs <- traverse (toPair root) srcDirs

248− return $ Map.lookupMin $ Map.mapMaybe isDup $

249− Map.fromListWith OneOrMore.more pairs

250−

184+ Pkg _ ->

185+ return $ Right outline

251186

252−toPair :: FilePath -> SrcDir -> IO (FilePath, OneOrMore.OneOrMore FilePath)

253−toPair root srcDir =

254− do key <- Dir.canonicalizePath (toAbsolute root srcDir)

255− return (key, OneOrMore.one (toGiven srcDir))

187+ App (AppOutline _ srcDirs _ _ _ _) ->

188+ do badDirs <- filterM (isBadSrcDir root) srcDirs

189+ case badDirs of

190+ [] -> return $ Right outline

191+ d:ds -> return $ Left (Exit.OutlineHasBadSrcDirs d ds)

256192

257193

258−isDup :: OneOrMore.OneOrMore FilePath -> Maybe (FilePath, FilePath)

259−isDup paths =

260− case paths of

261− OneOrMore.One _ -> Nothing

262− OneOrMore.More a b -> Just (OneOrMore.getFirstTwo a b)

194+isBadSrcDir :: FilePath -> FilePath -> IO Bool

195+isBadSrcDir root dir =

196+ not <$> Dir.doesDirectoryExist (root </> dir)

263197

264198

265199

@@ -272,21 +206,23 @@ type Decoder a =

272206

273207decoder :: Decoder Outline

274208decoder =

275− let

276− application = Json.fromChars "application"

277− package = Json.fromChars "package"

278− in

279209 do tipe <- D.field "type" D.string

280− if | tipe == application -> App <$> appDecoder

281− | tipe == package -> Pkg <$> pkgDecoder

282− | otherwise -> D.failure Exit.OP_BadType

210+ case tipe of

211+ "application" ->

212+ App <$> appDecoder

213+

214+ "package" ->

215+ Pkg <$> pkgDecoder

216+

217+ other ->

218+ D.failure (Exit.OP_BadType other)

283219

284220

285221appDecoder :: Decoder AppOutline

286222appDecoder =

287223 AppOutline

288224 <$> D.field "elm-version" versionDecoder

289− <*> D.field "source-directories" dirsDecoder

225+ <*> D.field "source-directories" (D.list dirDecoder)

290226 <*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))

291227 <*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))

292228 <*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))

@@ -296,7 +232,7 @@ appDecoder =

296232pkgDecoder :: Decoder PkgOutline

297233pkgDecoder =

298234 PkgOutline

299− <$> D.field "name" nameDecoder

235+ <$> D.field "name" (D.mapError Exit.OP_BadPkgName Pkg.decoder)

300236 <*> D.field "summary" summaryDecoder

301237 <*> D.field "license" (Licenses.decoder Exit.OP_BadLicense)

302238 <*> D.field "version" versionDecoder

@@ -310,21 +246,17 @@ pkgDecoder =

310246-- JSON DECODE HELPERS

311247

312248

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

319250summaryDecoder =

320− D.customString

321− (boundParser 80 Exit.OP_BadSummaryTooLong)

322− (\_ _ -> Exit.OP_BadSummaryTooLong)

251+ do summary <- D.string

252+ if Utf8.size summary < 80

253+ then return summary

254+ else D.failure Exit.OP_BadSummaryTooLong

323255

324256

325257versionDecoder :: Decoder V.Version

326258versionDecoder =

327− D.mapError (uncurry Exit.OP_BadVersion) V.decoder

259+ D.mapError Exit.OP_BadVersion V.decoder

328260

329261

330262constraintDecoder :: Decoder Con.Constraint

@@ -334,19 +266,24 @@ constraintDecoder =

334266

335267depsDecoder :: Decoder a -> Decoder (Map.Map Pkg.Name a)

336268depsDecoder valueDecoder =

337− D.dict (Pkg.keyDecoder Exit.OP_BadDependencyName) valueDecoder

269+ Map.fromList <$> (

270+ traverse validateKey =<< D.pairs valueDecoder

271+ )

338272

339273

340−dirsDecoder :: Decoder (NE.List SrcDir)

341−dirsDecoder =

342− fmap (toSrcDir . Json.toChars) <$> D.nonEmptyList D.string Exit.OP_NoSrcDirs

274+validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)

275+validateKey (key, value) =

276+ case Pkg.fromString key of

277+ Right name ->

278+ return (name, value)

343279

280+ Left _ ->

281+ D.failure (Exit.OP_BadDependencyName key)

344282

345−toSrcDir :: FilePath -> SrcDir

346−toSrcDir path =

347− if FP.isRelative path

348− then RelativeSrcDir path

349− else AbsoluteSrcDir path

283+

284+dirDecoder :: Decoder FilePath

285+dirDecoder =

286+ Utf8.toChars <$> D.string

350287

351288

352289

@@ -357,51 +294,81 @@ exposedDecoder :: Decoder Exposed

357294exposedDecoder =

358295 D.oneOf

359296 [ 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)

361300 ]

362301

363302

364303moduleDecoder :: Decoder ModuleName.Raw

365304moduleDecoder =

366− D.mapError (uncurry Exit.OP_BadModuleName) ModuleName.decoder

305+ D.mapError Exit.OP_BadModuleName ModuleName.decoder

367306

368307

369−headerKeyDecoder :: D.KeyDecoder Exit.OutlineProblem Json.String

370−headerKeyDecoder =

371− D.KeyDecoder

372− (boundParser 20 Exit.OP_BadModuleHeaderTooLong)

373− (\_ _ -> Exit.OP_BadModuleHeaderTooLong)

308+checkHeader :: Utf8.String -> Decoder ()

309+checkHeader header =

310+ if Utf8.size header < 20

311+ then return ()

312+ else D.failure (Exit.OP_BadModuleHeaderTooLong header)

374313

375314

376315

377−-- BOUND PARSER

316+-- BINARY

378317

379318

380−boundParser :: Int -> x -> P.Parser x Json.String

381−boundParser bound tooLong =

382− P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->

383− let

384− len = minusPtr end pos

385− newCol = col + fromIntegral len

386− in

387− if len < bound

388− then cok (Json.fromPtr pos end) (P.State src end end indent row newCol)

389− else cerr row newCol (\_ _ -> tooLong)

319+instance Binary Outline where

320+ put outline =

321+ case outline of

322+ App a -> putWord8 0 >> put a

323+ Pkg a -> putWord8 1 >> put a

390324

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"

391331

392332

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

394336

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)

395345

396−instance Binary SrcDir where

397− put outline =

398− case outline of

399− AbsoluteSrcDir a -> putWord8 0 >> put a

400− RelativeSrcDir a -> putWord8 1 >> put a

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+

363+instance Binary Exposed where

364+ put exposed =

365+ case exposed of

366+ ExposedList a -> putWord8 0 >> put a

367+ ExposedDict a -> putWord8 1 >> put a

401368

402369 get =

403370 do n <- getWord8

404371 case n of

405− 0 -> liftM AbsoluteSrcDir get

406− 1 -> liftM RelativeSrcDir get

407− _ -> fail "binary encoding of SrcDir was corrupted"

372+ 0 -> liftM ExposedList get

373+ 1 -> liftM ExposedDict get

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

11module File

22 ( Time

33 , getTime

4− , zeroTime

54 , writeBinary

65 , readBinary

76 , writeUtf8

@@ -24,7 +23,6 @@ import qualified Data.ByteString.Builder as B

2423import qualified Data.ByteString.Lazy as LBS

2524import qualified Data.Fixed as Fixed

2625import qualified Data.List as List

27−import qualified Data.Time.Clock as Time

2826import qualified Data.Time.Clock.POSIX as Time

2927import qualified Foreign.ForeignPtr as FPtr

3028import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))

@@ -46,15 +44,11 @@ newtype Time = Time Fixed.Pico

4644getTime :: FilePath -> IO Time

4745getTime path =

4846 fmap

49− (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

47+ (Time . realToFrac . Time.utcTimeToPOSIXSeconds)

48+-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

5049 (Dir.getModificationTime path)

5150

5251

53−zeroTime :: Time

54−zeroTime =

55− Time 0

56−

57−

5852instance Binary.Binary Time where

5953 put (Time time) = Binary.put time

6054 get = Time <$> Binary.get

@@ -78,21 +72,8 @@ readBinary path =

7872 then

7973 do result <- Binary.decodeFileOrFail path

8074 case result of

81− Right a ->

82− return (Just a)

83−

84− Left (offset, message) ->

85− do IO.hPutStrLn IO.stderr $ unlines $

86− [ "+-------------------------------------------------------------------------------"

87− , "| Corrupt File: " ++ path

88− , "| Byte Offset: " ++ show offset

89− , "| Message: " ++ message

90− , "|"

91− , "| Please report this to https://github.com/elm/compiler/issues"

92− , "| Trying to continue anyway."

93− , "+-------------------------------------------------------------------------------"

94− ]

95− return Nothing

75+ Right a -> return (Just a)

76+ Left e -> return Nothing

9677 else

9778 return Nothing

9879

@@ -190,11 +171,7 @@ writeEntry destination root entry =

190171 let

191172 path = drop root (Zip.eRelativePath entry)

192173 in

193− if List.isPrefixOf "src/" path

194− || path == "LICENSE"

195− || path == "README.md"

196− || path == "elm.json"

197− then

174+ if List.isPrefixOf "src/" path then

198175 if not (null path) && last path == '/'

199176 then Dir.createDirectoryIfMissing True (destination </> path)

200177 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

1616 -- upload

1717 , upload

1818 , filePart

19− , jsonPart

2019 , stringPart

2120 )

2221 where

@@ -27,7 +26,6 @@ import qualified Codec.Archive.Zip as Zip

2726import Control.Exception (SomeException, handle)

2827import qualified Data.Binary as Binary

2928import qualified Data.Binary.Get as Binary

30−import qualified Data.ByteString.Builder as B

3129import qualified Data.ByteString.Char8 as BS

3230import qualified Data.Digest.Pure.SHA as SHA

3331import qualified Data.String as String

@@ -36,10 +34,8 @@ import Network.HTTP.Client

3634import Network.HTTP.Client.TLS (tlsManagerSettings)

3735import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)

3836import Network.HTTP.Types.Method (Method, methodGet, methodPost)

39−import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))

4037import qualified Network.HTTP.Client.MultipartFormData as Multi

4138

42−import qualified Json.Encode as Encode

4339import qualified Elm.Version as V

4440

4541

@@ -230,15 +226,6 @@ filePart name filePath =

230226 Multi.partFileSource (String.fromString name) filePath

231227

232228

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−

242229stringPart :: String -> String -> Multi.Part

243230stringPart 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−43

@@ -1,7 +1,6 @@

11{-# LANGUAGE BangPatterns, OverloadedStrings #-}

22module Reporting

33 ( Style

4− , silent

54 , json

65 , terminal

76 --

@@ -33,7 +32,7 @@ import qualified Data.ByteString.Builder as B

3332import qualified Data.NonEmptyList as NE

3433import qualified System.Exit as Exit

3534import qualified System.Info as Info

36−import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)

35+import System.IO (hFlush, hPutStr, stderr, stdout)

3736

3837import qualified Elm.ModuleName as ModuleName

3938import qualified Elm.Package as Pkg

@@ -50,16 +49,10 @@ import qualified Reporting.Exit.Help as Help

5049

5150

5251data Style

53− = Silent

54− | Json

52+ = Json

5553 | Terminal (MVar ())

5654

5755

58−silent :: Style

59−silent =

60− Silent

61−

62−

6356json :: Style

6457json =

6558 Json

@@ -78,9 +71,7 @@ attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a

7871attempt toReport work =

7972 do result <- work `catch` reportExceptionsNicely

8073 case result of

81− Right a ->

82− return a

83−

74+ Right a -> return a

8475 Left x ->

8576 do Exit.toStderr (toReport x)

8677 Exit.exitFailure

@@ -90,14 +81,9 @@ attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a

9081attemptWithStyle style toReport work =

9182 do result <- work `catch` reportExceptionsNicely

9283 case result of

93− Right a ->

94− return a

95−

84+ Right a -> return a

9685 Left x ->

9786 case style of

98− Silent ->

99− do Exit.exitFailure

100−

10187 Json ->

10288 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))

10389 Exit.exitFailure

@@ -122,6 +108,11 @@ badMark =

122108 D.red $ if isWindows then "X" else "✗"

123109

124110

111+_waitingMark :: D.Doc

112+_waitingMark =

113+ D.dullyellow $ if isWindows then "-" else "→"

114+

115+

125116isWindows :: Bool

126117isWindows =

127118 Info.os == "mingw32"

@@ -177,9 +168,6 @@ type DKey = Key DMsg

177168trackDetails :: Style -> (DKey -> IO a) -> IO a

178169trackDetails style callback =

179170 case style of

180− Silent ->

181− callback (Key (\_ -> return ()))

182−

183171 Json ->

184172 callback (Key (\_ -> return ()))

185173

@@ -264,8 +252,8 @@ putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()

264252putDownload mark pkg vsn =

265253 Help.toStdout $ D.indent 2 $

266254 mark

267− <+> D.fromPackage pkg

268− <+> D.fromVersion vsn

255+ <+> D.fromUtf8 (Pkg.toString pkg)

256+ <+> D.fromUtf8 (V.toString vsn)

269257 <> "\n"

270258

271259

@@ -309,9 +297,6 @@ type BResult a = Either Exit.BuildProblem a

309297trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)

310298trackBuild style callback =

311299 case style of

312− Silent ->

313− callback (Key (\_ -> return ()))

314−

315300 Json ->

316301 callback (Key (\_ -> return ()))

317302

@@ -364,10 +349,10 @@ toFinalMessage done result =

364349

365350 Left problem ->

366351 case problem of

367− Exit.BuildBadModules _ _ [] ->

352+ Exit.BuildModuleProblems _ [] ->

368353 "Detected problems in 1 module."

369354

370− Exit.BuildBadModules _ _ (_:ps) ->

355+ Exit.BuildModuleProblems _ (_:ps) ->

371356 "Detected problems in " ++ show (2 + length ps) ++ " modules."

372357

373358 Exit.BuildProjectProblem _ ->

@@ -381,9 +366,6 @@ toFinalMessage done result =

381366reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()

382367reportGenerate style names output =

383368 case style of

384− Silent ->

385− return ()

386−

387369 Json ->

388370 return ()

389371

@@ -446,23 +428,20 @@ reportExceptionsNicely e =

446428

447429

448430putException :: SomeException -> IO ()

449−putException e = do

450− hPutStrLn stderr ""

431+putException e =

451432 Help.toStderr $ D.stack $

452− [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"

453− , D.reflow $

454− "I ran into something that bypassed the normal error reporting process!\

433+ [ D.reflow $

434+ "Oh no! I ran into something that bypassed the normal error reporting process!\

455435 \ I extracted whatever information I could from the internal error:"

456436 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))

457437 , D.reflow $

458− "These errors are usually pretty confusing, so start by asking around on one of\

459− \ forums listed at https://elm-lang.org/community to see if anyone can get you\

460− \ unstuck quickly."

461− , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"

438+ "These errors are usually pretty confusing, so start by asking around on Slack\

439+ \ or Discourse to see if anyone can get you unstuck quickly."

440+ , "------------------------------------------------------------"

462441 , D.reflow $

463− "If you are feeling up to it, please try to get your code down to the smallest\

464− \ version that still triggers this message. Ideally in a single Main.elm and\

465− \ elm.json file."

442+ "From there, if you are feeling up to it, please try to get your code down to the\

443+ \ smallest version that still triggers this message. Ideally in a single Main.elm\

444+ \ and elm.json file."

466445 , D.reflow $

467446 "From there open a NEW issue at https://github.com/elm/compiler/issues with\

468447 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\

builder/src/Reporting/Exit.hs+366−1625

@@ -1,27 +1,31 @@

11{-# LANGUAGE OverloadedStrings #-}

22module Reporting.Exit

3− ( Init(..), initToReport

4− , Diff(..), diffToReport

5− , Make(..), makeToReport

6− , Bump(..), bumpToReport

7− , Repl(..), replToReport

8− , Publish(..), publishToReport

9− , Install(..), installToReport

10− , Reactor(..), reactorToReport

11− , newPackageOverview

3+ ( Exit(..)

4+ --

5+ , Init(..)

6+ , initToReport

7+ --

8+ , Diff(..)

9+ , diffToReport

10+ --

11+ , Install(..)

12+ , installToReport

1213 --

1314 , Solver(..)

15+ --

1416 , Outline(..)

1517 , OutlineProblem(..)

18+ --

1619 , Details(..)

17− , DetailsBadDep(..)

18− , PackageProblem(..)

1920 , RegistryProblem(..)

21+ , PackageProblem(..)

22+ --

23+ , Make(..)

2024 , BuildProblem(..)

2125 , BuildProjectProblem(..)

22− , DocsProblem(..)

23− , Generate(..)

26+ , makeToReport

2427 --

28+ , DocsProblem(..)

2529 , toString

2630 , toStderr

2731 , toJson

@@ -29,56 +33,59 @@ module Reporting.Exit

2933 where

3034

3135

32−import qualified Data.ByteString as BS

33−import qualified Data.ByteString.UTF8 as BS_UTF8

3436import qualified Data.List as List

35−import qualified Data.Map as Map

36−import qualified Data.Name as N

37−import qualified Data.NonEmptyList as NE

38−import qualified Network.HTTP.Client as HTTP

39−import qualified Network.HTTP.Types.Header as HTTP

40−import qualified Network.HTTP.Types.Status as HTTP

41−import qualified System.FilePath as FP

42−import System.FilePath ((</>), (<.>))

37+import qualified Data.Utf8 as Utf8

4338

4439import qualified Elm.Constraint as C

4540import qualified Elm.Magnitude as M

4641import qualified Elm.ModuleName as ModuleName

4742import qualified Elm.Package as Pkg

4843import qualified Elm.Version as V

49−import qualified File

5044import qualified Http

51−import qualified Json.Decode as Decode

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

5646import Reporting.Doc ((<>))

5747import qualified Reporting.Doc as D

58−import qualified Reporting.Error.Import as Import

5948import qualified Reporting.Error.Json as Json

6049import qualified Reporting.Exit.Help as Help

61−import qualified Reporting.Error as Error

62−import qualified Reporting.Render.Code as Code

63−

64−

50+import qualified Reporting.Problem as Problem

6551

66−-- RENDERERS

6752

6853

69−toString :: Help.Report -> String

70−toString report =

71− Help.toString (Help.reportToDoc report)

54+-- ALL POSSIBLE ERRORS

7255

7356

74−toStderr :: Help.Report -> IO ()

75−toStderr report =

76− Help.toStderr (Help.reportToDoc report)

57+data Exit

58+ -- bump

59+ = BumpApplication

60+ | BumpUnexpectedVersion V.Version [V.Version]

61+ | BumpMustHaveLatestRegistry RegistryProblem

62+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem

63+ -- publish

64+ | PublishMustHaveLatestRegistry RegistryProblem

65+ | PublishApplication

66+ | PublishNotInitialVersion V.Version

67+ | PublishAlreadyPublished V.Version

68+ | PublishInvalidBump V.Version V.Version

69+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude

70+ | PublishNoSummary

71+ | PublishNoExposed

72+ | PublishNoReadme

73+ | PublishShortReadme

74+ | PublishNoLicense

75+ | PublishCannotGetTag Http.Error

76+ | PublishCannotGetZip Http.Error

77+ | PublishCannotDecodeZip

78+ | PublishCannotGetDocs DocsProblem

79+ | PublishCannotRegister Http.Error

80+ | PublishMissingTag V.Version

81+ | PublishNoGit

82+ | PublishLocalChanges V.Version

7783

7884

79−toJson :: Help.Report -> Encode.Value

80−toJson report =

81− Help.reportToJson report

85+data DocsProblem

86+ = DP_Http Http.Error

87+ | DP_Data

88+ | DP_Cache

8289

8390

8491

@@ -109,18 +116,13 @@ initToReport exit =

109116

110117 InitNoOfflineSolution pkgs ->

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

119+ (error "TODO InitNoOfflineSolution" pkgs)

120+ (error "TODO InitNoOfflineSolution" pkgs)

121+ -- note about Russia IP addresses?

122+ -- ask if they are on a plane or train

121123

122124 InitSolverProblem solver ->

123− toSolverReport solver

125+ error "TODO InitSolverProblem" solver

124126

125127 InitAlreadyExists ->

126128 Help.report "EXISTING PROJECT" Nothing

@@ -131,9 +133,8 @@ initToReport exit =

131133 ]

132134 ]

133135

134− InitRegistryProblem problem ->

135− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

136− "I need the list of published packages before I can start initializing projects"

136+ InitRegistryProblem _ ->

137+ error "TODO InitRegistryProblem"

137138

138139

139140

@@ -141,48 +142,22 @@ initToReport exit =

141142

142143

143144data Diff

144− = DiffNoOutline

145− | DiffBadOutline Outline

146− | DiffApplication

147− | DiffNoExposed

145+ = DiffApplication

148146 | DiffUnpublished

149147 | DiffUnknownPackage Pkg.Name [Pkg.Name]

150148 | DiffUnknownVersion Pkg.Name V.Version [V.Version]

151− | DiffDocsProblem V.Version DocsProblem

149+ | DiffCannotFindDocs DocsProblem

152150 | DiffMustHaveLatestRegistry RegistryProblem

153− | DiffBadDetails Details

154− | DiffBadBuild BuildProblem

155151

156152

157153diffToReport :: Diff -> Help.Report

158154diffToReport diff =

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

171156 DiffApplication ->

172− Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")

173− "Your elm.json says this project is an application, but `elm diff` only works\

174− \ with packages. That way there are previously published versions of the API to\

175− \ diff against!"

176− [ D.reflow $ "If you are just curious to see a diff, try running this command:"

177− , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"

178− ]

179−

180− DiffNoExposed ->

181− Help.report "NO EXPOSED MODULES" (Just "elm.json")

182− "Your elm.json has no \"exposed-modules\" which means there is no public API at\

183− \ all right now! What am I supposed to diff?"

184− [ D.reflow $

185− "Try adding some modules back to the \"exposed-modules\" field."

157+ Help.report "CANNOT DIFF APPLICATIONS" Nothing

158+ "I cannot perform diffs on applications, only packages! If you are\

159+ \ just curious to see a diff, try running this command:"

160+ [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"

186161 ]

187162

188163 DiffUnpublished ->

@@ -194,16 +169,16 @@ diffToReport diff =

194169 Help.report "UNKNOWN PACKAGE" Nothing

195170 ( "I cannot find a package called:"

196171 )

197− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg

172+ [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg

198173 , "Maybe you want one of these instead?"

199− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions

174+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions

200175 , "But check <https://package.elm-lang.org> to see all possibilities!"

201176 ]

202177

203178 DiffUnknownVersion _pkg vsn realVersions ->

204179 Help.docReport "UNKNOWN VERSION" Nothing

205180 ( D.fillSep $

206− [ "Version", D.red (D.fromVersion vsn)

181+ [ "Version", D.red (D.fromUtf8 (V.toString vsn))

207182 , "has", "never", "been", "published,", "so", "I"

208183 , "cannot", "diff", "against", "it."

209184 ]

@@ -212,57 +187,230 @@ diffToReport diff =

212187 , D.indent 4 $ D.dullyellow $ D.vcat $

213188 let

214189 sameMajor v1 v2 = V._major v1 == V._major v2

215− mkRow vsns = D.hsep $ map D.fromVersion vsns

190+ mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns

216191 in

217192 map mkRow $ List.groupBy sameMajor (List.sort realVersions)

218193 , "Want one of those instead?"

219194 ]

220195

221− DiffDocsProblem version problem ->

222− toDocsProblemReport problem $

223− "I need the docs for " ++ V.toChars version ++ " to compute this diff"

196+ DiffCannotFindDocs problem ->

197+ error "TODO DiffCannotFindDocs" problem

224198

225199 DiffMustHaveLatestRegistry problem ->

226− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

227− "I need the latest list of published packages before I do this diff"

200+ error "TODO DiffMustHaveLatestRegistry" problem

228201

229− DiffBadDetails details ->

230− toDetailsReport details

231202

232− DiffBadBuild buildProblem ->

233− toBuildProblemReport buildProblem

234203

204+-- INSTALL

235205

236206

237−-- BUMP

207+data Install

208+ = InstallNoProject

209+ | InstallNoArgs FilePath

210+ | InstallNoOnlineSolution

211+ | InstallNoOfflineSolution

212+ | InstallHadSolverTrouble Solver

213+ | InstallUnknownPackageOnline [Pkg.Name]

214+ | InstallUnknownPackageOffline [Pkg.Name]

215+ | InstallHasBadDetails Details

238216

239217

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

218+installToReport :: Install -> Help.Report

219+installToReport exit =

220+ case exit of

221+ InstallNoProject ->

222+ Help.report "NEW PROJECT?" Nothing

223+ "Are you trying to start a new project? Try this command instead:"

224+ [ D.indent 4 $ D.green "elm init"

225+ , D.reflow "It will help you get started!"

226+ ]

250227

228+ InstallNoArgs elmHome ->

229+ Help.report "INSTALL WHAT?" Nothing

230+ "I am expecting commands like:"

231+ [ D.green $ D.indent 4 $ D.vcat $

232+ [ "elm install elm/http"

233+ , "elm install elm/json"

234+ , "elm install elm/random"

235+ ]

236+ , D.toFancyHint

237+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."

238+ ,"\"Gotta","download","everything!\"","But","why","download","packages"

239+ ,"again","and","again?","Instead,","Elm","caches","packages","in"

240+ ,D.dullyellow (D.fromChars elmHome)

241+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."

242+ ,"Elm","projects","check","that","cache","before","trying","the","internet."

243+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"

244+ ,"easier","to","work","offline.","As","a","result"

245+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"

246+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"

247+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"

248+ ]

249+ ]

251250

252−bumpToReport :: Bump -> Help.Report

253−bumpToReport bump =

254− case bump of

255− BumpNoOutline ->

256− Help.report "BUMP WHAT?" Nothing

257− "I cannot find an elm.json so I am not sure what you want me to bump."

258− [ D.reflow $

259− "Elm packages always have an elm.json that says current the version number. If\

260− \ you run this command from a directory with an elm.json file, I will try to bump\

261− \ the version in there based on the API changes."

251+ InstallNoOnlineSolution ->

252+ Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json") -- TODO recommend using solver in `elm reactor`

253+ "This usually happens if you try to modify dependency constraints by\

254+ \ hand. I recommend deleting any dependency you added recently (or all\

255+ \ of them if things are bad) and then adding them again with:"

256+ [ D.indent 4 $ D.green "elm install"

257+ , D.reflow $

258+ "And do not be afaid to ask for help on Slack if you get stuck!"

262259 ]

263260

264− BumpBadOutline outline ->

265− toOutlineReport outline

261+ InstallNoOfflineSolution ->

262+ error "TODO InstallNoOfflineSolution"

263+

264+ InstallHadSolverTrouble solver ->

265+ error "TODO InstallHadSolverTrouble" solver

266+

267+ InstallUnknownPackageOnline suggestions ->

268+ error "TODO InstallUnknownPackageOnline" suggestions

269+

270+ InstallUnknownPackageOffline suggestions ->

271+ error "TODO InstallUnknownPackageOffline" suggestions

272+

273+ InstallHasBadDetails _ ->

274+ error "TODO InstallHasBadDetails"

275+

276+

277+{- TODO detect if library has no 0.19.0 version. Maybe do this on website though?

278+ Help.report "OLD DEPENDENCIES" (Just "elm.json")

279+ ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"

280+ )

281+ [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages

282+ , D.reflow $

283+ "This may be because it is not upgraded yet. It may be because a\

284+ \ better solution came along, so there was no need to upgrade it.\

285+ \ Etc. Try asking around on Slack to learn more about the topic."

286+ , D.toSimpleNote

287+ "Whatever the case, please be kind to the relevant package authors! Having\

288+ \ friendly interactions with users is great motivation, and conversely, getting\

289+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\

290+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\

291+ \ goals, etc. They face obstacles outside of their technical work you will never\

292+ \ know about, so please assume the best and try to be patient and supportive!"

293+ ]

294+-}

295+

296+

297+

298+-- SOLVER

299+

300+

301+data Solver

302+ = SolverBadCacheData Pkg.Name V.Version

303+ | SolverBadHttpData Pkg.Name V.Version

304+ | SolverBadHttp Http.Error

305+

306+

307+

308+-- OUTLINE

309+

310+

311+data Outline

312+ = OutlineHasBadStructure (Json.Error OutlineProblem)

313+ | OutlineHasBadSrcDirs FilePath [FilePath]

314+

315+

316+data OutlineProblem

317+ = OP_BadType Utf8.String

318+ | OP_BadPkgName Pkg.BadName

319+ | OP_BadVersion Utf8.String

320+ | OP_BadConstraint C.Error

321+ | OP_BadModuleName Utf8.String

322+ | OP_BadModuleHeaderTooLong Utf8.String

323+ | OP_BadDependencyName Utf8.String

324+ | OP_BadLicense Utf8.String [Utf8.String]

325+ | OP_BadSummaryTooLong

326+

327+

328+

329+-- DETAILS

330+

331+

332+data Details

333+ = DetailsCorrupt

334+ | DetailsNoSolution

335+ | DetailsNoOfflineSolution

336+ | DetailsSolverProblem Solver

337+ | DetailsBadElmInPkg C.Constraint

338+ | DetailsBadElmInAppOutline V.Version

339+ | DetailsHandEditedDependencies

340+ | DetailsBadOutline Outline

341+ | DetailsCannotGetRegistry RegistryProblem

342+ | DetailsCannotBuildPackage Pkg.Name V.Version PackageProblem

343+

344+

345+data RegistryProblem

346+ = RP_Http Http.Error

347+ | RP_Data

348+

349+

350+data PackageProblem

351+ = PP_BadEndpointRequest Http.Error

352+ | PP_BadEndpointContent

353+ | PP_BadArchiveRequest Http.Error

354+ | PP_BadArchiveContent

355+ | PP_BadArchiveHash String String

356+

357+

358+

359+-- MAKE

360+

361+

362+data Make

363+ = MakeNeedsOutline

364+ | MakeCannotOptimizeAndDebug

365+ | MakeBlockedByDetailsProblem Details

366+ | MakeAppNeedsFileNames

367+ | MakePkgNeedsExposing

368+ | MakeMultipleFilesIntoHtml

369+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]

370+ | MakeCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]

371+ | MakeCannotBuild BuildProblem

372+ | MakeCannotLoadArtifacts

373+

374+

375+data BuildProblem

376+ = BuildModuleProblems Problem.Problem [Problem.Problem]

377+ | BuildProjectProblem BuildProjectProblem

378+

379+

380+data BuildProjectProblem

381+ = BP_PathUnknown FilePath

382+ | BP_WithBadExtension FilePath

383+ | BP_WithAmbiguousSrcDir FilePath FilePath

384+ | BP_MainPathDuplicate FilePath FilePath

385+ | BP_MainNameDuplicate ModuleName.Raw FilePath FilePath

386+ | BP_CannotLoadDependencies

387+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]

388+

389+

390+

391+-- RENDERERS

392+

393+

394+toString :: Help.Report -> String

395+toString report =

396+ Help.toString (Help.reportToDoc report)

397+

398+

399+toStderr :: Help.Report -> IO ()

400+toStderr report =

401+ Help.toStderr (Help.reportToDoc report)

402+

403+

404+toJson :: Help.Report -> Encode.Value

405+toJson report =

406+ Help.reportToJson report

407+

408+

409+_toReport :: Exit -> Help.Report

410+_toReport exit =

411+ case exit of

412+

413+ -- bump

266414

267415 BumpApplication ->

268416 Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")

@@ -274,7 +422,7 @@ bumpToReport bump =

274422 Help.docReport "CANNOT BUMP" (Just "elm.json")

275423 ( D.fillSep

276424 ["Your","elm.json","says","I","should","bump","relative","to","version"

277− ,D.red (D.fromVersion vsn) <> ","

425+ ,D.red (D.fromUtf8 (V.toString vsn)) <> ","

278426 ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."

279427 ,"That","means","there","is","no","API","for","me","to","diff","against","and"

280428 ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."

@@ -283,116 +431,19 @@ bumpToReport bump =

283431 [ D.fillSep $

284432 ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]

285433 ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]

286− , D.vcat $ map (D.green . D.fromVersion) versions

434+ , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions

287435 ]

288436

289437 BumpMustHaveLatestRegistry problem ->

290− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

291− "I need the latest list of published packages before I can bump any versions"

292−

293− BumpCannotFindDocs _ version problem ->

294− toDocsProblemReport problem $

295− "I need the docs for " ++ V.toChars version ++ " to compute the next version number"

296−

297− BumpBadDetails details ->

298− toDetailsReport details

299−

300− BumpNoExposed ->

301− Help.docReport "NO EXPOSED MODULES" (Just "elm.json")

302− ( D.fillSep $

303− [ "To", "bump", "a", "package,", "the"

304− , D.dullyellow "\"exposed-modules\"", "field", "of", "your"

305− , "elm.json", "must", "list", "at", "least", "one", "module."

306− ]

307− )

308− [ D.reflow $

309− "Try adding some modules back to the \"exposed-modules\" field."

310− ]

311−

312− BumpBadBuild problem ->

313− toBuildProblemReport problem

314−

315−

316−

317−-- OVERVIEW OF VERSIONING

318−

319−

320−newPackageOverview :: String

321−newPackageOverview =

322− unlines

323− [ "This package has never been published before. Here's how things work:"

324− , ""

325− , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"

326− , ""

327− , " - All packages start with initial version " ++ V.toChars V.one

328− , ""

329− , " - Versions are incremented based on how the API changes:"

330− , ""

331− , " PATCH = the API is the same, no risk of breaking code"

332− , " MINOR = values have been added, existing values are unchanged"

333− , " MAJOR = existing values have been changed or removed"

334− , ""

335− , " - I will bump versions for you, automatically enforcing these rules"

336− , ""

337− ]

338−

339−

340−

341−-- PUBLISH

342−

343−

344−data Publish

345− = PublishNoOutline

346− | PublishBadOutline Outline

347− | PublishBadDetails Details

348− | PublishMustHaveLatestRegistry RegistryProblem

349− | PublishApplication

350− | PublishNotInitialVersion V.Version

351− | PublishAlreadyPublished V.Version

352− | PublishInvalidBump V.Version V.Version

353− | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude

354− | PublishNoSummary

355− | PublishNoExposed

356− | PublishNoReadme

357− | PublishShortReadme

358− | PublishNoLicense

359− | PublishBuildProblem BuildProblem

360− | PublishMissingTag V.Version

361− | PublishCannotGetTag V.Version Http.Error

362− | PublishCannotGetTagData V.Version String BS.ByteString

363− | PublishCannotGetZip Http.Error

364− | PublishCannotDecodeZip String

365− | PublishCannotGetDocs V.Version V.Version DocsProblem

366− | PublishCannotRegister Http.Error

367− | PublishNoGit

368− | PublishLocalChanges V.Version

369− --

370− | PublishZipBadDetails Details

371− | PublishZipApplication

372− | PublishZipNoExposed

373− | PublishZipBuildProblem BuildProblem

374−

375−

376−publishToReport :: Publish -> Help.Report

377−publishToReport publish =

378− case publish of

379− PublishNoOutline ->

380− Help.report "PUBLISH WHAT?" Nothing

381− "I cannot find an elm.json so I am not sure what you want me to publish."

382− [ D.reflow $

383− "Elm packages always have an elm.json that states the version number,\

384− \ dependencies, exposed modules, etc."

385− ]

438+ error "TODO BumpMustHaveLatestRegistry" problem

386439

387− PublishBadOutline outline ->

388− toOutlineReport outline

440+ BumpCannotFindDocs name version problem ->

441+ error "TODO BumpCannotFindDocs" name version problem

389442

390− PublishBadDetails problem ->

391− toDetailsReport problem

443+ -- publish

392444

393445 PublishMustHaveLatestRegistry problem ->

394− toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

395− "I need the latest list of published packages to make sure this is safe to publish"

446+ error "TODO PublishMustHaveLatestRegistry" problem

396447

397448 PublishApplication ->

398449 Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []

@@ -401,7 +452,7 @@ publishToReport publish =

401452 Help.docReport "INVALID VERSION" Nothing

402453 ( D.fillSep

403454 ["I","cannot","publish"

404− ,D.red (D.fromVersion vsn)

455+ ,D.red (D.fromUtf8 (V.toString vsn))

405456 ,"as","the","initial","version."

406457 ]

407458 )

@@ -415,7 +466,7 @@ publishToReport publish =

415466 Help.docReport "ALREADY PUBLISHED" Nothing

416467 ( D.vcat

417468 [ D.fillSep

418− [ "Version", D.green (D.fromVersion vsn)

469+ [ "Version", D.green (D.fromUtf8 (V.toString vsn))

419470 , "has", "already", "been", "published.", "You", "cannot"

420471 , "publish", "it", "again!"

421472 ]

@@ -432,14 +483,14 @@ publishToReport publish =

432483 Help.docReport "INVALID VERSION" (Just "elm.json")

433484 ( D.fillSep $

434485 ["Your","elm.json","says","the","next","version","should","be"

435− ,D.red (D.fromVersion statedVersion) <> ","

486+ ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","

436487 ,"but","that","is","not","valid","based","on","the","previously"

437488 ,"published","versions."

438489 ]

439490 )

440491 [ D.fillSep $

441492 ["Change","the","version","back","to"

442− ,D.green (D.fromVersion latestVersion)

493+ ,D.green (D.fromUtf8 (V.toString latestVersion))

443494 ,"which","is","the","most","recently","published","version."

444495 ,"From","there,","have","Elm","bump","the","version","by","running:"

445496 ]

@@ -454,7 +505,7 @@ publishToReport publish =

454505 (

455506 D.fillSep $

456507 ["Your","elm.json","says","the","next","version","should","be"

457− ,D.red (D.fromVersion new) <> ","

508+ ,D.red (D.fromUtf8 (V.toString new)) <> ","

458509 ,"indicating","a",D.fromChars (M.toChars magnitude)

459510 ,"change","to","the","public","API."

460511 ,"This","does","not","match","the","API","diff","given","by:"

@@ -467,7 +518,7 @@ publishToReport publish =

467518 ["This","command","says","this","is","a"

468519 ,D.fromChars (M.toChars realMagnitude)

469520 ,"change,","so","the","next","version","should","be"

470− ,D.green (D.fromVersion realNew) <> "."

521+ ,D.green (D.fromUtf8 (V.toString realNew)) <> "."

471522 ,"Double","check","everything","to","make","sure","you"

472523 ,"are","publishing","what","you","want!"

473524 ]

@@ -497,17 +548,16 @@ publishToReport publish =

497548 ]

498549 )

499550 [ D.reflow $

500− "Which modules do you want users of the package to have access to? Add their\

501− \ names to the \"exposed-modules\" list."

551+ "What is the point of a package that has no modules?!"

502552 ]

503553

504554 PublishNoReadme ->

505− toBadReadmeReport "NO README" $

555+ badReadmeReport "NO README" $

506556 "Every published package must have a helpful README.md\

507557 \ file, but I do not see one in your project."

508558

509559 PublishShortReadme ->

510− toBadReadmeReport "SHORT README" $

560+ badReadmeReport "SHORT README" $

511561 "This README.md is too short. Having more details will help\

512562 \ people assess your package quickly and fairly."

513563

@@ -524,8 +574,20 @@ publishToReport publish =

524574 \ named LICENSE. Add that file and you will be all set!"

525575 ]

526576

527− PublishBuildProblem buildProblem ->

528− toBuildProblemReport buildProblem

577+ PublishCannotGetTag httpError ->

578+ error "TODO PublishCannotGetTag" httpError

579+

580+ PublishCannotGetZip httpError ->

581+ error "TODO PublishCannotGetZip" httpError

582+

583+ PublishCannotDecodeZip ->

584+ error "TODO PublishCannotDecodeZip"

585+

586+ PublishCannotGetDocs docsProblem ->

587+ error "TODO PublishCannotGetDocs" docsProblem

588+

589+ PublishCannotRegister httpError ->

590+ error "TODO PublishCannotRegister" httpError

529591

530592 PublishMissingTag version ->

531593 let vsn = V.toChars version in

@@ -546,70 +608,6 @@ publishToReport publish =

546608 , "The -m flag is for a helpful message. Try to make it more informative!"

547609 ]

548610

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−

613611 PublishNoGit ->

614612 Help.report "NO GIT" Nothing

615613 "I searched your PATH environment variable for `git` and could not\

@@ -639,21 +637,9 @@ publishToReport publish =

639637 ++ vsn ++ "` and publish your code from there."

640638 ]

641639

642− PublishZipBadDetails _ ->

643− badZipReport

644640

645− PublishZipApplication ->

646− badZipReport

647−

648− PublishZipNoExposed ->

649− badZipReport

650−

651− PublishZipBuildProblem _ ->

652− badZipReport

653−

654−

655−toBadReadmeReport :: String -> String -> Help.Report

656−toBadReadmeReport title summary =

641+badReadmeReport :: String -> String -> Help.Report

642+badReadmeReport title summary =

657643 Help.report title (Just "README.md") summary

658644 [ D.reflow $

659645 "When people look at your README, they are wondering:"

@@ -666,653 +652,32 @@ toBadReadmeReport title summary =

666652 \ most common usage scenario. Show people what they can expect if\

667653 \ they learn more!"

668654 , D.toSimpleNote $

669− "By publishing your package, you are inviting people to invest time in\

670− \ understanding your work. Spending an hour on your README to communicate your\

671− \ knowledge more clearly can save the community days or weeks of time in\

672− \ aggregate, and saving time in aggregate is the whole point of publishing\

673− \ packages! People really appreciate it, and it makes the whole ecosystem feel\

674− \ nicer!"

675− ]

676−

677−

678−badZipReport :: Help.Report

679−badZipReport =

680− Help.report "PROBLEM VERIFYING PACKAGE" Nothing

681− "Before publishing packages, I download the code from GitHub and try to build it\

682− \ from scratch. That way I can be more confident that it will work for other\

683− \ people too. But I am not able to build it!"

684− [ D.reflow $

685− "I was just able to build your local copy though. Is there some way the version\

686− \ on GitHub could be different?"

655+ "By publishing your package, you are inviting people to invest time\

656+ \ in understanding your work. Spending an hour to communicate your\

657+ \ knowledge more clearly can save the community days or weeks of time\

658+ \ in aggregate, and saving time in aggregate is the whole point of\

659+ \ publishing packages! People really appreciate it, and it makes the\

660+ \ whole ecosystem feel nicer!"

687661 ]

688662

689663

690664

691−-- DOCS

692−

693−

694−data DocsProblem

695− = DP_Http Http.Error

696− | DP_Data String BS.ByteString

697− | DP_Cache

698−

699−

700−toDocsProblemReport :: DocsProblem -> String -> Help.Report

701−toDocsProblemReport problem context =

702− case problem of

703− DP_Http httpError ->

704− toHttpErrorReport "PROBLEM LOADING DOCS" httpError context

705−

706− DP_Data url body ->

707− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")

708− [ D.indent 4 $ D.dullyellow $ D.fromChars url

709− , D.reflow $

710− "I got the data back, but it was not what I was expecting. The response\

711− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

712− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

713− , D.indent 4 $ D.dullyellow $ D.fromChars $

714− if BS.length body <= 76

715− then BS_UTF8.toString body

716− else take 73 (BS_UTF8.toString body) ++ "..."

717− , D.reflow $

718− "Does this error keep showing up? Maybe there is something weird with your\

719− \ internet connection. We have gotten reports that schools, businesses,\

720− \ airports, etc. sometimes intercept requests and add things to the body\

721− \ or change its contents entirely. Could that be the problem?"

722− ]

723−

724− DP_Cache ->

725− Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")

726− [ D.reflow $

727− "I deleted the cached version, so the next run should download a fresh copy of\

728− \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\

729− \ problem if, for example, a 3rd party editor plugin is modifing cached files\

730− \ for some reason."

731− ]

732−

733−

734−

735−-- INSTALL

736−

737−

738−data Install

739− = InstallNoOutline

740− | InstallBadOutline Outline

741− | InstallBadRegistry RegistryProblem

742− | InstallNoArgs FilePath

743− | InstallNoOnlineAppSolution Pkg.Name

744− | InstallNoOfflineAppSolution Pkg.Name

745− | InstallNoOnlinePkgSolution Pkg.Name

746− | InstallNoOfflinePkgSolution Pkg.Name

747− | InstallHadSolverTrouble Solver

748− | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]

749− | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]

750− | InstallBadDetails Details

751−

752−

753−installToReport :: Install -> Help.Report

754−installToReport exit =

755− case exit of

756− InstallNoOutline ->

757− Help.report "NEW PROJECT?" Nothing

758− "Are you trying to start a new project? Try this command instead:"

759− [ D.indent 4 $ D.green "elm init"

760− , D.reflow "It will help you get started!"

761− ]

665+-- DETAILS TO REPORT

762666

763− InstallBadOutline outline ->

764− toOutlineReport outline

765667

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 =

668+detailsToReport :: Details -> Help.Report

669+detailsToReport details =

1279670 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

671+ DetailsCorrupt ->

672+ error "TODO DetailsCorrupt"

1308673

1309674 DetailsBadElmInPkg constraint ->

1310675 Help.report "ELM VERSION MISMATCH" (Just "elm.json")

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

677+ [ D.indent 4 $ D.dullyellow $ D.fromUtf8 $ C.toString constraint

1313678 , D.fillSep

1314679 [ "But", "you", "are", "using", "Elm"

1315− , D.red (D.fromVersion V.compiler)

680+ , D.red (D.fromUtf8 (V.toString V.compiler))

1316681 , "right", "now."

1317682 ]

1318683 ]

@@ -1322,286 +687,40 @@ toDetailsReport details =

1322687 "Your elm.json says this application needs a different version of Elm."

1323688 [ D.fillSep

1324689 [ "It", "requires"

1325− , D.green (D.fromVersion version) <> ","

690+ , D.green (D.fromUtf8 (V.toString version)) <> ","

1326691 , "but", "you", "are", "using"

1327− , D.red (D.fromVersion V.compiler)

692+ , D.red (D.fromUtf8 (V.toString V.compiler))

1328693 , "right", "now."

1329694 ]

1330695 ]

1331696

1332697 DetailsHandEditedDependencies ->

1333− Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")

1334− "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\

1335− \ party tool) leaving them in an invalid state."

1336− [ D.fillSep

1337− ["Try","to","change","them","back","to","what","they","were","before!"

1338− ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."

1339− ]

1340− , D.reflow $

1341− "Please ask for help on the community forums if you try those paths and are still\

1342− \ having problems!"

1343− ]

698+ error "TODO DetailsHandEditedDependencies"

1344699

1345− DetailsBadOutline outline ->

1346− toOutlineReport outline

700+ DetailsBadOutline problem ->

701+ error "TODO DetailsBadOutline" problem

1347702

1348703 DetailsCannotGetRegistry problem ->

1349− toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

1350− "I need the list of published packages to verify your dependencies"

1351−

1352− DetailsBadDeps cacheDir deps ->

1353− case List.sortOn toBadDepRank deps of

1354− [] ->

1355− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing

1356− "I am not sure what is going wrong though."

1357− [ D.reflow $

1358− "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\

1359− \ trying to build again. That will work if some cached files got corrupted\

1360− \ somehow."

1361− , D.reflow $

1362− "If that does not work, go to https://elm-lang.org/community and ask for\

1363− \ help. This is a weird case!"

1364− ]

1365−

1366− d:_ ->

1367− case d of

1368− BD_BadDownload pkg vsn packageProblem ->

1369− toPackageProblemReport pkg vsn packageProblem

1370−

1371− BD_BadBuild pkg vsn fingerprint ->

1372− Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing

1373− "I ran into a compilation error when trying to build the following package:"

1374− [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn

1375− , D.reflow $

1376− "This probably means it has package constraints that are too wide. It may be\

1377− \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\

1378− \ over to https://elm-lang.org/community to get help figuring out how to take\

1379− \ this path!"

1380− , D.toSimpleNote $

1381− "To help with the root problem, please report this to the package author along\

1382− \ with the following information:"

1383− , D.indent 4 $ D.vcat $

1384− map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $

1385− Map.toList fingerprint

1386− , D.reflow $

1387− "If you want to help out even more, try building the package locally. That should\

1388− \ give you much more specific information about why this package is failing to\

1389− \ build, which will in turn make it easier for the package author to fix it!"

1390− ]

1391−

1392−

1393−toBadDepRank :: DetailsBadDep -> Int -- lower is better

1394−toBadDepRank badDep =

1395− case badDep of

1396− BD_BadDownload _ _ _ -> 0

1397− BD_BadBuild _ _ _ -> 1

1398−

1399−

1400−

1401−-- PACKAGE PROBLEM

1402−

1403−

1404−data PackageProblem

1405− = PP_BadEndpointRequest Http.Error

1406− | PP_BadEndpointContent String

1407− | PP_BadArchiveRequest Http.Error

1408− | PP_BadArchiveContent String

1409− | PP_BadArchiveHash String String String

1410−

1411−

1412−toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report

1413−toPackageProblemReport pkg vsn problem =

1414− let

1415− thePackage =

1416− Pkg.toChars pkg ++ " " ++ V.toChars vsn

1417− in

1418− case problem of

1419− PP_BadEndpointRequest httpError ->

1420− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $

1421− "I need to find the latest download link for " ++ thePackage

1422−

1423− PP_BadEndpointContent url ->

1424− Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing

1425− (

1426− "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"

1427− )

1428− [ D.indent 4 $ D.dullyellow $ D.fromChars url

1429− , D.reflow $

1430− "Is something weird with your internet connection. We have gotten reports that\

1431− \ schools, businesses, airports, etc. sometimes intercept requests and add things\

1432− \ to the body or change its contents entirely. Could that be the problem?"

1433− ]

1434−

1435− PP_BadArchiveRequest httpError ->

1436− toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $

1437− "I was trying to download the source code for " ++ thePackage

704+ error "TODO DetailsCannotGetRegistry" problem

1438705

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

706+ DetailsCannotBuildPackage name version problem ->

707+ error "TODO DetailsCannotBuildPackage" name version problem

1451708

1452− PP_BadArchiveHash url expectedHash actualHash ->

1453− Help.report "CORRUPT PACKAGE DATA" Nothing

1454− (

1455− "I downloaded the source code for " ++ thePackage ++ " from:"

1456− )

1457− [ D.indent 4 $ D.dullyellow $ D.fromChars url

1458− , D.reflow "But it looks like the hash of the archive has changed since publication:"

1459− , D.vcat $ map D.fromChars $

1460− [ " Expected: " ++ expectedHash

1461− , " Actual: " ++ actualHash

1462− ]

1463− , D.reflow $

1464− "This usually means that the package author moved the version\

1465− \ tag, so report it to them and see if that is the issue. Folks\

1466− \ on Elm slack can probably help as well."

1467− ]

1468−

1469−

1470−

1471−-- REGISTRY PROBLEM

1472−

1473−

1474−data RegistryProblem

1475− = RP_Http Http.Error

1476− | RP_Data String BS.ByteString

1477−

1478−

1479−toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report

1480−toRegistryProblemReport title problem context =

1481− case problem of

1482− RP_Http err ->

1483− toHttpErrorReport title err context

1484−

1485− RP_Data url body ->

1486− Help.report title Nothing (context ++ ", so I fetched:")

1487− [ D.indent 4 $ D.dullyellow $ D.fromChars url

1488− , D.reflow $

1489− "I got the data back, but it was not what I was expecting. The response\

1490− \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

1491− ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

1492− , D.indent 4 $ D.dullyellow $ D.fromChars $

1493− if BS.length body <= 76

1494− then BS_UTF8.toString body

1495− else take 73 (BS_UTF8.toString body) ++ "..."

1496− , D.reflow $

1497− "Does this error keep showing up? Maybe there is something weird with your\

1498− \ internet connection. We have gotten reports that schools, businesses,\

1499− \ airports, etc. sometimes intercept requests and add things to the body\

1500− \ or change its contents entirely. Could that be the problem?"

1501− ]

1502−

1503−

1504−toHttpErrorReport :: String -> Http.Error -> String -> Help.Report

1505−toHttpErrorReport title err context =

1506− let

1507− toHttpReport intro url details =

1508− Help.report title Nothing intro $

1509− D.indent 4 (D.dullyellow (D.fromChars url)) : details

1510− in

1511− case err of

1512− Http.BadUrl url reason ->

1513− toHttpReport (context ++ ", so I wanted to fetch:") url

1514− [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"

1515− , D.indent 4 $ D.fromChars reason

1516− , D.reflow $

1517− "This may indicate that there is some problem in the compiler, so please open an\

1518− \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\

1519− \ version, the command you ran, the terminal output, and any additional information\

1520− \ that might help others reproduce the error."

1521− ]

1522−

1523− Http.BadHttp url httpExceptionContent ->

1524− case httpExceptionContent of

1525− HTTP.StatusCodeException response body ->

1526− let

1527− (HTTP.Status code message) = HTTP.responseStatus response

1528− in

1529− toHttpReport (context ++ ", so I tried to fetch:") url

1530− [ D.fillSep $

1531− ["But","it","came","back","as",D.red (D.fromInt code)]

1532− ++ map D.fromChars (words (BS_UTF8.toString message))

1533− , D.indent 4 $ D.reflow $ BS_UTF8.toString body

1534− , D.reflow $

1535− "This may mean some online endpoint changed in an unexpected way, so if does not\

1536− \ seem like something on your side is causing this (e.g. firewall) please report\

1537− \ this to https://github.com/elm/compiler/issues with your operating system, Elm\

1538− \ version, the command you ran, the terminal output, and any additional information\

1539− \ that can help others reproduce the error!"

1540− ]

1541−

1542− HTTP.TooManyRedirects responses ->

1543− toHttpReport (context ++ ", so I tried to fetch:") url

1544− [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"

1545− , D.indent 4 $ D.vcat $ map toRedirectDoc responses

1546− , D.reflow $

1547− "Is it possible that your internet connection intercepts certain requests? That\

1548− \ sometimes causes problems for folks in schools, businesses, airports, hotels,\

1549− \ and certain countries. Try asking for help locally or in a community forum!"

1550− ]

1551−

1552− otherException ->

1553− toHttpReport (context ++ ", so I tried to fetch:") url

1554− [ D.reflow $ "But my HTTP library is giving me the following error message:"

1555− , D.indent 4 $ D.fromChars (show otherException)

1556− , D.reflow $

1557− "Are you somewhere with a slow internet connection? Or no internet?\

1558− \ Does the link I am trying to fetch work in your browser? Maybe the\

1559− \ site is down? Does your internet connection have a firewall that\

1560− \ blocks certain domains? It is usually something like that!"

1561− ]

1562−

1563− Http.BadMystery url someException ->

1564− toHttpReport (context ++ ", so I tried to fetch:") url

1565− [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"

1566− , D.indent 4 $ D.fromChars (show someException)

1567− , D.reflow $

1568− "Is it possible that your internet connection intercepts certain requests? That\

1569− \ sometimes causes problems for folks in schools, businesses, airports, hotels,\

1570− \ and certain countries. Try asking for help locally or in a community forum!"

1571− ]

1572−

1573−

1574−toRedirectDoc :: HTTP.Response body -> D.Doc

1575−toRedirectDoc response =

1576− let

1577− (HTTP.Status code message) = HTTP.responseStatus response

1578− in

1579− case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of

1580− Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)

1581− Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)

709+ DetailsNoSolution ->

710+ error "TODO DetailsNoSolution"

1582711

712+ DetailsNoOfflineSolution ->

713+ error "TODO DetailsNoOfflineSolution"

1583714

715+ DetailsSolverProblem _ ->

716+ error "TODO DetailsSolverProblem"

1584717

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

1599718

1600719

1601720makeToReport :: Make -> Help.Report

1602721makeToReport make =

1603722 case make of

1604− MakeNoOutline ->

723+ MakeNeedsOutline ->

1605724 Help.report "NO elm.json FILE" Nothing

1606725 "It looks like you are starting a new Elm project. Very exciting! Try running:"

1607726 [ D.indent 4 $ D.green $ "elm init"

@@ -1622,344 +741,27 @@ makeToReport make =

1622741 \ at once though! Pick just one of those flags and it should work!"

1623742 ]

1624743

1625− MakeBadDetails detailsProblem ->

1626− toDetailsReport detailsProblem

744+ MakeBlockedByDetailsProblem detailsProblem ->

745+ detailsToReport detailsProblem

1627746

1628747 MakeAppNeedsFileNames ->

1629748 Help.report "NO INPUT" Nothing

1630− "What should I make though? I need specific files like:"

1631− [ D.vcat

1632− [ D.indent 4 $ D.green "elm make src/Main.elm"

1633− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

1634− ]

1635− , D.reflow $

1636− "I recommend reading through https://guide.elm-lang.org for guidance on what to\

1637− \ actually put in those files!"

749+ "What should I make though? I need a specific file like this:"

750+ [ D.indent 4 $ D.green "elm make src/Main.elm"

751+ , D.reflow

752+ "However many files you give, I will create one JS file out of them."

1638753 ]

1639754

1640755 MakePkgNeedsExposing ->

1641− Help.report "NO INPUT" Nothing

1642− "What should I make though? I need specific files like:"

1643− [ D.vcat

1644− [ D.indent 4 $ D.green "elm make src/Main.elm"

1645− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

1646− ]

1647− , D.reflow $

1648− "You can also entries to the \"exposed-modules\" list in your elm.json file, and\

1649− \ I will try to compile the relevant files."

1650− ]

756+ error "TODO MakePkgNeedsExposing"

1651757

1652758 MakeMultipleFilesIntoHtml ->

1653− Help.report "TOO MANY FILES" Nothing

1654− (

1655− "When producing an HTML file, I can only handle one file."

1656− )

1657− [ D.fillSep

1658− ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"

1659− ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"

1660− ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."

1661− ]

1662− , D.fillSep

1663− ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"

1664− ,"`main`","values","available","in","a","single","JavaScript","file.","Then"

1665− ,"you","can","make","your","own","customized","HTML","file","that","embeds"

1666− ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"

1667− ,"dependencies","between","modules,","so","it","should","be","smaller","than"

1668− ,"compiling","each","module","separately."

1669− ]

1670− ]

759+ error "TODO MakeMultipleFilesIntoHtml"

1671760

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

761+ MakeNonMainFilesIntoJavaScript _ _ ->

762+ error "TODO MakeNonMainFilesIntoJavaScript"

1695763

1696− MakeNonMainFilesIntoJavaScript m ms ->

1697− case ms of

1698− [] ->

1699− Help.report "NO MAIN" Nothing

1700− (

1701− "When producing a JS file, I require that the given file has a `main` value. That\

1702− \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\

1703− \ resulting file!"

1704− )

1705− [ D.reflow $

1706− "Try adding a `main` value to your file? Or if you just want to verify that this\

1707− \ module compiles, switch to --output=/dev/null to skip the code gen phase\

1708− \ altogether."

1709− , D.toSimpleNote $

1710− "Adding a `main` value can be as brief as adding something like this:"

1711− , D.vcat

1712− [ D.fillSep [D.cyan "import","Html"]

1713− , ""

1714− , D.fillSep [D.green "main","="]

1715− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]

1716− ]

1717− , D.reflow $

1718− "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\

1719− \ make a `main` with no user interface."

1720− ]

1721−

1722− _:_ ->

1723− Help.report "NO MAIN" Nothing

1724− (

1725− "When producing a JS file, I require that given files all have `main` values.\

1726− \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\

1727− \ definitely defined in the resulting file. I am missing `main` values in:"

1728− )

1729− [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)

1730− , D.reflow $

1731− "Try adding a `main` value to them? Or if you just want to verify that these\

1732− \ modules compile, switch to --output=/dev/null to skip the code gen phase\

1733− \ altogether."

1734− , D.toSimpleNote $

1735− "Adding a `main` value can be as brief as adding something like this:"

1736− , D.vcat

1737− [ D.fillSep [D.cyan "import","Html"]

1738− , ""

1739− , D.fillSep [D.green "main","="]

1740− , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]

1741− ]

1742− , D.reflow $

1743− "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\

1744− \ make a `main` with no user interface."

1745− ]

1746−

1747− MakeCannotBuild buildProblem ->

1748− toBuildProblemReport buildProblem

1749−

1750− MakeBadGenerate generateProblem ->

1751− toGenerateReport generateProblem

1752−

1753−

1754−

1755−-- BUILD PROBLEM

1756−

1757−

1758−data BuildProblem

1759− = BuildBadModules FilePath Error.Module [Error.Module]

1760− | BuildProjectProblem BuildProjectProblem

1761−

1762−

1763−data BuildProjectProblem

1764− = BP_PathUnknown FilePath

1765− | BP_WithBadExtension FilePath

1766− | BP_WithAmbiguousSrcDir FilePath FilePath FilePath

1767− | BP_MainPathDuplicate FilePath FilePath

1768− | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath

1769− | BP_RootNameInvalid FilePath FilePath [String]

1770− | BP_CannotLoadDependencies

1771− | BP_Cycle ModuleName.Raw [ModuleName.Raw]

1772− | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))

1773−

1774−

1775−toBuildProblemReport :: BuildProblem -> Help.Report

1776−toBuildProblemReport problem =

1777− case problem of

1778− BuildBadModules root e es ->

1779− Help.compilerReport root e es

1780−

1781− BuildProjectProblem projectProblem ->

1782− toProjectProblemReport projectProblem

1783−

1784−

1785−toProjectProblemReport :: BuildProjectProblem -> Help.Report

1786−toProjectProblemReport projectProblem =

1787− case projectProblem of

1788− BP_PathUnknown path ->

1789− Help.report "FILE NOT FOUND" Nothing

1790− "I cannot find this file:"

1791− [ D.indent 4 $ D.red $ D.fromChars path

1792− , D.reflow $ "Is there a typo?"

1793− , D.toSimpleNote $

1794− "If you are just getting started, try working through the examples in the\

1795− \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\

1796− \ that typically go in a src/Main.elm file."

1797− ]

1798−

1799− BP_WithBadExtension path ->

1800− Help.report "UNEXPECTED FILE EXTENSION" Nothing

1801− "I can only compile Elm files (with a .elm extension) but you want me to compile:"

1802− [ D.indent 4 $ D.red $ D.fromChars path

1803− , D.reflow $ "Is there a typo? Can the file extension be changed?"

1804− ]

1805−

1806− BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->

1807− Help.report "CONFUSING FILE" Nothing

1808− "I am getting confused when I try to compile this file:"

1809− [ D.indent 4 $ D.red $ D.fromChars path

1810− , D.reflow $

1811− "I always check if files appear in any of the \"source-directories\" listed in\

1812− \ your elm.json to see if there might be some cached information about them. That\

1813− \ can help me compile faster! But in this case, it looks like this file may be in\

1814− \ either of these directories:"

1815− , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]

1816− , D.reflow $

1817− "Try to make it so no source directory contains another source directory!"

1818− ]

1819−

1820− BP_MainPathDuplicate path1 path2 ->

1821− Help.report "CONFUSING FILES" Nothing

1822− "You are telling me to compile these two files:"

1823− [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]

1824− , D.reflow $

1825− if path1 == path2 then

1826− "Why are you telling me twice? Is something weird going on with a script?\

1827− \ I figured I would let you know about it just in case something is wrong.\

1828− \ Only list it once and you should be all set!"

1829− else

1830− "But seem to be the same file though... It makes me think something tricky is\

1831− \ going on with symlinks in your project, so I figured I would let you know\

1832− \ about it just in case. Remove one of these files from your command to get\

1833− \ unstuck!"

1834− ]

1835−

1836− BP_RootNameDuplicate name outsidePath otherPath ->

1837− Help.report "MODULE NAME CLASH" Nothing

1838− "These two files are causing a module name clash:"

1839− [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]

1840− , D.reflow $

1841− "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\

1842− \ at the top, but they cannot have the same name!"

1843− , D.reflow $

1844− "Try changing to a different module name in one of them!"

1845− ]

1846−

1847− BP_RootNameInvalid givenPath srcDir _ ->

1848− Help.report "UNEXPECTED FILE NAME" Nothing

1849− "I am having trouble with this file name:"

1850− [ D.indent 4 $ D.red $ D.fromChars givenPath

1851− , D.reflow $

1852− "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\

1853− \ which is good, but I expect all of the files in there to use the following\

1854− \ module naming convention:"

1855− , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]

1856− , D.reflow $

1857− "Notice that the names always start with capital letters! Can you make your file\

1858− \ use this naming convention?"

1859− , D.toSimpleNote $

1860− "Having a strict naming convention like this makes it a lot easier to find\

1861− \ things in large projects. If you see a module imported, you know where to look\

1862− \ for the corresponding file every time!"

1863− ]

1864−

1865− BP_CannotLoadDependencies ->

1866− corruptCacheReport

1867−

1868− BP_Cycle name names ->

1869− Help.report "IMPORT CYCLE" Nothing

1870− "Your module imports form a cycle:"

1871− [ D.cycle 4 name names

1872− , D.reflow $

1873− "Learn more about why this is disallowed and how to break cycles here:"

1874− ++ D.makeLink "import-cycles"

1875− ]

1876−

1877− BP_MissingExposed (NE.List (name, problem) _) ->

1878− case problem of

1879− Import.NotFound ->

1880− Help.report "MISSING MODULE" (Just "elm.json")

1881− "The \"exposed-modules\" of your elm.json lists the following module:"

1882− [ D.indent 4 $ D.red $ D.fromName name

1883− , D.reflow $

1884− "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"

1885− ]

1886−

1887− Import.Ambiguous _ _ pkg _ ->

1888− Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

1889− "The \"exposed-modules\" of your elm.json lists the following module:"

1890− [ D.indent 4 $ D.red $ D.fromName name

1891− , D.reflow $

1892− "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\

1893− \ choosing a different name for your local file."

1894− ]

1895−

1896− Import.AmbiguousLocal path1 path2 paths ->

1897− Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

1898− "The \"exposed-modules\" of your elm.json lists the following module:"

1899− [ D.indent 4 $ D.red $ D.fromName name

1900− , D.reflow $

1901− "But I found multiple files with that name:"

1902− , D.dullyellow $ D.indent 4 $ D.vcat $

1903− map D.fromChars (path1:path2:paths)

1904− , D.reflow $

1905− "Change the module names to be distinct!"

1906− ]

1907−

1908− Import.AmbiguousForeign _ _ _ ->

1909− Help.report "MISSING MODULE" (Just "elm.json")

1910− "The \"exposed-modules\" of your elm.json lists the following module:"

1911− [ D.indent 4 $ D.red $ D.fromName name

1912− , D.reflow $

1913− "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"

1914− , D.toSimpleNote $

1915− "It is not possible to \"re-export\" modules from other packages. You can only\

1916− \ expose modules that you define in your own code."

1917− ]

1918−

1919−

1920−toModuleNameConventionTable :: FilePath -> [String] -> D.Doc

1921−toModuleNameConventionTable srcDir names =

1922− let

1923− toPair name =

1924− ( name

1925− , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"

1926− )

1927−

1928− namePairs = map toPair names

1929− nameWidth = maximum (11 : map (length . fst) namePairs)

1930− pathWidth = maximum ( 9 : map (length . snd) namePairs)

1931−

1932− padded width str =

1933− str ++ replicate (width - length str) ' '

1934−

1935− toRow (name, path) =

1936− D.fromChars $

1937− "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"

1938−

1939− bar =

1940− D.fromChars $

1941− "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"

1942− in

1943− D.indent 4 $ D.vcat $

1944− [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]

1945−

1946−

1947−

1948−-- GENERATE

1949−

1950−

1951−data Generate

1952− = GenerateCannotLoadArtifacts

1953− | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]

1954−

1955−

1956−toGenerateReport :: Generate -> Help.Report

1957−toGenerateReport problem =

1958− case problem of

1959− GenerateCannotLoadArtifacts ->

1960− corruptCacheReport

1961−

1962− GenerateCannotOptimizeDebugValues m ms ->

764+ MakeCannotOptimizeDebugValues m ms ->

1963765 Help.report "DEBUG REMNANTS" Nothing

1964766 "There are uses of the `Debug` module in the following modules:"

1965767 [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)

@@ -1968,7 +770,7 @@ toGenerateReport problem =

1968770 "The issue is that --optimize strips out info needed by `Debug` functions.\

1969771 \ Here are two examples:"

1970772 , D.indent 4 $ D.reflow $

1971− "(1) It shortens record field names. This makes the generated JavaScript\

773+ "(1) It shortens record field names. This makes the generated JavaScript is\

1972774 \ smaller, but `Debug.toString` cannot know the real field names anymore."

1973775 , D.indent 4 $ D.reflow $

1974776 "(2) Values like `type Height = Height Float` are unboxed. This reduces\

@@ -1981,89 +783,28 @@ toGenerateReport problem =

1981783 \ exists!"

1982784 ]

1983785

786+ MakeCannotBuild buildProblem ->

787+ case buildProblem of

788+ BuildProjectProblem bp ->

789+ case bp of

790+ BP_PathUnknown _ -> error "TODO BP_PathUnknown"

791+ BP_WithBadExtension _ -> error "TODO BP_WithBadExtension"

792+ BP_WithAmbiguousSrcDir _ _ -> error "TODO BP_WithAmbiguousSrcDir"

793+ BP_MainPathDuplicate _ _ -> error "TODO BP_MainPathDuplicate"

794+ BP_MainNameDuplicate _ _ _ -> error "TODO BP_MainNameDuplicate"

795+ BP_CannotLoadDependencies -> error "TODO BP_CannotLoadDependencies"

796+ BP_Cycle name names ->

797+ Help.report "IMPORT CYCLE" Nothing

798+ "Your module imports form a cycle:"

799+ [ D.cycle 4 name names

800+ , D.reflow $

801+ "Learn more about why this is disallowed and how to break cycles here:"

802+ ++ D.makeLink "import-cycles"

803+ ]

1984804

1985805

1986−-- CORRUPT CACHE

1987−

1988−

1989−corruptCacheReport :: Help.Report

1990−corruptCacheReport =

1991− Help.report "CORRUPT CACHE" Nothing

1992− "It looks like some of the information cached in elm-stuff/ has been corrupted."

1993− [ D.reflow $

1994− "Try deleting your elm-stuff/ directory to get unstuck."

1995− , D.toSimpleNote $

1996− "This almost certainly means that a 3rd party tool (or editor plugin) is\

1997− \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\

1998− \ one by one until you figure out which it is!"

1999− ]

2000−

2001−

2002−

2003−-- REACTOR

2004−

2005−

2006−data Reactor

2007− = ReactorNoOutline

2008− | ReactorBadDetails Details

2009− | ReactorBadBuild BuildProblem

2010− | ReactorBadGenerate Generate

2011−

2012−

2013−reactorToReport :: Reactor -> Help.Report

2014−reactorToReport problem =

2015− case problem of

2016− ReactorNoOutline ->

2017− Help.report "NEW PROJECT?" Nothing

2018− "Are you trying to start a new project? Try this command in the terminal:"

2019− [ D.indent 4 $ D.green "elm init"

2020− , D.reflow "It will help you get started!"

2021− ]

2022−

2023− ReactorBadDetails details ->

2024− toDetailsReport details

2025−

2026− ReactorBadBuild buildProblem ->

2027− toBuildProblemReport buildProblem

2028−

2029− ReactorBadGenerate generate ->

2030− toGenerateReport generate

2031−

2032−

2033−

2034−-- REPL

2035−

2036−

2037−data Repl

2038− = ReplBadDetails Details

2039− | ReplBadInput BS.ByteString Error.Error

2040− | ReplBadLocalDeps FilePath Error.Module [Error.Module]

2041− | ReplProjectProblem BuildProjectProblem

2042− | ReplBadGenerate Generate

2043− | ReplBadCache

2044− | ReplBlocked

2045−

2046−

2047−replToReport :: Repl -> Help.Report

2048−replToReport problem =

2049− case problem of

2050− ReplBadDetails details ->

2051− toDetailsReport details

2052−

2053− ReplBadInput source err ->

2054− Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []

2055−

2056− ReplBadLocalDeps root e es ->

2057− Help.compilerReport root e es

2058−

2059− ReplProjectProblem projectProblem ->

2060− toProjectProblemReport projectProblem

2061−

2062− ReplBadGenerate generate ->

2063− toGenerateReport generate

2064−

2065− ReplBadCache ->

2066− corruptCacheReport

806+ BuildModuleProblems p ps ->

807+ error "TODO MakeCannotBuild" p ps

2067808

2068− ReplBlocked ->

2069− corruptCacheReport

809+ MakeCannotLoadArtifacts ->

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

1414 where

1515

1616

17+import qualified Data.Utf8 as Utf8

1718import GHC.IO.Handle (hIsTerminalDevice)

1819import System.IO (Handle, hPutStr, stderr, stdout)

1920

@@ -21,7 +22,7 @@ import qualified Json.Encode as E

2122import Json.Encode ((==>))

2223import Reporting.Doc ((<+>))

2324import qualified Reporting.Doc as D

24−import qualified Reporting.Error as Error

25+import qualified Reporting.Exit.Compile as Compile

2526

2627

2728

@@ -29,7 +30,7 @@ import qualified Reporting.Error as Error

2930

3031

3132data Report

32− = CompilerReport FilePath Error.Module [Error.Module]

33+ = CompilerReport Compile.Exit [Compile.Exit]

3334 | Report

3435 { _title :: String

3536 , _path :: Maybe FilePath

@@ -52,7 +53,7 @@ jsonReport =

5253 Report

5354

5455

55−compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report

56+compilerReport :: Compile.Exit -> [Compile.Exit] -> Report

5657compilerReport =

5758 CompilerReport

5859

@@ -64,8 +65,8 @@ compilerReport =

6465reportToDoc :: Report -> D.Doc

6566reportToDoc report_ =

6667 case report_ of

67− CompilerReport root e es ->

68− Error.toDoc root e es

68+ CompilerReport e es ->

69+ Compile.toDoc e es

6970

7071 Report title maybePath message ->

7172 let

@@ -94,17 +95,17 @@ reportToDoc report_ =

9495reportToJson :: Report -> E.Value

9596reportToJson report_ =

9697 case report_ of

97− CompilerReport _ e es ->

98+ CompilerReport e es ->

9899 E.object

99− [ "type" ==> E.chars "compile-errors"

100− , "errors" ==> E.list Error.toJson (e:es)

100+ [ "type" ==> E.string "compile-errors"

101+ , "errors" ==> E.list Compile.toJson (e:es)

101102 ]

102103

103104 Report title maybePath message ->

104105 E.object

105− [ "type" ==> E.chars "error"

106− , "path" ==> maybe E.null E.chars maybePath

107− , "title" ==> E.chars title

106+ [ "type" ==> E.string "error"

107+ , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath

108+ , "title" ==> E.string (Utf8.fromChars title)

108109 , "message" ==> D.encode message

109110 ]

110111

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

33 ( Task

44 , run

55 , throw

6− , mapError

76 --

87 , io

9− , mio

108 , eio

119 )

1210 where

@@ -33,12 +31,6 @@ throw x =

3331 Task $ \_ err -> err x

3432

3533

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−

4234

4335-- IO

4436

@@ -49,15 +41,6 @@ io work =

4941 Task $ \ok _ -> work >>= ok

5042

5143

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−

6144eio :: (x -> y) -> IO (Either x a) -> Task y a

6245eio func work =

6346 Task $ \ok err ->

builder/src/Stuff.hs+9−8

@@ -8,8 +8,8 @@ module Stuff

88 , elmo

99 , temp

1010 , findRoot

11− , withRootLock

12− , withRegistryLock

11+ , withProjectLock

12+ , withCacheLock

1313 , PackageCache

1414 , getPackageCache

1515 , registry

@@ -120,16 +120,17 @@ findRootHelp dirs =

120120-- LOCKS

121121

122122

123−withRootLock :: FilePath -> IO a -> IO a

124−withRootLock root work =

123+withProjectLock :: FilePath -> IO a -> IO a

124+withProjectLock root work =

125125 do let dir = stuff root

126126 Dir.createDirectoryIfMissing True dir

127− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

127+ Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)

128128

129129

130−withRegistryLock :: PackageCache -> IO a -> IO a

131−withRegistryLock (PackageCache dir) work =

132− Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

130+withCacheLock :: PackageCache -> IO a -> IO a

131+withCacheLock (PackageCache dir) work =

132+ Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)

133+

133134

134135

135136

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

5656import qualified Data.List as List

5757import qualified Data.Map as Map

5858import Data.Name (Name)

59+import qualified Data.Utf8 as Utf8

5960

60−import qualified AST.Source as Src

6161import qualified AST.Utils.Binop as Binop

6262import qualified AST.Utils.Shader as Shader

6363import qualified Data.Index as Index

64−import qualified Elm.Float as EF

6564import qualified Elm.ModuleName as ModuleName

66−import qualified Elm.String as ES

6765import qualified Reporting.Annotation as A

6866

6967

@@ -84,10 +82,10 @@ data Expr_

8482 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation

8583 | VarDebug ModuleName.Canonical Name Annotation

8684 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization

87− | Chr ES.String

88− | Str ES.String

85+ | Chr Utf8.String

86+ | Str Utf8.String

8987 | Int Int

90− | Float EF.Float

88+ | Float (Utf8.Under256 Float)

9189 | List [Expr]

9290 | Negate Expr

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

@@ -152,8 +150,8 @@ data Pattern_

152150 | PList [Pattern]

153151 | PCons Pattern Pattern

154152 | PBool Union Bool

155− | PChr ES.String

156− | PStr ES.String

153+ | PChr Utf8.String

154+ | PStr Utf8.String

157155 | PInt Int

158156 | PCtor

159157 { _p_home :: ModuleName.Canonical

@@ -233,7 +231,6 @@ data Module =

233231 Module

234232 { _name :: ModuleName.Canonical

235233 , _exports :: Exports

236− , _docs :: Src.Docs

237234 , _decls :: Decls

238235 , _unions :: Map.Map Name Union

239236 , _aliases :: Map.Map Name Alias

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

342339 0 -> return Normal

343340 1 -> return Enum

344341 2 -> return Unbox

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

342+ _ -> error "binary encoding of CtorOpts was corrupted"

346343

347344

348345instance Binary Annotation where

@@ -393,7 +390,7 @@ instance Binary AliasType where

393390 case n of

394391 0 -> liftM Holey get

395392 1 -> liftM Filled get

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

393+ _ -> error "binary encoding of AliasType was corrupted"

397394

398395

399396instance Binary FieldType where

compiler/src/AST/Optimized.hs+14−31

@@ -27,15 +27,14 @@ import qualified Data.Map as Map

2727import qualified Data.Name as Name

2828import Data.Name (Name)

2929import qualified Data.Set as Set

30+import qualified Data.Utf8 as Utf8

3031

3132import qualified AST.Canonical as Can

3233import qualified AST.Utils.Shader as Shader

3334import qualified Data.Index as Index

34−import qualified Elm.Float as EF

3535import qualified Elm.Kernel as K

3636import qualified Elm.ModuleName as ModuleName

3737import qualified Elm.Package as Pkg

38−import qualified Elm.String as ES

3938import qualified Optimize.DecisionTree as DT

4039import qualified Reporting.Annotation as A

4140

@@ -46,10 +45,10 @@ import qualified Reporting.Annotation as A

4645

4746data Expr

4847 = Bool Bool

49− | Chr ES.String

50− | Str ES.String

48+ | Chr Utf8.String

49+ | Str Utf8.String

5150 | Int Int

52− | Float EF.Float

51+ | Float (Utf8.Under256 Float)

5352 | VarLocal Name

5453 | VarGlobal Global

5554 | VarEnum Global Index.ZeroBased

@@ -75,6 +74,7 @@ data Expr

7574

7675

7776data Global = Global ModuleName.Canonical Name

77+ deriving (Eq, Ord)

7878

7979

8080

@@ -135,7 +135,7 @@ data GlobalGraph =

135135data LocalGraph =

136136 LocalGraph

137137 { _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

139139 , _l_fields :: Map.Map Name Int

140140 }

141141

@@ -222,23 +222,6 @@ toKernelGlobal shortName =

222222

223223

224224

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−

242225-- BINARY

243226

244227

@@ -308,7 +291,7 @@ instance Binary Expr where

308291 24 -> pure Unit

309292 25 -> liftM3 Tuple get get get

310293 26 -> liftM3 Shader get get get

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

294+ _ -> error "problem getting Opt.Expr binary"

312295

313296

314297instance Binary Def where

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

322305 case word of

323306 0 -> liftM2 Def get get

324307 1 -> liftM3 TailDef get get get

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

308+ _ -> error "problem getting Opt.Def binary"

326309

327310

328311instance Binary Destructor where

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

345328 1 -> liftM2 Field get get

346329 2 -> liftM Unbox get

347330 3 -> liftM Root get

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

331+ _ -> error "problem getting Opt.Path binary"

349332

350333

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

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

361344 0 -> liftM Leaf get

362345 1 -> liftM3 Chain get get get

363346 2 -> liftM3 FanOut get get get

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

347+ _ -> error "problem getting Opt.Decider binary"

365348

366349

367350instance Binary Choice where

@@ -375,7 +358,7 @@ instance Binary Choice where

375358 case word of

376359 0 -> liftM Inline get

377360 1 -> liftM Jump get

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

361+ _ -> error "problem getting Opt.Choice binary"

379362

380363

381364

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

400383 case word of

401384 0 -> return Static

402385 1 -> liftM2 Dynamic get get

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

386+ _ -> error "problem getting Opt.Main binary"

404387

405388

406389instance Binary Node where

@@ -432,7 +415,7 @@ instance Binary Node where

432415 8 -> liftM2 Kernel get get

433416 9 -> liftM2 PortIncoming get get

434417 10 -> liftM2 PortOutgoing get get

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

418+ _ -> error "problem getting Opt.Node binary"

436419

437420

438421instance Binary EffectsType where

@@ -448,4 +431,4 @@ instance Binary EffectsType where

448431 0 -> return Cmd

449432 1 -> return Sub

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

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

23module AST.Source

34 ( Expr, Expr_(..), VarType(..)

45 , Def(..)

@@ -11,12 +12,10 @@ module AST.Source

1112 , Value(..)

1213 , Union(..)

1314 , Alias(..)

14− , Infix(..)

15+ , Binop(..)

1516 , Port(..)

1617 , Effects(..)

1718 , Manager(..)

18− , Docs(..)

19− , Comment(..)

2019 , Exposing(..)

2120 , Exposed(..)

2221 , Privacy(..)

@@ -25,13 +24,10 @@ module AST.Source

2524

2625

2726import Data.Name (Name)

28−import qualified Data.Name as Name

27+import qualified Data.Utf8 as Utf8

2928

3029import qualified AST.Utils.Binop as Binop

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

3531import qualified Reporting.Annotation as A

3632

3733

@@ -43,10 +39,10 @@ type Expr = A.Located Expr_

4339

4440

4541data Expr_

46− = Chr ES.String

47− | Str ES.String

42+ = Chr Utf8.String

43+ | Str Utf8.String

4844 | Int Int

49− | Float EF.Float

45+ | Float (Utf8.Under256 Float)

5046 | Var VarType Name

5147 | VarQual VarType Name Name

5248 | List [Expr]

@@ -97,8 +93,8 @@ data Pattern_

9793 | PCtorQual A.Region Name Name [Pattern]

9894 | PList [Pattern]

9995 | PCons Pattern Pattern

100− | PChr ES.String

101− | PStr ES.String

96+ | PChr Utf8.String

97+ | PStr Utf8.String

10298 | PInt Int

10399

104100

@@ -126,26 +122,22 @@ data Type_

126122

127123data Module =

128124 Module

129− { _name :: Maybe (A.Located Name)

125+ { _name :: Maybe Name

130126 , _exports :: A.Located Exposing

131− , _docs :: Docs

132127 , _imports :: [Import]

133128 , _values :: [A.Located Value]

134129 , _unions :: [A.Located Union]

135130 , _aliases :: [A.Located Alias]

136− , _binops :: [A.Located Infix]

131+ , _binops :: [A.Located Binop]

137132 , _effects :: Effects

138133 }

139134

140135

141136getName :: Module -> Name

142−getName (Module maybeName _ _ _ _ _ _ _ _) =

137+getName (Module maybeName _ _ _ _ _ _ _) =

143138 case maybeName of

144− Just (A.At _ name) ->

145− name

146−

147− Nothing ->

148− Name._Main

139+ Just name -> name

140+ Nothing -> "Main"

149141

150142

151143getImportName :: Import -> Name

@@ -164,7 +156,7 @@ data Import =

164156data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)

165157data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]

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

168160data Port = Port (A.Located Name) Type

169161

170162

@@ -180,30 +172,21 @@ data Manager

180172 | Fx (A.Located Name) (A.Located Name)

181173

182174

183−data Docs

184− = NoDocs A.Region

185− | YesDocs Comment [(Name, Comment)]

186−

187−

188−newtype Comment =

189− Comment P.Snippet

190−

191−

192175

193176-- EXPOSING

194177

195178

196179data Exposing

197180 = Open

198− | Explicit [Exposed]

181+ | Explicit [A.Located Exposed]

199182

200183

201184data Exposed

202− = Lower (A.Located Name)

203− | Upper (A.Located Name) Privacy

204− | Operator A.Region Name

185+ = Lower Name

186+ | Upper Name Privacy

187+ | Operator Name

205188

206189

207190data Privacy

208− = Public A.Region

191+ = Public

209192 | Private

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

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

4141instance Binary Associativity where

4242 get =

4343 do n <- getWord8

44− case n of

45− 0 -> return Left

46− 1 -> return Non

47− 2 -> return Right

48− _ -> fail "Error reading valid associativity from serialized string"

44+ return $

45+ case n of

46+ 0 -> Left

47+ 1 -> Non

48+ 2 -> Right

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

4950

5051 put assoc =

5152 putWord8 $

compiler/src/AST/Utils/Shader.hs+4−51

@@ -4,27 +4,22 @@ module AST.Utils.Shader

44 ( Source

55 , Types(..)

66 , Type(..)

7− , fromChars

8− , toJsStringBuilder

97 )

108 where

119

1210

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

1811import qualified Data.Map as Map

1912import qualified Data.Name as Name

13+import qualified Data.Utf8 as Utf8

2014

2115

2216

2317-- SOURCE

2418

2519

26−newtype Source =

27− Source BS.ByteString

20+type Source = Utf8.VeryLong SOURCE

21+

22+data SOURCE

2823

2924

3025

@@ -47,45 +42,3 @@ data Type

4742 | V4

4843 | M4

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

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

23module AST.Utils.Type

34 ( delambda

45 , dealias

compiler/src/Canonicalize/Environment.hs+20−50

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

44 ( Env(..)

55 , Exposed

66 , Qualified

7− , Info(..)

8− , mergeInfo

97 , Var(..)

108 , Type(..)

119 , Ctor(..)

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

2220

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

2422import qualified Data.Map.Strict as Map

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

2524import qualified Data.Name as Name

26−import qualified Data.OneOrMore as OneOrMore

2725

2826import qualified AST.Utils.Binop as Binop

2927import qualified AST.Canonical as Can

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

6058

6159

6260type Exposed a =

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

61+ Map.Map Name.Name (Map.Map ModuleName.Canonical a)

6462

6563

6664type Qualified a =

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

68−

69−

70−

71−-- INFO

72−

73−

74−data Info a

75− = Specific ModuleName.Canonical a

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

77−

78−

79−mergeInfo :: Info a -> Info a -> Info a

80−mergeInfo info1 info2 =

81− case info1 of

82− Specific h1 _ ->

83− case info2 of

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

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

86−

87− Ambiguous h1 hs1 ->

88− case info2 of

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

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

65+ Map.Map Name.Name (Map.Map Name.Name (Map.Map ModuleName.Canonical a))

9166

9267

9368

@@ -97,8 +72,7 @@ mergeInfo info1 info2 =

9772data Var

9873 = Local A.Region

9974 | TopLevel A.Region

100− | Foreign ModuleName.Canonical Can.Annotation

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

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

10276

10377

10478

@@ -165,10 +139,7 @@ addLocalLeft _ region =

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

166140addLocalBoth name region var =

167141 case var of

168− Foreign _ _ ->

169− Result.ok (Local region)

170−

171− Foreigns _ _ ->

142+ Foreign _ ->

172143 Result.ok (Local region)

173144

174145 Local parentRegion ->

@@ -179,18 +150,17 @@ addLocalBoth name region var =

179150

180151

181152

182−

183153-- FIND TYPE

184154

185155

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

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

188158 case Map.lookup name ts of

189− Just (Specific _ tipe) ->

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

190160 Result.ok tipe

191161

192− Just (Ambiguous h hs) ->

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

162+ Just homes ->

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

194164

195165 Nothing ->

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

@@ -201,11 +171,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

201171 case Map.lookup prefix qts of

202172 Just qualified ->

203173 case Map.lookup name qualified of

204− Just (Specific _ tipe) ->

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

205175 Result.ok tipe

206176

207− Just (Ambiguous h hs) ->

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

177+ Just homes ->

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

209179

210180 Nothing ->

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

@@ -221,11 +191,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

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

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

223193 case Map.lookup name cs of

224− Just (Specific _ ctor) ->

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

225195 Result.ok ctor

226196

227− Just (Ambiguous h hs) ->

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

197+ Just homes ->

198+ Result.throw (Error.AmbiguousVariant region Nothing name (Map.keys homes))

229199

230200 Nothing ->

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

@@ -236,11 +206,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

236206 case Map.lookup prefix qcs of

237207 Just qualified ->

238208 case Map.lookup name qualified of

239− Just (Specific _ pattern) ->

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

240210 Result.ok pattern

241211

242− Just (Ambiguous h hs) ->

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

212+ Just homes ->

213+ Result.throw (Error.AmbiguousVariant region (Just prefix) name (Map.keys homes))

244214

245215 Nothing ->

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

@@ -256,11 +226,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

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

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

258228 case Map.lookup name binops of

259− Just (Specific _ binop) ->

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

260230 Result.ok binop

261231

262− Just (Ambiguous h hs) ->

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

232+ Just homes ->

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

264234

265235 Nothing ->

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

5757 OneOrMore.One (Info _ value) ->

5858 return value

5959

60− OneOrMore.More left right ->

61− let

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

63− OneOrMore.getFirstTwo left right

64− in

60+ OneOrMore.More _ _ ->

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

6562 Result.throw (toError name r1 r2)

6663

6764

@@ -105,7 +102,7 @@ one name region value =

105102

106103insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a

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

109106

110107

111108union :: Dict a -> Dict a -> Dict a

compiler/src/Canonicalize/Environment/Foreign.hs+37−49

@@ -35,14 +35,7 @@ type Result i w a =

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

3636createInitialEnv home ifaces imports =

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

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

39−

40−

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

42−infoToVar info =

43− case info of

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

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

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

4639

4740

4841

@@ -68,7 +61,7 @@ emptyState =

6861

6962emptyTypes :: Env.Exposed Env.Type

7063emptyTypes =

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

7265

7366

7467

@@ -109,8 +102,8 @@ addImport ifaces (State vs ts cs bs qvs qts qcs) (Src.Import (A.At _ name) maybe

109102 (Map.mapMaybeWithKey (unionToType home) unions)

110103 (Map.mapMaybeWithKey (aliasToType home) aliases)

111104

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

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

105+ !vars = Map.map (Map.singleton home) defs

106+ !types = Map.map (Map.singleton home . fst) rawTypeInfo

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

115108

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

136129

137130addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a

138131addExposed =

139− Map.unionWith Env.mergeInfo

132+ Map.unionWith Map.union

140133

141134

142135addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a

@@ -157,7 +150,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,

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

158151 let

159152 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

161154 in

162155 ( Env.Union (length vars) home

163156 , List.foldl' addCtor Map.empty ctors

@@ -188,7 +181,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =

188181 (Can.TAlias home name avars (Can.Filled tipe))

189182 (Can.fieldsToList fields)

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

192185

193186 _ ->

194187 Map.empty

@@ -199,9 +192,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =

199192-- BINOP

200193

201194

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

203196binopToBinop 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)

205198

206199

207200

@@ -214,19 +207,19 @@ addExposedValue

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

215208 -> Map.Map Name.Name I.Binop

216209 -> State

217− -> Src.Exposed

210+ -> A.Located Src.Exposed

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

220213 case exposed of

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

214+ Src.Lower name ->

222215 case Map.lookup name vars of

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

225218

226219 Nothing ->

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

228221

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

222+ Src.Upper name privacy ->

230223 case privacy of

231224 Src.Private ->

232225 case Map.lookup name types of

@@ -234,43 +227,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =

234227 case tipe of

235228 Env.Union _ _ ->

236229 let

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

230+ !ts2 = Map.insert name (Map.singleton home tipe) ts

238231 in

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

240233

241234 Env.Alias _ _ _ _ ->

242235 let

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

236+ !ts2 = Map.insert name (Map.singleton home tipe) ts

244237 !cs2 = addExposed cs ctors

245238 in

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

247240

248241 Nothing ->

249− case checkForCtorMistake name types of

250− tipe:_ ->

242+ case Map.lookup name (toCtors types) of

243+ Just tipe ->

251244 Result.throw $ Error.ImportCtorByName region name tipe

252245

253− [] ->

246+ Nothing ->

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

255248

256− Src.Public dotDotRegion ->

249+ Src.Public ->

257250 case Map.lookup name types of

258251 Just (tipe, ctors) ->

259252 case tipe of

260253 Env.Union _ _ ->

261254 let

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

255+ !ts2 = Map.insert name (Map.singleton home tipe) ts

263256 !cs2 = addExposed cs ctors

264257 in

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

266259

267260 Env.Alias _ _ _ _ ->

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

261+ Result.throw (Error.ImportOpenAlias region name)

269262

270263 Nothing ->

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

272265

273− Src.Operator region op ->

266+ Src.Operator op ->

274267 case Map.lookup op binops of

275268 Just binop ->

276269 let

@@ -282,23 +275,18 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) exposed =

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

283276

284277

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

286−checkForCtorMistake givenName types =

287− Map.foldr addMatches [] types

278+

279+toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name

280+toCtors types =

281+ Map.foldr addCtors Map.empty types

288282 where

289− addMatches (_, exposedCtors) matches =

290− Map.foldrWithKey addMatch matches exposedCtors

291−

292− addMatch ctorName info matches =

293− if ctorName /= givenName

294− then matches

295− else

296− case info of

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

298− tipeName : matches

299−

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

301− matches

302−

303− Env.Ambiguous _ _ ->

304− matches

283+ addCtors (_, exposedCtors) dict =

284+ Map.foldrWithKey addCtor dict exposedCtors

285+

286+ addCtor ctorName homes dict =

287+ case Map.elems homes of

288+ [Env.Ctor _ tipeName _ _ _] ->

289+ Map.insert ctorName tipeName dict

290+

291+ _ ->

292+ dict

compiler/src/Canonicalize/Environment/Local.hs+8−8

@@ -54,7 +54,7 @@ addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =

5454

5555

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

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

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

5858 let

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

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

@@ -95,7 +95,7 @@ toEffectDups effects =

9595

9696

9797addTypes :: 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) =

9999 let

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

101101 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

110110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)

111111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =

112112 do arity <- checkUnionFreeVars union

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

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

114114 Result.ok $ Map.insert name one types

115115

116116

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

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

134134 do args <- checkAliasFreeVars alias

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

137137 let ts1 = Map.insert name one ts

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

139139

@@ -262,7 +262,7 @@ addFreeVars freeVars (A.At region tipe) =

262262

263263

264264addCtors :: 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) =

266266 do unionInfo <- traverse (canonicalizeUnion env) unions

267267 aliasInfo <- traverse (canonicalizeAlias env) aliases

268268

@@ -281,7 +281,7 @@ addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs

281281 )

282282

283283

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

284+type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)

285285

286286

287287

@@ -297,7 +297,7 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At regi

297297 ,

298298 case ctipe of

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

301301

302302 _ ->

303303 Dups.none

@@ -351,5 +351,5 @@ toOpts ctors =

351351

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

353353toCtor 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 $

355355 Env.Ctor home typeName union index args

compiler/src/Canonicalize/Expression.hs+7−6

@@ -14,6 +14,7 @@ import Control.Monad (foldM)

1414import qualified Data.Graph as Graph

1515import qualified Data.List as List

1616import qualified Data.Map.Strict as Map

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

1718import qualified Data.Name as Name

1819

1920import qualified AST.Canonical as Can

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

695696 Env.TopLevel _ ->

696697 logVar name (Can.VarTopLevel localHome name)

697698

698− Env.Foreign home annotation ->

699+ Env.Foreign (I.Bin 1 home annotation _ _) ->

699700 Result.ok $

700701 if home == ModuleName.debug then

701702 Can.VarDebug localHome name annotation

702703 else

703704 Can.VarForeign home name annotation

704705

705− Env.Foreigns h hs ->

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

706+ Env.Foreign homes ->

707+ Result.throw (Error.AmbiguousVar region Nothing name (Map.keys homes))

707708

708709 Nothing ->

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

@@ -714,15 +715,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =

714715 case Map.lookup prefix qvs of

715716 Just qualified ->

716717 case Map.lookup name qualified of

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

718+ Just (I.Bin 1 home annotation _ _) ->

718719 Result.ok $

719720 if home == ModuleName.debug then

720721 Can.VarDebug localHome name annotation

721722 else

722723 Can.VarForeign home name annotation

723724

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

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

725+ Just homes ->

726+ Result.throw (Error.AmbiguousVar region (Just prefix) name (Map.keys homes))

726727

727728 Nothing ->

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

4242

4343

4444canonicalize :: 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) =

4646 do let home = ModuleName.Canonical pkg (Src.getName modul)

4747 let cbinops = Map.fromList (map canonicalizeBinop binops)

4848

@@ -54,15 +54,15 @@ canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ bino

5454 ceffects <- Effects.canonicalize env values cunions effects

5555 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports

5656

57− return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects

57+ return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects

5858

5959

6060

6161-- CANONICALIZE BINOP

6262

6363

64−canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )

65−canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =

64+canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )

65+canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =

6666 ( op, Can.Binop_ associativity precedence func )

6767

6868

@@ -236,11 +236,11 @@ checkExposed

236236 -> Map.Map Name.Name alias

237237 -> Map.Map Name.Name binop

238238 -> Can.Effects

239− -> Src.Exposed

239+ -> A.Located Src.Exposed

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

242242 case exposed of

243− Src.Lower (A.At region name) ->

243+ Src.Lower name ->

244244 if Map.member name values then

245245 ok name region Can.ExportValue

246246 else

@@ -252,23 +252,23 @@ checkExposed values unions aliases binops effects exposed =

252252 Result.throw $ Error.ExportNotFound region Error.BadVar name $

253253 ports ++ Map.keys values

254254

255− Src.Operator region name ->

255+ Src.Operator name ->

256256 if Map.member name binops then

257257 ok name region Can.ExportBinop

258258 else

259259 Result.throw $ Error.ExportNotFound region Error.BadOp name $

260260 Map.keys binops

261261

262− Src.Upper (A.At region name) (Src.Public dotDotRegion) ->

262+ Src.Upper name Src.Public ->

263263 if Map.member name unions then

264264 ok name region Can.ExportUnionOpen

265265 else if Map.member name aliases then

266− Result.throw $ Error.ExportOpenAlias dotDotRegion name

266+ Result.throw $ Error.ExportOpenAlias region name

267267 else

268268 Result.throw $ Error.ExportNotFound region Error.BadType name $

269269 Map.keys unions ++ Map.keys aliases

270270

271− Src.Upper (A.At region name) Src.Private ->

271+ Src.Upper name Src.Private ->

272272 if Map.member name unions then

273273 ok name region Can.ExportUnionClosed

274274 else if Map.member name aliases then

compiler/src/Canonicalize/Pattern.hs+2−3

@@ -8,7 +8,6 @@ module Canonicalize.Pattern

88 where

99

1010

11−import qualified Data.List as List

1211import qualified Data.Map.Strict as Map

1312import qualified Data.Name as Name

1413

@@ -174,8 +173,8 @@ logVar name region value =

174173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a

175174logFields fields value =

176175 let

177− addField dict (A.At region name) =

176+ addField (A.At region name) dict =

178177 Dups.insert name region region dict

179178 in

180179 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

88

99import qualified Data.Map as Map

1010import qualified Data.Name as Name

11+import qualified Data.OneOrMore as OneOrMore

1112

1213import qualified AST.Source as Src

1314import qualified AST.Canonical as Can

@@ -20,7 +21,7 @@ import qualified Nitpick.PatternMatches as PatternMatches

2021import qualified Optimize.Module as Optimize

2122import qualified Reporting.Error as E

2223import qualified Reporting.Result as R

23−import qualified Reporting.Render.Type.Localizer as Localizer

24+import qualified Reporting.Warning as W

2425import qualified Type.Constrain.Module as Type

2526import qualified Type.Solve as Type

2627

@@ -39,12 +40,13 @@ data Artifacts =

3940 }

4041

4142

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

4344compile pkg ifaces modul =

45+ snd $ R.run $

4446 do canonical <- canonicalize pkg ifaces modul

45− annotations <- typeCheck modul canonical

47+ annotations <- typeCheck canonical

4648 () <- nitpick canonical

47− objects <- optimize modul annotations canonical

49+ objects <- optimize annotations canonical

4850 return (Artifacts canonical annotations objects)

4951

5052

@@ -52,41 +54,31 @@ compile pkg ifaces modul =

5254-- PHASES

5355

5456

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

5658canonicalize pkg ifaces modul =

57− case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of

58− Right canonical ->

59− Right canonical

60−

61− Left errors ->

62− Left $ E.BadNames errors

59+ R.mapError E.Canonicalize $ Canonicalize.canonicalize pkg ifaces modul

6360

6461

65−typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)

66−typeCheck modul canonical =

62+typeCheck :: Can.Module -> R.Result i w E.Error (Map.Map Name.Name Can.Annotation)

63+typeCheck canonical =

6764 case unsafePerformIO (Type.run =<< Type.constrain canonical) of

6865 Right annotations ->

69− Right annotations

66+ R.ok annotations

7067

7168 Left errors ->

72− Left (E.BadTypes (Localizer.fromModule modul) errors)

69+ R.throw (E.Type errors)

7370

7471

75−nitpick :: Can.Module -> Either E.Error ()

72+nitpick :: Can.Module -> R.Result i w E.Error ()

7673nitpick canonical =

7774 case PatternMatches.check canonical of

7875 Right () ->

79− Right ()

76+ R.ok ()

8077

8178 Left errors ->

82− Left (E.BadPatterns errors)

79+ R.throw (E.Pattern errors)

8380

8481

85−optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph

86−optimize modul annotations canonical =

87− case snd $ R.run $ Optimize.optimize annotations canonical of

88− Right localGraph ->

89− Right localGraph

90−

91− Left errors ->

92− Left (E.BadMains (Localizer.fromModule modul) errors)

82+optimize :: Map.Map Name.Name Can.Annotation -> Can.Module -> R.Result i [W.Warning] E.Error Opt.LocalGraph

83+optimize annotations canonical =

84+ R.mapError E.Main $ Optimize.optimize annotations canonical

compiler/src/Data/Map/Utils.hs−6

@@ -1,7 +1,6 @@

11module Data.Map.Utils

22 ( fromKeys

33 , fromKeysA

4− , fromValues

54 , any

65 )

76 where

@@ -26,11 +25,6 @@ fromKeysA toValue keys =

2625 Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys

2726

2827

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−

3428

3529-- ANY

3630

compiler/src/Data/Name.hs+177−166

@@ -1,119 +1,130 @@

11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}

33module Data.Name

44 ( Name

5− --

6− , toChars

7− , toElmString

8− , toBuilder

9− --

10− , fromPtr

11− , fromChars

12− --

5+ , toUtf8

6+ , fromUtf8

7+ , toEscapedBuilder

8+ , Utf8.toBuilder

9+ , Utf8.fromPtr

10+ , Utf8.fromChars

11+ , Utf8.toChars

12+ -- misc

1313 , getKernel

1414 , hasDot

15− , splitDots

1615 , isKernel

1716 , isNumberType

1817 , isComparableType

1918 , isAppendableType

2019 , isCompappendType

2120 , fromVarIndex

21+ , fromReplCount

2222 , fromWords

2323 , fromManyNames

2424 , fromTypeVariable

2525 , fromTypeVariableScheme

2626 , sepBy

27− --

27+ -- interned

2828 , int, float, bool, char, string

2929 , maybe, result, list, array, dict, tuple, jsArray

3030 , task, router, cmd, sub, platform, virtualDom

3131 , shader, debug, debugger, bitwise, basics

3232 , utils, negate, true, false, value

33− , node, program, _main, _Main, dollar, identity

34− , replModule, replValueToPrint

33+ , node, program, main, dollar, identity

34+ , replModule

3535 )

3636 where

3737

3838

3939import Prelude hiding (length, maybe, negate)

4040import Control.Exception (assert)

41−import qualified Data.Binary as Binary

4241import qualified Data.ByteString.Builder.Internal as B

43−import qualified Data.Coerce as Coerce

42+import Data.Coerce (coerce)

4443import qualified Data.List as List

45−import qualified Data.String as Chars

4644import qualified Data.Utf8 as Utf8

45+import Foreign.Ptr (plusPtr, minusPtr)

4746import GHC.Exts

48− ( Int(I#), Ptr

47+ ( Int(I#), Ptr(Ptr)

48+ , RealWorld

4949 , MutableByteArray#

5050 , isTrue#

5151 , newByteArray#

5252 , sizeofByteArray#

53+ , writeWord8OffAddr#

54+ , copyByteArrayToAddr#

5355 , unsafeFreezeByteArray#

5456 )

57+import GHC.IO

5558import GHC.ST (ST(ST), runST)

5659import GHC.Prim

5760import GHC.Word (Word8(W8#))

5861

59−import qualified Elm.String as ES

60−

6162

6263

6364-- NAME

6465

6566

66−type Name =

67− Utf8.Utf8 ELM_NAME

68−

69−

70−data ELM_NAME

71−

72−

73−

74−-- INSTANCES

75−

67+type Name = Utf8.Under256 NAME

7668

77−instance Chars.IsString (Utf8.Utf8 ELM_NAME) where

78− fromString = Utf8.fromChars

7969

80−instance Binary.Binary (Utf8.Utf8 ELM_NAME) where

81− get = Utf8.getUnder256

82− put = Utf8.putUnder256

70+data NAME

8371

8472

73+toUtf8 :: Name -> Utf8.String

74+toUtf8 =

75+ coerce

8576

86−-- TO

8777

78+fromUtf8 :: Utf8.String -> Name

79+fromUtf8 =

80+ coerce

8881

89−toChars :: Name -> [Char]

90−toChars =

91− Utf8.toChars

9282

9383

94−toElmString :: Name -> ES.String

95−toElmString =

96− Coerce.coerce

84+-- TO ESCAPED BUILDER

9785

9886

99−{-# INLINE toBuilder #-}

100−toBuilder :: Name -> B.Builder

101−toBuilder =

102− Utf8.toBuilder

87+{-# INLINE toEscapedBuilder #-}

88+toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder

89+toEscapedBuilder before after =

90+ \name -> B.builder (toEscapedBuilderHelp before after name)

10391

10492

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)

105125

106−-- FROM

107−

108−

109−fromPtr :: Ptr Word8 -> Ptr Word8 -> Name

110−fromPtr =

111− Utf8.fromPtr

112−

113−

114−fromChars :: [Char] -> Name

115−fromChars =

116− Utf8.fromChars

126+ else

127+ return ()

117128

118129

119130

@@ -122,12 +133,7 @@ fromChars =

122133

123134hasDot :: Name -> Bool

124135hasDot name =

125− Utf8.contains 0x2E {- . -} name

126−

127−

128−splitDots :: Name -> [Name]

129−splitDots name =

130− Utf8.split 0x2E {- . -} name

136+ Utf8.contains 0x2E {- . -} (coerce name)

131137

132138

133139

@@ -175,23 +181,23 @@ isCompappendType = Utf8.startsWith prefix_compappend

175181

176182{-# NOINLINE prefix_kernel #-}

177183prefix_kernel :: Name

178−prefix_kernel = fromChars "Elm.Kernel."

184+prefix_kernel = "Elm.Kernel."

179185

180186{-# NOINLINE prefix_number #-}

181187prefix_number :: Name

182−prefix_number = fromChars "number"

188+prefix_number = "number"

183189

184190{-# NOINLINE prefix_comparable #-}

185191prefix_comparable :: Name

186−prefix_comparable = fromChars "comparable"

192+prefix_comparable = "comparable"

187193

188194{-# NOINLINE prefix_appendable #-}

189195prefix_appendable :: Name

190−prefix_appendable = fromChars "appendable"

196+prefix_appendable = "appendable"

191197

192198{-# NOINLINE prefix_compappend #-}

193199prefix_compappend :: Name

194−prefix_compappend = fromChars "compappend"

200+prefix_compappend = "compappend"

195201

196202

197203

@@ -202,11 +208,11 @@ fromVarIndex :: Int -> Name

202208fromVarIndex n =

203209 runST

204210 (

205− do let !size = 2 + getIndexSize n

211+ do let !size = getIndexSize n

206212 mba <- newByteArray size

207213 writeWord8 mba 0 0x5F {- _ -}

208214 writeWord8 mba 1 0x76 {- v -}

209− writeDigitsAtEnd mba size n

215+ writeDigits mba (size - 1) n

210216 freeze mba

211217 )

212218

@@ -214,20 +220,19 @@ fromVarIndex n =

214220{-# INLINE getIndexSize #-}

215221getIndexSize :: Int -> Int

216222getIndexSize n

217− | n < 10 = 1

218− | n < 100 = 2

219− | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

223+ | n < 10 = 3

224+ | n < 100 = 4

225+ | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)

220226

221227

222228

223−writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()

224−writeDigitsAtEnd !mba !oldOffset !n =

229+writeDigits :: MBA s -> Int -> Int -> ST s ()

230+writeDigits !mba !offset !n =

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

228233 if q <= 0

229234 then return ()

230− else writeDigitsAtEnd mba newOffset q

235+ else writeDigits mba (offset-1) q

231236

232237

233238

@@ -250,7 +255,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =

250255 mba <- newByteArray size

251256 copyToMBA name mba

252257 writeWord8 mba (I# len#) 0x5F {- _ -}

253− writeDigitsAtEnd mba size index

258+ writeDigits mba (size - 1) index

254259 freeze mba

255260 )

256261 else

@@ -259,7 +264,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =

259264 do let !size = I# len# + getIndexSize index

260265 mba <- newByteArray size

261266 copyToMBA name mba

262− writeDigitsAtEnd mba size index

267+ writeDigits mba (size - 1) index

263268 freeze mba

264269 )

265270

@@ -278,61 +283,61 @@ fromTypeVariableScheme scheme =

278283 freeze mba

279284 else

280285 do let (extra, letter) = quotRem scheme 26

281− let !size = 1 + getIndexSize extra

286+ let !size = getIndexSize extra

282287 mba <- newByteArray size

283288 writeWord8 mba 0 (0x61 + fromIntegral letter)

284− writeDigitsAtEnd mba size extra

289+ writeDigits mba (size - 1) extra

285290 freeze mba

286291 )

287292

288293

289294

295+-- FROM REPL COUNT

296+

297+

298+fromReplCount :: Int -> Name

299+fromReplCount n =

300+ Utf8.fromChars ("repl_value_" ++ show n)

301+

302+

303+

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

300305

301306

302307fromManyNames :: [Name] -> Name

303308fromManyNames names =

304− case names of

305− [] ->

306− blank

307− -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)

308− -- but maybe unused patterns should be stripped out instead

309−

310− Utf8.Utf8 ba# : _ ->

311− let

312− len# = sizeofByteArray# ba#

313− in

314− runST

315− (

316− ST $ \s ->

317− case newByteArray# (len# +# 3#) s of

318− (# s, mba# #) ->

319− case writeWord8Array# mba# 0# 0x5F## {-_-} s of

320− s ->

321− case writeWord8Array# mba# 1# 0x4D## {-M-} s of

322− s ->

323− case writeWord8Array# mba# 2# 0x24## {-$-} s of

324− s ->

325− case copyByteArray# ba# 0# mba# 3# len# s of

326− s ->

327− case unsafeFreezeByteArray# mba# s of

328− (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

329− )

309+ let

310+ !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)

311+ in

312+ runST

313+ (

314+ ST $ \s ->

315+ case newByteArray# size# s of

316+ (# s, mba# #) ->

317+ case writeNames mba# 0# names s of

318+ s ->

319+ case unsafeFreezeByteArray# mba# s of

320+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

321+ )

330322

331323

332−{-# NOINLINE blank #-}

333−blank :: Name

334−blank =

335− fromWords [0x5F,0x4D,0x24] {-_M$-}

324+writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s

325+writeNames mba# !offset# names s =

326+ case names of

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

336341

337342

338343

@@ -418,6 +423,22 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

418423 s -> (# s, () #)

419424

420425

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+

421442{-# INLINE copyToMBA #-}

422443copyToMBA :: Name -> MBA s -> ST s ()

423444copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

@@ -432,179 +453,169 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

432453

433454{-# NOINLINE int #-}

434455int :: Name

435−int = fromChars "Int"

456+int = "Int"

436457

437458

438459{-# NOINLINE float #-}

439460float :: Name

440−float = fromChars "Float"

461+float = "Float"

441462

442463

443464{-# NOINLINE bool #-}

444465bool :: Name

445−bool = fromChars "Bool"

466+bool = "Bool"

446467

447468

448469{-# NOINLINE char #-}

449470char :: Name

450−char = fromChars "Char"

471+char = "Char"

451472

452473

453474{-# NOINLINE string #-}

454475string :: Name

455−string = fromChars "String"

476+string = "String"

456477

457478

458479{-# NOINLINE maybe #-}

459480maybe :: Name

460−maybe = fromChars "Maybe"

481+maybe = "Maybe"

461482

462483

463484{-# NOINLINE result #-}

464485result :: Name

465−result = fromChars "Result"

486+result = "Result"

466487

467488

468489{-# NOINLINE list #-}

469490list :: Name

470−list = fromChars "List"

491+list = "List"

471492

472493

473494{-# NOINLINE array #-}

474495array :: Name

475−array = fromChars "Array"

496+array = "Array"

476497

477498

478499{-# NOINLINE dict #-}

479500dict :: Name

480−dict = fromChars "Dict"

501+dict = "Dict"

481502

482503

483504{-# NOINLINE tuple #-}

484505tuple :: Name

485−tuple = fromChars "Tuple"

506+tuple = "Tuple"

486507

487508

488509{-# NOINLINE jsArray #-}

489510jsArray :: Name

490−jsArray = fromChars "JsArray"

511+jsArray = "JsArray"

491512

492513

493514{-# NOINLINE task #-}

494515task :: Name

495−task = fromChars "Task"

516+task = "Task"

496517

497518

498519{-# NOINLINE router #-}

499520router :: Name

500−router = fromChars "Router"

521+router = "Router"

501522

502523

503524{-# NOINLINE cmd #-}

504525cmd :: Name

505−cmd = fromChars "Cmd"

526+cmd = "Cmd"

506527

507528

508529{-# NOINLINE sub #-}

509530sub :: Name

510−sub = fromChars "Sub"

531+sub = "Sub"

511532

512533

513534{-# NOINLINE platform #-}

514535platform :: Name

515−platform = fromChars "Platform"

536+platform = "Platform"

516537

517538

518539{-# NOINLINE virtualDom #-}

519540virtualDom :: Name

520−virtualDom = fromChars "VirtualDom"

541+virtualDom = "VirtualDom"

521542

522543

523544{-# NOINLINE shader #-}

524545shader :: Name

525−shader = fromChars "Shader"

546+shader = "Shader"

526547

527548

528549{-# NOINLINE debug #-}

529550debug :: Name

530−debug = fromChars "Debug"

551+debug = "Debug"

531552

532553

533554{-# NOINLINE debugger #-}

534555debugger :: Name

535−debugger = fromChars "Debugger"

556+debugger = "Debugger"

536557

537558

538559{-# NOINLINE bitwise #-}

539560bitwise :: Name

540−bitwise = fromChars "Bitwise"

561+bitwise = "Bitwise"

541562

542563

543564{-# NOINLINE basics #-}

544565basics :: Name

545−basics = fromChars "Basics"

566+basics = "Basics"

546567

547568

548569{-# NOINLINE utils #-}

549570utils :: Name

550−utils = fromChars "Utils"

571+utils = "Utils"

551572

552573

553574{-# NOINLINE negate #-}

554575negate :: Name

555−negate = fromChars "negate"

576+negate = "negate"

556577

557578

558579{-# NOINLINE true #-}

559580true :: Name

560−true = fromChars "True"

581+true = "True"

561582

562583

563584{-# NOINLINE false #-}

564585false :: Name

565−false = fromChars "False"

586+false = "False"

566587

567588

568589{-# NOINLINE value #-}

569590value :: Name

570−value = fromChars "Value"

591+value = "Value"

571592

572593

573594{-# NOINLINE node #-}

574595node :: Name

575−node = fromChars "Node"

596+node = "Node"

576597

577598

578599{-# NOINLINE program #-}

579600program :: Name

580−program = fromChars "Program"

581−

601+program = "Program"

582602

583−{-# NOINLINE _main #-}

584−_main :: Name

585−_main = fromChars "main"

586603

587−

588−{-# NOINLINE _Main #-}

589−_Main :: Name

590−_Main = fromChars "Main"

604+{-# NOINLINE main #-}

605+main :: Name

606+main = "main"

591607

592608

593609{-# NOINLINE dollar #-}

594610dollar :: Name

595−dollar = fromChars "$"

611+dollar = "$"

596612

597613

598614{-# NOINLINE identity #-}

599615identity :: Name

600−identity = fromChars "identity"

616+identity = "identity"

601617

602618

603619{-# NOINLINE replModule #-}

604620replModule :: Name

605−replModule = fromChars "Elm_Repl"

606−

607−

608−{-# NOINLINE replValueToPrint #-}

609−replValueToPrint :: Name

610−replValueToPrint = fromChars "repl_input_value_"

621+replModule = "Elm_Repl"

compiler/src/Data/NonEmptyList.hs−42

@@ -1,17 +1,10 @@

11module Data.NonEmptyList

22 ( List(..)

3− , singleton

43 , toList

5− , sortBy

64 )

75 where

86

97

10−import Control.Monad (liftM2)

11−import Data.Binary (Binary, get, put)

12−import qualified Data.List as List

13−

14−

158

169-- LIST

1710

@@ -20,11 +13,6 @@ data List a =

2013 List a [a]

2114

2215

23−singleton :: a -> List a

24−singleton a =

25− List a []

26−

27−

2816toList :: List a -> [a]

2917toList (List x xs) =

3018 x:xs

@@ -46,33 +34,3 @@ instance Foldable List where

4634 foldr step state (List x xs) = step x (foldr step state xs)

4735 foldl step state (List x xs) = foldl step (step state x) xs

4836 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

33 ( OneOrMore(..)

44 , one

55 , more

6+ , toList

67 , map

78 , destruct

8− , getFirstTwo

99 )

1010 where

1111

@@ -33,6 +33,25 @@ more =

3333

3434

3535

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+

3655-- MAP

3756

3857

@@ -52,48 +71,14 @@ map func oneOrMore =

5271

5372destruct :: (a -> [a] -> b) -> OneOrMore a -> b

5473destruct func oneOrMore =

55− destructLeft func oneOrMore []

74+ destructHelp func oneOrMore []

5675

5776

58−destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

59−destructLeft func oneOrMore xs =

77+destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

78+destructHelp func oneOrMore xs =

6079 case oneOrMore of

6180 One x ->

6281 func x xs

6382

6483 More a b ->

65− destructLeft func a (destructRight b xs)

66−

67−

68−destructRight :: OneOrMore a -> [a] -> [a]

69−destructRight oneOrMore xs =

70− case oneOrMore of

71− One x ->

72− x : xs

73−

74− More a b ->

75− destructRight a (destructRight b xs)

76−

77−

78−

79−-- GET FIRST TWO

80−

81−

82−getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)

83−getFirstTwo left right =

84− case left of

85− One x ->

86− (x, getFirstOne right)

87−

88− More lleft lright ->

89− getFirstTwo lleft lright

90−

91−

92−getFirstOne :: OneOrMore a -> a

93−getFirstOne oneOrMore =

94− case oneOrMore of

95− One x ->

96− x

97−

98− More left _ ->

99− getFirstOne left

84+ destructHelp func a (toListHelp b xs)

compiler/src/Data/Utf8.hs+300−158

@@ -1,42 +1,36 @@

11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

33module Data.Utf8

4− ( Utf8(..)

4+ ( String

5+ , Utf8(..)

6+ , VeryLong

7+ , Under256

58 , isEmpty

6− , empty

79 , size

810 , contains

11+ , containsDouble

912 , startsWith

1013 , startsWithChar

11− , endsWithWord8

14+ , endsWithWord

1215 , split

1316 , join

14− --

15− , getUnder256

16− , putUnder256

17− --

18− , getVeryLong

19− , putVeryLong

20− --

17+ , all

18+ , any

19+ , toWord16

20+ , fromWord16

21+ -- conversions

22+ , fromChars

2123 , toChars

2224 , toBuilder

23− , toEscapedBuilder

24− --

2525 , fromPtr

26− , fromSnippet

27− , fromChars

28− --

29− , MBA

30− , newByteArray

31− , copyFromPtr

32− , writeWord8

33− , freeze

26+ , fromChunks

27+ , Chunk(..)

3428 )

3529 where

3630

3731

3832import Prelude hiding (String, all, any, concat)

39−import Data.Binary (Get, get, getWord8, Put, put, putWord8)

33+import Data.Binary (Binary(..), Get, getWord8, putWord8)

4034import Data.Binary.Put (putBuilder)

4135import Data.Binary.Get.Internal (readN)

4236import Data.Bits ((.&.), shiftR)

@@ -44,6 +38,7 @@ import qualified Data.ByteString.Internal as B

4438import qualified Data.ByteString.Builder.Internal as B

4539import qualified Data.Char as Char

4640import qualified Data.List as List

41+import Data.String (IsString(..))

4742import Foreign.ForeignPtr (touchForeignPtr)

4843import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

4944import Foreign.Ptr (minusPtr, plusPtr)

@@ -58,35 +53,36 @@ import GHC.Exts

5853 , copyByteArray#

5954 , copyAddrToByteArray#

6055 , copyByteArrayToAddr#

61− , writeWord8Array#

56+ , writeWord8Array#,

6257 )

6358import GHC.IO

6459import GHC.ST (ST(ST), runST)

6560import GHC.Prim

66−import GHC.Word (Word8(W8#))

67−

68−import qualified Parse.Primitives as P

61+import GHC.Word (Word8(W8#), Word16(W16#))

6962

7063

7164

7265-- UTF-8

7366

7467

75−data Utf8 tipe =

68+data Utf8 size tipe =

7669 Utf8 ByteArray#

7770

7871

72+type String = Utf8 VERY_LONG STRING

73+type VeryLong t = Utf8 VERY_LONG t

74+type Under256 t = Utf8 UNDER_256 t

7975

80−-- EMPTY

76+data STRING

77+data VERY_LONG

78+data UNDER_256

8179

8280

83−{-# NOINLINE empty #-}

84−empty :: Utf8 t

85−empty =

86− runST (freeze =<< newByteArray 0)

8781

82+-- IS EMPTY

8883

89−isEmpty :: Utf8 t -> Bool

84+

85+isEmpty :: Utf8 l t -> Bool

9086isEmpty (Utf8 ba#) =

9187 isTrue# (sizeofByteArray# ba# ==# 0#)

9288

@@ -95,7 +91,7 @@ isEmpty (Utf8 ba#) =

9591-- SIZE

9692

9793

98−size :: Utf8 t -> Int

94+size :: Utf8 l t -> Int

9995size (Utf8 ba#) =

10096 I# (sizeofByteArray# ba#)

10197

@@ -104,7 +100,7 @@ size (Utf8 ba#) =

104100-- CONTAINS

105101

106102

107−contains :: Word8 -> Utf8 t -> Bool

103+contains :: Word8 -> Utf8 l t -> Bool

108104contains (W8# word#) (Utf8 ba#) =

109105 containsHelp word# ba# 0# (sizeofByteArray# ba#)

110106

@@ -120,11 +116,32 @@ containsHelp word# ba# !offset# len# =

120116

121117

122118

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+

123140-- STARTS WITH

124141

125142

126143{-# INLINE startsWith #-}

127−startsWith :: Utf8 t -> Utf8 t -> Bool

144+startsWith :: Utf8 l t -> Utf8 l t -> Bool

128145startsWith (Utf8 ba1#) (Utf8 ba2#) =

129146 let

130147 !len1# = sizeofByteArray# ba1#

@@ -139,9 +156,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =

139156-- STARTS WITH CHAR

140157

141158

142−startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool

143−startsWithChar isGood bytes@(Utf8 ba#) =

144− if isEmpty bytes then

159+startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool

160+startsWithChar isGood str@(Utf8 ba#) =

161+ if isEmpty str then

145162 False

146163 else

147164 let

@@ -159,8 +176,8 @@ startsWithChar isGood bytes@(Utf8 ba#) =

159176-- ENDS WITH WORD

160177

161178

162−endsWithWord8 :: Word8 -> Utf8 t -> Bool

163−endsWithWord8 (W8# w#) (Utf8 ba#) =

179+endsWithWord :: Word8 -> Utf8 l t -> Bool

180+endsWithWord (W8# w#) (Utf8 ba#) =

164181 let len# = sizeofByteArray# ba# in

165182 isTrue# (len# ># 0#)

166183 &&

@@ -171,12 +188,12 @@ endsWithWord8 (W8# w#) (Utf8 ba#) =

171188-- SPLIT

172189

173190

174−split :: Word8 -> Utf8 t -> [Utf8 t]

191+split :: Word8 -> String -> [String]

175192split (W8# divider#) str@(Utf8 ba#) =

176193 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

177194

178195

179−splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]

196+splitHelp :: String -> Int -> [Int] -> [String]

180197splitHelp str start offsets =

181198 case offsets of

182199 [] ->

@@ -197,7 +214,7 @@ findDividers divider# ba# !offset# len# revOffsets =

197214 reverse revOffsets

198215

199216

200−unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t

217+unsafeSlice :: String -> Int -> Int -> String

201218unsafeSlice str start end =

202219 let !len = end - start in

203220 if len == 0 then

@@ -213,7 +230,7 @@ unsafeSlice str start end =

213230-- JOIN

214231

215232

216−join :: Word8 -> [Utf8 t] -> Utf8 t

233+join :: Word8 -> [String] -> String

217234join sep strings =

218235 case strings of

219236 [] ->

@@ -227,7 +244,7 @@ join sep strings =

227244 freeze mba

228245

229246

230−joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()

247+joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()

231248joinHelp sep mba offset str strings =

232249 let

233250 !len = size str

@@ -245,10 +262,46 @@ joinHelp sep mba offset str strings =

245262

246263

247264

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+

248301-- EQUAL

249302

250303

251−instance Eq (Utf8 t) where

304+instance Eq (Utf8 l t) where

252305 (==) (Utf8 ba1#) (Utf8 ba2#) =

253306 let

254307 !len1# = sizeofByteArray# ba1#

@@ -261,11 +314,9 @@ instance Eq (Utf8 t) where

261314

262315

263316-- COMPARE

264−--

265−-- TODO: is it fine to sort by length and only compare bytes on length ties?

266−--

267317

268−instance Ord (Utf8 t) where

318+

319+instance Ord (Utf8 l t) where

269320 compare (Utf8 ba1#) (Utf8 ba2#) =

270321 let

271322 !len1# = sizeofByteArray# ba1#

@@ -282,20 +333,84 @@ instance Ord (Utf8 t) where

282333

283334

284335

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+

285395-- FROM STRING

286396

287397

288−fromChars :: [Char] -> Utf8 t

289−fromChars chars =

290− runST

291− (

292− do mba <- newByteArray (sum (map getWidth chars))

293− writeChars mba 0 chars

294− )

398+fromChars :: [Char] -> Utf8 l t

399+fromChars =

400+ fromString

401+

295402

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

296410

297−writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)

298−writeChars !mba !offset chars =

411+

412+writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)

413+writeString !mba !offset chars =

299414 case chars of

300415 [] ->

301416 freeze mba

@@ -303,25 +418,25 @@ writeChars !mba !offset chars =

303418 char : chars

304419 | n < 0x80 ->

305420 do writeWord8 mba (offset ) (fromIntegral n)

306− writeChars mba (offset + 1) chars

421+ writeString mba (offset + 1) chars

307422

308423 | n < 0x800 ->

309424 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

310425 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

311− writeChars mba (offset + 2) chars

426+ writeString mba (offset + 2) chars

312427

313428 | n < 0x10000 ->

314429 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

315430 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

316431 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

317− writeChars mba (offset + 3) chars

432+ writeString mba (offset + 3) chars

318433

319434 | otherwise ->

320435 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

321436 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

322437 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

323438 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

324− writeChars mba (offset + 4) chars

439+ writeString mba (offset + 4) chars

325440

326441 where

327442 n = Char.ord char

@@ -339,10 +454,10 @@ getWidth char

339454

340455

341456

342−-- TO CHARS

457+-- TO STRING

343458

344459

345−toChars :: Utf8 t -> [Char]

460+toChars :: Utf8 l t -> [Char]

346461toChars (Utf8 ba#) =

347462 toCharsHelp ba# 0# (sizeofByteArray# ba#)

348463

@@ -412,13 +527,13 @@ chr4 ba# offset# firstWord# =

412527

413528

414529{-# INLINE toBuilder #-}

415−toBuilder :: Utf8 t -> B.Builder

530+toBuilder :: Utf8 l t -> B.Builder

416531toBuilder =

417532 \bytes -> B.builder (toBuilderHelp bytes)

418533

419534

420535{-# INLINE toBuilderHelp #-}

421−toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a

536+toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a

422537toBuilderHelp !bytes@(Utf8 ba#) k =

423538 go 0 (I# (sizeofByteArray# ba#))

424539 where

@@ -438,57 +553,10 @@ toBuilderHelp !bytes@(Utf8 ba#) k =

438553

439554

440555

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−

488556-- FROM PTR

489557

490558

491−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t

559+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t

492560fromPtr pos end =

493561 unsafeDupablePerformIO (stToIO (

494562 do let !len = minusPtr end pos

@@ -499,48 +567,130 @@ fromPtr pos end =

499567

500568

501569

502−-- FROM SNIPPET

570+-- FROM CHUNKS

503571

504572

505−fromSnippet :: P.Snippet -> Utf8 t

506−fromSnippet (P.Snippet fptr off len _ _) =

573+data Chunk

574+ = Slice (Ptr Word8) Int

575+ | Escape Word8

576+ | CodePoint Int

577+

578+

579+fromChunks :: [Chunk] -> Utf8 l t

580+fromChunks chunks =

507581 unsafeDupablePerformIO (stToIO (

508− do mba <- newByteArray len

509− let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off

510− copyFromPtr pos mba 0 len

582+ do let !len = sum (map chunkToWidth chunks)

583+ mba <- newByteArray len

584+ writeChunks mba 0 chunks

511585 freeze mba

512586 ))

513587

514588

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)

515649

516−-- BINARY

517650

518651

519−putUnder256 :: Utf8 t -> Put

520−putUnder256 bytes =

521− do putWord8 (fromIntegral (size bytes))

522− putBuilder (toBuilder bytes)

652+-- UNDER 256 BINARY

523653

524654

525−getUnder256 :: Get (Utf8 t)

526−getUnder256 =

527− do word <- getWord8

528− let !n = fromIntegral word

529− readN n (copyFromByteString n)

655+instance Binary (Utf8 UNDER_256 t) where

656+ put bytes@(Utf8 ba#) =

657+ do putWord8 (W8# (int2Word# (sizeofByteArray# ba#)))

658+ putBuilder (toBuilder bytes)

659+ get =

660+ getUnder256 =<< getWord8

530661

531662

532−putVeryLong :: Utf8 t -> Put

533−putVeryLong bytes =

534− do put (size bytes)

535− putBuilder (toBuilder bytes)

663+{-# INLINE getUnder256 #-}

664+getUnder256 :: Word8 -> Get (Utf8 UNDER_256 t)

665+getUnder256 w =

666+ let !n = fromIntegral w in

667+ readN n (copyFromByteString n)

536668

537669

538−getVeryLong :: Get (Utf8 t)

539−getVeryLong =

540− do n <- get

541− if n > 0

542− then readN n (copyFromByteString n)

543− else return empty

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 =

679+ getVeryLong =<< get

680+

681+

682+{-# INLINE getVeryLong #-}

683+getVeryLong :: Int -> Get (Utf8 VERY_LONG t)

684+getVeryLong n =

685+ if n > 0

686+ then readN n (copyFromByteString n)

687+ else return empty

688+

689+

690+{-# NOINLINE empty #-}

691+empty :: Utf8 l t

692+empty =

693+ runST (freeze =<< newByteArray 0)

544694

545695

546696

@@ -548,7 +698,7 @@ getVeryLong =

548698

549699

550700{-# INLINE copyFromByteString #-}

551−copyFromByteString :: Int -> B.ByteString -> Utf8 t

701+copyFromByteString :: Int -> B.ByteString -> Utf8 l t

552702copyFromByteString len (B.PS fptr offset _) =

553703 unsafeDupablePerformIO

554704 (

@@ -567,21 +717,21 @@ data MBA s =

567717 MBA# (MutableByteArray# s)

568718

569719

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

571721newByteArray (I# len#) =

572722 ST $ \s ->

573723 case newByteArray# len# s of

574724 (# s, mba# #) -> (# s, MBA# mba# #)

575725

576726

577−freeze :: MBA s -> ST s (Utf8 t)

727+freeze :: MBA s -> ST s (Utf8 l t)

578728freeze (MBA# mba#) =

579729 ST $ \s ->

580730 case unsafeFreezeByteArray# mba# s of

581731 (# s, ba# #) -> (# s, Utf8 ba# #)

582732

583733

584−copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()

734+copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()

585735copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

586736 ST $ \s ->

587737 case copyByteArray# ba# offset# mba# i# len# s of

@@ -595,11 +745,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =

595745 s -> (# s, () #)

596746

597747

598−copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()

748+copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()

599749copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

600− IO $ \s ->

601− case copyByteArrayToAddr# ba# offset# mba# len# s of

602− s -> (# s, () #)

750+ IO $ \s ->

751+ case copyByteArrayToAddr# ba# offset# mba# len# s of

752+ s -> (# s, () #)

603753

604754

605755{-# INLINE writeWord8 #-}

@@ -608,11 +758,3 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

608758 ST $ \s ->

609759 case writeWord8Array# mba# offset# w# s of

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

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Elm.Compiler.Imports

4− ( defaults

4+ ( addDefaults

55 )

66 where

77

@@ -14,6 +14,15 @@ import qualified Reporting.Annotation as A

1414

1515

1616

17+-- ADD DEFAULTS

18+

19+

20+addDefaults :: [Src.Import] -> [Src.Import]

21+addDefaults imports =

22+ defaults ++ imports

23+

24+

25+

1726-- DEFAULTS

1827

1928

@@ -49,14 +58,14 @@ closed =

4958

5059typeOpen :: Name.Name -> Src.Exposing

5160typeOpen 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) ]

5362

5463

5564typeClosed :: Name.Name -> Src.Exposing

5665typeClosed 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) ]

5867

5968

6069operator :: Name.Name -> Src.Exposing

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

1515

1616

1717import qualified Data.Name as Name

18+import qualified Data.Utf8 as Utf8

1819

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

2421import qualified Parse.Primitives as P

2522import qualified Parse.Type as Type

2623import qualified Reporting.Annotation as A

@@ -28,6 +25,10 @@ import qualified Reporting.Doc as D

2825import qualified Reporting.Render.Type as RT

2926import qualified Reporting.Render.Type.Localizer as L

3027

28+import qualified Json.Decode as D

29+import qualified Json.Encode as E

30+import Json.Encode ((==>))

31+

3132

3233

3334-- TYPES

@@ -113,16 +114,18 @@ collectLambdas tipe =

113114

114115encode :: Type -> E.Value

115116encode 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)

117118

118119

119120decoder :: D.Decoder () Type

120121decoder =

121− let

122− parser =

123− P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)

124− in

125− D.customString parser (\_ _ -> ())

122+ do str <- D.string

123+ case P.fromByteString Type.expression (error "TODO turn Utf8 to something that can be parsed" str) of

124+ P.Ok (tipe, _, _) _ ->

125+ return (fromRawType tipe)

126+

127+ P.Err _ _ _ _ ->

128+ D.failure ()

126129

127130

128131fromRawType :: Src.Type -> Type

@@ -164,31 +167,29 @@ encodeMetadata :: DebugMetadata -> E.Value

164167encodeMetadata (DebugMetadata msg aliases unions) =

165168 E.object

166169 [ "message" ==> encode msg

167− , "aliases" ==> E.object (map toTypeAliasField aliases)

168− , "unions" ==> E.object (map toCustomTypeField unions)

170+ , "aliases" ==> E.object (map toAliasField aliases)

171+ , "unions" ==> E.object (map toUnionField unions)

169172 ]

170173

171174

172−toTypeAliasField :: Alias -> ( Json.String, E.Value )

173−toTypeAliasField (Alias name args tipe) =

174− ( Json.fromName name

175− , E.object

175+toAliasField :: Alias -> ( Utf8.String, E.Value )

176+toAliasField (Alias name args tipe) =

177+ Name.toUtf8 name ==>

178+ E.object

176179 [ "args" ==> E.list E.name args

177180 , "type" ==> encode tipe

178181 ]

179− )

180182

181183

182−toCustomTypeField :: Union -> ( Json.String, E.Value )

183−toCustomTypeField (Union name args constructors) =

184− ( Json.fromName name

185− , E.object

184+toUnionField :: Union -> ( Utf8.String, E.Value )

185+toUnionField (Union name args constructors) =

186+ Name.toUtf8 name ==>

187+ E.object

186188 [ "args" ==> E.list E.name args

187− , "tags" ==> E.object (map toVariantObject constructors)

189+ , "tags" ==> E.object (map toCtorObject constructors)

188190 ]

189− )

190191

191192

192−toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )

193−toVariantObject (name, args) =

194− ( Json.fromName name, E.list encode args )

193+toCtorObject :: (Name.Name, [Type]) -> ( Utf8.String, E.Value )

194+toCtorObject (name, 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 =

8787

8888newtype Types =

8989 Types (Map.Map ModuleName.Canonical Types_)

90− -- PERF profile Opt.Global representation

90+ -- TODO profile Opt.Global representation

9191 -- current representation needs less allocation

9292 -- but maybe the lookup is much worse

9393

compiler/src/Elm/Constraint.hs+77−55

@@ -5,6 +5,9 @@ module Elm.Constraint

55 , exactly

66 , anything

77 , toChars

8+ , toString

9+ , Error(..)

10+ , fromString

811 , satisfies

912 , check

1013 , intersect

@@ -13,8 +16,6 @@ module Elm.Constraint

1316 , untilNextMajor

1417 , untilNextMinor

1518 , expand

16− --

17− , Error(..)

1819 , decoder

1920 , encode

2021 )

@@ -23,12 +24,11 @@ module Elm.Constraint

2324

2425import Control.Monad (liftM4)

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

27+import qualified Data.Utf8 as Utf8

2628

2729import qualified Elm.Version as V

2830import qualified Json.Decode as D

2931import qualified Json.Encode as E

30−import qualified Parse.Primitives as P

31−import Parse.Primitives (Row, Col)

3232

3333

3434

@@ -61,21 +61,78 @@ anything =

6161

6262

6363

64−-- TO CHARS

64+-- TO STRING

6565

6666

67−toChars :: Constraint -> [Char]

67+toChars :: Constraint -> String

6868toChars constraint =

69+ Utf8.toChars (toString constraint)

70+

71+

72+toString :: Constraint -> Utf8.String

73+toString constraint =

6974 case constraint of

7075 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+ ]

7283

7384

74−opToChars :: Op -> [Char]

75−opToChars op =

85+toStringHelp :: Op -> Utf8.String

86+toStringHelp op =

7687 case op of

77− Less -> " < "

78− LessOrEqual -> " <= "

88+ Less -> "<"

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

79136

80137

81138

@@ -188,12 +245,18 @@ expand constraint@(Range lower lowerOp upperOp upper) version

188245

189246encode :: Constraint -> E.Value

190247encode constraint =

191− E.chars (toChars constraint)

248+ E.string (toString constraint)

192249

193250

194251decoder :: D.Decoder Error Constraint

195252decoder =

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

197260

198261

199262

@@ -216,45 +279,4 @@ instance Binary Op where

216279 case n of

217280 0 -> return Less

218281 1 -> return LessOrEqual

219− _ -> fail "binary encoding of Op was corrupted"

220−

221−

222−

223−-- PARSER

224−

225−

226−data Error

227− = BadFormat Row Col

228− | InvalidRange V.Version V.Version

229−

230−

231−parser :: P.Parser Error Constraint

232−parser =

233− do lower <- parseVersion

234− P.word1 0x20 {- -} BadFormat

235− loOp <- parseOp

236− P.word1 0x20 {- -} BadFormat

237− P.word1 0x76 {-v-} BadFormat

238− P.word1 0x20 {- -} BadFormat

239− hiOp <- parseOp

240− P.word1 0x20 {- -} BadFormat

241− higher <- parseVersion

242− P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->

243− if lower < higher

244− then eok (Range lower loOp hiOp higher) state

245− else eerr row col (\_ _ -> InvalidRange lower higher)

246−

247−

248−parseVersion :: P.Parser Error V.Version

249−parseVersion =

250− P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser

251−

252−

253−parseOp :: P.Parser Error Op

254−parseOp =

255− do P.word1 0x3C {-<-} BadFormat

256− P.oneOfWithFallback

257− [ do P.word1 0x3D {-=-} BadFormat

258− return LessOrEqual

259− ]

260− Less

282+ _ -> error "binary encoding of Op was corrupted"

compiler/src/Elm/Docs.hs+158−218

@@ -1,7 +1,8 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}

2+{-# LANGUAGE OverloadedStrings #-}

33module Elm.Docs

44 ( Documentation

5+ , toDict

56 , Module(..)

67 , fromModule

78 , Union(..)

@@ -17,35 +18,33 @@ module Elm.Docs

1718 where

1819

1920

20−import qualified Data.Coerce as Coerce

21+import qualified Data.ByteString as B

2122import qualified Data.List as List

2223import Data.Map ((!))

2324import qualified Data.Map as Map

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

2525import qualified Data.Name as Name

26−import qualified Data.NonEmptyList as NE

27−import qualified Data.OneOrMore as OneOrMore

28−import Data.Word (Word8)

29−import Foreign.Ptr (Ptr, plusPtr)

26+import qualified Data.Text as Text

27+import qualified Data.Text.Encoding as Text

3028

3129import qualified AST.Canonical as Can

32−import qualified AST.Source as Src

3330import qualified AST.Utils.Binop as Binop

31+import qualified Data.OneOrMore as OneOrMore

3432import qualified Elm.Compiler.Type as Type

3533import qualified Elm.Compiler.Type.Extract as Extract

3634import qualified Elm.ModuleName as ModuleName

3735import qualified Json.Decode as D

3836import qualified Json.Encode as E

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

4638import qualified Reporting.Annotation as A

39+import qualified Reporting.Error as Error

4740import qualified Reporting.Error.Docs as E

41+import qualified Reporting.Region as R

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

4948

5049

5150

@@ -56,6 +55,21 @@ type Documentation =

5655 Map.Map Name.Name Module

5756

5857

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+

5973data Module =

6074 Module

6175 { _name :: Name.Name

@@ -66,7 +80,9 @@ data Module =

6680 , _binops :: Map.Map Name.Name Binop

6781 }

6882

69−type Comment = Json.String

83+

84+type Comment = Text.Text

85+

7086

7187data Alias = Alias Comment [Name.Name] Type.Type

7288data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]

@@ -75,19 +91,14 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence

7591

7692

7793

78−-- JSON

79−

80−

81−encode :: Documentation -> E.Value

82−encode docs =

83− E.list encodeModule (Map.elems docs)

94+-- JSON ENCODE / DECODE

8495

8596

86−encodeModule :: Module -> E.Value

87−encodeModule (Module name comment unions aliases values binops) =

97+encode :: Module -> E.Value

98+encode (Module name comment unions aliases values binops) =

8899 E.object $

89100 [ "name" ==> ModuleName.encode name

90− , "comment" ==> E.string comment

101+ , "comment" ==> E.text comment

91102 , "unions" ==> E.list encodeUnion (Map.toList unions)

92103 , "aliases" ==> E.list encodeAlias (Map.toList aliases)

93104 , "values" ==> E.list encodeValue (Map.toList values)

@@ -96,31 +107,16 @@ encodeModule (Module name comment unions aliases values binops) =

96107

97108

98109data Error

99− = BadAssociativity

100− | BadModuleName

110+ = BadAssociativity Text.Text

111+ | BadName

101112 | BadType

102113

103114

104−decoder :: D.Decoder Error Documentation

115+decoder :: D.Decoder Error Module

105116decoder =

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 =

121117 Module

122− <$> D.field "name" moduleNameDecoder

123− <*> D.field "comment" D.string

118+ <$> D.field "name" nameDecoder

119+ <*> D.field "comment" D.text

124120 <*> D.field "unions" (dictDecoder union)

125121 <*> D.field "aliases" (dictDecoder alias)

126122 <*> D.field "values" (dictDecoder value)

@@ -135,18 +131,13 @@ dictDecoder entryDecoder =

135131named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)

136132named entryDecoder =

137133 (,)

138− <$> D.field "name" nameDecoder

134+ <$> D.field "name" D.name

139135 <*> entryDecoder

140136

141137

142−nameDecoder :: D.Decoder e Name.Name

138+nameDecoder :: D.Decoder Error Name.Name

143139nameDecoder =

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

150141

151142

152143typeDecoder :: D.Decoder Error Type.Type

@@ -162,7 +153,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value

162153encodeUnion (name, Union comment args cases) =

163154 E.object

164155 [ "name" ==> E.name name

165− , "comment" ==> E.string comment

156+ , "comment" ==> E.text comment

166157 , "args" ==> E.list E.name args

167158 , "cases" ==> E.list encodeCase cases

168159 ]

@@ -171,8 +162,8 @@ encodeUnion (name, Union comment args cases) =

171162union :: D.Decoder Error Union

172163union =

173164 Union

174− <$> D.field "comment" D.string

175− <*> D.field "args" (D.list nameDecoder)

165+ <$> D.field "comment" D.text

166+ <*> D.field "args" (D.list D.name)

176167 <*> D.field "cases" (D.list caseDecoder)

177168

178169

@@ -183,7 +174,7 @@ encodeCase ( tag, args ) =

183174

184175caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )

185176caseDecoder =

186− D.pair nameDecoder (D.list typeDecoder)

177+ D.pair D.name (D.list typeDecoder)

187178

188179

189180

@@ -194,7 +185,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value

194185encodeAlias ( name, Alias comment args tipe) =

195186 E.object

196187 [ "name" ==> E.name name

197− , "comment" ==> E.string comment

188+ , "comment" ==> E.text comment

198189 , "args" ==> E.list E.name args

199190 , "type" ==> Type.encode tipe

200191 ]

@@ -203,8 +194,8 @@ encodeAlias ( name, Alias comment args tipe) =

203194alias :: D.Decoder Error Alias

204195alias =

205196 Alias

206− <$> D.field "comment" D.string

207− <*> D.field "args" (D.list nameDecoder)

197+ <$> D.field "comment" D.text

198+ <*> D.field "args" (D.list D.name)

208199 <*> D.field "type" typeDecoder

209200

210201

@@ -216,7 +207,7 @@ encodeValue :: (Name.Name, Value) -> E.Value

216207encodeValue (name, Value comment tipe) =

217208 E.object

218209 [ "name" ==> E.name name

219− , "comment" ==> E.string comment

210+ , "comment" ==> E.text comment

220211 , "type" ==> Type.encode tipe

221212 ]

222213

@@ -224,7 +215,7 @@ encodeValue (name, Value comment tipe) =

224215value :: D.Decoder Error Value

225216value =

226217 Value

227− <$> D.field "comment" D.string

218+ <$> D.field "comment" D.text

228219 <*> D.field "type" typeDecoder

229220

230221

@@ -236,7 +227,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value

236227encodeBinop (name, Binop comment tipe assoc prec) =

237228 E.object

238229 [ "name" ==> E.name name

239− , "comment" ==> E.string comment

230+ , "comment" ==> E.text comment

240231 , "type" ==> Type.encode tipe

241232 , "associativity" ==> encodeAssoc assoc

242233 , "precedence" ==> encodePrec prec

@@ -246,7 +237,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =

246237binop :: D.Decoder Error Binop

247238binop =

248239 Binop

249− <$> D.field "comment" D.string

240+ <$> D.field "comment" D.text

250241 <*> D.field "type" typeDecoder

251242 <*> D.field "associativity" assocDecoder

252243 <*> D.field "precedence" precDecoder

@@ -259,23 +250,19 @@ binop =

259250encodeAssoc :: Binop.Associativity -> E.Value

260251encodeAssoc assoc =

261252 case assoc of

262− Binop.Left -> E.chars "left"

263− Binop.Non -> E.chars "non"

264− Binop.Right -> E.chars "right"

253+ Binop.Left -> E.text "left"

254+ Binop.Non -> E.text "non"

255+ Binop.Right -> E.text "right"

265256

266257

267258assocDecoder :: D.Decoder Error Binop.Associativity

268259assocDecoder =

269− let

270− left = Json.fromChars "left"

271− non = Json.fromChars "non"

272− right = Json.fromChars "right"

273− in

274− do str <- D.string

275− if | str == left -> return Binop.Left

276− | str == non -> return Binop.Non

277− | str == right -> return Binop.Right

278− | otherwise -> D.failure BadAssociativity

260+ do txt <- D.text

261+ case txt of

262+ "left" -> D.succeed Binop.Left

263+ "non" -> D.succeed Binop.Non

264+ "right" -> D.succeed Binop.Right

265+ _ -> D.fail (BadAssociativity txt)

279266

280267

281268

@@ -296,190 +283,142 @@ precDecoder =

296283-- FROM MODULE

297284

298285

299−fromModule :: Can.Module -> Either E.Error Module

300−fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =

286+fromModule :: Can.Module -> Result.Result i w Error.Error Module

287+fromModule (Can.Module name docs exports decls unions aliases binops effects) =

301288 case exports of

302289 Can.ExportEverything region ->

303− Left (E.ImplicitExposing region)

290+ Result.throw $ Error.Docs $ E.ImplicitExposing region

304291

305292 Can.Export exportDict ->

306293 case docs of

307− Src.NoDocs region ->

308− Left (E.NoDocs region)

294+ Can.NoDocs region ->

295+ Result.throw $ Error.Docs $ E.NoDocs region

309296

310− Src.YesDocs overview comments ->

311− do names <- parseOverview overview

312− checkNames exportDict names

313− checkDefs exportDict overview (Map.fromList comments) modul

297+ Can.YesDocs region overview comments ->

298+ do names <- parseOverview region overview

299+ Result.mapError Error.Docs $

300+ do checkNames exportDict names

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

314310

315311

316312

317313-- PARSE OVERVIEW

318314

319315

320−parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name]

321−parseOverview (Src.Comment snippet) =

322− case P.fromSnippet (chompOverview []) E.BadEnd snippet of

316+parseOverview :: R.Region -> B.ByteString -> Result.Result i w Error.Error [A.Located Name.Name]

317+parseOverview (R.Region (R.Position row col) _) overview =

318+ case P.runAt row (col + 3) (chompOverview []) overview of

323319 Left err ->

324− Left (E.SyntaxProblem err)

320+ Result.throw (Error.Syntax err)

325321

326322 Right names ->

327− Right names

328−

329−

330−type Parser a =

331− P.Parser E.SyntaxProblem a

323+ Result.ok names

332324

333325

334326chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

335327chompOverview names =

336− do isDocs <- chompUntilDocs

328+ do isDocs <- W.chompUntilDocs

337329 if isDocs

338− then

339− do Space.chomp E.Space

340− chompOverview =<< chompDocs names

341− else

342− return names

330+ then chompOverviewHelp names

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+ else chompOverview =<< chompDocs names

343341

344342

345343chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

346344chompDocs names =

347− do name <-

348− P.addLocation $

349− P.oneOf E.Name

350− [ Var.lower E.Name

351− , Var.upper E.Name

352− , chompOperator

353− ]

354−

355− Space.chomp E.Space

356−

357− P.oneOfWithFallback

358− [ do pos <- P.getPosition

359− Space.checkIndent pos E.Comma

360− word1 0x2C {-,-} E.Comma

361− Space.chomp E.Space

345+ do name <- P.addLocation (P.oneOf [ Var.lower, Var.upper, chompBinop ])

346+ spos <- W.whitespace

347+ P.oneOf

348+ [ do P.checkSpace spos

349+ Symbol.comma

350+ P.spaces

362351 chompDocs (name:names)

352+ , return (name:names)

363353 ]

364− (name:names)

365−

366−

367−chompOperator :: Parser Name.Name

368−chompOperator =

369− do word1 0x28 {-(-} E.Op

370− op <- Symbol.operator E.Op E.OpBad

371− word1 0x29 {-)-} E.Op

372− return op

373−

374−

375−-- TODO add rule that @docs must be after newline in 0.20

376−--

377−chompUntilDocs :: Parser Bool

378−chompUntilDocs =

379− P.Parser $ \(P.State src pos end indent row col) cok _ _ _ ->

380− let

381− (# isDocs, newPos, newRow, newCol #) = untilDocs pos end row col

382− !newState = P.State src newPos end indent newRow newCol

383− in

384− cok isDocs newState

385−

386−

387−untilDocs :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Bool, Ptr Word8, Row, Col #)

388−untilDocs pos end row col =

389− if pos >= end then

390− (# False, pos, row, col #)

391− else

392− let !word = P.unsafeIndex pos in

393− if word == 0x0A {-\n-} then

394− untilDocs (plusPtr pos 1) end (row + 1) 1

395− else

396− let !pos5 = plusPtr pos 5 in

397− if pos5 <= end

398− && P.unsafeIndex ( pos ) == 0x40 {-@-}

399− && P.unsafeIndex (plusPtr pos 1) == 0x64 {-d-}

400− && P.unsafeIndex (plusPtr pos 2) == 0x6F {-o-}

401− && P.unsafeIndex (plusPtr pos 3) == 0x63 {-c-}

402− && P.unsafeIndex (plusPtr pos 4) == 0x73 {-s-}

403− && Var.getInnerWidth pos5 end == 0

404− then

405− (# True, pos5, row, col + 5 #)

406− else

407− let !newPos = plusPtr pos (P.getCharWidth word) in

408− untilDocs newPos end row (col + 1)

354+

355+

356+chompBinop :: Parser Name.Name

357+chompBinop =

358+ do Symbol.leftParen

359+ name <- Symbol.binop

360+ Symbol.rightParen

361+ return name

409362

410363

411364

412365-- CHECK NAMES

413366

414367

415−checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Either E.Error ()

416−checkNames exports names =

417− let

418− docs = List.foldl' addName Map.empty names

419− loneDoc = Map.traverseMissing onlyInDocs

420− loneExport = Map.traverseMissing onlyInExports

421− checkBoth = Map.zipWithAMatched (\n _ r -> isUnique n r)

422− in

423− case Result.run (Map.mergeA loneExport loneDoc checkBoth exports docs) of

424− (_, Right _) -> Right ()

425− (_, Left es) -> Left (E.NameProblems (OneOrMore.destruct NE.List es))

368+type Result i w a =

369+ Result.Result i w E.Error a

370+

371+

372+type Dups =

373+ Map.Map Name.Name (OneOrMore.OneOrMore R.Region)

426374

427375

428−type DocNameRegions =

429− Map.Map Name.Name (OneOrMore.OneOrMore A.Region)

376+checkNames :: Map.Map Name.Name (A.Located Can.Export) -> [A.Located Name.Name] -> Result i w ()

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

430386

431387

432−addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions

388+addName :: Dups -> A.Located Name.Name -> Dups

433389addName dict (A.At region name) =

434390 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

435391

436392

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

438394isUnique name regions =

439395 case regions of

440396 OneOrMore.One region ->

441397 Result.ok region

442398

443− OneOrMore.More left right ->

444− let (r1, r2) = OneOrMore.getFirstTwo left right in

445− Result.throw (E.NameDuplicate name r1 r2)

399+ OneOrMore.More _ _ ->

400+ let (r1:r2:_) = OneOrMore.toList regions in

401+ Result.throw (E.Duplicate name r1 r2)

446402

447403

448−onlyInDocs :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem a

449−onlyInDocs name regions =

450− do region <- isUnique name regions

451− Result.throw $ E.NameOnlyInDocs name region

404+onlyInDocs :: Name.Name -> R.Region -> Result i w a

405+onlyInDocs name region =

406+ Result.throw $ E.OnlyInDocs name region

452407

453408

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

455410onlyInExports name (A.At region _) =

456− Result.throw $ E.NameOnlyInExports name region

457−

458−

459−

460−-- CHECK DEFS

461−

411+ Result.throw $ E.OnlyInExports name region

462412

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

472413

473414

474−emptyModule :: ModuleName.Canonical -> Src.Comment -> Module

475−emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) =

476− Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty

415+-- CHECK EXPORTS

477416

478417

479418data Info =

480419 Info

481− { _iComments :: Map.Map Name.Name Src.Comment

482− , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)

420+ { _iComments :: Map.Map Name.Name Comment

421+ , _iValues :: Types

483422 , _iUnions :: Map.Map Name.Name Can.Union

484423 , _iAliases :: Map.Map Name.Name Can.Alias

485424 , _iBinops :: Map.Map Name.Name Can.Binop

@@ -487,7 +426,7 @@ data Info =

487426 }

488427

489428

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)

491430checkExport info name (A.At region export) =

492431 case export of

493432 Can.ExportValue ->

@@ -528,23 +467,23 @@ checkExport info name (A.At region export) =

528467 m { _values = Map.insert name (Value comment tipe) (_values m) }

529468

530469

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

532471getComment region name info =

533472 case Map.lookup name (_iComments info) of

534473 Nothing ->

535474 Result.throw (E.NoComment name region)

536475

537− Just (Src.Comment snippet) ->

538− Result.ok (Json.fromComment snippet)

476+ Just comment ->

477+ Result.ok comment

539478

540479

541−getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type

480+getType :: Name.Name -> Info -> Result i w Type.Type

542481getType name info =

543482 case _iValues info ! name of

544− Left region ->

545− Result.throw (E.NoAnnotation name region)

483+ A.At defRegion Nothing ->

484+ Result.throw (E.NoAnnotation name defRegion)

546485

547− Right tipe ->

486+ A.At _ (Just tipe) ->

548487 Result.ok (Extract.fromType tipe)

549488

550489

@@ -558,7 +497,7 @@ dector (Can.Ctor name _ _ args) =

558497

559498

560499type Types =

561− Map.Map Name.Name (Either A.Region Can.Type)

500+ Map.Map Name.Name (A.Located (Maybe Can.Type))

562501

563502

564503gatherTypes :: Can.Decls -> Types -> Types

@@ -567,8 +506,8 @@ gatherTypes decls types =

567506 Can.Declare def subDecls ->

568507 gatherTypes subDecls (addDef types def)

569508

570− Can.DeclareRec def defs subDecls ->

571− gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)

509+ Can.DeclareRec defs subDecls ->

510+ gatherTypes subDecls (List.foldl' addDef types defs)

572511

573512 Can.SaveTheEnvironment ->

574513 types

@@ -578,10 +517,11 @@ addDef :: Types -> Can.Def -> Types

578517addDef types def =

579518 case def of

580519 Can.Def (A.At region name) _ _ ->

581− Map.insert name (Left region) types

520+ Map.insert name (A.At region Nothing) types

582521

583− Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->

522+ Can.TypedDef (A.At region name) _ typedArgs _ resultType ->

584523 let

585− tipe = foldr Can.TLambda resultType (map snd typedArgs)

524+ tipe =

525+ foldr Can.TLambda resultType (map snd typedArgs)

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

7373

7474

7575fromModule :: 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 =

7777 Interface

7878 { _home = home

7979 , _values = restrict exports annotations

@@ -215,7 +215,7 @@ instance Binary Union where

215215 0 -> liftM OpenUnion get

216216 1 -> liftM ClosedUnion get

217217 2 -> liftM PrivateUnion get

218− _ -> fail "binary encoding of Union was corrupted"

218+ _ -> error "binary encoding of Union was corrupted"

219219

220220

221221instance Binary Alias where

@@ -229,7 +229,7 @@ instance Binary Alias where

229229 case n of

230230 0 -> liftM PublicAlias get

231231 1 -> liftM PrivateAlias get

232− _ -> fail "binary encoding of Alias was corrupted"

232+ _ -> error "binary encoding of Alias was corrupted"

233233

234234

235235instance Binary Binop where

@@ -251,4 +251,4 @@ instance Binary DependencyInterface where

251251 case n of

252252 0 -> liftM Public get

253253 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+56−71

@@ -11,24 +11,25 @@ module Elm.Kernel

1111

1212import Control.Monad (liftM, liftM2)

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

14−import qualified Data.ByteString.Internal as B

14+import qualified Data.ByteString as BS

15+import Data.Coerce (coerce)

1516import qualified Data.List as List

1617import qualified Data.Map as Map

1718import qualified Data.Name as Name

18−import Data.Word (Word8)

19−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

20−import Foreign.ForeignPtr (ForeignPtr)

21−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

19+import qualified Data.Utf8 as Utf8

20+import Data.Word (Word8, Word16)

21+import Foreign.Ptr (Ptr, plusPtr)

2222

2323import qualified AST.Source as Src

2424import qualified Elm.ModuleName as ModuleName

2525import qualified Elm.Package as Pkg

2626import qualified Parse.Module as Module

27−import qualified Parse.Space as Space

2827import qualified Parse.Variable as Var

29−import Parse.Primitives hiding (fromByteString)

28+import Parse.Utils

29+import Parse.Primitives hiding (Parser, fromByteString)

3030import qualified Parse.Primitives as P

3131import qualified Reporting.Annotation as A

32+import qualified Reporting.Error.Syntax as E

3233

3334

3435

@@ -36,7 +37,7 @@ import qualified Reporting.Annotation as A

3637

3738

3839data Chunk

39− = JS B.ByteString

40+ = JS (Utf8.VeryLong UNCHECKED)

4041 | ElmVar ModuleName.Canonical Name.Name

4142 | JsVar Name.Name Name.Name

4243 | ElmField Name.Name

@@ -46,6 +47,9 @@ data Chunk

4647 | Prod

4748

4849

50+data UNCHECKED

51+

52+

4953

5054-- COUNT FIELDS

5155

@@ -80,58 +84,44 @@ type Foreigns =

8084 Map.Map ModuleName.Raw Pkg.Name

8185

8286

83−fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content

87+fromByteString :: Pkg.Name -> Foreigns -> BS.ByteString -> Maybe Content

8488fromByteString pkg foreigns bytes =

85− case P.fromByteString (parser pkg foreigns) toError bytes of

86− Right content ->

87− Just content

89+ case P.fromByteString (parser pkg foreigns) bytes of

90+ P.Ok content _ -> Just content

91+ P.Err _ _ _ _ -> Nothing

8892

89− Left () ->

90− Nothing

9193

92−

93−parser :: Pkg.Name -> Foreigns -> Parser () Content

94+parser :: Pkg.Name -> Foreigns -> Parser Content

9495parser pkg foreigns =

95− do word2 0x2F 0x2A {-/*-} toError

96− Space.chomp ignoreError

97− Space.checkFreshLine toError

98− imports <- specialize ignoreError (Module.chompImports [])

99− word2 0x2A 0x2F {-*/-} toError

96+ do word2 0x2F 0x2A {-/*-} E.XXX

97+ Module.freshLine

98+ imports <- Module.chompImports []

99+ word2 0x2A 0x2F {-*/-} E.XXX

100100 chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty

101101 return (Content imports chunks)

102102

103103

104−toError :: Row -> Col -> ()

105−toError _ _ =

106− ()

107−

108−

109−ignoreError :: a -> Row -> Col -> ()

110−ignoreError _ _ _ =

111− ()

112−

113−

114104

115105-- PARSE CHUNKS

116106

117107

118−parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]

108+parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]

119109parseChunks 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 _ ->

121111 let

122112 (# 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 []

124114 in

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

127117 else

128− cerr row col toError

118+ cerr row col ctx E.XXX

129119

130120

131−chompChunks :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)

132−chompChunks vs es fs src pos end row col lastPos revChunks =

121+chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)

122+chompChunks vs es fs pos end row col lastPos revChunks =

133123 if pos >= end then

134− let !js = toByteString src lastPos end in

124+ let !js = Utf8.fromPtr lastPos end in

135125 (# reverse (JS js : revChunks), pos, row, col #)

136126

137127 else

@@ -142,34 +132,24 @@ chompChunks vs es fs src pos end row col lastPos revChunks =

142132 !pos3 = plusPtr pos 3

143133 in

144134 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then

145− let !js = toByteString src lastPos pos in

146− chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)

135+ let !js = Utf8.fromPtr lastPos pos in

136+ chompTag vs es fs pos3 end row (col + 3) (JS js : revChunks)

147137 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

149139

150140 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

152142

153143 else

154144 let

155− !newPos = plusPtr pos (getCharWidth word)

145+ !newPos = plusPtr pos (getCharWidth pos end word)

156146 in

157− chompChunks vs es fs src newPos end row (col + 1) lastPos revChunks

158−

159−

160−toByteString :: ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> B.ByteString

161−toByteString src pos end =

162− let

163− !off = minusPtr pos (unsafeForeignPtrToPtr src)

164− !len = minusPtr end pos

165− in

166− B.PS src off len

167−

147+ chompChunks vs es fs newPos end row (col + 1) lastPos revChunks

168148

169149

170150-- relies on external checks in chompChunks

171−chompTag :: VarTable -> Enums -> Fields -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Chunk] -> (# [Chunk], Ptr Word8, Row, Col #)

172−chompTag vs es fs src pos end row col revChunks =

151+chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)

152+chompTag vs es fs pos end row col revChunks =

173153 let

174154 (# newPos, newCol #) = Var.chompInnerChars pos end col

175155 !tagPos = plusPtr pos (-1)

@@ -179,7 +159,7 @@ chompTag vs es fs src pos end row col revChunks =

179159 let

180160 !name = Name.fromPtr pos newPos

181161 in

182− chompChunks vs es fs src newPos end row newCol newPos $

162+ chompChunks vs es fs newPos end row newCol newPos $

183163 ElmField name : revChunks

184164 else

185165 let

@@ -190,7 +170,7 @@ chompTag vs es fs src pos end row col revChunks =

190170 (enum, newEnums) =

191171 lookupEnum (word - 0x30) name es

192172 in

193− chompChunks vs newEnums fs src newPos end row newCol newPos $

173+ chompChunks vs newEnums fs newPos end row newCol newPos $

194174 JsEnum enum : revChunks

195175

196176 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then

@@ -198,19 +178,19 @@ chompTag vs es fs src pos end row col revChunks =

198178 (field, newFields) =

199179 lookupField name fs

200180 in

201− chompChunks vs es newFields src newPos end row newCol newPos $

181+ chompChunks vs es newFields newPos end row newCol newPos $

202182 JsField field : revChunks

203183

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

206186

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

209189

210190 else

211191 case Map.lookup name vs of

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

214194

215195 Nothing ->

216196 (# revChunks, pos, row, col #)

@@ -319,19 +299,19 @@ toNames exposing =

319299 map toName exposedList

320300

321301

322−toName :: Src.Exposed -> Name.Name

323−toName exposed =

302+toName :: A.Located Src.Exposed -> Name.Name

303+toName (A.At _ exposed) =

324304 case exposed of

325− Src.Lower (A.At _ name) ->

305+ Src.Lower name ->

326306 name

327307

328− Src.Upper (A.At _ name) Src.Private ->

308+ Src.Upper name Src.Private ->

329309 name

330310

331− Src.Upper _ (Src.Public _) ->

311+ Src.Upper _ Src.Public ->

332312 error "cannot have Maybe(..) syntax in kernel code header"

333313

334− Src.Operator _ _ ->

314+ Src.Operator _ ->

335315 error "cannot use binops in kernel code"

336316

337317

@@ -342,7 +322,7 @@ toName exposed =

342322instance Binary Chunk where

343323 put chunk =

344324 case chunk of

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

325+ JS a -> putWord8 0 >> put (coerce a :: Utf8.String)

346326 ElmVar a b -> putWord8 1 >> put a >> put b

347327 JsVar a b -> putWord8 2 >> put a >> put b

348328 ElmField a -> putWord8 3 >> put a

@@ -354,7 +334,7 @@ instance Binary Chunk where

354334 get =

355335 do word <- getWord8

356336 case word of

357− 0 -> liftM JS get

337+ 0 -> liftM toJS get

358338 1 -> liftM2 ElmVar get get

359339 2 -> liftM2 JsVar get get

360340 3 -> liftM ElmField get

@@ -363,3 +343,8 @@ instance Binary Chunk where

363343 6 -> return Debug

364344 7 -> return Prod

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

99 where

1010

1111

12+import Control.Monad (liftM2)

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

14+import Data.Map ((!))

1215import qualified Data.Map as Map

1316import qualified Data.Utf8 as Utf8

1417

1518import qualified Json.Decode as D

1619import qualified Json.Encode as E

17−import qualified Json.String as Json

1820import qualified Reporting.Suggest as Suggest

1921

2022

@@ -22,21 +24,25 @@ import qualified Reporting.Suggest as Suggest

2224-- LICENCES

2325

2426

25−newtype License =

26− License Json.String

27+data License =

28+ License

29+ { _name :: Utf8.String

30+ , _code :: Utf8.String

31+ }

32+ deriving (Eq, Ord)

2733

2834

2935bsd3 :: License

3036bsd3 =

31− License (Json.fromChars "BSD-3-Clause")

37+ osiApprovedSpdxLicenses ! "BSD-3-Clause"

3238

3339

3440encode :: License -> E.Value

35−encode (License code) =

41+encode (License _ code) =

3642 E.string code

3743

3844

39−decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License

45+decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License

4046decoder toError =

4147 do str <- D.string

4248 case check str of

@@ -51,93 +57,97 @@ decoder toError =

5157-- CHECK

5258

5359

54−check :: Json.String -> Either [Json.String] License

55−check givenCode =

56− if Map.member givenCode osiApprovedSpdxLicenses then

57− Right (License givenCode)

60+check :: Utf8.String -> Either [Utf8.String] License

61+check rawName =

62+ case Map.lookup rawName osiApprovedSpdxLicenses of

63+ Just license ->

64+ Right license

5865

59− else

60− let

61− pairs =

62− map (\code -> (code, Json.toChars code)) (Map.keys osiApprovedSpdxLicenses)

63− ++

64− Map.toList osiApprovedSpdxLicenses

65− in

66− Left $ map fst $ take 4 $

67− Suggest.sort (Utf8.toChars givenCode) snd pairs

66+ Nothing ->

67+ let

68+ toPairs (License name code) =

69+ [ (Utf8.toChars code, code), (Utf8.toChars name, code) ]

70+

71+ pairs =

72+ concatMap toPairs (Map.elems osiApprovedSpdxLicenses)

73+ in

74+ Left $ map snd $

75+ Suggest.sort (Utf8.toChars rawName) fst pairs

6876

6977

7078

7179-- LIST OF LICENCES

7280

7381

74−(==>) :: [Char] -> [Char] -> (Json.String, [Char])

75−(==>) code fullName =

76− ( Json.fromChars code, fullName )

82+(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)

83+(==>) code name =

84+ ( code, License name code )

7785

7886

7987--

8088-- OSI approved licenses in SPDX format.

8189-- <https://spdx.org/licenses/>

8290--

83−osiApprovedSpdxLicenses :: Map.Map Json.String [Char]

91+osiApprovedSpdxLicenses :: Map.Map Utf8.String License

8492osiApprovedSpdxLicenses =

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

8995 , "AFL-1.2" ==> "Academic Free License v1.2"

9096 , "AFL-2.0" ==> "Academic Free License v2.0"

9197 , "AFL-2.1" ==> "Academic Free License v2.1"

9298 , "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"

94100 , "Apache-1.1" ==> "Apache License 1.1"

95101 , "Apache-2.0" ==> "Apache License 2.0"

96− , "APL-1.0" ==> "Adaptive Public License 1.0"

97102 , "APSL-1.0" ==> "Apple Public Source License 1.0"

98103 , "APSL-1.1" ==> "Apple Public Source License 1.1"

99104 , "APSL-1.2" ==> "Apple Public Source License 1.2"

100105 , "APSL-2.0" ==> "Apple Public Source License 2.0"

101106 , "Artistic-1.0" ==> "Artistic License 1.0"

102− , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"

103107 , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"

108+ , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"

104109 , "Artistic-2.0" ==> "Artistic License 2.0"

110+ , "AAL" ==> "Attribution Assurance License"

111+ , "BSL-1.0" ==> "Boost Software License 1.0"

105112 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"

106113 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"

107− , "BSL-1.0" ==> "Boost Software License 1.0"

108− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"

109− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"

114+ , "0BSD" ==> "BSD Zero Clause License"

110115 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"

111116 , "CNRI-Python" ==> "CNRI Python License"

117+ , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"

112118 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"

113119 , "CPL-1.0" ==> "Common Public License 1.0"

120+ , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"

114121 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"

122+ , "EPL-1.0" ==> "Eclipse Public License 1.0"

115123 , "ECL-1.0" ==> "Educational Community License v1.0"

116124 , "ECL-2.0" ==> "Educational Community License v2.0"

117125 , "EFL-1.0" ==> "Eiffel Forum License v1.0"

118126 , "EFL-2.0" ==> "Eiffel Forum License v2.0"

119127 , "Entessa" ==> "Entessa Public License v1.0"

120− , "EPL-1.0" ==> "Eclipse Public License 1.0"

121128 , "EUDatagrid" ==> "EU DataGrid Software License"

122129 , "EUPL-1.1" ==> "European Union Public License 1.1"

123130 , "Fair" ==> "Fair License"

124131 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"

132+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"

125133 , "GPL-2.0" ==> "GNU General Public License v2.0 only"

126134 , "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"

127138 , "HPND" ==> "Historic Permission Notice and Disclaimer"

139+ , "IPL-1.0" ==> "IBM Public License v1.0"

128140 , "Intel" ==> "Intel Open Source License"

129141 , "IPA" ==> "IPA Font License"

130− , "IPL-1.0" ==> "IBM Public License v1.0"

131142 , "ISC" ==> "ISC License"

132− , "LGPL-2.0" ==> "GNU Library General Public License v2 only"

133− , "LGPL-2.1" ==> "GNU Lesser General Public License v2.1 only"

134− , "LGPL-3.0" ==> "GNU Lesser General Public License v3.0 only"

143+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

135144 , "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"

137145 , "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"

139147 , "LPL-1.02" ==> "Lucent Public License v1.02"

140− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

148+ , "LPL-1.0" ==> "Lucent Public License Version 1.0"

149+ , "MS-PL" ==> "Microsoft Public License"

150+ , "MS-RL" ==> "Microsoft Reciprocal License"

141151 , "MirOS" ==> "MirOS Licence"

142152 , "MIT" ==> "MIT License"

143153 , "Motosoto" ==> "Motosoto License"

@@ -145,41 +155,48 @@ osiApprovedSpdxLicenses =

145155 , "MPL-1.1" ==> "Mozilla Public License 1.1"

146156 , "MPL-2.0" ==> "Mozilla Public License 2.0"

147157 , "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"

150158 , "Multics" ==> "Multics License"

151159 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"

152160 , "Naumen" ==> "Naumen Public License"

153− , "NCSA" ==> "University of Illinois/NCSA Open Source License"

154161 , "NGPL" ==> "Nethack General Public License"

155162 , "Nokia" ==> "Nokia Open Source License"

156163 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"

157164 , "NTP" ==> "NTP License"

158165 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"

159− , "OFL-1.1" ==> "SIL Open Font License 1.1"

160166 , "OGTSL" ==> "Open Group Test Suite License"

161− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

162167 , "OSL-1.0" ==> "Open Software License 1.0"

163168 , "OSL-2.0" ==> "Open Software License 2.0"

164169 , "OSL-2.1" ==> "Open Software License 2.1"

165170 , "OSL-3.0" ==> "Open Software License 3.0"

171+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

166172 , "PHP-3.0" ==> "PHP License v3.0"

167173 , "PostgreSQL" ==> "PostgreSQL License"

168174 , "Python-2.0" ==> "Python License 2.0"

169175 , "QPL-1.0" ==> "Q Public License 1.0"

176+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

170177 , "RPL-1.1" ==> "Reciprocal Public License 1.1"

171178 , "RPL-1.5" ==> "Reciprocal Public License 1.5"

172− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

173179 , "RSCPL" ==> "Ricoh Source Code Public License"

180+ , "OFL-1.1" ==> "SIL Open Font License 1.1"

174181 , "SimPL-2.0" ==> "Simple Public License 2.0"

175− , "SISSL" ==> "Sun Industry Standards Source License v1.1"

176182 , "Sleepycat" ==> "Sleepycat License"

183+ , "SISSL" ==> "Sun Industry Standards Source License v1.1"

177184 , "SPL-1.0" ==> "Sun Public License v1.0"

185+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

178186 , "UPL-1.0" ==> "Universal Permissive License v1.0"

187+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"

179188 , "VSL-1.0" ==> "Vovida Software License v1.0"

180189 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"

181− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

182190 , "Xnet" ==> "X.Net License"

183191 , "Zlib" ==> "zlib License"

184192 , "ZPL-2.0" ==> "Zope Public License 2.0"

185193 ]

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

22module Elm.ModuleName

33 ( Raw

44 , toChars

5+ , toString

56 , toFilePath

67 , toHyphenPath

7− --

8+ , fromHyphenPath

89 , encode

910 , decoder

10− , parser

11− --

1211 , Canonical(..)

12+ , canonicalIsKernel

1313 , basics, char, string

1414 , maybe, result, list, array, dict, tuple

1515 , platform, cmd, sub

16− , debug

16+ , debug, bitwise

1717 , virtualDom

1818 , jsonDecode, jsonEncode

1919 , webgl, texture, vector2, vector3, vector4, matrix4

@@ -23,19 +23,15 @@ module Elm.ModuleName

2323

2424import Control.Monad (liftM2)

2525import Data.Binary (Binary(..))

26+import qualified Data.Char as Char

2627import qualified Data.Name as Name

2728import qualified Data.Utf8 as Utf8

28−import Data.Word (Word8)

29−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

3029import Prelude hiding (maybe)

3130import qualified System.FilePath as FP

3231

3332import qualified Elm.Package as Pkg

34−import qualified Json.Decode as D

35−import qualified Json.Encode as E

36−import qualified Parse.Variable as Var

37−import qualified Parse.Primitives as P

38−import Parse.Primitives (Row, Col)

33+import qualified Json.Decode as Decode

34+import qualified Json.Encode as Encode

3935

4036

4137

@@ -50,6 +46,11 @@ toChars =

5046 Name.toChars

5147

5248

49+toString :: Raw -> Utf8.String

50+toString =

51+ Name.toUtf8

52+

53+

5354toFilePath :: Raw -> FilePath

5455toFilePath name =

5556 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)

@@ -60,68 +61,38 @@ toHyphenPath name =

6061 map (\c -> if c == '.' then '-' else c) (Name.toChars name)

6162

6263

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+

6375

6476-- JSON

6577

6678

67−encode :: Raw -> E.Value

79+encode :: Raw -> Encode.Value

6880encode =

69− E.name

81+ Encode.name

7082

7183

72−decoder :: D.Decoder (Row, Col) Raw

84+decoder :: Decode.Decoder Utf8.String Raw

7385decoder =

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

7590

7691

77−

78−-- PARSER

79−

80−

81−parser :: P.Parser (Row, Col) Raw

82−parser =

83− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

84− let

85− (# isGood, newPos, newCol #) = chompStart pos end col

86− in

87− if isGood && minusPtr newPos pos < 256 then

88− let !newState = P.State src newPos end indent row newCol in

89− cok (Utf8.fromPtr pos newPos) newState

90−

91− else if col == newCol then

92− eerr row newCol (,)

93−

94− else

95− cerr row newCol (,)

96−

97−

98−chompStart :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)

99−chompStart pos end col =

100− let

101− !width = Var.getUpperWidth pos end

102− in

103− if width == 0 then

104− (# False, pos, col #)

105− else

106− chompInner (plusPtr pos width) end (col + 1)

107−

108−

109−chompInner :: Ptr Word8 -> Ptr Word8 -> Col -> (# Bool, Ptr Word8, Col #)

110−chompInner pos end col =

111− if pos >= end then

112− (# True, pos, col #)

113− else

114− let

115− !word = P.unsafeIndex pos

116− !width = Var.getInnerWidthHelp pos end word

117− in

118− if width == 0 then

119− if word == 0x2E {-.-} then

120− chompStart (plusPtr pos 1) end (col + 1)

121− else

122− (# True, pos, col #)

123− else

124− chompInner (plusPtr pos width) end (col + 1)

92+isGoodChunk :: Utf8.String -> Bool

93+isGoodChunk chunk =

94+ Utf8.startsWithChar Char.isUpper chunk

95+ && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk

12596

12697

12798

@@ -133,6 +104,12 @@ data Canonical =

133104 { _package :: !Pkg.Name

134105 , _module :: !Name.Name

135106 }

107+ deriving (Ord)

108+

109+

110+canonicalIsKernel :: Canonical -> Bool

111+canonicalIsKernel (Canonical _ name) =

112+ Name.isKernel name

136113

137114

138115

@@ -144,14 +121,6 @@ instance Eq Canonical where

144121 name1 == name2 && pkg1 == pkg2

145122

146123

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−

155124instance Binary Canonical where

156125 put (Canonical a b) = put a >> put b

157126 get = liftM2 Canonical get get

@@ -226,6 +195,11 @@ debug :: Canonical

226195debug = Canonical Pkg.core Name.debug

227196

228197

198+{-# NOINLINE bitwise #-}

199+bitwise :: Canonical

200+bitwise = Canonical Pkg.core Name.bitwise

201+

202+

229203

230204-- HTML

231205

compiler/src/Elm/Package.hs+89−220

@@ -1,52 +1,38 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}

2+{-# LANGUAGE OverloadedStrings #-}

33module Elm.Package

44 ( Name(..)

5− , Author

6− , Project

75 , Canonical(..)

86 , isKernel

7+ , toString

98 , toChars

109 , toUrl

1110 , toFilePath

12− , toJsonString

13− --

11+ , BadName(..)

12+ , fromString

1413 , dummyName, kernel, core

1514 , browser, virtualDom, html

1615 , json, http, url

1716 , webgl, linearAlgebra

18− --

1917 , suggestions

20− , nearbyNames

21− --

2218 , decoder

2319 , encode

24− , keyDecoder

25− --

26− , parser

2720 )

2821 where

2922

3023

3124import Control.Monad (liftM2)

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

33−import qualified Data.Coerce as Coerce

34−import qualified Data.List as List

35−import qualified Data.Map as Map

26+import qualified Data.Char as Char

3627import qualified Data.Name as Name

28+import qualified Data.Map as Map

3729import Data.Monoid ((<>))

3830import qualified Data.Utf8 as Utf8

39−import Data.Word (Word8)

40−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

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

4232

4333import qualified Elm.Version as V

44−import qualified Json.Decode as D

45−import qualified Json.Encode as E

46−import qualified Json.String as Json

47−import qualified Parse.Primitives as P

48−import Parse.Primitives (Row, Col)

49−import qualified Reporting.Suggest as Suggest

34+import qualified Json.Decode as Decode

35+import qualified Json.Encode as Encode

5036

5137

5238

@@ -55,17 +41,10 @@ import qualified Reporting.Suggest as Suggest

5541

5642data Name =

5743 Name

58− { _author :: !Author

59− , _project :: !Project

44+ { _author :: !Name.Name

45+ , _project :: !Name.Name

6046 }

61− deriving (Ord)

62−

63−

64−type Author = Utf8.Utf8 AUTHOR

65−type Project = Utf8.Utf8 PROJECT

66−

67−data AUTHOR

68−data PROJECT

47+ deriving (Eq, Ord)

6948

7049

7150data Canonical =

@@ -73,7 +52,7 @@ data Canonical =

7352 { _name :: !Name

7453 , _version :: !V.Version

7554 }

76− deriving (Ord)

55+ deriving (Eq, Ord)

7756

7857

7958

@@ -82,114 +61,127 @@ data Canonical =

8261

8362isKernel :: Name -> Bool

8463isKernel (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 ]

8670

8771

8872toChars :: Name -> String

8973toChars (Name author project) =

90− Utf8.toChars author <> "/" <> Utf8.toChars project

74+ Name.toChars author <> "/" <> Name.toChars project

9175

9276

9377toUrl :: Name -> String

9478toUrl (Name author project) =

95− Utf8.toChars author ++ "/" ++ Utf8.toChars project

79+ Name.toChars author ++ "/" ++ Name.toChars project

9680

9781

9882toFilePath :: Name -> FilePath

9983toFilePath (Name author project) =

100− Utf8.toChars author </> Utf8.toChars project

84+ Name.toChars author </> Name.toChars project

10185

10286

103−toJsonString :: Name -> Json.String

104−toJsonString (Name author project) =

105− Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]

87+fromString :: Utf8.String -> Either BadName Name

88+fromString str =

89+ case Utf8.split 0x2F {- / -} str of

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

106101

102+ _ ->

103+ Left BadStructure

107104

108105

109−-- COMMON PACKAGE NAMES

106+data BadName

107+ = BadStructure

108+ | TooLong

109+ | HasDoubleDash

110+ | HasUnderscore

111+ | HasDot

112+ | HasUppercase

113+ | HasDashEnd

114+ | HasNonLowercaseStart

115+

110116

111117

112−toName :: Author -> [Char] -> Name

113−toName author project =

114− Name author (Utf8.fromChars project)

118+-- COMMON PACKAGE NAMES

115119

116120

117121{-# NOINLINE dummyName #-}

118122dummyName :: Name

119123dummyName =

120− toName (Utf8.fromChars "author") "project"

124+ Name "author" "project"

121125

122126

123127{-# NOINLINE kernel #-}

124128kernel :: Name

125129kernel =

126− toName elm "kernel"

130+ Name "elm" "kernel"

127131

128132

129133{-# NOINLINE core #-}

130134core :: Name

131135core =

132− toName elm "core"

136+ Name "elm" "core"

133137

134138

135139{-# NOINLINE browser #-}

136140browser :: Name

137141browser =

138− toName elm "browser"

142+ Name "elm" "browser"

139143

140144

141145{-# NOINLINE virtualDom #-}

142146virtualDom :: Name

143147virtualDom =

144− toName elm "virtual-dom"

148+ Name "elm" "virtual-dom"

145149

146150

147151{-# NOINLINE html #-}

148152html :: Name

149153html =

150− toName elm "html"

154+ Name "elm" "html"

151155

152156

153157{-# NOINLINE json #-}

154158json :: Name

155159json =

156− toName elm "json"

160+ Name "elm" "json"

157161

158162

159163{-# NOINLINE http #-}

160164http :: Name

161165http =

162− toName elm "http"

166+ Name "elm" "http"

163167

164168

165169{-# NOINLINE url #-}

166170url :: Name

167171url =

168− toName elm "url"

172+ Name "elm" "url"

169173

170174

171175{-# NOINLINE webgl #-}

172176webgl :: Name

173177webgl =

174− toName elm_explorations "webgl"

178+ Name "elm-explorations" "webgl"

175179

176180

177181{-# NOINLINE linearAlgebra #-}

178182linearAlgebra :: Name

179183linearAlgebra =

180− toName elm_explorations "linear-algebra"

181−

182−

183−{-# NOINLINE elm #-}

184−elm :: Author

185−elm =

186− Utf8.fromChars "elm"

187−

188−

189−{-# NOINLINE elm_explorations #-}

190−elm_explorations :: Author

191−elm_explorations =

192− Utf8.fromChars "elm-explorations"

184+ Name "elm-explorations" "linear-algebra"

193185

194186

195187

@@ -198,177 +190,54 @@ elm_explorations =

198190

199191suggestions :: Map.Map Name.Name Name

200192suggestions =

201− let

202− random = toName elm "random"

203− time = toName elm "time"

204− file = toName elm "file"

205− in

206193 Map.fromList

207− [ "Browser" ==> browser

208− , "File" ==> file

209− , "File.Download" ==> file

210− , "File.Select" ==> file

211− , "Html" ==> html

212− , "Html.Attributes" ==> html

213− , "Html.Events" ==> html

214− , "Http" ==> http

215− , "Json.Decode" ==> json

216− , "Json.Encode" ==> json

217− , "Random" ==> random

218− , "Time" ==> time

219− , "Url.Parser" ==> url

220− , "Url" ==> url

194+ [ ("Browser", browser)

195+ , ("Html", html)

196+ , ("Http", http)

197+ , ("Json.Decode", json)

198+ , ("Json.Encode", json)

199+ , ("Url.Parser", url)

200+ , ("Url", url)

221201 ]

222202

223203

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−

271204

272205-- BINARY

273206

274207

275−instance Binary Name where -- PERF try storing as a Word16

276− get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256

277− put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b

208+instance Binary Name where

209+ get =

210+ liftM2 Name get get

211+

212+ put (Name author project) =

213+ do put author

214+ put project

278215

279216

280217instance Binary Canonical where

281− get = liftM2 Canonical get get

282− put (Canonical a b) = put a >> put b

218+ get =

219+ liftM2 Canonical get get

220+

221+ put (Canonical name version) =

222+ do put name

223+ put version

283224

284225

285226

286227-- JSON

287228

288229

289−decoder :: D.Decoder (Row, Col) Name

230+decoder :: Decode.Decoder BadName Name

290231decoder =

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

292239

293240

294−encode :: Name -> E.Value

241+encode :: Name -> Encode.Value

295242encode name =

296− E.chars (toChars name)

297−

298−

299−keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name

300−keyDecoder toError =

301− let

302− keyParser =

303− P.specialize (\(r,c) _ _ -> toError r c) parser

304− in

305− D.KeyDecoder keyParser toError

306−

307−

308−

309−-- PARSER

310−

311−

312−parser :: P.Parser (Row, Col) Name

313−parser =

314− do author <- parseName isAlphaOrDigit isAlphaOrDigit

315− P.word1 0x2F {-/-} (,)

316− project <- parseName isLower isLowerOrDigit

317− return (Name author project)

318−

319−

320−parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)

321−parseName isGoodStart isGoodInner =

322− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

323− if pos >= end then

324− eerr row col (,)

325− else

326− let !word = P.unsafeIndex pos in

327− if not (isGoodStart word) then

328− eerr row col (,)

329− else

330− let

331− (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False

332− !len = fromIntegral (minusPtr newPos pos)

333− !newCol = col + len

334− in

335− if isGood && len < 256 then

336− let !newState = P.State src newPos end indent row newCol in

337− cok (Utf8.fromPtr pos newPos) newState

338− else

339− cerr row newCol (,)

340−

341−

342−isLower :: Word8 -> Bool

343−isLower word =

344− 0x61 {-a-} <= word && word <= 0x7A {-z-}

345−

346−

347−isLowerOrDigit :: Word8 -> Bool

348−isLowerOrDigit word =

349− 0x61 {-a-} <= word && word <= 0x7A {-z-}

350− || 0x30 {-0-} <= word && word <= 0x39 {-9-}

351−

352−

353−isAlphaOrDigit :: Word8 -> Bool

354−isAlphaOrDigit word =

355− 0x61 {-a-} <= word && word <= 0x7A {-z-}

356− || 0x41 {-A-} <= word && word <= 0x5A {-Z-}

357− || 0x30 {-0-} <= word && word <= 0x39 {-9-}

358−

359−

360−chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)

361−chompName isGoodChar pos end prevWasDash =

362− if pos >= end then

363− (# not prevWasDash, pos #)

364− else

365− let !word = P.unsafeIndex pos in

366− if isGoodChar word then

367− chompName isGoodChar (plusPtr pos 1) end False

368− else if word == 0x2D {---} then

369− if prevWasDash then

370− (# False, pos #)

371− else

372− chompName isGoodChar (plusPtr pos 1) end True

373− else

374− (# True, pos #)

243+ Encode.string (toString name)

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

31module Elm.Version

42 ( Version(..)

53 , one

@@ -9,11 +7,10 @@ module Elm.Version

97 , bumpMinor

108 , bumpMajor

119 , toChars

12− --

10+ , toString

11+ , fromString

1312 , decoder

1413 , encode

15− --

16− , parser

1714 )

1815 where

1916

@@ -21,15 +18,13 @@ module Elm.Version

2118import Prelude hiding (max)

2219import Control.Monad (liftM3)

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

21+import qualified Data.Utf8 as Utf8

2422import qualified Data.Version as Version

25−import Data.Word (Word8, Word16)

26−import Foreign.Ptr (Ptr, plusPtr, minusPtr)

23+import Data.Word (Word16)

2724import qualified Paths_elm

2825

2926import qualified Json.Decode as D

3027import qualified Json.Encode as E

31−import qualified Parse.Primitives as P

32−import Parse.Primitives (Row, Col)

3328

3429

3530

@@ -91,26 +86,58 @@ bumpMajor (Version major _minor _patch) =

9186

9287

9388

94−-- TO CHARS

89+-- TO STRING

9590

9691

97−toChars :: Version -> [Char]

98−toChars (Version major minor patch) =

99− show major ++ '.' : show minor ++ '.' : show patch

92+toChars :: Version -> String

93+toChars vsn =

94+ Utf8.toChars (toString vsn)

95+

96+

97+toString :: Version -> Utf8.String

98+toString (Version major minor 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

100121

101122

102123

103124-- JSON

104125

105126

106−decoder :: D.Decoder (Row, Col) Version

127+decoder :: D.Decoder Utf8.String Version

107128decoder =

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

109136

110137

111138encode :: Version -> E.Value

112139encode version =

113− E.chars (toChars version)

140+ E.string (toString version)

114141

115142

116143

@@ -137,60 +164,3 @@ instance Binary Version where

137164 put major

138165 put minor

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

2929

3030<body>

3131

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>

3339

3440<script>

35−try {

3641|] <> javascript <> [r|

3742

43+try {

3844 var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });

39−}

40−catch (e)

41−{

45+} catch (e) {

4246 // display initialization errors (e.g. bad flags, infinite recursion)

43− var header = document.createElement("h1");

44− header.style.fontFamily = "monospace";

45− header.innerText = "Initialization Error";

46− var pre = document.getElementById("elm");

47− document.body.insertBefore(header, pre);

48− pre.innerText = e;

47+ document.getElementById("elm").innerText = e;

4948 throw e;

5049}

5150</script>

compiler/src/Generate/JavaScript.hs+55−76

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

22module Generate.JavaScript

33 ( generate

44 , generateForRepl

5− , generateForReplEndpoint

65 )

76 where

87

@@ -86,9 +85,7 @@ generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _

8685 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

8786 evalState = addGlobal mode graph debugState (Opt.Global home name)

8887 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

9289 <> print ansi localizer home name tipe

9390

9491

@@ -100,47 +97,14 @@ print ansi localizer home name tipe =

10097 tipeDoc = RT.canToDoc localizer RT.None tipe

10198 bool = if ansi then "true" else "false"

10299 in

103− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\

104− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\

105− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\

106− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\

107− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\

108− \} else {\n\

109− \ _print(' : ' + _type);\n\

110− \}\n"

111−

112−

113−

114−-- GENERATE FOR REPL ENDPOINT

115−

116−

117−generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder

118−generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =

119− let

120− name = maybe Name.replValueToPrint id maybeName

121− mode = Mode.Dev Nothing

122− debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

123− evalState = addGlobal mode graph debugState (Opt.Global home name)

124− in

125− Functions.functions

126− <> stateToBuilder evalState

127− <> postMessage localizer home maybeName tipe

128−

129−

130−postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder

131−postMessage localizer home maybeName tipe =

132− let

133− name = maybe Name.replValueToPrint id maybeName

134− value = JsName.toBuilder (JsName.fromGlobal home name)

135− toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")

136− tipeDoc = RT.canToDoc localizer RT.None tipe

137− toName n = "\"" <> Name.toBuilder n <> "\""

138− in

139− "self.postMessage({\n\

140− \ name: " <> maybe "null" toName maybeName <> ",\n\

141− \ value: " <> toString <> "(true, " <> value <> "),\n\

142− \ type: " <> B.stringUtf8 (show (D.toString tipeDoc)) <> "\n\

143− \});\n"

100+ "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\

101+ \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\

102+ \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\

103+ \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\

104+ \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\

105+ \} else {\n\

106+ \ _print(' : ' + _type);\n\

107+ \}\n"

144108

145109

146110

@@ -261,7 +225,7 @@ addKernel (State revKernels revBuilders seen) kernel =

261225

262226var :: Opt.Global -> Expr.Code -> JS.Stmt

263227var (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)) ]

265229

266230

267231isDebugger :: Opt.Global -> Bool

@@ -292,7 +256,7 @@ generateCycle mode (Opt.Global home _) names values functions =

292256 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"

293257 <> drawCycle names

294258 <> "\\n\\nThese errors are very tricky, so read "

295− <> B.stringUtf8 (D.makeNakedLink "bad-recursion")

259+ <> B.stringUtf8 (D.makeNakedLink "halting-problem")

296260 <> " to learn how to fix it!"

297261 ]

298262

@@ -301,10 +265,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt

301265generateCycleFunc mode home def =

302266 case def of

303267 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))) ]

305269

306270 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))) ]

308272

309273

310274generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt

@@ -320,9 +284,9 @@ generateRealCycle home (name, _) =

320284 realName = JsName.fromGlobal home name

321285 in

322286 JS.Block

323− [ JS.Var realName (JS.Call (JS.Ref safeName) [])

287+ [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]

324288 , 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)) ]

326290 ]

327291

328292

@@ -350,7 +314,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder

350314addChunk mode chunk builder =

351315 case chunk of

352316 K.JS javascript ->

353− B.byteString javascript <> builder

317+ Utf8.toBuilder javascript <> builder

354318

355319 K.ElmVar home name ->

356320 JsName.toBuilder (JsName.fromGlobal home name) <> builder

@@ -390,13 +354,16 @@ addChunk mode chunk builder =

390354

391355generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt

392356generateEnum mode global@(Opt.Global home name) index =

393− JS.Var (JsName.fromGlobal home name) $

394− case mode of

395− Mode.Dev _ ->

396− Expr.codeToExpr (Expr.generateCtor mode global index 0)

357+ let

358+ definition =

359+ case mode of

360+ Mode.Dev _ ->

361+ Expr.codeToExpr (Expr.generateCtor mode global index 0)

397362

398− Mode.Prod _ ->

399− JS.Int (Index.toMachine index)

363+ Mode.Prod _ ->

364+ JS.Int (Index.toMachine index)

365+ in

366+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

400367

401368

402369

@@ -405,13 +372,16 @@ generateEnum mode global@(Opt.Global home name) index =

405372

406373generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt

407374generateBox mode global@(Opt.Global home name) =

408− JS.Var (JsName.fromGlobal home name) $

409− case mode of

410− Mode.Dev _ ->

411− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

375+ let

376+ definition =

377+ case mode of

378+ Mode.Dev _ ->

379+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

412380

413− Mode.Prod _ ->

414− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

381+ Mode.Prod _ ->

382+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

383+ in

384+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

415385

416386

417387{-# NOINLINE identity #-}

@@ -426,11 +396,14 @@ identity =

426396

427397generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt

428398generatePort mode (Opt.Global home name) makePort converter =

429− JS.Var (JsName.fromGlobal home name) $

430− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))

431− [ JS.String (Name.toBuilder name)

432− , Expr.codeToExpr (Expr.generate mode converter)

433− ]

399+ let

400+ definition =

401+ JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))

402+ [ JS.String (Name.toBuilder name)

403+ , Expr.codeToExpr (Expr.generate mode converter)

404+ ]

405+ in

406+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

434407

435408

436409

@@ -458,9 +431,11 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)

458431

459432generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt

460433generateLeaf home@(ModuleName.Canonical _ moduleName) name =

461− JS.Var (JsName.fromGlobal home name) $

462− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

463−

434+ let

435+ definition =

436+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

437+ in

438+ JS.Var [ (JsName.fromGlobal home name, Just definition) ]

464439

465440

466441{-# NOINLINE leaf #-}

@@ -534,7 +509,7 @@ generateExports mode (Trie maybeMain subs) =

534509 <> List.foldl' (addSubTrie mode) "}" otherSubTries

535510

536511

537−addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder

512+addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder

538513addSubTrie mode end (name, trie) =

539514 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end

540515

@@ -546,7 +521,7 @@ addSubTrie mode end (name, trie) =

546521data Trie =

547522 Trie

548523 { _main :: Maybe (ModuleName.Canonical, Opt.Main)

549− , _subs :: Map.Map Name.Name Trie

524+ , _subs :: Map.Map Utf8.String Trie

550525 }

551526

552527

@@ -557,10 +532,14 @@ emptyTrie =

557532

558533addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie

559534addToTrie home@(ModuleName.Canonical _ moduleName) main trie =

560− merge trie $ segmentsToTrie home (Name.splitDots moduleName) main

535+ let

536+ segments =

537+ Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)

538+ in

539+ merge trie $ segmentsToTrie home segments main

561540

562541

563−segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie

542+segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie

564543segmentsToTrie home segments main =

565544 case segments of

566545 [] ->

compiler/src/Generate/JavaScript/Builder.hs+217−207

@@ -16,7 +16,6 @@ module Generate.JavaScript.Builder

1616

1717import Prelude hiding (lines)

1818import qualified Data.List as List

19−import qualified Data.ByteString as BS

2019import Data.ByteString.Builder as B

2120import Data.Monoid ((<>))

2221import qualified Generate.JavaScript.Name as Name

@@ -28,19 +27,6 @@ import qualified Json.Encode as Json

2827-- EXPRESSIONS

2928

3029

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

4430data Expr

4531 = String Builder

4632 | Float Builder

@@ -51,13 +37,13 @@ data Expr

5137 | Array [Expr]

5238 | Object [(Name, Expr)]

5339 | Ref Name

54− | Access Expr Name -- foo.bar

55− | Index Expr Expr -- foo[bar]

40+ | Access Expr Name -- ^ @foo.bar@, spec 11.2.1

41+ | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1

5642 | Prefix PrefixOp Expr

5743 | Infix InfixOp Expr Expr

5844 | If Expr Expr Expr

5945 | Assign LValue Expr

60− | Call Expr [Expr]

46+ | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3

6147 | Function (Maybe Name) [Name] [Stmt]

6248

6349

@@ -72,21 +58,20 @@ data LValue

7258

7359

7460data Stmt

75− = Block [Stmt]

76− | EmptyStmt

77− | ExprStmt Expr

78− | IfStmt Expr Stmt Stmt

79− | Switch Expr [Case]

80− | While Expr Stmt

81− | Break (Maybe Name)

82− | Continue (Maybe Name)

83− | Labelled Name Stmt

84− | Try Stmt Name Stmt

85− | Throw Expr

86− | Return Expr

87− | Var Name Expr

88− | Vars [(Name, Expr)]

89− | FunctionStmt Name [Name] [Stmt]

61+ = Block [Stmt] -- {stmts}

62+ | EmptyStmt -- ;

63+ | ExprStmt Expr -- expr;

64+ | IfStmt Expr Stmt Stmt -- if (e) stmt1 else stmt2

65+ | Switch Expr [Case] -- switch (e) clauses

66+ | While Expr Stmt -- while (e) do stmt

67+ | Break (Maybe Name) -- break lab;

68+ | Continue (Maybe Name) -- continue lab;

69+ | Labelled Name Stmt -- lab: stmt

70+ | Try Stmt Name Stmt -- try stmt catch (x) stmt

71+ | Throw Expr -- throw expr;

72+ | Return (Maybe Expr) -- return expr;

73+ | Var [(Name, Maybe Expr)] -- var x, y=42;

74+ | FunctionStmt Name [Name] [Stmt] -- function f(x, y, z) {...}

9075

9176

9277data Case

@@ -99,31 +84,37 @@ data Case

9984

10085

10186data InfixOp

102− = OpAdd -- +

103− | OpSub -- -

87+ = OpLT -- <

88+ | OpLEq -- <=

89+ | OpGT -- >

90+ | OpGEq -- >=

91+ | OpIn -- in

92+ | OpInstanceof -- instanceof

93+ | OpEq -- ==

94+ | OpNEq -- !=

95+ | OpStrictEq -- ===

96+ | OpStrictNEq -- !==

97+ | OpLAnd -- &&

98+ | OpLOr -- ||

10499 | OpMul -- *

105100 | OpDiv -- /

106101 | OpMod -- %

107− | OpEq -- ===

108− | OpNe -- !==

109− | OpLt -- <

110− | OpLe -- <=

111− | OpGt -- >

112− | OpGe -- >=

113− | OpAnd -- &&

114− | OpOr -- ||

115− | OpBitwiseAnd -- &

116− | OpBitwiseXor -- ^

117− | OpBitwiseOr -- |

118− | OpLShift -- <<

119− | OpSpRShift -- >>

120− | OpZfRShift -- >>>

102+ | OpSub -- -

103+ | OpLShift -- <<

104+ | OpSpRShift -- >>

105+ | OpZfRShift -- >>>

106+ | OpBAnd -- &

107+ | OpBXor -- ^

108+ | OpBOr -- |

109+ | OpAdd -- +

121110

122111

123112data PrefixOp

124− = PrefixNot -- !

125− | PrefixNegate -- -

126− | PrefixComplement -- ~

113+ = PrefixLNot -- !

114+ | PrefixBNot -- ~

115+ | PrefixPlus -- +

116+ | PrefixMinus -- -

117+ | PrefixTypeof -- typeof

127118

128119

129120

@@ -132,40 +123,21 @@ data PrefixOp

132123

133124stmtToBuilder :: Stmt -> Builder

134125stmtToBuilder stmts =

135− fromStmt levelZero stmts

126+ fromStmt "" stmts

136127

137128

138129exprToBuilder :: Expr -> Builder

139130exprToBuilder expr =

140− snd $ fromExpr levelZero Whatever expr

141−

142−

143−

144−-- INDENT LEVEL

145−

146−

147−data Level =

148− Level Builder Level

149−

131+ snd $ fromExpr "" Whatever expr

150132

151−levelZero :: Level

152−levelZero =

153− Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))

154133

155134

156−makeLevel :: Int -> BS.ByteString -> Level

157−makeLevel level oldTabs =

158− let

159− tabs =

160− if level <= BS.length oldTabs

161− then oldTabs

162− else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}

163− in

164− Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)

165−

135+-- HELPERS

166136

167137

168−-- HELPERS

138+deeper :: Builder -> Builder

139+deeper indent =

140+ "\t" <> indent

169141

170142

171143commaSep :: [Builder] -> Builder

@@ -173,52 +145,52 @@ commaSep builders =

173145 mconcat (List.intersperse ", " builders)

174146

175147

176−commaNewlineSep :: Level -> [Builder] -> Builder

177−commaNewlineSep (Level _ (Level deeperIndent _)) builders =

178− mconcat (List.intersperse (",\n" <> deeperIndent) builders)

148+commaNewlineSep :: Builder -> [Builder] -> Builder

149+commaNewlineSep indent builders =

150+ mconcat (List.intersperse (",\n" <> deeper indent) builders)

179151

180152

181153

182154-- STATEMENTS

183155

184156

185−fromStmtBlock :: Level -> [Stmt] -> Builder

186−fromStmtBlock level stmts =

187− mconcat (map (fromStmt level) stmts)

157+fromStmtBlock :: Builder -> [Stmt] -> Builder

158+fromStmtBlock indent stmts =

159+ mconcat (map (fromStmt indent) stmts)

188160

189161

190−fromStmt :: Level -> Stmt -> Builder

191−fromStmt level@(Level indent nextLevel) statement =

162+fromStmt :: Builder -> Stmt -> Builder

163+fromStmt indent statement =

192164 case statement of

193165 Block stmts ->

194− fromStmtBlock level stmts

166+ fromStmtBlock indent stmts

195167

196168 EmptyStmt ->

197169 mempty

198170

199171 ExprStmt expr ->

200− indent <> snd (fromExpr level Whatever expr) <> ";\n"

172+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"

201173

202174 IfStmt condition thenStmt elseStmt ->

203175 mconcat

204− [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"

205− , fromStmt nextLevel thenStmt

176+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"

177+ , fromStmt (deeper indent) thenStmt

206178 , indent, "} else {\n"

207− , fromStmt nextLevel elseStmt

179+ , fromStmt (deeper indent) elseStmt

208180 , indent, "}\n"

209181 ]

210182

211183 Switch expr clauses ->

212184 mconcat

213− [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"

214− , mconcat (map (fromClause nextLevel) clauses)

185+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"

186+ , mconcat (map (fromClause (deeper indent)) clauses)

215187 , indent, "}\n"

216188 ]

217189

218190 While expr stmt ->

219191 mconcat

220− [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"

221− , fromStmt nextLevel stmt

192+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"

193+ , fromStmt (deeper indent) stmt

222194 , indent, "}\n"

223195 ]

224196

@@ -237,37 +209,37 @@ fromStmt level@(Level indent nextLevel) statement =

237209 Labelled label stmt ->

238210 mconcat

239211 [ indent, Name.toBuilder label, ":\n"

240− , fromStmt level stmt

212+ , fromStmt indent stmt

241213 ]

242214

243215 Try tryStmt errorName catchStmt ->

244216 mconcat

245217 [ indent, "try {\n"

246− , fromStmt nextLevel tryStmt

218+ , fromStmt (deeper indent) tryStmt

247219 , indent, "} catch (", Name.toBuilder errorName, ") {\n"

248− , fromStmt nextLevel catchStmt

220+ , fromStmt (deeper indent) catchStmt

249221 , indent, "}\n"

250222 ]

251223

252224 Throw expr ->

253− indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"

225+ "throw " <> snd (fromExpr indent Whatever expr) <> ";"

254226

255− Return expr ->

256− indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"

227+ Return Nothing ->

228+ indent <> "return;\n"

257229

258− Var name expr ->

259− indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"

230+ Return (Just expr) ->

231+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"

260232

261− Vars [] ->

233+ Var [] ->

262234 mempty

263235

264− Vars vars ->

265− indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"

236+ Var vars ->

237+ indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"

266238

267239 FunctionStmt name args stmts ->

268240 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

269241 <>

270− fromStmtBlock nextLevel stmts

242+ fromStmtBlock (deeper indent) stmts

271243 <>

272244 indent <> "}\n"

273245

@@ -276,25 +248,30 @@ fromStmt level@(Level indent nextLevel) statement =

276248-- SWITCH CLAUSES

277249

278250

279−fromClause :: Level -> Case -> Builder

280−fromClause level@(Level indent nextLevel) clause =

251+fromClause :: Builder -> Case -> Builder

252+fromClause indent clause =

281253 case clause of

282254 Case expr stmts ->

283− indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"

284− <> fromStmtBlock nextLevel stmts

255+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"

256+ <> fromStmtBlock (deeper indent) stmts

285257

286258 Default stmts ->

287259 indent <> "default:\n"

288− <> fromStmtBlock nextLevel stmts

260+ <> fromStmtBlock (deeper indent) stmts

289261

290262

291263

292264-- VAR DECLS

293265

294266

295−varToBuilder :: Level -> (Name, Expr) -> Builder

296−varToBuilder level (name, expr) =

297− Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)

267+varToBuilder :: Builder -> (Name, Maybe Expr) -> Builder

268+varToBuilder indent (name, maybeExpr) =

269+ case maybeExpr of

270+ Nothing ->

271+ Name.toBuilder name

272+

273+ Just expr ->

274+ Name.toBuilder name <> " = " <> snd (fromExpr indent Whatever expr)

298275

299276

300277

@@ -312,11 +289,12 @@ merge a b =

312289linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])

313290linesMap func xs =

314291 let

315− pairs = map func xs

292+ pairs =

293+ map func xs

316294 in

317− ( any ((==) Many . fst) pairs

318− , map snd pairs

319− )

295+ ( any ((==) Many . fst) pairs

296+ , map snd pairs

297+ )

320298

321299

322300data Grouping = Atomic | Whatever

@@ -332,23 +310,23 @@ parensFor grouping builder =

332310 builder

333311

334312

335−fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)

336−fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =

313+fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)

314+fromExpr indent grouping expression =

337315 case expression of

338316 String string ->

339− ( One, "'" <> string <> "'" )

317+ (One, "'" <> string <> "'")

340318

341319 Float float ->

342− ( One, float )

320+ (One, float)

343321

344322 Int n ->

345− ( One, B.intDec n )

323+ (One, B.intDec n)

346324

347325 Bool bool ->

348− ( One, if bool then "true" else "false" )

326+ (One, if bool then "true" else "false")

349327

350328 Null ->

351− ( One, "null" )

329+ (One, "null")

352330

353331 Json json ->

354332 ( One, Json.encodeUgly json )

@@ -356,90 +334,111 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi

356334 Array exprs ->

357335 (,) Many $

358336 let

359− (anyMany, builders) = linesMap (fromExpr level Whatever) exprs

337+ (anyMany, builders) =

338+ linesMap (fromExpr indent Whatever) exprs

360339 in

361− if anyMany then

362− "[\n"

363− <> deeperIndent

364− <> commaNewlineSep level builders

365− <> "\n" <> indent <> "]"

366− else

367− "[" <> commaSep builders <> "]"

340+ if anyMany then

341+ "[\n"

342+ <> deeper indent

343+ <> commaNewlineSep indent builders

344+ <> "\n" <> indent <> "]"

345+

346+ else

347+ "[" <> commaSep builders <> "]"

368348

369349 Object fields ->

370350 (,) Many $

371351 let

372− (anyMany, builders) = linesMap (fromField nextLevel) fields

352+ deeperIndent =

353+ deeper indent

354+

355+ (anyMany, builders) =

356+ linesMap (fromField deeperIndent) fields

373357 in

374− if anyMany then

375− "{\n"

376− <> deeperIndent

377− <> commaNewlineSep level builders

378− <> "\n" <> indent <> "}"

379− else

380− "{" <> commaSep builders <> "}"

358+ if anyMany then

359+ "{\n"

360+ <> deeperIndent

361+ <> commaNewlineSep indent builders

362+ <> "\n" <> indent <> "}"

363+

364+ else

365+ "{" <> commaSep builders <> "}"

381366

382367 Ref name ->

383− ( One, Name.toBuilder name )

368+ (One, Name.toBuilder name)

384369

385370 Access expr field ->

386− makeDot level expr field

371+ makeDot indent expr field

387372

388373 Index expr bracketedExpr ->

389− makeBracketed level expr bracketedExpr

374+ makeBracketed indent expr bracketedExpr

390375

391376 Prefix op expr ->

392377 let

393− (lines, builder) = fromExpr level Atomic expr

378+ (lines, builder) =

379+ fromExpr indent Atomic expr

394380 in

395− ( lines

396− , parensFor grouping (fromPrefix op <> builder)

397− )

381+ ( lines

382+ , parensFor grouping (fromPrefix op <> builder)

383+ )

398384

399385 Infix op leftExpr rightExpr ->

400386 let

401− (leftLines , left ) = fromExpr level Atomic leftExpr

402− (rightLines, right) = fromExpr level Atomic rightExpr

387+ (leftLines, left) =

388+ fromExpr indent Atomic leftExpr

389+

390+ (rightLines, right) =

391+ fromExpr indent Atomic rightExpr

403392 in

404− ( merge leftLines rightLines

405− , parensFor grouping (left <> fromInfix op <> right)

406− )

393+ ( merge leftLines rightLines

394+ , parensFor grouping (left <> fromInfix op <> right)

395+ )

407396

408397 If condExpr thenExpr elseExpr ->

409398 let

410− condB = snd (fromExpr level Atomic condExpr)

411− thenB = snd (fromExpr level Atomic thenExpr)

412− elseB = snd (fromExpr level Atomic elseExpr)

399+ condB = snd (fromExpr indent Atomic condExpr)

400+ thenB = snd (fromExpr indent Atomic thenExpr)

401+ elseB = snd (fromExpr indent Atomic elseExpr)

413402 in

414− ( Many

415− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

416− )

403+ ( Many

404+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

405+ )

417406

418407 Assign lValue expr ->

419408 let

420− (leftLines , left ) = fromLValue level lValue

421− (rightLines, right) = fromExpr level Whatever expr

409+ (leftLines, left) =

410+ fromLValue indent lValue

411+

412+ (rightLines, right) =

413+ fromExpr indent Whatever expr

422414 in

423− ( merge leftLines rightLines

424− , parensFor grouping (left <> " = " <> right)

425− )

415+ ( merge leftLines rightLines

416+ , parensFor grouping (left <> " = " <> right)

417+ )

426418

427419 Call function args ->

428420 (,) Many $

429421 let

430− (_ , funcB) = fromExpr level Atomic function

431− (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args

422+ deeperIndent =

423+ deeper indent

424+

425+ funcB =

426+ snd (fromExpr indent Atomic function)

427+

428+ (anyMany, argsB) =

429+ linesMap (fromExpr deeperIndent Whatever) args

432430 in

433− if anyMany then

434− funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"

435− else

436− funcB <> "(" <> commaSep argsB <> ")"

431+ if anyMany then

432+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"

433+

434+ else

435+ funcB <> "(" <> commaSep argsB <> ")"

437436

438437 Function maybeName args stmts ->

439438 (,) Many $

440439 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

441440 <>

442− fromStmtBlock nextLevel stmts

441+ fromStmtBlock (deeper indent) stmts

443442 <>

444443 indent <> "}"

445444

@@ -448,50 +447,55 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi

448447-- FIELDS

449448

450449

451−fromField :: Level -> (Name, Expr) -> (Lines, Builder)

452−fromField level (field, expr) =

450+fromField :: Builder -> (Name, Expr) -> (Lines, Builder)

451+fromField indent (field, expr) =

453452 let

454− (lines, builder) = fromExpr level Whatever expr

453+ (lines, builder) =

454+ fromExpr indent Whatever expr

455455 in

456− ( lines

457− , Name.toBuilder field <> ": " <> builder

458− )

456+ ( lines

457+ , Name.toBuilder field <> ": " <> builder

458+ )

459459

460460

461461

462462-- VALUES

463463

464464

465−fromLValue :: Level -> LValue -> (Lines, Builder)

466−fromLValue level lValue =

465+fromLValue :: Builder -> LValue -> (Lines, Builder)

466+fromLValue indent lValue =

467467 case lValue of

468468 LRef name ->

469469 (One, Name.toBuilder name)

470470

471471 LDot expr field ->

472− makeDot level expr field

472+ makeDot indent expr field

473473

474474 LBracket expr bracketedExpr ->

475− makeBracketed level expr bracketedExpr

475+ makeBracketed indent expr bracketedExpr

476476

477477

478−makeDot :: Level -> Expr -> Name -> (Lines, Builder)

479−makeDot level expr field =

478+makeDot :: Builder -> Expr -> Name -> (Lines, Builder)

479+makeDot indent expr field =

480480 let

481− (lines, builder) = fromExpr level Atomic expr

481+ (lines, builder) =

482+ fromExpr indent Atomic expr

482483 in

483− (lines, builder <> "." <> Name.toBuilder field)

484+ (lines, builder <> "." <> Name.toBuilder field)

484485

485486

486−makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)

487−makeBracketed level expr bracketedExpr =

487+makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)

488+makeBracketed indent expr bracketedExpr =

488489 let

489− (lines , builder ) = fromExpr level Atomic expr

490− (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr

490+ (lines, builder) =

491+ fromExpr indent Atomic expr

492+

493+ (bracketedLines, bracketedBuilder) =

494+ fromExpr indent Whatever bracketedExpr

491495 in

492− ( merge lines bracketedLines

493− , builder <> "[" <> bracketedBuilder <> "]"

494− )

496+ ( merge lines bracketedLines

497+ , builder <> "[" <> bracketedBuilder <> "]"

498+ )

495499

496500

497501

@@ -501,30 +505,36 @@ makeBracketed level expr bracketedExpr =

501505fromPrefix :: PrefixOp -> Builder

502506fromPrefix op =

503507 case op of

504− PrefixNot -> "!"

505− PrefixNegate -> "-"

506− PrefixComplement -> "~"

508+ PrefixLNot -> "!"

509+ PrefixBNot -> "~"

510+ PrefixPlus -> "+"

511+ PrefixMinus -> "-"

512+ PrefixTypeof -> "typeof "

507513

508514

509515fromInfix :: InfixOp -> Builder

510516fromInfix op =

511517 case op of

512− OpAdd -> " + "

513− OpSub -> " - "

518+ OpLT -> " < "

519+ OpLEq -> " <= "

520+ OpGT -> " > "

521+ OpGEq -> " >= "

522+ OpIn -> " in "

523+ OpInstanceof -> " instanceof "

524+ OpEq -> " == "

525+ OpNEq -> " != "

526+ OpStrictEq -> " === "

527+ OpStrictNEq -> " !== "

528+ OpLAnd -> " && "

529+ OpLOr -> " || "

514530 OpMul -> " * "

515531 OpDiv -> " / "

516532 OpMod -> " % "

517− OpEq -> " === "

518− OpNe -> " !== "

519− OpLt -> " < "

520− OpLe -> " <= "

521− OpGt -> " > "

522− OpGe -> " >= "

523− OpAnd -> " && "

524− OpOr -> " || "

525− OpBitwiseAnd -> " & "

526− OpBitwiseXor -> " ^ "

527− OpBitwiseOr -> " | "

533+ OpSub -> " - "

528534 OpLShift -> " << "

529535 OpSpRShift -> " >> "

530536 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

2222

2323import qualified AST.Canonical as Can

2424import qualified AST.Optimized as Opt

25−import qualified AST.Utils.Shader as Shader

2625import qualified Data.Index as Index

2726import qualified Elm.Compiler.Type as Type

2827import qualified Elm.Compiler.Type.Extract as Extract

@@ -33,7 +32,6 @@ import qualified Generate.JavaScript.Builder as JS

3332import qualified Generate.JavaScript.Name as JsName

3433import qualified Generate.Mode as Mode

3534import qualified Json.Encode as Encode

36−import Json.Encode ((==>))

3735import qualified Optimize.DecisionTree as DT

3836import qualified Reporting.Annotation as A

3937

@@ -130,7 +128,8 @@ generate mode expression =

130128

131129 Opt.Destruct (Opt.Destructor name path) body ->

132130 let

133− pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)

131+ pathExpr = generatePath mode path

132+ pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]

134133 in

135134 JsBlock $ pathDef : codeToStmtList (generate mode body)

136135

@@ -139,7 +138,7 @@ generate mode expression =

139138

140139 Opt.Accessor field ->

141140 JsExpr $ JS.Function Nothing [JsName.dollar]

142− [ JS.Return $

141+ [ JS.Return $ Just $

143142 JS.Access (JS.Ref JsName.dollar) (generateField mode field)

144143 ]

145144

@@ -191,7 +190,7 @@ generate mode expression =

191190 JS.Object (map toTranlation (Set.toList fields))

192191 in

193192 JsExpr $ JS.Object $

194− [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )

193+ [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )

195194 , ( JsName.fromLocal "attributes", toTranslationObject attributes )

196195 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )

197196 ]

@@ -212,7 +211,7 @@ codeToExpr code =

212211 JsExpr expr ->

213212 expr

214213

215− JsBlock [ JS.Return expr ] ->

214+ JsBlock [ JS.Return (Just expr) ] ->

216215 expr

217216

218217 JsBlock stmts ->

@@ -226,7 +225,7 @@ codeToStmtList code =

226225 stmts

227226

228227 JsExpr expr ->

229− [ JS.Return expr ]

228+ [ JS.Return (Just expr) ]

230229

231230 JsBlock stmts ->

232231 stmts

@@ -239,7 +238,7 @@ codeToStmt code =

239238 JS.Block stmts

240239

241240 JsExpr expr ->

242− JS.Return expr

241+ JS.Return (Just expr)

243242

244243 JsBlock [stmt] ->

245244 stmt

@@ -483,17 +482,17 @@ generateBitwiseCall home name args =

483482 case args of

484483 [arg] ->

485484 case name of

486− "complement" -> JS.Prefix JS.PrefixComplement arg

485+ "complement" -> JS.Prefix JS.PrefixBNot arg

487486 _ -> generateGlobalCall home name args

488487

489488 [left,right] ->

490489 case name of

491− "and" -> JS.Infix JS.OpBitwiseAnd left right

492− "or" -> JS.Infix JS.OpBitwiseOr left right

493− "xor" -> JS.Infix JS.OpBitwiseXor left right

494− "shiftLeftBy" -> JS.Infix JS.OpLShift right left

495− "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

496− "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

490+ "and" -> JS.Infix JS.OpBAnd left right

491+ "or" -> JS.Infix JS.OpBOr left right

492+ "xor" -> JS.Infix JS.OpBXor left right

493+ "shiftLeftBy" -> JS.Infix JS.OpLShift right left

494+ "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

495+ "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

497496 _ -> generateGlobalCall home name args

498497

499498 _ ->

@@ -506,10 +505,10 @@ generateBasicsCall mode home name args =

506505 [elmArg] ->

507506 let arg = generateJsExpr mode elmArg in

508507 case name of

509− "not" -> JS.Prefix JS.PrefixNot arg

510− "negate" -> JS.Prefix JS.PrefixNegate arg

508+ "not" -> JS.Prefix JS.PrefixLNot arg

509+ "negate" -> JS.Prefix JS.PrefixMinus arg

511510 "toFloat" -> arg

512− "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)

511+ "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)

513512 _ -> generateGlobalCall home name [arg]

514513

515514 [elmLeft, elmRight] ->

@@ -529,16 +528,16 @@ generateBasicsCall mode home name args =

529528 "sub" -> JS.Infix JS.OpSub left right

530529 "mul" -> JS.Infix JS.OpMul left right

531530 "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)

533532 "eq" -> equal left right

534533 "neq" -> notEqual left right

535− "lt" -> cmp JS.OpLt JS.OpLt 0 left right

536− "gt" -> cmp JS.OpGt JS.OpGt 0 left right

537− "le" -> cmp JS.OpLe JS.OpLt 1 left right

538− "ge" -> cmp JS.OpGe JS.OpGt (-1) left right

539− "or" -> JS.Infix JS.OpOr left right

540− "and" -> JS.Infix JS.OpAnd left right

541− "xor" -> JS.Infix JS.OpNe left right

534+ "lt" -> cmp JS.OpLT JS.OpLT 0 left right

535+ "gt" -> cmp JS.OpGT JS.OpGT 0 left right

536+ "le" -> cmp JS.OpLEq JS.OpLT 1 left right

537+ "ge" -> cmp JS.OpGEq JS.OpGT (-1) left right

538+ "or" -> JS.Infix JS.OpLOr left right

539+ "and" -> JS.Infix JS.OpLAnd left right

540+ "xor" -> JS.Infix JS.OpStrictNEq left right

542541 "remainderBy" -> JS.Infix JS.OpMod right left

543542 _ -> generateGlobalCall home name [left, right]

544543

@@ -559,7 +558,7 @@ notEqual left right =

559558 if isLiteral left || isLiteral right then

560559 strictNEq left right

561560 else

562− JS.Prefix JS.PrefixNot $

561+ JS.Prefix JS.PrefixLNot $

563562 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]

564563

565564

@@ -648,42 +647,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr

648647strictEq left right =

649648 case left of

650649 JS.Int 0 ->

651− JS.Prefix JS.PrefixNot right

650+ JS.Prefix JS.PrefixLNot right

652651

653652 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

655654

656655 _ ->

657656 case right of

658657 JS.Int 0 ->

659− JS.Prefix JS.PrefixNot left

658+ JS.Prefix JS.PrefixLNot left

660659

661660 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

663662

664663 _ ->

665− JS.Infix JS.OpEq left right

664+ JS.Infix JS.OpStrictEq left right

666665

667666

668667strictNEq :: JS.Expr -> JS.Expr -> JS.Expr

669668strictNEq left right =

670669 case left of

671670 JS.Int 0 ->

672− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)

671+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)

673672

674673 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

676675

677676 _ ->

678677 case right of

679678 JS.Int 0 ->

680− JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)

679+ JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)

681680

682681 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

684683

685684 _ ->

686− JS.Infix JS.OpNe left right

685+ JS.Infix JS.OpStrictNEq left right

687686

688687

689688

@@ -696,13 +695,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm

696695generateTailCall mode name args =

697696 let

698697 toTempVars (argName, arg) =

699− ( JsName.makeTemp argName, generateJsExpr mode arg )

698+ ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )

700699

701700 toRealVars (argName, _) =

702701 JS.ExprStmt $

703702 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))

704703 in

705− JS.Vars (map toTempVars args)

704+ JS.Var (map toTempVars args)

706705 : map toRealVars args

707706 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]

708707

@@ -715,10 +714,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt

715714generateDef mode def =

716715 case def of

717716 Opt.Def name body ->

718− JS.Var (JsName.fromLocal name) (generateJsExpr mode body)

717+ JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]

719718

720719 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))) ]

722721

723722

724723generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code

@@ -851,7 +850,7 @@ generateDecider mode label root decisionTree =

851850

852851 Opt.Chain testChain success failure ->

853852 [ 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))

855854 (JS.Block $ generateDecider mode label root success)

856855 (JS.Block $ generateDecider mode label root failure)

857856 ]

@@ -893,7 +892,7 @@ generateIfTest mode root (path, test) =

893892 value

894893

895894 DT.IsBool False ->

896− JS.Prefix JS.PrefixNot value

895+ JS.Prefix JS.PrefixLNot value

897896

898897 DT.IsInt int ->

899898 strictEq value (JS.Int int)

@@ -911,7 +910,7 @@ generateIfTest mode root (path, test) =

911910 JS.Access value (JsName.fromLocal "b")

912911

913912 DT.IsNil ->

914− JS.Prefix JS.PrefixNot $

913+ JS.Prefix JS.PrefixLNot $

915914 JS.Access value (JsName.fromLocal "b")

916915

917916 DT.IsTuple ->

@@ -1065,6 +1064,6 @@ toDebugMetadata mode msgType =

10651064

10661065 Mode.Dev (Just interfaces) ->

10671066 JS.Json $ Encode.object $

1068− [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]

1069− , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)

1067+ [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])

1068+ , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))

10701069 ]

compiler/src/Generate/JavaScript/Name.hs+12−22

@@ -62,13 +62,19 @@ fromLocal name =

6262

6363

6464fromGlobal :: ModuleName.Canonical -> Name.Name -> Name

65−fromGlobal home name =

66− Name $ homeToBuilder home <> usd <> Name.toBuilder 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

69+ <> "$" <> Name.toBuilder name

6770

6871

6972fromCycle :: ModuleName.Canonical -> Name.Name -> Name

70−fromCycle home name =

71− Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder 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

77+ <> "$cyclic$" <> Name.toBuilder name

7278

7379

7480fromKernel :: Name.Name -> Name.Name -> Name

@@ -76,17 +82,6 @@ fromKernel home name =

7682 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)

7783

7884

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−

9085

9186-- TEMPORARY NAMES

9287

@@ -103,7 +98,7 @@ makeA n =

10398

10499makeLabel :: Name.Name -> Int -> Name

105100makeLabel name index =

106− Name (Name.toBuilder name <> usd <> B.intDec index)

101+ Name (Name.toBuilder name <> "$" <> B.intDec index)

107102

108103

109104makeTemp :: Name.Name -> Name

@@ -113,12 +108,7 @@ makeTemp name =

113108

114109dollar :: Name

115110dollar =

116− Name usd

117−

118−

119−usd :: B.Builder

120−usd =

121− Name.toBuilder Name.dollar

111+ Name (Name.toBuilder Name.dollar)

122112

123113

124114

compiler/src/Generate/Mode.hs+1

@@ -49,6 +49,7 @@ shortenFieldNames (Opt.GlobalGraph _ frequencies) =

4949

5050addToBuckets :: Name.Name -> Int -> Map.Map Int [Name.Name] -> Map.Map Int [Name.Name]

5151addToBuckets field frequency buckets =

52+ -- TODO try using an IntMap for buckets

5253 Map.insertWith (++) frequency [field] buckets

5354

5455

compiler/src/Json/Decode.hs+176−335

@@ -4,110 +4,61 @@ module Json.Decode

44 ( fromByteString

55 , Decoder

66 , string

7− , customString

87 , bool

98 , int

10− , list

11− , nonEmptyList

12− , pair

13− --

14− , KeyDecoder(..)

15− , dict

16− , pairs

17− , field

18− --

9+ , list, pair

10+ , dict, pairs, field

1911 , oneOf

2012 , failure

2113 , mapError

22− --

23− , Error(..)

24− , Problem(..)

25− , DecodeExpectation(..)

26− , ParseError(..)

27− , StringProblem(..)

2814 )

2915 where

3016

3117

32−import qualified Data.ByteString.Internal as B

18+import qualified Data.ByteString as B

19+import qualified Data.List as List

3320import qualified Data.Map as Map

34−import qualified Data.NonEmptyList as NE

35−import Data.Word (Word8)

21+import qualified Data.Utf8 as Utf8

22+import Data.Word (Word8, Word16)

3623import Foreign.Ptr (Ptr, plusPtr, minusPtr)

37−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

3824

39−import qualified Json.String as Json

4025import qualified Parse.Keyword as K

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

4428

4529

4630

4731-- RUNNERS

4832

4933

50−fromByteString :: Decoder x a -> B.ByteString -> Either (Error x) a

51−fromByteString (Decoder decode) src =

52− case P.fromByteString pFile BadEnd src of

53− Right ast ->

54− decode ast Right (Left . DecodeProblem src)

34+fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a

35+fromByteString decoder src =

36+ fromAST decoder (P.fromByteString pFile src)

5537

56− Left problem ->

57− Left (ParseProblem src problem)

5838

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)

5944

45+ P.Err row col ctx expectation ->

46+ Left (E.ParseProblem row col ctx expectation)

6047

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

8248

8349

84−

85−-- DECODE PROBLEMS

86−

87−

88−data Problem x

89− = Field B.ByteString (Problem x)

90− | Index Int (Problem x)

91− | OneOf (Problem x) [Problem x]

92− | Failure A.Region x

93− | Expecting A.Region DecodeExpectation

50+-- DECODERS

9451

9552

96−data DecodeExpectation

97− = TObject

98− | TArray

99− | TString

100− | TBool

101− | TInt

102− | TObjectWith B.ByteString

103− | TArrayPair Int

53+newtype Decoder e a =

54+ Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)

10455

10556

10657

10758-- INSTANCES

10859

10960

110−instance Functor (Decoder x) where

61+instance Functor (Decoder e) where

11162 {-# INLINE fmap #-}

11263 fmap func (Decoder decodeA) =

11364 Decoder $ \ast ok err ->

@@ -117,7 +68,7 @@ instance Functor (Decoder x) where

11768 decodeA ast ok' err

11869

11970

120−instance Applicative (Decoder x) where

71+instance Applicative (Decoder e) where

12172 {-# INLINE pure #-}

12273 pure = return

12374

@@ -134,7 +85,7 @@ instance Applicative (Decoder x) where

13485 decodeFunc ast okF err

13586

13687

137−instance Monad (Decoder x) where

88+instance Monad (Decoder e) where

13889 {-# INLINE return #-}

13990 return a =

14091 Decoder $ \_ ok _ ->

@@ -155,37 +106,24 @@ instance Monad (Decoder x) where

155106-- STRINGS

156107

157108

158−string :: Decoder x Json.String

109+string :: Decoder e Utf8.String

159110string =

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

172112 case ast of

173− String snippet ->

174− case P.fromSnippet parser toBadEnd snippet of

175− Right a -> ok a

176− Left x -> err (Failure region x)

113+ String bits ->

114+ ok bits

177115

178116 _ ->

179− err (Expecting region TString)

117+ err (E.Expecting E.TString)

180118

181119

182120

183121-- BOOL

184122

185123

186−bool :: Decoder x Bool

124+bool :: Decoder e Bool

187125bool =

188− Decoder $ \(A.At region ast) ok err ->

126+ Decoder $ \ast ok err ->

189127 case ast of

190128 TRUE ->

191129 ok True

@@ -194,40 +132,40 @@ bool =

194132 ok False

195133

196134 _ ->

197− err (Expecting region TBool)

135+ err (E.Expecting E.TBool)

198136

199137

200138

201139-- INT

202140

203141

204−int :: Decoder x Int

142+int :: Decoder e Int

205143int =

206− Decoder $ \(A.At region ast) ok err ->

144+ Decoder $ \ast ok err ->

207145 case ast of

208146 Int n ->

209147 ok n

210148

211149 _ ->

212− err (Expecting region TInt)

150+ err (E.Expecting E.TInt)

213151

214152

215153

216−-- LISTS

154+-- ARRAYS

217155

218156

219−list :: Decoder x a -> Decoder x [a]

157+list :: Decoder e a -> Decoder e [a]

220158list decoder =

221− Decoder $ \(A.At region ast) ok err ->

159+ Decoder $ \ast ok err ->

222160 case ast of

223161 Array asts ->

224162 listHelp decoder ok err 0 asts []

225163

226164 _ ->

227− err (Expecting region TArray)

165+ err (E.Expecting E.TArray)

228166

229167

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

231169listHelp decoder@(Decoder decodeA) ok err !i asts revs =

232170 case asts of

233171 [] ->

@@ -235,40 +173,24 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =

235173

236174 ast:asts ->

237175 let

238− ok' value = listHelp decoder ok err (i+1) asts (value:revs)

239− err' prob = err (Index i prob)

176+ ok' a = listHelp decoder ok err (i+1) asts (a:revs)

177+ err' e = err (E.Index i e)

240178 in

241179 decodeA ast ok' err'

242180

243181

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)

261183pair (Decoder decodeA) (Decoder decodeB) =

262− Decoder $ \(A.At region ast) ok err ->

184+ Decoder $ \ast ok err ->

263185 case ast of

264186 Array vs ->

265187 case vs of

266188 [astA,astB] ->

267189 let

268− err0 e = err (Index 0 e)

190+ err0 e = err (E.Index 0 e)

269191 ok0 a =

270192 let

271− err1 e = err (Index 1 e)

193+ err1 e = err (E.Index 1 e)

272194 ok1 b = ok (a,b)

273195 in

274196 decodeB astB ok1 err1

@@ -276,103 +198,70 @@ pair (Decoder decodeA) (Decoder decodeB) =

276198 decodeA astA ok0 err0

277199

278200 _ ->

279− err (Expecting region (TArrayPair (length vs)))

201+ err (E.Expecting (E.TArrayPair (length vs)))

280202

281203 _ ->

282− err (Expecting region TArray)

283−

204+ err (E.Expecting E.TArray)

284205

285206

286−-- OBJECTS

287207

288−

289−data KeyDecoder x a =

290− KeyDecoder (P.Parser x a) (Row -> Col -> x)

208+-- OBJECT

291209

292210

293−dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)

294−dict keyDecoder valueDecoder =

295− Map.fromList <$> pairs keyDecoder valueDecoder

211+dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)

212+dict decoder =

213+ Map.fromList <$> pairs decoder

296214

297215

298−pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]

299−pairs keyDecoder valueDecoder =

300− Decoder $ \(A.At region ast) ok err ->

216+pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]

217+pairs decoder =

218+ Decoder $ \ast ok err ->

301219 case ast of

302220 Object kvs ->

303− pairsHelp keyDecoder valueDecoder ok err kvs []

221+ pairsHelp decoder ok err kvs []

304222

305223 _ ->

306− err (Expecting region TObject)

224+ err (E.Expecting E.TObject)

307225

308226

309−pairsHelp :: KeyDecoder x k -> Decoder x a -> ([(k, a)] -> b) -> (Problem x -> b) -> [(P.Snippet, AST)] -> [(k, a)] -> b

310−pairsHelp keyDecoder@(KeyDecoder keyParser toBadEnd) valueDecoder@(Decoder decodeA) ok err kvs revs =

227+pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b

228+pairsHelp decoder@(Decoder decodeA) ok err kvs revs =

311229 case kvs of

312230 [] ->

313231 ok (reverse revs)

314232

315− (snippet, ast) : kvs ->

316− case P.fromSnippet keyParser toBadEnd snippet of

317− Left x ->

318− err (Failure (snippetToRegion snippet) x)

319−

320− Right key ->

321− let

322− ok' value = pairsHelp keyDecoder valueDecoder ok err kvs ((key,value):revs)

323− err' prob =

324− let (P.Snippet fptr off len _ _) = snippet in

325− err (Field (B.PS fptr off len) prob)

326− in

327− decodeA ast ok' err'

328−

329−

330−snippetToRegion :: P.Snippet -> A.Region

331−snippetToRegion (P.Snippet _ _ len row col) =

332− A.Region (A.Position row col) (A.Position row (col + fromIntegral len))

333−

334−

335−

336−-- FIELDS

233+ (key, ast) : kvs ->

234+ let

235+ ok' a = pairsHelp decoder ok err kvs ((key,a):revs)

236+ err' e = err (E.Field key e)

237+ in

238+ decodeA ast ok' err'

337239

338240

339−field :: B.ByteString -> Decoder x a -> Decoder x a

241+field :: Utf8.String -> Decoder e a -> Decoder e a

340242field key (Decoder decodeA) =

341− Decoder $ \(A.At region ast) ok err ->

243+ Decoder $ \ast ok err ->

342244 case ast of

343245 Object kvs ->

344− case findField key kvs of

345− Just value ->

246+ case List.lookup key kvs of

247+ Just v ->

346248 let

347− err' prob =

348− err (Field key prob)

249+ err' e = err (E.Field key e)

349250 in

350− decodeA value ok err'

251+ decodeA v ok err'

351252

352253 Nothing ->

353− err (Expecting region (TObjectWith key))

254+ err (E.Expecting (E.TObjectWith key))

354255

355256 _ ->

356− err (Expecting region TObject)

357−

358−

359−findField :: B.ByteString -> [(P.Snippet, AST)] -> Maybe AST

360−findField key pairs =

361− case pairs of

362− [] ->

363− Nothing

364−

365− (P.Snippet fptr off len _ _, value) : remainingPairs ->

366− if key == B.PS fptr off len

367− then Just value

368− else findField key remainingPairs

257+ err (E.Expecting E.TObject)

369258

370259

371260

372261-- ONE OF

373262

374263

375−oneOf :: [Decoder x a] -> Decoder x a

264+oneOf :: [Decoder e a] -> Decoder e a

376265oneOf decoders =

377266 Decoder $ \ast ok err ->

378267 case decoders of

@@ -387,75 +276,71 @@ oneOf decoders =

387276 error "Ran into (Json.Decode.oneOf [])"

388277

389278

390−oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b

391−oneOfHelp ast ok err decoders p ps =

279+oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b

280+oneOfHelp ast ok err decoders e es =

392281 case decoders of

393282 Decoder decodeA : decoders ->

394283 let

395− err' p' =

396− oneOfHelp ast ok err decoders p' (p:ps)

284+ err' e' =

285+ oneOfHelp ast ok err decoders e' (e:es)

397286 in

398287 decodeA ast ok err'

399288

400289 [] ->

401− err (oneOfError [] p ps)

290+ err (oneOfError [] e es)

402291

403292

404−oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x

405−oneOfError problems prob ps =

406− case ps of

293+oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e

294+oneOfError errors err es =

295+ case es of

407296 [] ->

408− OneOf prob problems

297+ E.OneOf err errors

409298

410− p:ps ->

411− oneOfError (prob:problems) p ps

299+ e:es ->

300+ oneOfError (err:errors) e es

412301

413302

414303

415304-- FAILURE

416305

417306

418−failure :: x -> Decoder x a

419−failure x =

420− Decoder $ \(A.At region _) _ err ->

421− err (Failure region x)

307+failure :: e -> Decoder e a

308+failure e =

309+ Decoder $ \_ _ err ->

310+ err (E.Failure e)

422311

423312

424313

425314-- ERRORS

426315

427316

428−mapError :: (x -> y) -> Decoder x a -> Decoder y a

317+mapError :: (e -> e') -> Decoder e a -> Decoder e' a

429318mapError func (Decoder decodeA) =

430319 Decoder $ \ast ok err ->

431320 let

432− err' prob = err (mapErrorHelp func prob)

321+ err' e = err (mapErrorHelp func e)

433322 in

434323 decodeA ast ok err'

435324

436325

437−mapErrorHelp :: (x -> y) -> Problem x -> Problem y

438−mapErrorHelp func problem =

439− case problem of

440− Field k p -> Field k (mapErrorHelp func p)

441− Index i p -> Index i (mapErrorHelp func p)

442− OneOf p ps -> OneOf (mapErrorHelp func p) (map (mapErrorHelp func) ps)

443− Failure r x -> Failure r (func x)

444− Expecting r e -> Expecting r e

326+mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'

327+mapErrorHelp func err =

328+ case err of

329+ E.Field k e -> E.Field k (mapErrorHelp func e)

330+ E.Index i e -> E.Index i (mapErrorHelp func e)

331+ E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)

332+ E.Failure e -> E.Failure (func e)

333+ E.Expecting e -> E.Expecting e

445334

446335

447336

448337-- AST

449338

450339

451−type AST =

452− A.Located AST_

453−

454−

455−data AST_

340+data AST

456341 = Array [AST]

457− | Object [(P.Snippet, AST)]

458− | String P.Snippet

342+ | Object [(Utf8.String, AST)]

343+ | String Utf8.String

459344 | Int Int

460345 | TRUE

461346 | FALSE

@@ -467,33 +352,7 @@ data AST_

467352

468353

469354type Parser a =

470− P.Parser ParseError a

471−

472−

473−data ParseError

474− = Start Row Col

475− | ObjectField Row Col

476− | ObjectColon Row Col

477− | ObjectEnd Row Col

478− | ArrayEnd Row Col

479− | StringProblem StringProblem Row Col

480− | NoLeadingZeros Row Col

481− | NoFloats Row Col

482− | BadEnd Row Col

483−

484−-- PIndex Int ParseError Row Col

485−-- PField Json.String ParseError Row Col

486−

487−

488−data StringProblem

489− = BadStringEnd

490− | BadStringControlChar

491− | BadStringEscapeChar

492− | BadStringEscapeHex

493−

494−

495−

496−-- PARSE AST

355+ P.Parser E.Context E.ParseExpectation a

497356

498357

499358pFile :: Parser AST

@@ -501,60 +360,69 @@ pFile =

501360 do spaces

502361 value <- pValue

503362 spaces

363+ endOfFile

504364 return value

505365

506366

507367pValue :: Parser AST

508368pValue =

509− P.addLocation $

510− P.oneOf Start

511− [ String <$> pString Start

369+ P.oneOf E.Value

370+ [ fmap String pString

512371 , pObject

513372 , pArray

514373 , pInt

515− , K.k4 0x74 0x72 0x75 0x65 Start >> return TRUE

516− , K.k5 0x66 0x61 0x6C 0x73 0x65 Start >> return FALSE

517− , K.k4 0x6E 0x75 0x6C 0x6C Start >> return NULL

374+ , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE

375+ , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE

376+ , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL

518377 ]

519378

520379

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+

521389

522390-- OBJECT

523391

524392

525−pObject :: Parser AST_

393+pObject :: Parser AST

526394pObject =

527− do P.word1 0x7B {- { -} Start

395+ do P.word1 0x7B {- { -} E.ObjectStart

528396 spaces

529− P.oneOf ObjectField

397+ P.oneOf E.ObjectMore

530398 [ do entry <- pField

531399 spaces

532400 pObjectHelp [entry]

533− , do P.word1 0x7D {-}-} ObjectEnd

401+ , do P.word1 0x7D {-}-} E.ObjectEnd

534402 return (Object [])

535403 ]

536404

537405

538−pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_

406+pObjectHelp :: [(Utf8.String, AST)] -> Parser AST

539407pObjectHelp revEntries =

540− P.oneOf ObjectEnd

408+ P.oneOf E.ObjectMore

541409 [

542− do P.word1 0x2C {-,-} ObjectEnd

410+ do P.word1 0x2C {-,-} E.ObjectMore

543411 spaces

544412 entry <- pField

545413 spaces

546414 pObjectHelp (entry:revEntries)

547415 ,

548− do P.word1 0x7D {-}-} ObjectEnd

416+ do P.word1 0x7D {-}-} E.ObjectEnd

549417 return (Object (reverse revEntries))

550418 ]

551419

552420

553−pField :: Parser (P.Snippet, AST)

421+pField :: Parser (Utf8.String, AST)

554422pField =

555− do key <- pString ObjectField

423+ do key <- pString

556424 spaces

557− P.word1 0x3A {-:-} ObjectColon

425+ P.word1 0x3A {-:-} E.Colon

558426 spaces

559427 value <- pValue

560428 return (key, value)

@@ -564,30 +432,30 @@ pField =

564432-- ARRAY

565433

566434

567−pArray :: Parser AST_

435+pArray :: Parser AST

568436pArray =

569− do P.word1 0x5B {-[-} Start

437+ do P.word1 0x5B {-[-} E.ArrayStart

570438 spaces

571− P.oneOf Start

439+ P.oneOf E.ArrayMore

572440 [ do entry <- pValue

573441 spaces

574442 pArrayHelp 1 [entry]

575− , do P.word1 0x5D {-]-} ArrayEnd

443+ , do P.word1 0x5D {-]-} E.ArrayEnd

576444 return (Array [])

577445 ]

578446

579447

580−pArrayHelp :: Int -> [AST] -> Parser AST_

448+pArrayHelp :: Int -> [AST] -> Parser AST

581449pArrayHelp !len revEntries =

582− P.oneOf ArrayEnd

450+ P.oneOf E.ArrayMore

583451 [

584− do P.word1 0x2C {-,-} ArrayEnd

452+ do P.word1 0x2C {-,-} E.ArrayMore

585453 spaces

586454 entry <- pValue

587455 spaces

588456 pArrayHelp (len + 1) (entry:revEntries)

589457 ,

590− do P.word1 0x5D {-]-} ArrayEnd

458+ do P.word1 0x5D {-]-} E.ArrayEnd

591459 return (Array (reverse revEntries))

592460 ]

593461

@@ -596,44 +464,41 @@ pArrayHelp !len revEntries =

596464-- STRING

597465

598466

599−pString :: (Row -> Col -> ParseError) -> Parser P.Snippet

600−pString start =

601− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

467+pString :: Parser Utf8.String

468+pString =

469+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

602470 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then

603471

604472 let

605473 !pos1 = plusPtr pos 1

606− !col1 = col + 1

607474

608475 (# status, newPos, newRow, newCol #) =

609− pStringHelp pos1 end row col1

476+ pStringHelp pos1 end row (col + 1)

610477 in

611478 case status of

612479 GoodString ->

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

618483 in

619− cok snp newState

484+ cok content newState

620485

621− BadString problem ->

622− cerr newRow newCol (StringProblem problem)

486+ BadStringEnd ->

487+ cerr newRow newCol ctx E.StringEnd

623488

624489 else

625− eerr row col start

490+ eerr row col ctx E.StringStart

626491

627492

628493data StringStatus

629494 = GoodString

630− | BadString StringProblem

495+ | BadStringEnd

631496

632497

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

634499pStringHelp pos end row col =

635500 if pos >= end then

636− (# BadString BadStringEnd, pos, row, col #)

501+ (# BadStringEnd, pos, row, col #)

637502

638503 else

639504 case P.unsafeIndex pos of

@@ -641,50 +506,26 @@ pStringHelp pos end row col =

641506 (# GoodString, plusPtr pos 1, row, col + 1 #)

642507

643508 0x0A {-\n-} ->

644− (# BadString BadStringEnd, pos, row, col #)

509+ (# BadStringEnd, pos, row, col #)

645510

646511 0x5C {-\-} ->

647− let !pos1 = plusPtr pos 1 in

648− if pos1 >= end then

649− (# BadString BadStringEnd, pos1, row + 1, col #)

650− else

651− case P.unsafeIndex pos1 of

652− 0x22 {-"-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

653− 0x5C {-\-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

654− 0x2F {-/-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

655− 0x62 {-b-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

656− 0x66 {-f-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

657− 0x6E {-n-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

658− 0x72 {-r-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

659− 0x74 {-t-} -> pStringHelp (plusPtr pos 2) end row (col + 2)

660− 0x75 {-u-} ->

661− let !pos6 = plusPtr pos 6 in

662− if pos6 <= end

663− && isHex (P.unsafeIndex (plusPtr pos 2))

664− && isHex (P.unsafeIndex (plusPtr pos 3))

665− && isHex (P.unsafeIndex (plusPtr pos 4))

666− && isHex (P.unsafeIndex (plusPtr pos 5))

667− then

668− pStringHelp pos6 end row (col + 6)

669− else

670− (# BadString BadStringEscapeHex, pos, row, col #)

671−

672− _ ->

673− (# BadString BadStringEscapeChar, pos, row, col #)

512+ let

513+ !pos1 = plusPtr pos 1

514+ in

515+ if pos1 < end then

674516

675− word ->

676− if word < 0x20 then

677− (# BadString BadStringControlChar, pos, row, col #)

678− else

679− let !newPos = plusPtr pos (P.getCharWidth word) in

680− pStringHelp newPos end row (col + 1)

517+ let

518+ !word = P.unsafeIndex pos1

519+ !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)

520+ in

521+ pStringHelp newPos end row (col + 2)

681522

523+ else

524+ (# BadStringEnd, pos1, row + 1, col #)

682525

683−isHex :: Word8 -> Bool

684−isHex word =

685− 0x30 {-0-} <= word && word <= 0x39 {-9-}

686− || 0x61 {-a-} <= word && word <= 0x66 {-f-}

687− || 0x41 {-A-} <= word && word <= 0x46 {-F-}

526+ word ->

527+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in

528+ pStringHelp newPos end row (col + 1)

688529

689530

690531

@@ -693,7 +534,7 @@ isHex word =

693534

694535spaces :: Parser ()

695536spaces =

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

697538 let

698539 (# newPos, newRow, newCol #) =

699540 eatSpaces pos end row col

@@ -703,12 +544,12 @@ spaces =

703544 else

704545 let

705546 !newState =

706− P.State src newPos end indent newRow newCol

547+ P.State newPos end indent newRow newCol ctx

707548 in

708549 cok () newState

709550

710551

711−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)

552+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)

712553eatSpaces pos end row col =

713554 if pos >= end then

714555 (# pos, row, col #)

@@ -727,29 +568,29 @@ eatSpaces pos end row col =

727568-- INTS

728569

729570

730−pInt :: Parser AST_

571+pInt :: Parser AST

731572pInt =

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

733574 if pos >= end then

734− eerr row col Start

575+ eerr row col ctx E.IntStart

735576

736577 else

737578 let !word = P.unsafeIndex pos in

738579 if not (isDecimalDigit word) then

739− eerr row col Start

580+ eerr row col ctx E.IntStart

740581

741582 else if word == 0x30 {-0-} then

742583

743584 let

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

746587 in

747588 if pos1 < end then

748589 let !word1 = P.unsafeIndex pos1 in

749590 if isDecimalDigit word1 then

750− cerr row (col + 1) NoLeadingZeros

591+ cerr row (col + 1) ctx E.NoLeadingZeros

751592 else if word1 == 0x2E {-.-} then

752− cerr row (col + 1) NoFloats

593+ cerr row (col + 1) ctx E.NoFloats

753594 else

754595 cok (Int 0) newState

755596 else

@@ -766,12 +607,12 @@ pInt =

766607 GoodInt ->

767608 let

768609 !newState =

769− P.State src newPos end indent row (col + len)

610+ P.State newPos end indent row (col + len) ctx

770611 in

771612 cok (Int n) newState

772613

773614 BadIntEnd ->

774− cerr row (col + len) NoFloats

615+ cerr row (col + len) ctx E.NoFloats

775616

776617

777618data IntStatus = GoodInt | BadIntEnd

compiler/src/Json/Encode.hs+21−37

@@ -10,7 +10,6 @@ module Json.Encode

1010 , object

1111 , string

1212 , name

13− , chars

1413 , bool

1514 , int

1615 , number

@@ -33,7 +32,6 @@ import qualified Data.Name as Name

3332import qualified Data.Utf8 as Utf8

3433

3534import qualified File

36−import qualified Json.String as Json

3735

3836

3937

@@ -42,7 +40,7 @@ import qualified Json.String as Json

4240

4341data Value

4442 = Array [Value]

45− | Object [(Json.String, Value)]

43+ | Object [(Utf8.String, Value)]

4644 | String B.Builder

4745 | Boolean Bool

4846 | Integer Int

@@ -55,14 +53,14 @@ array =

5553 Array

5654

5755

58−object :: [(Json.String, Value)] -> Value

56+object :: [(Utf8.String,Value)] -> Value

5957object =

6058 Object

6159

6260

63−string :: Json.String -> Value

61+string :: Utf8.String -> Value

6462string str =

65− String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')

63+ String (encodeUtf8 str)

6664

6765

6866name :: Name.Name -> Value

@@ -90,7 +88,7 @@ null =

9088 Null

9189

9290

93−dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value

91+dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value

9492dict encodeKey encodeValue pairs =

9593 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)

9694

@@ -101,35 +99,12 @@ list encodeEntry entries =

10199

102100

103101

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−

127102-- HELPERS

128103

129104

130−(==>) :: [Char] -> value -> (Json.String, value)

131−(==>) key value =

132− (Json.fromChars key, value)

105+(==>) :: a -> b -> (a, b)

106+(==>) a b =

107+ (a, b)

133108

134109

135110

@@ -169,7 +144,7 @@ encodeUgly value =

169144 Object (first : rest) ->

170145 let

171146 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

173148 in

174149 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'

175150

@@ -230,6 +205,15 @@ encodeHelp indent value =

230205

231206

232207

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+

233217-- ENCODE ARRAY

234218

235219

@@ -252,7 +236,7 @@ arrayClose =

252236-- ENCODE OBJECT

253237

254238

255−encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder

239+encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder

256240encodeObject =

257241 encodeSequence objectOpen objectClose encodeField

258242

@@ -267,9 +251,9 @@ objectClose =

267251 B.char7 '}'

268252

269253

270−encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder

254+encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder

271255encodeField indent (key, value) =

272− B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value

256+ encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value

273257

274258

275259

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

2121import qualified Data.Map as Map

2222import qualified Data.Maybe as Maybe

2323import qualified Data.Name as Name

24−import qualified Data.NonEmptyList as NE

24+import qualified Data.Utf8 as Utf8

2525

2626import qualified AST.Canonical as Can

2727import qualified Data.Index as Index

2828import qualified Elm.ModuleName as ModuleName

29−import qualified Elm.String as ES

3029import qualified Reporting.Annotation as A

3130

3231

@@ -41,8 +40,8 @@ data Pattern

4140

4241

4342data Literal

44− = Chr ES.String

45− | Str ES.String

43+ = Chr Utf8.String

44+ | Str Utf8.String

4645 | Int Int

4746 deriving (Eq)

4847

@@ -203,14 +202,14 @@ data Context

203202-- CHECK

204203

205204

206−check :: Can.Module -> Either (NE.List Error) ()

207−check (Can.Module _ _ _ decls _ _ _ _) =

205+check :: Can.Module -> Either [Error] ()

206+check (Can.Module _ _ decls _ _ _ _) =

208207 case checkDecls decls [] of

209208 [] ->

210209 Right ()

211210

212− e:es ->

213− Left (NE.List e es)

211+ errors ->

212+ Left errors

214213

215214

216215

compiler/src/Optimize/DecisionTree.hs+5−5

@@ -27,11 +27,11 @@ import qualified Data.List as List

2727import qualified Data.Maybe as Maybe

2828import qualified Data.Name as Name

2929import qualified Data.Set as Set

30+import qualified Data.Utf8 as Utf8

3031

3132import qualified AST.Canonical as Can

3233import qualified Data.Index as Index

3334import qualified Elm.ModuleName as ModuleName

34−import qualified Elm.String as ES

3535import qualified Reporting.Annotation as A

3636

3737

@@ -77,8 +77,8 @@ data Test

7777 | IsNil

7878 | IsTuple

7979 | IsInt Int

80− | IsChr ES.String

81− | IsStr ES.String

80+ | IsChr Utf8.String

81+ | IsStr Utf8.String

8282 | IsBool Bool

8383 deriving (Eq, Ord)

8484

@@ -618,7 +618,7 @@ instance Binary Test where

618618 5 -> liftM IsStr get

619619 6 -> liftM IsInt get

620620 7 -> liftM IsBool get

621− _ -> fail "problem getting DecisionTree.Test binary"

621+ _ -> error "problem getting DecisionTree.Test binary"

622622

623623

624624instance Binary Path where

@@ -634,4 +634,4 @@ instance Binary Path where

634634 0 -> liftM2 Index get get

635635 1 -> liftM Unbox get

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

4141

4242

4343optimize :: 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) =

4545 addDecls home annotations decls $

4646 addEffects home effects $

4747 addUnions home unions $

@@ -213,10 +213,10 @@ findMain defs =

213213 def:rest ->

214214 case def of

215215 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

217217

218218 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

220220

221221

222222defToName :: Can.Def -> Name.Name

@@ -244,7 +244,7 @@ addDef home annotations def graph =

244244

245245addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph

246246addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =

247− if name /= Name._main then

247+ if name /= Name.main then

248248 Result.ok (addDefNode home name args body Set.empty graph)

249249 else

250250 let

compiler/src/Optimize/Port.hs+3−3

@@ -58,7 +58,7 @@ toEncoder tipe =

5858 | name == Name.array -> encodeArray arg

5959

6060 _ ->

61− error "toEncoder: bad custom type"

61+ error "toEncoder: bad union type"

6262

6363 Can.TRecord _ (Just _) ->

6464 error "toEncoder: bad record"

@@ -68,7 +68,7 @@ toEncoder tipe =

6868 encodeField (name, Can.FieldType _ fieldType) =

6969 do encoder <- toEncoder fieldType

7070 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

7272 in

7373 do object <- encode "object"

7474 keyValuePairs <- traverse encodeField (Map.toList fields)

@@ -309,7 +309,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) =

309309 return $

310310 Opt.Call andThen

311311 [ Opt.Function [key] decoder

312− , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]

312+ , Opt.Call field [ Opt.Str (Name.toUtf8 key), typeDecoder ]

313313 ]

314314

315315

compiler/src/Parse/Declaration.hs+131−180

@@ -16,11 +16,11 @@ import qualified Parse.Expression as Expr

1616import qualified Parse.Pattern as Pattern

1717import qualified Parse.Keyword as Keyword

1818import qualified Parse.Number as Number

19−import qualified Parse.Space as Space

2019import qualified Parse.Symbol as Symbol

2120import qualified Parse.Type as Type

2221import qualified Parse.Variable as Var

23−import Parse.Primitives hiding (State)

22+import Parse.Utils

23+import Parse.Primitives hiding (Parser, State)

2424import qualified Parse.Primitives as P

2525import qualified Reporting.Annotation as A

2626import qualified Reporting.Error.Syntax as E

@@ -31,182 +31,141 @@ import qualified Reporting.Error.Syntax as E

3131

3232

3333data Decl

34− = Value (Maybe Src.Comment) (A.Located Src.Value)

35− | Union (Maybe Src.Comment) (A.Located Src.Union)

36− | Alias (Maybe Src.Comment) (A.Located Src.Alias)

37− | Port (Maybe Src.Comment) Src.Port

34+ = Value (A.Located Src.Value)

35+ | Union (A.Located Src.Union)

36+ | Alias (A.Located Src.Alias)

37+ | Port Src.Port

3838

3939

40−declaration :: Space.Parser E.Decl Decl

40+declaration :: SParser Decl

4141declaration =

42− do maybeDocs <- chompDocComment

43− start <- getPosition

44− oneOf E.DeclStart

45− [ typeDecl maybeDocs start

46− , portDecl maybeDocs

47− , valueDecl maybeDocs start

42+ do start <- getPosition

43+ oneOf E.XXX

44+ [ typeDecl start

45+ , portDecl

46+ , valueDecl start

4847 ]

4948

5049

5150

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−

6851-- DEFINITION and ANNOTATION

6952

7053

7154{-# INLINE valueDecl #-}

72−valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl

73−valueDecl maybeDocs start =

74− do name <- Var.lower E.DeclStart

55+valueDecl :: A.Position -> SParser Decl

56+valueDecl start =

57+ do name <- Var.lower

7558 end <- getPosition

76− specialize (E.DeclDef name) $

77− do Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals

78− oneOf E.DeclDefEquals

79− [

80− do word1 0x3A {-:-} E.DeclDefEquals

81− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentType

82− (tipe, _) <- specialize E.DeclDefType Type.expression

83− Space.checkFreshLine E.DeclDefNameRepeat

84− defName <- chompMatchingName name

85− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals

86− chompDefArgsAndBody maybeDocs start defName (Just tipe) []

87− ,

88− chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing []

89− ]

90−

91−

92−chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl

93−chompDefArgsAndBody maybeDocs start name tipe revArgs =

94− oneOf E.DeclDefEquals

95− [ do arg <- specialize E.DeclDefArg Pattern.term

96− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentEquals

97− chompDefArgsAndBody maybeDocs start name tipe (arg : revArgs)

98− , do word1 0x3D {-=-} E.DeclDefEquals

99− Space.chompAndCheckIndent E.DeclDefSpace E.DeclDefIndentBody

100− (body, end) <- specialize E.DeclDefBody Expr.expression

101− let value = Src.Value name (reverse revArgs) body tipe

102− let avalue = A.at start end value

103− return (Value maybeDocs avalue, end)

59+ spaces

60+ oneOf E.XXX

61+ [

62+ do word1 0x3A {-:-} E.XXX

63+ pushContext start (E.Annotation name)

64+ spaces

65+ (tipe, _, space) <- Type.expression

66+ popContext ()

67+ checkAligned space

68+ defName <- matchingName name

69+ let (A.At (A.Region defStart _) _) = defName

70+ pushContext defStart (E.Definition name)

71+ spaces

72+ decl <- valueHelp start defName (Just tipe) []

73+ popContext decl

74+ ,

75+ do pushContext start (E.Definition name)

76+ decl <- valueHelp start (A.at start end name) Nothing []

77+ popContext decl

78+ ]

79+

80+

81+valueHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser Decl

82+valueHelp start name tipe revArgs =

83+ oneOf E.XXX

84+ [ do arg <- Pattern.term

85+ spaces

86+ valueHelp start name tipe (arg : revArgs)

87+ , do word1 0x3D {-=-} E.XXX

88+ spaces

89+ (body, end, space) <- Expr.expression

90+ let value = A.at start end (Src.Value name (reverse revArgs) body tipe)

91+ return ( Value value, end, space )

10492 ]

10593

10694

107−chompMatchingName :: Name.Name -> Parser E.DeclDef (A.Located Name.Name)

108−chompMatchingName expectedName =

109− let

110− (P.Parser parserL) = Var.lower E.DeclDefNameRepeat

111− in

112− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->

95+matchingName :: Name.Name -> Parser (A.Located Name.Name)

96+matchingName expectedName =

97+ let (P.Parser parserL) = Var.lower in

98+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->

11399 let

114− cokL name newState@(P.State _ _ _ _ er ec) =

100+ cokL name newState@(P.State _ _ _ er ec _) =

115101 if expectedName == name

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

118104

119− eokL name newState@(P.State _ _ _ _ er ec) =

105+ eokL name newState@(P.State _ _ _ er ec _) =

120106 if expectedName == name

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

123109 in

124110 parserL state cokL eokL cerr eerr

125111

126112

127113

128−-- TYPE DECLARATIONS

114+-- TYPE ALIAS and UNION TYPES

129115

130116

131117{-# INLINE typeDecl #-}

132−typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl

133−typeDecl maybeDocs start =

134− inContext E.DeclType (Keyword.type_ E.DeclStart) $

135− do Space.chompAndCheckIndent E.DT_Space E.DT_IndentName

136− oneOf E.DT_Name

137− [

138− inContext E.DT_Alias (Keyword.alias_ E.DT_Name) $

139− do Space.chompAndCheckIndent E.AliasSpace E.AliasIndentEquals

140− (name, args) <- chompAliasNameToEquals

141− (tipe, end) <- specialize E.AliasBody Type.expression

142− let alias = A.at start end (Src.Alias name args tipe)

143− return (Alias maybeDocs alias, end)

144− ,

145− specialize E.DT_Union $

146− do (name, args) <- chompCustomNameToEquals

147− (firstVariant, firstEnd) <- Type.variant

148− (variants, end) <- chompVariants [firstVariant] firstEnd

149− let union = A.at start end (Src.Union name args variants)

150− return (Union maybeDocs union, end)

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

175−

176−

177−

178−-- CUSTOM TYPES

118+typeDecl :: A.Position -> SParser Decl

119+typeDecl start =

120+ do Keyword.type_

121+ spaces

122+ oneOf E.XXX

123+ [

124+ inContext E.TypeAlias Keyword.alias_ $

125+ do spaces

126+ (name, args) <- nameArgsEquals

127+ (tipe, end, pos) <- Type.expression

128+ let alias = A.at start end (Src.Alias name args tipe)

129+ return (Alias alias, end, pos)

130+ ,

131+ do pushContext start E.TypeUnion

132+ (name, args) <- nameArgsEquals

133+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor

134+ (ctors, end, pos) <- chompConstructors [firstCtor] firstEnd firstSpace

135+ let union = A.at start end (Src.Union name args ctors)

136+ popContext (Union union, end, pos)

137+ ]

179138

180139

181−chompCustomNameToEquals :: Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])

182−chompCustomNameToEquals =

183− do name <- addLocation (Var.upper E.CT_Name)

184− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals

185− chompCustomNameToEqualsHelp name []

140+nameArgsEquals :: Parser (A.Located Name.Name, [A.Located Name.Name])

141+nameArgsEquals =

142+ do name <- addLocation Var.upper

143+ spaces

144+ nameArgsEqualsHelp name []

186145

187146

188−chompCustomNameToEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser E.CustomType (A.Located Name.Name, [A.Located Name.Name])

189−chompCustomNameToEqualsHelp name args =

190− oneOf E.CT_Equals

191− [ do arg <- addLocation (Var.lower E.CT_Equals)

192− Space.chompAndCheckIndent E.CT_Space E.CT_IndentEquals

193− chompCustomNameToEqualsHelp name (arg:args)

194− , do word1 0x3D {-=-} E.CT_Equals

195− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterEquals

147+nameArgsEqualsHelp :: A.Located Name.Name -> [A.Located Name.Name] -> Parser (A.Located Name.Name, [A.Located Name.Name])

148+nameArgsEqualsHelp name args =

149+ oneOf E.XXX

150+ [ do arg <- addLocation Var.lower

151+ spaces

152+ nameArgsEqualsHelp name (arg:args)

153+ , do word1 0x3D {-=-} E.XXX

154+ spaces

196155 return ( name, reverse args )

197156 ]

198157

199158

200−chompVariants :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> Space.Parser E.CustomType [(A.Located Name.Name, [Src.Type])]

201−chompVariants variants end =

202− oneOfWithFallback

203− [ do Space.checkIndent end E.CT_IndentBar

204− word1 0x7C {-|-} E.CT_Bar

205− Space.chompAndCheckIndent E.CT_Space E.CT_IndentAfterBar

206− (variant, newEnd) <- Type.variant

207− chompVariants (variant:variants) newEnd

159+chompConstructors :: [(A.Located Name.Name, [Src.Type])] -> A.Position -> SPos -> SParser [(A.Located Name.Name, [Src.Type])]

160+chompConstructors ctors end pos =

161+ oneOf E.XXX

162+ [ do checkSpace pos

163+ word1 0x7C {-|-} E.XXX

164+ spaces

165+ (ctor, newEnd, newSpace) <- Type.unionConstructor

166+ chompConstructors (ctor:ctors) newEnd newSpace

167+ , return ( reverse ctors, end, pos )

208168 ]

209− (reverse variants, end)

210169

211170

212171

@@ -214,19 +173,16 @@ chompVariants variants end =

214173

215174

216175{-# INLINE portDecl #-}

217−portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl

218−portDecl maybeDocs =

219− inContext E.Port (Keyword.port_ E.DeclStart) $

220− do Space.chompAndCheckIndent E.PortSpace E.PortIndentName

221− name <- addLocation (Var.lower E.PortName)

222− Space.chompAndCheckIndent E.PortSpace E.PortIndentColon

223− word1 0x3A {-:-} E.PortColon

224− Space.chompAndCheckIndent E.PortSpace E.PortIndentType

225− (tipe, end) <- specialize E.PortType Type.expression

226− return

227− ( Port maybeDocs (Src.Port name tipe)

228− , end

229− )

176+portDecl :: SParser Decl

177+portDecl =

178+ inContext E.Port Keyword.port_ $

179+ do spaces

180+ name <- addLocation Var.lower

181+ spaces

182+ word1 0x3A {-:-} E.XXX

183+ spaces

184+ (tipe, end, pos) <- Type.expression

185+ return ( Port (Src.Port name tipe), end, pos )

230186

231187

232188

@@ -235,32 +191,27 @@ portDecl maybeDocs =

235191

236192-- INVARIANT: always chomps to a freshline

237193--

238−infix_ :: Parser E.Module (A.Located Src.Infix)

194+infix_ :: Parser (A.Located Src.Binop)

239195infix_ =

240− let

241− err = E.Infix

242− _err = \_ -> E.Infix

243− in

244196 do start <- getPosition

245− Keyword.infix_ err

246− Space.chompAndCheckIndent _err err

247− associativity <-

248− oneOf err

249− [ Keyword.left_ err >> return Binop.Left

250− , Keyword.right_ err >> return Binop.Right

251− , Keyword.non_ err >> return Binop.Non

252− ]

253− Space.chompAndCheckIndent _err err

254− precedence <- Number.precedence err

255− Space.chompAndCheckIndent _err err

256− word1 0x28 {-(-} err

257− op <- Symbol.operator err _err

258− word1 0x29 {-)-} err

259− Space.chompAndCheckIndent _err err

260− word1 0x3D {-=-} err

261− Space.chompAndCheckIndent _err err

262− name <- Var.lower err

263− end <- getPosition

264− Space.chomp _err

265− Space.checkFreshLine err

266− return (A.at start end (Src.Infix op associativity precedence name))

197+ inContext E.Infix Keyword.infix_ $

198+ do spaces

199+ associativity <-

200+ oneOf E.XXX

201+ [ Keyword.left_ >> return Binop.Left

202+ , Keyword.right_ >> return Binop.Right

203+ , Keyword.non_ >> return Binop.Non

204+ ]

205+ spaces

206+ precedence <- Number.precedence

207+ spaces

208+ word1 0x28 {-(-} E.XXX

209+ op <- Symbol.binop

210+ word1 0x29 {-)-} E.XXX

211+ spaces

212+ word1 0x3D {-=-} E.XXX

213+ spaces

214+ name <- Var.lower

215+ end <- getPosition

216+ checkFreshLine =<< whitespace

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

77

88

99import qualified Data.Name as Name

10+import Data.Word (Word16)

1011

1112import qualified AST.Source as Src

1213import qualified Parse.Keyword as Keyword

1314import qualified Parse.Number as Number

1415import qualified Parse.Pattern as Pattern

1516import qualified Parse.Shader as Shader

16−import qualified Parse.Space as Space

1717import qualified Parse.Symbol as Symbol

1818import qualified Parse.Type as Type

19−import qualified Parse.String as String

19+import qualified Parse.Utf8 as Utf8

2020import qualified Parse.Variable as Var

21−import Parse.Primitives hiding (State)

21+import Parse.Utils

22+import Parse.Primitives hiding (Parser, State)

2223import qualified Parse.Primitives as P

2324import qualified Reporting.Annotation as A

2425import qualified Reporting.Error.Syntax as E

@@ -28,10 +29,10 @@ import qualified Reporting.Error.Syntax as E

2829-- TERMS

2930

3031

31−term :: Parser E.Expr Src.Expr

32+term :: Parser Src.Expr

3233term =

3334 do start <- getPosition

34− oneOf E.Start

35+ oneOf E.XXX

3536 [ variable start >>= accessible start

3637 , string start

3738 , number start

@@ -44,80 +45,90 @@ term =

4445 ]

4546

4647

47−string :: A.Position -> Parser E.Expr Src.Expr

48+string :: A.Position -> Parser Src.Expr

4849string start =

49− do str <- String.string E.Start E.String

50− addEnd start (Src.Str str)

50+ do str <- Utf8.string

51+ end <- getPosition

52+ return (A.at start end (Src.Str str))

5153

5254

53−character :: A.Position -> Parser E.Expr Src.Expr

55+character :: A.Position -> Parser Src.Expr

5456character start =

55− do chr <- String.character E.Start E.Char

56− addEnd start (Src.Chr chr)

57+ do chr <- Utf8.character

58+ end <- getPosition

59+ return (A.at start end (Src.Chr chr))

5760

5861

59−number :: A.Position -> Parser E.Expr Src.Expr

62+number :: A.Position -> Parser Src.Expr

6063number start =

61− do nmbr <- Number.number E.Start E.Number

62− addEnd start $

64+ do nmbr <- Number.number

65+ end <- getPosition

66+ return $ A.at start end $

6367 case nmbr of

64− Number.Int int -> Src.Int int

65− Number.Float float -> Src.Float float

68+ Number.Int int ->

69+ Src.Int int

6670

71+ Number.Float float ->

72+ Src.Float float

6773

68−accessor :: A.Position -> Parser E.Expr Src.Expr

74+

75+accessor :: A.Position -> Parser Src.Expr

6976accessor start =

70− do word1 0x2E {-.-} E.Dot

71− field <- Var.lower E.Access

72− addEnd start (Src.Accessor field)

77+ do word1 0x2E {-.-} E.XXX

78+ field <- Var.lower

79+ end <- getPosition

80+ return (A.at start end (Src.Accessor field))

7381

7482

75−variable :: A.Position -> Parser E.Expr Src.Expr

83+variable :: A.Position -> Parser Src.Expr

7684variable start =

77− do var <- Var.foreignAlpha E.Start

78− addEnd start var

85+ do var <- Var.foreignAlpha

86+ end <- getPosition

87+ return (A.at start end var)

7988

8089

81−accessible :: A.Position -> Src.Expr -> Parser E.Expr Src.Expr

90+accessible :: A.Position -> Src.Expr -> Parser Src.Expr

8291accessible start expr =

83− oneOfWithFallback

84− [ do word1 0x2E {-.-} E.Dot

92+ oneOf E.XXX

93+ [ do word1 0x2E {-.-} E.XXX

8594 pos <- getPosition

86− field <- Var.lower E.Access

95+ field <- Var.lower

8796 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

90100 ]

91− expr

92101

93102

94103

95104-- LISTS

96105

97106

98−list :: A.Position -> Parser E.Expr Src.Expr

107+list :: A.Position -> Parser Src.Expr

99108list start =

100− inContext E.List (word1 0x5B {-[-} E.Start) $

101− do Space.chompAndCheckIndent E.ListSpace E.ListIndentOpen

102− oneOf E.ListOpen

103− [ do (entry, end) <- specialize E.ListExpr expression

104− Space.checkIndent end E.ListIndentEnd

105− chompListEnd start [entry]

106− , do word1 0x5D {-]-} E.ListOpen

107− addEnd start (Src.List [])

109+ inContext E.ExprList (word1 0x5B {-[-} E.XXX) $

110+ do spaces

111+ oneOf E.XXX

112+ [ do (entry, _, pos) <- expression

113+ checkSpace pos

114+ listHelp start [entry]

115+ , do word1 0x5D {-]-} E.XXX

116+ end <- getPosition

117+ return (A.at start end (Src.List []))

108118 ]

109119

110120

111−chompListEnd :: A.Position -> [Src.Expr] -> Parser E.List Src.Expr

112−chompListEnd start entries =

113− oneOf E.ListEnd

114− [ do word1 0x2C {-,-} E.ListEnd

115− Space.chompAndCheckIndent E.ListSpace E.ListIndentExpr

116− (entry, end) <- specialize E.ListExpr expression

117− Space.checkIndent end E.ListIndentEnd

118− chompListEnd start (entry:entries)

119− , do word1 0x5D {-]-} E.ListEnd

120− addEnd start (Src.List (reverse entries))

121+listHelp :: A.Position -> [Src.Expr] -> Parser Src.Expr

122+listHelp start entries =

123+ oneOf E.XXX

124+ [ do word1 0x2C {-,-} E.XXX

125+ spaces

126+ (entry, _, pos) <- expression

127+ checkSpace pos

128+ listHelp start (entry:entries)

129+ , do word1 0x5D {-]-} E.XXX

130+ end <- getPosition

131+ return (A.at start end (Src.List (reverse entries)))

121132 ]

122133

123134

@@ -125,66 +136,52 @@ chompListEnd start entries =

125136-- TUPLES

126137

127138

128−tuple :: A.Position -> Parser E.Expr Src.Expr

129−tuple start@(A.Position row col) =

130− inContext E.Tuple (word1 0x28 {-(-} E.Start) $

131− do before <- getPosition

132− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExpr1

133− after <- getPosition

134− if before /= after

135− then

136− do (entry, end) <- specialize E.TupleExpr expression

137− Space.checkIndent end E.TupleIndentEnd

138− chompTupleEnd start entry []

139− else

140− oneOf E.TupleIndentExpr1

141− [

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

148− addEnd start (Src.Op op)

149− ,

150− do (entry, end) <-

151− specialize E.TupleExpr $

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− addEnd start (Src.Op op)

163− ,

164− do word1 0x29 {-)-} E.TupleIndentExpr1

165− addEnd start Src.Unit

166− ,

167− do (entry, end) <- specialize E.TupleExpr expression

168− Space.checkIndent end E.TupleIndentEnd

169− chompTupleEnd start entry []

170− ]

171−

172−

173−chompTupleEnd :: A.Position -> Src.Expr -> [Src.Expr] -> Parser E.Tuple Src.Expr

174−chompTupleEnd start firstExpr revExprs =

175− oneOf E.TupleEnd

176− [ do word1 0x2C {-,-} E.TupleEnd

177− Space.chompAndCheckIndent E.TupleSpace E.TupleIndentExprN

178− (entry, end) <- specialize E.TupleExpr expression

179− Space.checkIndent end E.TupleIndentEnd

180− chompTupleEnd start firstExpr (entry : revExprs)

181− , do word1 0x29 {-)-} E.TupleEnd

139+tuple :: A.Position -> Parser Src.Expr

140+tuple start =

141+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $

142+ do pos <- getPosition

143+ spos <- whitespace

144+ oneOf E.XXX

145+ [ do noSpace pos spos

146+ word2 0x2D 0x29 {--)-} E.XXX

147+ end <- getPosition

148+ return $ A.at start end (Src.Op "-")

149+

150+ , do checkSpace spos

151+ (entry, _, spos2) <- expression

152+ checkSpace spos2

153+ tupleHelp start entry []

154+

155+ , do noSpace pos spos

156+ op <- Symbol.binop

157+ word1 0x29 {-)-} E.XXX

158+ end <- getPosition

159+ return $ A.at start end (Src.Op op)

160+

161+ , do noSpace pos spos

162+ word1 0x29 {-)-} E.XXX

163+ end <- getPosition

164+ return (A.at start end Src.Unit)

165+

166+ ]

167+

168+

169+tupleHelp :: A.Position -> Src.Expr -> [Src.Expr] -> Parser Src.Expr

170+tupleHelp start firstExpr revExprs =

171+ oneOf E.XXX

172+ [ do word1 0x2C {-,-} E.XXX

173+ spaces

174+ (entry, _, pos) <- expression

175+ checkSpace pos

176+ tupleHelp start firstExpr (entry : revExprs)

177+ , do word1 0x29 {-)-} E.XXX

178+ end <- getPosition

182179 case reverse revExprs of

183180 [] ->

184181 return firstExpr

185182

186− secondExpr : otherExprs ->

187− addEnd start (Src.Tuple firstExpr secondExpr otherExprs)

183+ secondExpr : others ->

184+ return (A.at start end (Src.Tuple firstExpr secondExpr others))

188185 ]

189186

190187

@@ -192,27 +189,30 @@ chompTupleEnd start firstExpr revExprs =

192189-- RECORDS

193190

194191

195−record :: A.Position -> Parser E.Expr Src.Expr

192+record :: A.Position -> Parser Src.Expr

196193record start =

197− inContext E.Record (word1 0x7B {- { -} E.Start) $

198− do Space.chompAndCheckIndent E.RecordSpace E.RecordIndentOpen

199− oneOf E.RecordOpen

200− [ do word1 0x7D {-}-} E.RecordOpen

201− addEnd start (Src.Record [])

202− , do starter <- addLocation (Var.lower E.RecordField)

203− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals

204− oneOf E.RecordEquals

205− [ do word1 0x7C {-|-} E.RecordEquals

206− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField

194+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $

195+ do spaces

196+ oneOf E.XXX

197+ [ do word1 0x7D {-}-} E.XXX

198+ end <- getPosition

199+ return (A.at start end (Src.Record []))

200+ , do starter <- addLocation Var.lower

201+ spaces

202+ oneOf E.XXX

203+ [ do word1 0x7C {-|-} E.XXX

204+ spaces

207205 firstField <- chompField

208206 fields <- chompFields [firstField]

209− addEnd start (Src.Update starter fields)

210− , do word1 0x3D {-=-} E.RecordEquals

211− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr

212− (value, end) <- specialize E.RecordExpr expression

213− Space.checkIndent end E.RecordIndentEnd

207+ end <- getPosition

208+ return (A.at start end (Src.Update starter fields))

209+ , do word1 0x3D {-=-} E.XXX

210+ spaces

211+ (value, _, nextPos) <- expression

212+ checkSpace nextPos

214213 fields <- chompFields [(starter, value)]

215− addEnd start (Src.Record fields)

214+ end <- getPosition

215+ return (A.at start end (Src.Record fields))

216216 ]

217217 ]

218218

@@ -220,26 +220,26 @@ record start =

220220type Field = ( A.Located Name.Name, Src.Expr )

221221

222222

223−chompFields :: [Field] -> Parser E.Record [Field]

223+chompFields :: [Field] -> Parser [Field]

224224chompFields fields =

225− oneOf E.RecordEnd

226− [ do word1 0x2C {-,-} E.RecordEnd

227− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField

225+ oneOf E.XXX

226+ [ do word1 0x2C {-,-} E.XXX

227+ spaces

228228 f <- chompField

229229 chompFields (f : fields)

230− , do word1 0x7D {-}-} E.RecordEnd

230+ , do word1 0x7D {-}-} E.XXX

231231 return (reverse fields)

232232 ]

233233

234234

235−chompField :: Parser E.Record Field

235+chompField :: Parser Field

236236chompField =

237− do key <- addLocation (Var.lower E.RecordField)

238− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals

239− word1 0x3D {-=-} E.RecordEquals

240− Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr

241− (value, end) <- specialize E.RecordExpr expression

242− Space.checkIndent end E.RecordIndentEnd

237+ do key <- addLocation Var.lower

238+ spaces

239+ word1 0x3D {-=-} E.XXX

240+ spaces

241+ (value, _, pos) <- expression

242+ checkSpace pos

243243 return (key, value)

244244

245245

@@ -247,18 +247,22 @@ chompField =

247247-- EXPRESSIONS

248248

249249

250−expression :: Space.Parser E.Expr Src.Expr

250+type ExprParser =

251+ SParser Src.Expr

252+

253+

254+expression :: ExprParser

251255expression =

252256 do start <- getPosition

253− oneOf E.Start

257+ oneOf E.XXX

254258 [ let_ start

255259 , if_ start

256260 , case_ start

257261 , function start

258262 , do expr <- possiblyNegativeTerm start

259263 end <- getPosition

260− Space.chomp E.Space

261− chompExprEnd start (State [] expr [] end)

264+ space <- whitespace

265+ exprHelp start (State [] expr [] end space)

262266 ]

263267

264268

@@ -268,77 +272,77 @@ data State =

268272 , _expr :: !Src.Expr

269273 , _args :: ![Src.Expr]

270274 , _end :: !A.Position

275+ , _pos :: !SPos

271276 }

272277

273278

274−chompExprEnd :: A.Position -> State -> Space.Parser E.Expr Src.Expr

275−chompExprEnd start (State ops expr args end) =

276− oneOfWithFallback

279+exprHelp :: A.Position -> State -> ExprParser

280+exprHelp start (State ops expr args end pos) =

281+ oneOf E.XXX

277282 [ -- argument

278− do Space.checkIndent end E.Start

283+ do checkSpace pos

279284 arg <- term

280285 newEnd <- getPosition

281− Space.chomp E.Space

282− chompExprEnd start (State ops expr (arg:args) newEnd)

283−

284− , -- operator

285− do Space.checkIndent end E.Start

286− op@(A.At (A.Region opStart opEnd) opName) <- addLocation (Symbol.operator E.Start E.OperatorReserved)

287− Space.chompAndCheckIndent E.Space (E.IndentOperatorRight opName)

286+ newPos <- whitespace

287+ exprHelp start (State ops expr (arg:args) newEnd newPos)

288+

289+ , -- infix operator

290+ do checkSpace pos

291+ opStart <- getPosition

292+ opName <- Symbol.binop

293+ opEnd <- getPosition

294+ let op = A.at opStart opEnd opName

295+ spos <- whitespace

296+ checkSpace spos

288297 newStart <- getPosition

289298 if "-" == opName && end /= opStart && opEnd == newStart

290299 then

291300 -- negative terms

292− do negatedExpr <- term

301+ do rawTerm <- term

293302 newEnd <- getPosition

294− Space.chomp E.Space

295− let arg = A.at opStart newEnd (Src.Negate negatedExpr)

296− chompExprEnd start (State ops expr (arg:args) newEnd)

303+ newPos <- whitespace

304+ let arg = A.at opStart newEnd (Src.Negate rawTerm)

305+ exprHelp start (State ops expr (arg:args) newEnd newPos)

297306 else

298− let err = E.OperatorRight opName in

299− oneOf err

307+ oneOf E.XXX

300308 [ -- term

301309 do newExpr <- possiblyNegativeTerm newStart

302310 newEnd <- getPosition

303− Space.chomp E.Space

311+ newPos <- whitespace

304312 let newOps = (toCall expr args, op) : ops

305− chompExprEnd start (State newOps newExpr [] newEnd)

313+ exprHelp start (State newOps newExpr [] newEnd newPos)

306314

307315 , -- final term

308− do (newLast, newEnd) <-

309− oneOf err

316+ do (newLast, newEnd, newPos) <-

317+ oneOf E.XXX

310318 [ let_ newStart

311319 , case_ newStart

312320 , if_ newStart

313321 , function newStart

314322 ]

315323 let newOps = (toCall expr args, op) : ops

316− let finalExpr = Src.Binops (reverse newOps) newLast

317− return ( A.at start newEnd finalExpr, newEnd )

324+ let finalExpr = A.at start newEnd (Src.Binops (reverse newOps) newLast)

325+ return ( finalExpr, newEnd, newPos )

318326 ]

319327

320− ]

321− -- done

322− (

328+ , -- done

329+ let finalExpr = toCall expr args in

323330 case ops of

324331 [] ->

325− ( toCall expr args

326− , end

327− )

332+ return ( finalExpr, end, pos )

328333

329334 _ ->

330− ( A.at start end (Src.Binops (reverse ops) (toCall expr args))

331− , end

332− )

333− )

335+ return ( A.at start end (Src.Binops (reverse ops) finalExpr), end, pos )

336+ ]

334337

335338

336−possiblyNegativeTerm :: A.Position -> Parser E.Expr Src.Expr

339+possiblyNegativeTerm :: A.Position -> Parser Src.Expr

337340possiblyNegativeTerm start =

338− oneOf E.Start

339− [ do word1 0x2D {---} E.Start

341+ oneOf E.XXX

342+ [ do word1 0x2D {---} E.XXX

340343 expr <- term

341− addEnd start (Src.Negate expr)

344+ end <- getPosition

345+ return (A.at start end (Src.Negate expr))

342346 , term

343347 ]

344348

@@ -357,32 +361,30 @@ toCall func revArgs =

357361-- IF EXPRESSION

358362

359363

360−if_ :: A.Position -> Space.Parser E.Expr Src.Expr

364+if_ :: A.Position -> ExprParser

361365if_ start =

362− inContext E.If (Keyword.if_ E.Start) $

363− chompIfEnd start []

364−

365−

366−chompIfEnd :: A.Position -> [(Src.Expr, Src.Expr)] -> Space.Parser E.If Src.Expr

367−chompIfEnd start branches =

368− do Space.chompAndCheckIndent E.IfSpace E.IfIndentCondition

369− (condition, condEnd) <- specialize E.IfCondition expression

370− Space.checkIndent condEnd E.IfIndentThen

371− Keyword.then_ E.IfThen

372− Space.chompAndCheckIndent E.IfSpace E.IfIndentThenBranch

373− (thenBranch, thenEnd) <- specialize E.IfThenBranch expression

374− Space.checkIndent thenEnd E.IfIndentElse

375− Keyword.else_ E.IfElse

376− Space.chompAndCheckIndent E.IfSpace E.IfIndentElseBranch

366+ inContext E.ExprIf Keyword.if_ $

367+ ifHelp start []

368+

369+

370+ifHelp :: A.Position -> [(Src.Expr, Src.Expr)] -> ExprParser

371+ifHelp start branches =

372+ do spaces

373+ (condition, _, condPos) <- expression

374+ checkSpace condPos

375+ Keyword.then_

376+ spaces

377+ (thenBranch, _, thenPos) <- expression

378+ checkSpace thenPos

379+ Keyword.else_

380+ spaces

377381 let newBranches = (condition, thenBranch) : branches

378− oneOf E.IfElseBranchStart

379− [

380− do Keyword.if_ E.IfElseBranchStart

381− chompIfEnd start newBranches

382− ,

383− do (elseBranch, elseEnd) <- specialize E.IfElseBranch expression

384− let ifExpr = Src.If (reverse newBranches) elseBranch

385− return ( A.at start elseEnd ifExpr, elseEnd )

382+ oneOf E.XXX

383+ [ do Keyword.if_

384+ ifHelp start newBranches

385+ , do (elseBranch, elseEnd, elseSpace) <- expression

386+ let ifExpr = A.at start elseEnd (Src.If (reverse newBranches) elseBranch)

387+ return ( ifExpr, elseEnd, elseSpace )

386388 ]

387389

388390

@@ -390,27 +392,27 @@ chompIfEnd start branches =

390392-- LAMBDA EXPRESSION

391393

392394

393−function :: A.Position -> Space.Parser E.Expr Src.Expr

395+function :: A.Position -> ExprParser

394396function start =

395− inContext E.Func (word1 0x5C {-\-} E.Start) $

396− do Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArg

397− arg <- specialize E.FuncArg Pattern.term

398− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow

399− revArgs <- chompArgs [arg]

400− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentBody

401− (body, end) <- specialize E.FuncBody expression

402− let funcExpr = Src.Lambda (reverse revArgs) body

403− return (A.at start end funcExpr, end)

404−

405−

406−chompArgs :: [Src.Pattern] -> Parser E.Func [Src.Pattern]

407−chompArgs revArgs =

408− oneOf E.FuncArrow

409− [ do arg <- specialize E.FuncArg Pattern.term

410− Space.chompAndCheckIndent E.FuncSpace E.FuncIndentArrow

411− chompArgs (arg:revArgs)

412− , do word2 0x2D 0x3E {-->-} E.FuncArrow

413− return revArgs

397+ inContext E.ExprFunc (word1 0x5C {-\-} E.XXX) $

398+ do spaces

399+ arg <- Pattern.term

400+ spaces

401+ revArgs <- gatherArgs [arg]

402+ spaces

403+ (body, end, space) <- expression

404+ let func = A.at start end (Src.Lambda (reverse revArgs) body)

405+ return ( func, end, space )

406+

407+

408+gatherArgs :: [Src.Pattern] -> Parser [Src.Pattern]

409+gatherArgs args =

410+ oneOf E.XXX

411+ [ do arg <- Pattern.term

412+ spaces

413+ gatherArgs (arg:args)

414+ , do word2 0x2D 0x3E {-->-} E.XXX

415+ return args

414416 ]

415417

416418

@@ -418,84 +420,90 @@ chompArgs revArgs =

418420-- CASE EXPRESSIONS

419421

420422

421−case_ :: A.Position -> Space.Parser E.Expr Src.Expr

423+case_ :: A.Position -> ExprParser

422424case_ start =

423− inContext E.Case (Keyword.case_ E.Start) $

424− do Space.chompAndCheckIndent E.CaseSpace E.CaseIndentExpr

425− (expr, exprEnd) <- specialize E.CaseExpr expression

426− Space.checkIndent exprEnd E.CaseIndentOf

427− Keyword.of_ E.CaseOf

428− Space.chompAndCheckIndent E.CaseSpace E.CaseIndentPattern

429− withIndent $

430− do (firstBranch, firstEnd) <- chompBranch

431− (branches, end) <- chompCaseEnd [firstBranch] firstEnd

432− return

433− ( A.at start end (Src.Case expr branches)

434− , end

435− )

436−

437−

438−chompBranch :: Space.Parser E.Case (Src.Pattern, Src.Expr)

439−chompBranch =

440− do (pattern, patternEnd) <- specialize E.CasePattern Pattern.expression

441− Space.checkIndent patternEnd E.CaseIndentArrow

442− word2 0x2D 0x3E {-->-} E.CaseArrow

443− Space.chompAndCheckIndent E.CaseSpace E.CaseIndentBranch

444− (branchExpr, end) <- specialize E.CaseBranch expression

445− return ( (pattern, branchExpr), end )

446−

447−

448−chompCaseEnd :: [(Src.Pattern, Src.Expr)] -> A.Position -> Space.Parser E.Case [(Src.Pattern, Src.Expr)]

449−chompCaseEnd branches end =

450− oneOfWithFallback

451− [ do Space.checkAligned E.CasePatternAlignment

452− (branch, newEnd) <- chompBranch

453− chompCaseEnd (branch:branches) newEnd

425+ inContext E.ExprCase Keyword.case_ $

426+ do spaces

427+ (switcher, _, switcherPos) <- expression

428+ checkSpace switcherPos

429+ Keyword.of_

430+ spaces

431+ oldIndent <- getIndent

432+ newIndent <- getCol

433+ setIndent newIndent

434+ (firstBranch, firstEnd, firstPos) <- branchHelp

435+ (branches, end, pos) <- caseHelp [firstBranch] firstEnd firstPos

436+ setIndent oldIndent

437+ return

438+ ( A.at start end (Src.Case switcher branches)

439+ , end

440+ , pos

441+ )

442+

443+

444+branchHelp :: SParser (Src.Pattern, Src.Expr)

445+branchHelp =

446+ do (pattern, patternPos) <- Pattern.expression

447+ checkSpace patternPos

448+ word2 0x2D 0x3E {-->-} E.XXX

449+ spaces

450+ (branchExpr, end, pos) <- expression

451+ return ( (pattern, branchExpr), end, pos )

452+

453+

454+caseHelp :: [(Src.Pattern, Src.Expr)] -> A.Position -> SPos -> SParser [(Src.Pattern, Src.Expr)]

455+caseHelp branches end pos =

456+ oneOf E.XXX

457+ [ do checkAligned pos

458+ (branch, newEnd, newPos) <- branchHelp

459+ caseHelp (branch:branches) newEnd newPos

460+ , return ( reverse branches, end, pos )

454461 ]

455− (reverse branches, end)

456462

457463

458464

459465-- LET EXPRESSION

460466

461467

462−let_ :: A.Position -> Space.Parser E.Expr Src.Expr

468+let_ :: A.Position -> ExprParser

463469let_ start =

464− inContext E.Let (Keyword.let_ E.Start) $

465− do (defs, defsEnd) <-

466− withBacksetIndent 3 $

467− do Space.chompAndCheckIndent E.LetSpace E.LetIndentDef

468− withIndent $

469− do (def, end) <- chompLetDef

470− chompLetDefs [def] end

471−

472− Space.checkIndent defsEnd E.LetIndentIn

473− Keyword.in_ E.LetIn

474− Space.chompAndCheckIndent E.LetSpace E.LetIndentBody

475− (body, end) <- specialize E.LetBody expression

476− return

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

486− (def, newEnd) <- chompLetDef

487− chompLetDefs (def:revDefs) newEnd

470+ do oldIndent <- getIndent

471+ letIndent <- getCol

472+ Keyword.let_

473+ pushContext start E.ExprLet

474+ setIndent letIndent

475+ spaces

476+ defIndent <- getCol

477+ setIndent defIndent

478+ (def, end, space) <- letDef

479+ letHelp start oldIndent [def] end space

480+

481+

482+letHelp :: A.Position -> Word16 -> [A.Located Src.Def] -> A.Position -> SPos -> ExprParser

483+letHelp start oldIndent revDefs end pos =

484+ oneOf E.XXX

485+ [ do checkAligned pos

486+ (def, newEnd, newPos) <- letDef

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 )

488497 ]

489− (reverse revDefs, end)

490498

491499

492500

493501-- LET DEFINITIONS

494502

495503

496−chompLetDef :: Space.Parser E.Let (A.Located Src.Def)

497−chompLetDef =

498− oneOf E.LetDefName

504+letDef :: SParser (A.Located Src.Def)

505+letDef =

506+ oneOf E.XXX

499507 [ definition

500508 , destructure

501509 ]

@@ -505,57 +513,61 @@ chompLetDef =

505513-- DEFINITION

506514

507515

508−definition :: Space.Parser E.Let (A.Located Src.Def)

516+definition :: SParser (A.Located Src.Def)

509517definition =

510− do aname@(A.At (A.Region start _) name) <- addLocation (Var.lower E.LetDefName)

511− specialize (E.LetDef name) $

512− do Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals

513− oneOf E.DefEquals

514− [

515− do word1 0x3A {-:-} E.DefEquals

516− Space.chompAndCheckIndent E.DefSpace E.DefIndentType

517− (tipe, _) <- specialize E.DefType Type.expression

518− Space.checkAligned E.DefAlignment

519− defName <- chompMatchingName name

520− Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals

521− chompDefArgsAndBody start defName (Just tipe) []

522− ,

523− chompDefArgsAndBody start aname Nothing []

524− ]

525−

526−

527−chompDefArgsAndBody :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.Def (A.Located Src.Def)

528−chompDefArgsAndBody start name tipe revArgs =

529− oneOf E.DefEquals

530− [ do arg <- specialize E.DefArg Pattern.term

531− Space.chompAndCheckIndent E.DefSpace E.DefIndentEquals

532− chompDefArgsAndBody start name tipe (arg : revArgs)

533− , do word1 0x3D {-=-} E.DefEquals

534− Space.chompAndCheckIndent E.DefSpace E.DefIndentBody

535− (body, end) <- specialize E.DefBody expression

536− return

537− ( A.at start end (Src.Define name (reverse revArgs) body tipe)

538− , end

539− )

518+ do start <- getPosition

519+ name <- Var.lower

520+ end <- getPosition

521+ spaces

522+ oneOf E.XXX

523+ [

524+ do word1 0x3A {-:-} E.XXX

525+ pushContext start (E.Annotation name)

526+ spaces

527+ (tipe, _, space) <- Type.expression

528+ popContext ()

529+ checkAligned space

530+ defName <- matchingName name

531+ let (A.At (A.Region defStart _) _) = defName

532+ pushContext defStart (E.Definition name)

533+ spaces

534+ def <- definitionHelp start defName (Just tipe) []

535+ popContext def

536+ ,

537+ do pushContext start (E.Definition name)

538+ def <- definitionHelp start (A.at start end name) Nothing []

539+ popContext def

540+ ]

541+

542+

543+definitionHelp :: A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> SParser (A.Located Src.Def)

544+definitionHelp start name tipe revArgs =

545+ oneOf E.XXX

546+ [ do arg <- Pattern.term

547+ spaces

548+ definitionHelp start name tipe (arg : revArgs)

549+ , do word1 0x3D {-=-} E.XXX

550+ spaces

551+ (body, end, space) <- expression

552+ let def = A.at start end (Src.Define name (reverse revArgs) body tipe)

553+ return ( def, end, space )

540554 ]

541555

542556

543−chompMatchingName :: Name.Name -> Parser E.Def (A.Located Name.Name)

544−chompMatchingName expectedName =

545− let

546− (P.Parser parserL) = Var.lower E.DefNameRepeat

547− in

548− P.Parser $ \state@(P.State _ _ _ _ sr sc) cok eok cerr eerr ->

557+matchingName :: Name.Name -> Parser (A.Located Name.Name)

558+matchingName expectedName =

559+ let (P.Parser parserL) = Var.lower in

560+ P.Parser $ \state@(P.State _ _ _ sr sc ctx) cok eok cerr eerr ->

549561 let

550− cokL name newState@(P.State _ _ _ _ er ec) =

562+ cokL name newState@(P.State _ _ _ er ec _) =

551563 if expectedName == name

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

554566

555− eokL name newState@(P.State _ _ _ _ er ec) =

567+ eokL name newState@(P.State _ _ _ er ec _) =

556568 if expectedName == name

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

559571 in

560572 parserL state cokL eokL cerr eerr

561573

@@ -565,13 +577,12 @@ chompMatchingName expectedName =

565577-- DESTRUCTURE

566578

567579

568−destructure :: Space.Parser E.Let (A.Located Src.Def)

580+destructure :: SParser (A.Located Src.Def)

569581destructure =

570− specialize E.LetDestruct $

571582 do start <- getPosition

572− pattern <- specialize E.DestructPattern Pattern.term

573− Space.chompAndCheckIndent E.DestructSpace E.DestructIndentEquals

574− word1 0x3D {-=-} E.DestructEquals

575− Space.chompAndCheckIndent E.DestructSpace E.DestructIndentBody

576− (expr, end) <- specialize E.DestructBody expression

577− return ( A.at start end (Src.Destruct pattern expr), end )

583+ pattern <- Pattern.term

584+ spaces

585+ word1 0x3D {-=-} E.XXX

586+ spaces

587+ (expr, end, space) <- expression

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

1616import Foreign.Ptr (plusPtr)

1717import Data.Word (Word8)

1818

19−import Parse.Primitives (Parser, Row, Col)

19+import Parse.Utils (Parser)

2020import qualified Parse.Variable as Var

2121import qualified Parse.Primitives as P

22+import qualified Reporting.Error.Syntax as E

2223

2324

2425

2526-- DECLARATIONS

2627

2728

28−type_ :: (Row -> Col -> x) -> Parser x ()

29−type_ tx = k4 0x74 0x79 0x70 0x65 tx

29+type_ :: Parser ()

30+type_ = k4 0x74 0x79 0x70 0x65 E.KeywordType

3031

31−alias_ :: (Row -> Col -> x) -> Parser x ()

32−alias_ tx = k5 0x61 0x6C 0x69 0x61 0x73 tx

32+alias_ :: Parser ()

33+alias_ = k5 0x61 0x6C 0x69 0x61 0x73 E.KeywordAlias

3334

34−port_ :: (Row -> Col -> x) -> Parser x ()

35−port_ tx = k4 0x70 0x6F 0x72 0x74 tx

35+port_ :: Parser ()

36+port_ = k4 0x70 0x6F 0x72 0x74 E.KeywordPort

3637

3738

3839

3940-- IF EXPRESSIONS

4041

4142

42−if_ :: (Row -> Col -> x) -> Parser x ()

43−if_ tx = k2 0x69 0x66 tx

43+if_ :: Parser ()

44+if_ = k2 0x69 0x66 E.KeywordIf

4445

45−then_ :: (Row -> Col -> x) -> Parser x ()

46−then_ tx = k4 0x74 0x68 0x65 0x6E tx

46+then_ :: Parser ()

47+then_ = k4 0x74 0x68 0x65 0x6E E.KeywordThen

4748

48−else_ :: (Row -> Col -> x) -> Parser x ()

49−else_ tx = k4 0x65 0x6C 0x73 0x65 tx

49+else_ :: Parser ()

50+else_ = k4 0x65 0x6C 0x73 0x65 E.KeywordElse

5051

5152

5253

5354-- CASE EXPRESSIONS

5455

5556

56−case_ :: (Row -> Col -> x) -> Parser x ()

57−case_ tx = k4 0x63 0x61 0x73 0x65 tx

57+case_ :: Parser ()

58+case_ = k4 0x63 0x61 0x73 0x65 E.KeywordCase

5859

59−of_ :: (Row -> Col -> x) -> Parser x ()

60−of_ tx = k2 0x6F 0x66 tx

60+of_ :: Parser ()

61+of_ = k2 0x6F 0x66 E.KeywordOf

6162

6263

6364

6465-- LET EXPRESSIONS

6566

6667

67−let_ :: (Row -> Col -> x) -> Parser x ()

68−let_ tx = k3 0x6C 0x65 0x74 tx

68+let_ :: Parser ()

69+let_ = k3 0x6C 0x65 0x74 E.KeywordLet

6970

70−in_ :: (Row -> Col -> x) -> Parser x ()

71−in_ tx = k2 0x69 0x6E tx

71+in_ :: Parser ()

72+in_ = k2 0x69 0x6E E.KeywordIn

7273

7374

7475

7576-- INFIXES

7677

7778

78−infix_ :: (Row -> Col -> x) -> Parser x ()

79−infix_ tx = k5 0x69 0x6E 0x66 0x69 0x78 tx

79+infix_ :: Parser ()

80+infix_ = k5 0x69 0x6E 0x66 0x69 0x78 E.KeywordInfix

8081

81−left_ :: (Row -> Col -> x) -> Parser x ()

82−left_ tx = k4 0x6C 0x65 0x66 0x74 tx

82+left_ :: Parser ()

83+left_ = k4 0x6C 0x65 0x66 0x74 E.Associativity

8384

84−right_ :: (Row -> Col -> x) -> Parser x ()

85−right_ tx = k5 0x72 0x69 0x67 0x68 0x74 tx

85+right_ :: Parser ()

86+right_ = k5 0x72 0x69 0x67 0x68 0x74 E.Associativity

8687

87−non_ :: (Row -> Col -> x) -> Parser x ()

88−non_ tx = k3 0x6E 0x6F 0x6E tx

88+non_ :: Parser ()

89+non_ = k3 0x6E 0x6F 0x6E E.Associativity

8990

9091

9192

9293-- IMPORTS

9394

9495

95−module_ :: (Row -> Col -> x) -> Parser x ()

96−module_ tx = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 tx

96+module_ :: Parser ()

97+module_ = k6 0x6D 0x6F 0x64 0x75 0x6C 0x65 E.KeywordModule

9798

98−import_ :: (Row -> Col -> x) -> Parser x ()

99−import_ tx = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 tx

99+import_ :: Parser ()

100+import_ = k6 0x69 0x6D 0x70 0x6F 0x72 0x74 E.KeywordImport

100101

101−exposing_ :: (Row -> Col -> x) -> Parser x ()

102−exposing_ tx = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 tx

102+exposing_ :: Parser ()

103+exposing_ = k8 0x65 0x78 0x70 0x6F 0x73 0x69 0x6E 0x67 E.KeywordExposing

103104

104−as_ :: (Row -> Col -> x) -> Parser x ()

105−as_ tx = k2 0x61 0x73 tx

105+as_ :: Parser ()

106+as_ = k2 0x61 0x73 E.KeywordAs

106107

107108

108109

109110-- EFFECTS

110111

111112

112−effect_ :: (Row -> Col -> x) -> Parser x ()

113−effect_ tx = k6 0x65 0x66 0x66 0x65 0x63 0x74 tx

113+effect_ :: Parser ()

114+effect_ = k6 0x65 0x66 0x66 0x65 0x63 0x74 E.EffectStuff

114115

115−where_ :: (Row -> Col -> x) -> Parser x ()

116−where_ tx = k5 0x77 0x68 0x65 0x72 0x65 tx

116+where_ :: Parser ()

117+where_ = k5 0x77 0x68 0x65 0x72 0x65 E.EffectStuff

117118

118−command_ :: (Row -> Col -> x) -> Parser x ()

119−command_ tx = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 tx

119+command_ :: Parser ()

120+command_ = k7 0x63 0x6F 0x6D 0x6D 0x61 0x6E 0x64 E.EffectStuff

120121

121−subscription_ :: (Row -> Col -> x) -> Parser x ()

122−subscription_ toError =

123− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

122+subscription_ :: Parser ()

123+subscription_ =

124+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

124125 let !pos12 = plusPtr pos 12 in

125126 if pos12 <= end

126127 && P.unsafeIndex ( pos ) == 0x73

@@ -137,32 +138,32 @@ subscription_ toError =

137138 && P.unsafeIndex (plusPtr pos 11) == 0x6E

138139 && Var.getInnerWidth pos12 end == 0

139140 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

141142 else

142− eerr row col toError

143+ eerr row col ctx E.EffectStuff

143144

144145

145146

146147-- KEYWORDS

147148

148149

149−k2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

150−k2 w1 w2 toError =

151− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

150+k2 :: Word8 -> Word8 -> x -> P.Parser c x ()

151+k2 w1 w2 x =

152+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

152153 let !pos2 = plusPtr pos 2 in

153154 if pos2 <= end

154155 && P.unsafeIndex ( pos ) == w1

155156 && P.unsafeIndex (plusPtr pos 1) == w2

156157 && Var.getInnerWidth pos2 end == 0

157158 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

159160 else

160− eerr row col toError

161+ eerr row col ctx x

161162

162163

163−k3 :: Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

164−k3 w1 w2 w3 toError =

165− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

164+k3 :: Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

165+k3 w1 w2 w3 x =

166+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

166167 let !pos3 = plusPtr pos 3 in

167168 if pos3 <= end

168169 && P.unsafeIndex ( pos ) == w1

@@ -170,14 +171,14 @@ k3 w1 w2 w3 toError =

170171 && P.unsafeIndex (plusPtr pos 2) == w3

171172 && Var.getInnerWidth pos3 end == 0

172173 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

174175 else

175− eerr row col toError

176+ eerr row col ctx x

176177

177178

178−k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

179−k4 w1 w2 w3 w4 toError =

180− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

179+k4 :: Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

180+k4 w1 w2 w3 w4 x =

181+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

181182 let !pos4 = plusPtr pos 4 in

182183 if pos4 <= end

183184 && P.unsafeIndex ( pos ) == w1

@@ -186,14 +187,14 @@ k4 w1 w2 w3 w4 toError =

186187 && P.unsafeIndex (plusPtr pos 3) == w4

187188 && Var.getInnerWidth pos4 end == 0

188189 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

190191 else

191− eerr row col toError

192+ eerr row col ctx x

192193

193194

194−k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

195−k5 w1 w2 w3 w4 w5 toError =

196− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

195+k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

196+k5 w1 w2 w3 w4 w5 x =

197+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

197198 let !pos5 = plusPtr pos 5 in

198199 if pos5 <= end

199200 && P.unsafeIndex ( pos ) == w1

@@ -203,14 +204,14 @@ k5 w1 w2 w3 w4 w5 toError =

203204 && P.unsafeIndex (plusPtr pos 4) == w5

204205 && Var.getInnerWidth pos5 end == 0

205206 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

207208 else

208− eerr row col toError

209+ eerr row col ctx x

209210

210211

211−k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

212−k6 w1 w2 w3 w4 w5 w6 toError =

213− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

212+k6 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

213+k6 w1 w2 w3 w4 w5 w6 x =

214+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

214215 let !pos6 = plusPtr pos 6 in

215216 if pos6 <= end

216217 && P.unsafeIndex ( pos ) == w1

@@ -221,14 +222,14 @@ k6 w1 w2 w3 w4 w5 w6 toError =

221222 && P.unsafeIndex (plusPtr pos 5) == w6

222223 && Var.getInnerWidth pos6 end == 0

223224 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

225226 else

226− eerr row col toError

227+ eerr row col ctx x

227228

228229

229−k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

230−k7 w1 w2 w3 w4 w5 w6 w7 toError =

231− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

230+k7 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

231+k7 w1 w2 w3 w4 w5 w6 w7 x =

232+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

232233 let !pos7 = plusPtr pos 7 in

233234 if pos7 <= end

234235 && P.unsafeIndex ( pos ) == w1

@@ -240,14 +241,14 @@ k7 w1 w2 w3 w4 w5 w6 w7 toError =

240241 && P.unsafeIndex (plusPtr pos 6) == w7

241242 && Var.getInnerWidth pos7 end == 0

242243 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

244245 else

245− eerr row col toError

246+ eerr row col ctx x

246247

247248

248−k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

249−k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =

250− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

249+k8 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> x -> P.Parser c x ()

250+k8 w1 w2 w3 w4 w5 w6 w7 w8 x =

251+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

251252 let !pos8 = plusPtr pos 8 in

252253 if pos8 <= end

253254 && P.unsafeIndex ( pos ) == w1

@@ -260,6 +261,6 @@ k8 w1 w2 w3 w4 w5 w6 w7 w8 toError =

260261 && P.unsafeIndex (plusPtr pos 7) == w8

261262 && Var.getInnerWidth pos8 end == 0

262263 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

264265 else

265− eerr row col toError

266+ eerr row col ctx x

compiler/src/Parse/Module.hs+259−330

@@ -2,15 +2,16 @@

22{-# LANGUAGE OverloadedStrings #-}

33module Parse.Module

44 ( fromByteString

5− , ProjectType(..)

6− , isKernel

5+ , Header(..)

6+ , Effects(..)

7+ , chompHeader

78 , chompImports

8− , chompImport

9+ , freshLine

910 )

1011 where

1112

1213

13−import qualified Data.ByteString as BS

14+import qualified Data.ByteString as B

1415import qualified Data.Name as Name

1516

1617import qualified AST.Source as Src

@@ -18,124 +19,105 @@ import qualified Elm.Compiler.Imports as Imports

1819import qualified Elm.Package as Pkg

1920import qualified Parse.Declaration as Decl

2021import qualified Parse.Keyword as Keyword

21−import qualified Parse.Space as Space

2222import qualified Parse.Symbol as Symbol

2323import qualified Parse.Variable as Var

2424import qualified Parse.Primitives as P

25−import Parse.Primitives hiding (State, fromByteString)

25+import Parse.Primitives hiding (Parser, State, fromByteString)

26+import Parse.Utils

2627import qualified Reporting.Annotation as A

2728import qualified Reporting.Error.Syntax as E

29+import qualified Reporting.Result as Result

2830

2931

3032

3133-- FROM BYTE STRING

3234

3335

34−fromByteString :: ProjectType -> BS.ByteString -> Either E.Error Src.Module

35−fromByteString projectType source =

36− case P.fromByteString (chompModule projectType) E.ModuleBadEnd source of

37− Right modul -> checkModule projectType modul

38− Left err -> Left (E.ParseError err)

39−

40−

41−

42−-- PROJECT TYPE

43−

44−

45−data ProjectType

46− = Package Pkg.Name

47− | Application

48−

36+fromByteString :: Pkg.Name -> B.ByteString -> Result.Result i w E.Error Src.Module

37+fromByteString pkg source =

38+ let

39+ parser

40+ | pkg == Pkg.core = core

41+ | Pkg.isKernel pkg = platform

42+ | otherwise = normal

43+ in

44+ case P.fromByteString parser source of

45+ P.Ok outcome _ ->

46+ case outcome of

47+ Right modul -> Result.ok modul

48+ Left err -> Result.throw err

4949

50−isCore :: ProjectType -> Bool

51−isCore projectType =

52− case projectType of

53− Package pkg -> pkg == Pkg.core

54− Application -> False

50+ P.Err row col ctx err ->

51+ Result.throw (E.ParseError row col ctx err)

5552

5653

57−isKernel :: ProjectType -> Bool

58−isKernel projectType =

59− case projectType of

60− Package pkg -> Pkg.isKernel pkg

61− Application -> False

6254

55+-- MODULE

6356

6457

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)

6666

6767

68−data Module =

69− Module

70− { _header :: Maybe Header

71− , _imports :: [Src.Import]

72− , _infixes :: [A.Located Src.Infix]

73− , _decls :: [Decl.Decl]

74− }

68+core :: Parser (Either E.Error Src.Module)

69+core =

70+ do freshLine

71+ header <- chompHeader

72+ imports <- chompImports []

73+ binops <- chompBinops []

74+ decls <- chompDecls []

75+ endOfFile

76+ return (checkModule header imports binops decls)

7577

7678

77−chompModule :: ProjectType -> Parser E.Module Module

78−chompModule projectType =

79− do header <- chompHeader

80− imports <- chompImports (if isCore projectType then [] else Imports.defaults)

81− infixes <- if isKernel projectType then chompInfixes [] else return []

82− decls <- specialize E.Declarations $ chompDecls []

83− return (Module header imports infixes decls)

79+platform :: Parser (Either E.Error Src.Module)

80+platform =

81+ do freshLine

82+ header <- chompHeader

83+ imports <- chompImports []

84+ binops <- chompBinops []

85+ decls <- chompDecls []

86+ endOfFile

87+ return (checkModule header (Imports.addDefaults imports) binops decls)

8488

8589

8690

8791-- CHECK MODULE

8892

8993

90−checkModule :: ProjectType -> Module -> Either E.Error Src.Module

91−checkModule projectType (Module maybeHeader imports infixes decls) =

94+checkModule :: Maybe Header -> [Src.Import] -> [A.Located Src.Binop] -> [Decl.Decl] -> Either E.Error Src.Module

95+checkModule maybeHeader imports binops decls =

9296 let

97+ (Header name effects exports) = maybe (Header "Main" NoEffects (A.At A.one Src.Open)) id maybeHeader

9398 (values, unions, aliases, ports) = categorizeDecls [] [] [] [] decls

9499 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

98− <$> checkEffects projectType ports effects

100+ Src.Module name exports imports values unions aliases binops

101+ <$> checkEffects ports effects

99102

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

106103

107−

108−checkEffects :: ProjectType -> [Src.Port] -> Effects -> Either E.Error Src.Effects

109−checkEffects projectType ports effects =

104+checkEffects :: [Src.Port] -> Effects -> Either E.Error Src.Effects

105+checkEffects ports effects =

110106 case effects of

111− NoEffects region ->

107+ NoEffects ->

112108 case ports of

113− [] ->

114− Right Src.NoEffects

115−

116− Src.Port name _ : _ ->

117− case projectType of

118− Package _ -> Left (E.NoPortsInPackage name)

119− Application -> Left (E.UnexpectedPort region)

109+ [] -> Right Src.NoEffects

110+ _:_ -> Left (error "TODO no ports")

120111

121112 Ports region ->

122− case projectType of

123− Package _ ->

124− Left (E.NoPortModulesInPackage region)

125−

126− Application ->

127− case ports of

128− [] -> Left (E.NoPorts region)

129− _:_ -> Right (Src.Ports ports)

113+ case ports of

114+ [] -> Left (error "TODO no ports in port module" region)

115+ _:_ -> Right (Src.Ports ports)

130116

131117 Manager region manager ->

132− if isKernel projectType then

133− case ports of

134− [] -> Right (Src.Manager region manager)

135− _:_ -> Left (E.UnexpectedPort region)

136− else

137− Left (E.NoEffectsOutsideKernel region)

138−

118+ case ports of

119+ [] -> Right (Src.Manager region manager)

120+ _:_ -> Left (error "TODO ports in effect manager")

139121

140122

141123categorizeDecls :: [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 =

146128

147129 decl:otherDecls ->

148130 case decl of

149− Decl.Value _ value -> categorizeDecls (value:values) unions aliases ports otherDecls

150− Decl.Union _ union -> categorizeDecls values (union:unions) aliases ports otherDecls

151− Decl.Alias _ alias -> categorizeDecls values unions (alias:aliases) ports otherDecls

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

131+ Decl.Value value -> categorizeDecls (value:values) unions aliases ports otherDecls

132+ Decl.Union union -> categorizeDecls values (union:unions) aliases ports otherDecls

133+ Decl.Alias alias -> categorizeDecls values unions (alias:aliases) ports otherDecls

134+ Decl.Port port_ -> categorizeDecls values unions aliases (port_:ports) otherDecls

181135

182136

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

188137

138+-- FRESH LINES

189139

190140

191−-- FRESH LINES

141+freshLine :: Parser ()

142+freshLine =

143+ checkFreshLine =<< whitespace

192144

193145

194−freshLine :: (Row -> Col -> E.Module) -> Parser E.Module ()

195−freshLine toFreshLineError =

196− do Space.chomp E.ModuleSpace

197− Space.checkFreshLine toFreshLineError

146+endOfFile :: Parser ()

147+endOfFile =

148+ P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->

149+ if pos < end then

150+ eerr row col ctx E.EndOfFile

151+ else

152+ eok () state

198153

199154

200155

201156-- CHOMP DECLARATIONS

202157

203158

204−chompDecls :: [Decl.Decl] -> Parser E.Decl [Decl.Decl]

159+chompDecls :: [Decl.Decl] -> Parser [Decl.Decl]

205160chompDecls decls =

206− do (decl, _) <- Decl.declaration

207− oneOfWithFallback

208− [ do Space.checkFreshLine E.DeclStart

161+ do (decl, _, pos) <- Decl.declaration

162+ oneOf E.XXX

163+ [ do checkFreshLine pos

209164 chompDecls (decl:decls)

165+ , return (reverse (decl:decls))

210166 ]

211− (reverse (decl:decls))

212167

213168

214−chompInfixes :: [A.Located Src.Infix] -> Parser E.Module [A.Located Src.Infix]

215−chompInfixes infixes =

216− oneOfWithFallback

169+chompBinops :: [A.Located Src.Binop] -> Parser [A.Located Src.Binop]

170+chompBinops binops =

171+ oneOf E.XXX

217172 [ do binop <- Decl.infix_

218− chompInfixes (binop:infixes)

173+ chompBinops (binop:binops)

174+ , return binops

219175 ]

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)

238176

239177

240178

@@ -242,246 +180,237 @@ chompModuleDocCommentSpace =

242180

243181

244182data 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)

246184

247185

248186data Effects

249− = NoEffects A.Region

187+ = NoEffects

250188 | Ports A.Region

251189 | Manager A.Region Src.Manager

252190

253191

254−chompHeader :: Parser E.Module (Maybe Header)

192+chompHeader :: Parser (Maybe Header)

255193chompHeader =

256− do freshLine E.FreshLine

257− start <- getPosition

258− oneOfWithFallback

194+ do start <- getPosition

195+ oneOf E.XXX

259196 [

260197 -- module MyThing exposing (..)

261− do Keyword.module_ E.ModuleProblem

262− effectEnd <- getPosition

263− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem

264− name <- addLocation (Var.moduleName E.ModuleName)

265− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem

266− Keyword.exposing_ E.ModuleProblem

267− Space.chompAndCheckIndent E.ModuleSpace E.ModuleProblem

268− exports <- addLocation (specialize E.ModuleExposing exposing)

269− comment <- chompModuleDocCommentSpace

270− return $ Just $

271− Header name (NoEffects (A.Region start effectEnd)) exports comment

198+ do Keyword.module_

199+ pushContext start E.Module

200+ spaces

201+ name <- Var.moduleName

202+ spaces

203+ Keyword.exposing_

204+ spaces

205+ exports <- addLocation exposing

206+ popContext ()

207+ freshLine

208+ return (Just (Header name NoEffects exports))

272209 ,

273210 -- port module MyThing exposing (..)

274− do Keyword.port_ E.PortModuleProblem

275− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

276− Keyword.module_ E.PortModuleProblem

277− effectEnd <- getPosition

278− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

279− name <- addLocation (Var.moduleName E.PortModuleName)

280− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

281− Keyword.exposing_ E.PortModuleProblem

282− Space.chompAndCheckIndent E.ModuleSpace E.PortModuleProblem

283− exports <- addLocation (specialize E.PortModuleExposing exposing)

284− comment <- chompModuleDocCommentSpace

285− return $ Just $

286− Header name (Ports (A.Region start effectEnd)) exports comment

211+ do Keyword.port_

212+ pushContext start E.Module

213+ spaces

214+ Keyword.module_

215+ end <- getPosition

216+ spaces

217+ name <- Var.moduleName

218+ spaces

219+ Keyword.exposing_

220+ spaces

221+ exports <- addLocation exposing

222+ popContext ()

223+ freshLine

224+ return (Just (Header name (Ports (A.Region start end)) exports))

287225 ,

288226 -- effect module MyThing where { command = MyCmd } exposing (..)

289− do Keyword.effect_ E.Effect

290− Space.chompAndCheckIndent E.ModuleSpace E.Effect

291− Keyword.module_ E.Effect

292− effectEnd <- getPosition

293− Space.chompAndCheckIndent E.ModuleSpace E.Effect

294− name <- addLocation (Var.moduleName E.ModuleName)

295− Space.chompAndCheckIndent E.ModuleSpace E.Effect

296− Keyword.where_ E.Effect

297− Space.chompAndCheckIndent E.ModuleSpace E.Effect

227+ do Keyword.effect_

228+ pushContext start E.Module

229+ spaces

230+ Keyword.module_

231+ end <- getPosition

232+ spaces

233+ name <- Var.moduleName

234+ spaces

235+ Keyword.where_

236+ spaces

298237 manager <- chompManager

299− Space.chompAndCheckIndent E.ModuleSpace E.Effect

300− Keyword.exposing_ E.Effect

301− Space.chompAndCheckIndent E.ModuleSpace E.Effect

302− exports <- addLocation (specialize (const E.Effect) exposing)

303− comment <- chompModuleDocCommentSpace

304− return $ Just $

305− Header name (Manager (A.Region start effectEnd) manager) exports comment

238+ spaces

239+ Keyword.exposing_

240+ spaces

241+ exports <- addLocation exposing

242+ popContext ()

243+ freshLine

244+ return (Just (Header name (Manager (A.Region start end) manager) exports))

245+ ,

246+ -- default header

247+ return Nothing

306248 ]

307− -- default header

308− Nothing

309249

310250

311−chompManager :: Parser E.Module Src.Manager

251+chompManager :: Parser Src.Manager

312252chompManager =

313− do word1 0x7B {- { -} E.Effect

314− spaces_em

315− oneOf E.Effect

253+ do word1 0x7B {- { -} E.XXX

254+ spaces

255+ oneOf E.XXX

316256 [ do cmd <- chompCommand

317− spaces_em

318− oneOf E.Effect

319− [ do word1 0x7D {-}-} E.Effect

320− spaces_em

257+ spaces

258+ oneOf E.XXX

259+ [ do word1 0x7D {-}-} E.XXX

260+ spaces

321261 return (Src.Cmd cmd)

322− , do word1 0x2C {-,-} E.Effect

323− spaces_em

262+ , do word1 0x2C {-,-} E.XXX

263+ spaces

324264 sub <- chompSubscription

325− spaces_em

326− word1 0x7D {-}-} E.Effect

327− spaces_em

265+ spaces

266+ word1 0x7D {-}-} E.XXX

267+ spaces

328268 return (Src.Fx cmd sub)

329269 ]

330270 , do sub <- chompSubscription

331− spaces_em

332− oneOf E.Effect

333− [ do word1 0x7D {-}-} E.Effect

334− spaces_em

271+ spaces

272+ oneOf E.XXX

273+ [ do word1 0x7D {-}-} E.XXX

274+ spaces

335275 return (Src.Sub sub)

336− , do word1 0x2C {-,-} E.Effect

337− spaces_em

276+ , do word1 0x2C {-,-} E.XXX

277+ spaces

338278 cmd <- chompCommand

339− spaces_em

340− word1 0x7D {-}-} E.Effect

341− spaces_em

279+ spaces

280+ word1 0x7D {-}-} E.XXX

281+ spaces

342282 return (Src.Fx cmd sub)

343283 ]

344284 ]

345285

346286

347−chompCommand :: Parser E.Module (A.Located Name.Name)

287+chompCommand :: Parser (A.Located Name.Name)

348288chompCommand =

349− do Keyword.command_ E.Effect

350− spaces_em

351− word1 0x3D {-=-} E.Effect

352− spaces_em

353− addLocation (Var.upper E.Effect)

289+ do Keyword.command_

290+ spaces

291+ word1 0x3D {-=-} E.XXX

292+ spaces

293+ addLocation Var.upper

354294

355295

356−chompSubscription :: Parser E.Module (A.Located Name.Name)

296+chompSubscription :: Parser (A.Located Name.Name)

357297chompSubscription =

358− do Keyword.subscription_ E.Effect

359− spaces_em

360− word1 0x3D {-=-} E.Effect

361− spaces_em

362− addLocation (Var.upper E.Effect)

363−

364−

365−spaces_em :: Parser E.Module ()

366−spaces_em =

367− Space.chompAndCheckIndent E.ModuleSpace E.Effect

298+ do Keyword.subscription_

299+ spaces

300+ word1 0x3D {-=-} E.XXX

301+ spaces

302+ addLocation Var.upper

368303

369304

370305

371306-- IMPORTS

372307

373308

374−chompImports :: [Src.Import] -> Parser E.Module [Src.Import]

375−chompImports is =

376− oneOfWithFallback

377− [ do i <- chompImport

378− chompImports (i:is)

309+chompImports :: [Src.Import] -> Parser [Src.Import]

310+chompImports imports =

311+ oneOf E.XXX

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

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)

379330 ]

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

398331

399332

400−chompAs :: A.Located Name.Name -> Parser E.Module Src.Import

401−chompAs name =

402− do Keyword.as_ E.ImportAs

403− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentAlias

404− alias <- Var.upper E.ImportAlias

405− end <- getPosition

406− Space.chomp E.ModuleSpace

407− oneOf E.ImportEnd

408− [ do Space.checkFreshLine E.ImportEnd

409− return $ Src.Import name (Just alias) (Src.Explicit [])

410− , do Space.checkIndent end E.ImportEnd

411− chompExposing name (Just alias)

333+chompAs :: A.Located Name.Name -> [Src.Import] -> Parser [Src.Import]

334+chompAs name imports =

335+ do Keyword.as_

336+ spaces

337+ alias <- Var.upper

338+ pos <- whitespace

339+ oneOf E.XXX

340+ [ do checkFreshLine pos

341+ popContext ()

342+ chompImports $

343+ Src.Import name (Just alias) (Src.Explicit []) : imports

344+ , do checkSpace pos

345+ chompExposing name (Just alias) imports

412346 ]

413347

414348

415−chompExposing :: A.Located Name.Name -> Maybe Name.Name -> Parser E.Module Src.Import

416−chompExposing name maybeAlias =

417− do Keyword.exposing_ E.ImportExposing

418− Space.chompAndCheckIndent E.ModuleSpace E.ImportIndentExposingList

419− exposed <- specialize E.ImportExposingList exposing

420− freshLine E.ImportEnd

421− return $ Src.Import name maybeAlias exposed

349+chompExposing :: A.Located Name.Name -> Maybe Name.Name -> [Src.Import] -> Parser [Src.Import]

350+chompExposing name maybeAlias imports =

351+ do Keyword.exposing_

352+ spaces

353+ exposed <- exposing

354+ freshLine

355+ popContext ()

356+ chompImports $

357+ Src.Import name maybeAlias exposed : imports

422358

423359

424360

425361-- LISTING

426362

427363

428−exposing :: Parser E.Exposing Src.Exposing

364+exposing :: Parser Src.Exposing

429365exposing =

430− do word1 0x28 {-(-} E.ExposingStart

431− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue

432− oneOf E.ExposingValue

433− [ do word2 0x2E 0x2E {-..-} E.ExposingValue

434− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

435− word1 0x29 {-)-} E.ExposingEnd

366+ do word1 0x28 {-(-} E.XXX

367+ spaces

368+ oneOf E.XXX

369+ [ do word2 0x2E 0x2E {-..-} E.XXX

370+ spaces

371+ word1 0x29 {-)-} E.XXX

436372 return Src.Open

437− , do exposed <- chompExposed

438− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

439− exposingHelp [exposed]

373+ , do entry <- addLocation chompEntry

374+ spaces

375+ exposingHelp [entry]

440376 ]

441377

442378

443−exposingHelp :: [Src.Exposed] -> Parser E.Exposing Src.Exposing

444−exposingHelp revExposed =

445− oneOf E.ExposingEnd

446− [ do word1 0x2C {-,-} E.ExposingEnd

447− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentValue

448− exposed <- chompExposed

449− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

450− exposingHelp (exposed:revExposed)

451− , do word1 0x29 {-)-} E.ExposingEnd

452− return (Src.Explicit (reverse revExposed))

379+exposingHelp :: [A.Located Src.Exposed] -> Parser Src.Exposing

380+exposingHelp revEntries =

381+ oneOf E.XXX

382+ [ do word1 0x2C {-,-} E.XXX

383+ spaces

384+ entry <- addLocation chompEntry

385+ spaces

386+ exposingHelp (entry:revEntries)

387+ , do word1 0x29 {-)-} E.XXX

388+ return (Src.Explicit (reverse revEntries))

453389 ]

454390

455391

456−chompExposed :: Parser E.Exposing Src.Exposed

457−chompExposed =

458− do start <- getPosition

459− oneOf E.ExposingValue

460− [ do name <- Var.lower E.ExposingValue

461− end <- getPosition

462− return $ Src.Lower $ A.at start end name

463− , do word1 0x28 {-(-} E.ExposingValue

464− op <- Symbol.operator E.ExposingOperator E.ExposingOperatorReserved

465− word1 0x29 {-)-} E.ExposingOperatorRightParen

466− end <- getPosition

467− return $ Src.Operator (A.Region start end) op

468− , do name <- Var.upper E.ExposingValue

469− end <- getPosition

470− Space.chompAndCheckIndent E.ExposingSpace E.ExposingIndentEnd

471− Src.Upper (A.at start end name) <$> privacy

472− ]

392+chompEntry :: Parser Src.Exposed

393+chompEntry =

394+ oneOf E.XXX

395+ [ Src.Lower <$> Var.lower

396+ , do word1 0x28 {-(-} E.XXX

397+ op <- Symbol.binop

398+ word1 0x29 {-)-} E.XXX

399+ return (Src.Operator op)

400+ , do name <- Var.upper

401+ spaces

402+ Src.Upper name <$> privacy

403+ ]

473404

474405

475−privacy :: Parser E.Exposing Src.Privacy

406+privacy :: Parser Src.Privacy

476407privacy =

477− oneOfWithFallback

478− [ do word1 0x28 {-(-} E.ExposingTypePrivacy

479− Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy

480− start <- getPosition

481− word2 0x2E 0x2E {-..-} E.ExposingTypePrivacy

482− end <- getPosition

483− Space.chompAndCheckIndent E.ExposingSpace E.ExposingTypePrivacy

484− word1 0x29 {-)-} E.ExposingTypePrivacy

485− return $ Src.Public (A.Region start end)

408+ oneOf E.XXX

409+ [ do word1 0x28 {-(-} E.XXX

410+ spaces

411+ word2 0x2E 0x2E {-..-} E.XXX

412+ spaces

413+ word1 0x29 {-)-} E.XXX

414+ return Src.Public

415+ , return Src.Private

486416 ]

487− Src.Private

compiler/src/Parse/Number.hs+34−37

@@ -11,12 +11,12 @@ module Parse.Number

1111 where

1212

1313

14+import qualified Data.Utf8 as Utf8

1415import Data.Word (Word8)

1516import Foreign.Ptr (Ptr, plusPtr, minusPtr)

1617

1718import 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)

2020import qualified Parse.Variable as Var

2121import qualified Parse.Primitives as P

2222import qualified Reporting.Error.Syntax as E

@@ -43,19 +43,19 @@ isDecimalDigit word =

4343

4444data Number

4545 = Int Int

46− | Float EF.Float

46+ | Float (Utf8.Under256 Float)

4747

4848

49−number :: (Row -> Col -> x) -> (E.Number -> Row -> Col -> x) -> Parser x Number

50−number toExpectation toError =

51− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

49+number :: Parser Number

50+number =

51+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

5252 if pos >= end then

53− eerr row col toExpectation

53+ eerr row col ctx E.Number_Start

5454

5555 else

5656 let !word = P.unsafeIndex pos in

5757 if not (isDecimalDigit word) then

58− eerr row col toExpectation

58+ eerr row col ctx E.Number_Start

5959

6060 else

6161 let

@@ -70,22 +70,22 @@ number toExpectation toError =

7070 let

7171 !newCol = col + fromIntegral (minusPtr newPos pos)

7272 in

73− cerr row newCol (toError problem)

73+ cerr row newCol ctx problem

7474

7575 OkInt newPos n ->

7676 let

7777 !newCol = col + fromIntegral (minusPtr newPos pos)

7878 !integer = Int n

79− !newState = P.State src newPos end indent row newCol

79+ !newState = P.State newPos end indent row newCol ctx

8080 in

8181 cok integer newState

8282

8383 OkFloat newPos ->

8484 let

8585 !newCol = col + fromIntegral (minusPtr newPos pos)

86− !copy = EF.fromPtr pos newPos

86+ !copy = Utf8.fromPtr pos newPos

8787 !float = Float copy

88− !newState = P.State src newPos end indent row newCol

88+ !newState = P.State newPos end indent row newCol ctx

8989 in

9090 cok float newState

9191

@@ -97,7 +97,7 @@ number toExpectation toError =

9797-- first Int is newPos

9898--

9999data Outcome

100− = Err (Ptr Word8) E.Number

100+ = Err (Ptr Word8) E.Expectation

101101 | OkInt (Ptr Word8) Int

102102 | OkFloat (Ptr Word8)

103103

@@ -121,13 +121,13 @@ chompInt !pos end !n =

121121 chompInt (plusPtr pos 1) end (10 * n + fromIntegral (word - 0x30 {-0-}))

122122

123123 else if word == 0x2E {-.-} then

124− chompFraction pos end n

124+ chompFraction (plusPtr pos 1) end n

125125

126126 else if word == 0x65 {-e-} || word == 0x45 {-E-} then

127127 chompExponent (plusPtr pos 1) end

128128

129129 else if isDirtyEnd pos end word then

130− Err pos E.NumberEnd

130+ Err pos E.Number_End

131131

132132 else

133133 OkInt pos n

@@ -139,17 +139,14 @@ chompInt !pos end !n =

139139

140140chompFraction :: Ptr Word8 -> Ptr Word8 -> Int -> Outcome

141141chompFraction pos end n =

142− let

143− !pos1 = plusPtr pos 1

144− in

145− if pos1 >= end then

146− Err pos (E.NumberDot n)

142+ if pos >= end then

143+ Err pos (E.Number_Dot n)

147144

148− else if isDecimalDigit (P.unsafeIndex pos1) then

149− chompFractionHelp (plusPtr pos1 1) end

145+ else if isDecimalDigit (P.unsafeIndex pos) then

146+ chompFractionHelp (plusPtr pos 1) end

150147

151148 else

152− Err pos (E.NumberDot n)

149+ Err pos (E.Number_Dot n)

153150

154151

155152chompFractionHelp :: Ptr Word8 -> Ptr Word8 -> Outcome

@@ -166,7 +163,7 @@ chompFractionHelp pos end =

166163 chompExponent (plusPtr pos 1) end

167164

168165 else if isDirtyEnd pos end word then

169− Err pos E.NumberEnd

166+ Err pos E.Number_End

170167

171168 else

172169 OkFloat pos

@@ -179,7 +176,7 @@ chompFractionHelp pos end =

179176chompExponent :: Ptr Word8 -> Ptr Word8 -> Outcome

180177chompExponent pos end =

181178 if pos >= end then

182− Err pos E.NumberEnd

179+ Err pos E.Number_End

183180

184181 else

185182 let !word = P.unsafeIndex pos in

@@ -192,10 +189,10 @@ chompExponent pos end =

192189 if pos1 < end && isDecimalDigit (P.unsafeIndex pos1) then

193190 chompExponentHelp (plusPtr pos 2) end

194191 else

195− Err pos E.NumberEnd

192+ Err pos E.Number_End

196193

197194 else

198− Err pos E.NumberEnd

195+ Err pos E.Number_End

199196

200197

201198chompExponentHelp :: Ptr Word8 -> Ptr Word8 -> Outcome

@@ -225,13 +222,13 @@ chompZero pos end =

225222 chompHexInt (plusPtr pos 1) end

226223

227224 else if word == 0x2E {-.-} then

228− chompFraction pos end 0

225+ chompFraction (plusPtr pos 1) end 0

229226

230227 else if isDecimalDigit word then

231− Err pos E.NumberNoLeadingZero

228+ Err pos E.Number_NoLeadingZero

232229

233230 else if isDirtyEnd pos end word then

234− Err pos E.NumberEnd

231+ Err pos E.Number_End

235232

236233 else

237234 OkInt pos 0

@@ -241,7 +238,7 @@ chompHexInt :: Ptr Word8 -> Ptr Word8 -> Outcome

241238chompHexInt pos end =

242239 let (# newPos, answer #) = chompHex pos end in

243240 if answer < 0 then

244− Err newPos E.NumberHexDigit

241+ Err newPos E.Number_HexDigit

245242 else

246243 OkInt newPos answer

247244

@@ -288,18 +285,18 @@ stepHex pos end word acc

288285-- PRECEDENCE

289286

290287

291−precedence :: (Row -> Col -> x) -> Parser x Binop.Precedence

292−precedence toExpectation =

293− P.Parser $ \(P.State src pos end indent row col) cok _ _ eerr ->

288+precedence :: Parser Binop.Precedence

289+precedence =

290+ P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->

294291 if pos >= end then

295− eerr row col toExpectation

292+ eerr row col ctx E.Precedence

296293

297294 else

298295 let !word = P.unsafeIndex pos in

299296 if isDecimalDigit word then

300297 cok

301298 (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)

303300

304301 else

305− eerr row col toExpectation

302+ eerr row col ctx E.Precedence

compiler/src/Parse/Pattern.hs+130−138

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

11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

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

2+{-# LANGUAGE OverloadedStrings #-}

33module Parse.Pattern

44 ( term

55 , expression

@@ -9,17 +9,16 @@ module Parse.Pattern

99

1010import qualified Data.List as List

1111import qualified Data.Name as Name

12−import qualified Data.Utf8 as Utf8

13−import Foreign.Ptr (plusPtr)

1412

1513import qualified AST.Source as Src

14+import Parse.Utils (Parser, SParser, SPos, checkSpace, spaces, whitespace)

1615import qualified Parse.Keyword as Keyword

1716import qualified Parse.Number as Number

18−import qualified Parse.Space as Space

19−import qualified Parse.String as String

17+import qualified Parse.Symbol as Symbol

18+import qualified Parse.Utf8 as Utf8

2019import qualified Parse.Variable as Var

2120import 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)

2322import qualified Reporting.Annotation as A

2423import qualified Reporting.Error.Syntax as E

2524

@@ -28,10 +27,10 @@ import qualified Reporting.Error.Syntax as E

2827-- TERM

2928

3029

31−term :: Parser E.Pattern Src.Pattern

30+term :: Parser Src.Pattern

3231term =

3332 do start <- getPosition

34− oneOf E.PStart

33+ oneOf E.XXX

3534 [ record start

3635 , tuple start

3736 , list start

@@ -39,17 +38,19 @@ term =

3938 ]

4039

4140

42−termHelp :: A.Position -> Parser E.Pattern Src.Pattern

41+termHelp :: A.Position -> Parser Src.Pattern

4342termHelp start =

44− oneOf E.PStart

43+ oneOf E.XXX

4544 [

46− do wildcard

47− addEnd start Src.PAnything

45+ do Symbol.underscore

46+ end <- getPosition

47+ return (A.at start end Src.PAnything)

4848 ,

49− do name <- Var.lower E.PStart

50− addEnd start (Src.PVar name)

49+ do name <- Var.lower

50+ end <- getPosition

51+ return (A.at start end (Src.PVar name))

5152 ,

52− do upper <- Var.foreignUpper E.PStart

53+ do upper <- Var.foreignUpper

5354 end <- getPosition

5455 let region = A.Region start end

5556 return $ A.at start end $

@@ -60,76 +61,60 @@ termHelp start =

6061 Var.Qualified home name ->

6162 Src.PCtorQual region home name []

6263 ,

63− do number <- Number.number E.PStart E.PNumber

64+ do number <- Number.number

6465 end <- getPosition

6566 case number of

6667 Number.Int int ->

6768 return (A.at start end (Src.PInt int))

6869

69− Number.Float float ->

70− P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->

71− let

72− width = fromIntegral (Utf8.size float)

73− in

74− cerr row (col - width) (E.PFloat width)

70+ Number.Float _ ->

71+ noFloatsAllowedInPatterns

7572 ,

76− do str <- String.string E.PStart E.PString

77− addEnd start (Src.PStr str)

73+ do str <- Utf8.string

74+ end <- getPosition

75+ return (A.at start end (Src.PStr str))

7876 ,

79− do chr <- String.character E.PStart E.PChar

80− addEnd start (Src.PChr chr)

77+ do chr <- Utf8.character

78+ end <- getPosition

79+ return (A.at start end (Src.PChr chr))

8180 ]

8281

8382

84−

85−-- WILDCARD

86−

87−

88−wildcard :: Parser E.Pattern ()

89−wildcard =

90− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

91− if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then

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

83+noFloatsAllowedInPatterns :: Parser a

84+noFloatsAllowedInPatterns =

85+ P.Parser $ \(P.State _ _ _ row col ctx) _ _ cerr _ ->

86+ cerr row col ctx E.FloatInPattern

10487

10588

10689

10790-- RECORDS

10891

10992

110−record :: A.Position -> Parser E.Pattern Src.Pattern

93+record :: A.Position -> Parser Src.Pattern

11194record start =

112− inContext E.PRecord (word1 0x7B {- { -} E.PStart) $

113− do Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen

114− oneOf E.PRecordOpen

115− [ do var <- addLocation (Var.lower E.PRecordField)

116− Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd

95+ inContext E.ExprRecord (word1 0x7B {- { -} E.XXX) $

96+ do spaces

97+ oneOf E.XXX

98+ [ do var <- addLocation Var.lower

99+ spaces

117100 recordHelp start [var]

118− , do word1 0x7D {-}-} E.PRecordEnd

119− addEnd start (Src.PRecord [])

101+ , do word1 0x7D {-}-} E.XXX

102+ end <- getPosition

103+ return (A.at start end (Src.PRecord []))

120104 ]

121105

122106

123−recordHelp :: A.Position -> [A.Located Name.Name] -> Parser E.PRecord Src.Pattern

107+recordHelp :: A.Position -> [A.Located Name.Name] -> Parser Src.Pattern

124108recordHelp start vars =

125− oneOf E.PRecordEnd

126− [ do word1 0x2C {-,-} E.PRecordEnd

127− Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField

128− var <- addLocation (Var.lower E.PRecordField)

129− Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd

109+ oneOf E.XXX

110+ [ do word1 0x2C {-,-} E.XXX

111+ spaces

112+ var <- addLocation Var.lower

113+ spaces

130114 recordHelp start (var:vars)

131− , do word1 0x7D {-}-} E.PRecordEnd

132− addEnd start (Src.PRecord (reverse vars))

115+ , do word1 0x7D {-}-} E.XXX

116+ end <- getPosition

117+ return (A.at start end (Src.PRecord vars))

133118 ]

134119

135120

@@ -137,34 +122,36 @@ recordHelp start vars =

137122-- TUPLES

138123

139124

140−tuple :: A.Position -> Parser E.Pattern Src.Pattern

125+tuple :: A.Position -> Parser Src.Pattern

141126tuple start =

142− inContext E.PTuple (word1 0x28 {-(-} E.PStart) $

143− do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1

144− oneOf E.PTupleOpen

145− [ do (pattern, end) <- P.specialize E.PTupleExpr expression

146− Space.checkIndent end E.PTupleIndentEnd

127+ inContext E.ExprTuple (word1 0x28 {-(-} E.XXX) $

128+ do spaces

129+ oneOf E.XXX

130+ [ do (pattern, sPos) <- expression

131+ checkSpace sPos

147132 tupleHelp start pattern []

148− , do word1 0x29 {-)-} E.PTupleEnd

149− addEnd start Src.PUnit

133+ , do word1 0x29 {-)-} E.XXX

134+ end <- getPosition

135+ return (A.at start end Src.PUnit)

150136 ]

151137

152138

153−tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.Pattern

139+tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser Src.Pattern

154140tupleHelp start firstPattern revPatterns =

155− oneOf E.PTupleEnd

156− [ do word1 0x2C {-,-} E.PTupleEnd

157− Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN

158− (pattern, end) <- P.specialize E.PTupleExpr expression

159− Space.checkIndent end E.PTupleIndentEnd

141+ oneOf E.XXX

142+ [ do word1 0x2C {-,-} E.XXX

143+ spaces

144+ (pattern, sPos) <- expression

145+ checkSpace sPos

160146 tupleHelp start firstPattern (pattern : revPatterns)

161− , do word1 0x29 {-)-} E.PTupleEnd

147+ , do word1 0x29 {-)-} E.XXX

162148 case reverse revPatterns of

163149 [] ->

164150 return firstPattern

165151

166152 secondPattern : otherPatterns ->

167− addEnd start (Src.PTuple firstPattern secondPattern otherPatterns)

153+ do end <- getPosition

154+ return (A.at start end (Src.PTuple firstPattern secondPattern otherPatterns))

168155 ]

169156

170157

@@ -172,29 +159,31 @@ tupleHelp start firstPattern revPatterns =

172159-- LIST

173160

174161

175−list :: A.Position -> Parser E.Pattern Src.Pattern

162+list :: A.Position -> Parser Src.Pattern

176163list start =

177− inContext E.PList (word1 0x5B {-[-} E.PStart) $

178− do Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen

179− oneOf E.PListOpen

180− [ do (pattern, end) <- P.specialize E.PListExpr expression

181− Space.checkIndent end E.PListIndentEnd

164+ inContext E.PatternList (word1 0x5B {-[-} E.XXX) $

165+ do spaces

166+ oneOf E.XXX

167+ [ do (pattern, sPos) <- expression

168+ checkSpace sPos

182169 listHelp start [pattern]

183− , do word1 0x5D {-]-} E.PListEnd

184− addEnd start (Src.PList [])

170+ , do word1 0x5D {-]-} E.XXX

171+ end <- getPosition

172+ return (A.at start end (Src.PList []))

185173 ]

186174

187175

188−listHelp :: A.Position -> [Src.Pattern] -> Parser E.PList Src.Pattern

176+listHelp :: A.Position -> [Src.Pattern] -> Parser Src.Pattern

189177listHelp start patterns =

190− oneOf E.PListEnd

191− [ do word1 0x2C {-,-} E.PListEnd

192− Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr

193− (pattern, end) <- P.specialize E.PListExpr expression

194− Space.checkIndent end E.PListIndentEnd

178+ oneOf E.XXX

179+ [ do word1 0x2C {-,-} E.XXX

180+ spaces

181+ (pattern, sPos) <- expression

182+ checkSpace sPos

195183 listHelp start (pattern:patterns)

196− , do word1 0x5D {-]-} E.PListEnd

197− addEnd start (Src.PList (reverse patterns))

184+ , do word1 0x5D {-]-} E.XXX

185+ end <- getPosition

186+ return (A.at start end (Src.PList (reverse patterns)))

198187 ]

199188

200189

@@ -202,37 +191,38 @@ listHelp start patterns =

202191-- EXPRESSION

203192

204193

205−expression :: Space.Parser E.Pattern Src.Pattern

194+expression :: Parser (Src.Pattern, SPos)

206195expression =

207196 do start <- getPosition

208− ePart <- exprPart

209− exprHelp start [] ePart

210−

211−

212−exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern

213−exprHelp start revPatterns (pattern, end) =

214− oneOfWithFallback

215− [ do Space.checkIndent end E.PIndentStart

216− word2 0x3A 0x3A {-::-} E.PStart

217− Space.chompAndCheckIndent E.PSpace E.PIndentStart

218− ePart <- exprPart

219− exprHelp start (pattern:revPatterns) ePart

220− , do Space.checkIndent end E.PIndentStart

221− Keyword.as_ E.PStart

222− Space.chompAndCheckIndent E.PSpace E.PIndentAlias

197+ cTerm <- exprTerm

198+ exprHelp start [] cTerm

199+

200+

201+exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position, SPos) -> Parser (Src.Pattern, SPos)

202+exprHelp start patterns (pattern, _end, sPos) =

203+ oneOf E.XXX

204+ [ do checkSpace sPos

205+ word1 0x3A {-:-} E.XXX

206+ spaces

207+ cTerm <- exprTerm

208+ exprHelp start (pattern:patterns) cTerm

209+ , do checkSpace sPos

210+ Keyword.as_

211+ spaces

223212 nameStart <- getPosition

224− name <- Var.lower E.PAlias

213+ name <- Var.lower

225214 newEnd <- getPosition

226− Space.chomp E.PSpace

215+ newSpace <- whitespace

227216 let alias = A.at nameStart newEnd name

228217 return

229− ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)

230− , newEnd

218+ ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern patterns) alias)

219+ , newSpace

231220 )

221+ , return

222+ ( List.foldl' cons pattern patterns

223+ , sPos

224+ )

232225 ]

233− ( List.foldl' cons pattern revPatterns

234− , end

235− )

236226

237227

238228cons :: Src.Pattern -> Src.Pattern -> Src.Pattern

@@ -241,39 +231,41 @@ cons tl hd =

241231

242232

243233

244−-- EXPRESSION PART

234+-- EXPRESSION TERM

245235

246236

247−exprPart :: Space.Parser E.Pattern Src.Pattern

248−exprPart =

249− oneOf E.PStart

237+exprTerm :: SParser Src.Pattern

238+exprTerm =

239+ oneOf E.XXX

250240 [

251241 do start <- getPosition

252− upper <- Var.foreignUpper E.PStart

242+ upper <- Var.foreignUpper

253243 end <- getPosition

254244 exprTermHelp (A.Region start end) upper start []

255245 ,

256− do eterm@(A.At (A.Region _ end) _) <- term

257− Space.chomp E.PSpace

258− return (eterm, end)

246+ do t@(A.At (A.Region _ end) _) <- term

247+ pos <- whitespace

248+ return (t, end, pos)

259249 ]

260250

261251

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

263253exprTermHelp region upper start revArgs =

264254 do end <- getPosition

265− Space.chomp E.PSpace

266− oneOfWithFallback

267− [ do Space.checkIndent end E.PIndentStart

255+ sPos <- whitespace

256+ oneOf E.XXX

257+ [ do checkSpace sPos

268258 arg <- term

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

270271 ]

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

11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-}

33module Parse.Primitives

4− ( fromByteString

4+ ( Result(..)

5+ , fromByteString

56 , Parser(..)

67 , State(..)

7− , Row

8− , Col

9− , oneOf, oneOfWithFallback

10− , inContext, specialize

11− , getPosition, getCol, addLocation, addEnd

12− , getIndent, setIndent, withIndent, withBacksetIndent

8+ , Context(..)

9+ , oneOf

10+ , pushContext, popContext, inContext

11+ , getPosition, getCol, addLocation

12+ , getIndent, setIndent

1313 , word1, word2

1414 , unsafeIndex, isWord, getCharWidth

15− , Snippet(..)

16− , fromSnippet

1715 )

1816 where

1917

2018

2119import Prelude hiding (length)

2220import qualified Control.Applicative as Applicative (Applicative(..))

21+import Control.Monad

2322import qualified Data.ByteString.Internal as B

2423import Data.Word (Word8, Word16)

2524import Foreign.Ptr (Ptr, plusPtr)

2625import Foreign.Storable (peek)

27−import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)

28−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

26+import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr)

2927

3028import qualified Reporting.Annotation as A

3129

@@ -34,38 +32,39 @@ import qualified Reporting.Annotation as A

3432-- PARSER

3533

3634

37−newtype Parser x a =

35+newtype Parser c x a =

3836 Parser (

3937 forall b.

40− State

41− -> (a -> State -> b) -- consumed ok

42− -> (a -> State -> b) -- empty ok

43− -> (Row -> Col -> (Row -> Col -> x) -> b) -- consumed err

44− -> (Row -> Col -> (Row -> Col -> x) -> b) -- empty err

38+ State c

39+ -> (a -> State c -> b) -- consumed ok

40+ -> (a -> State c -> b) -- empty ok

41+ -> (Word16 -> Word16 -> Context c -> x -> b) -- consumed err

42+ -> (Word16 -> Word16 -> Context c -> x -> b) -- empty err

4543 -> b

4644 )

4745

4846

49−data State = -- PERF try taking some out to avoid allocation

47+data State c =

5048 State

51− { _src :: ForeignPtr Word8

52− , _pos :: !(Ptr Word8)

49+ { _pos :: !(Ptr Word8)

5350 , _end :: !(Ptr Word8)

5451 , _indent :: !Word16

55− , _row :: !Row

56− , _col :: !Col

52+ , _row :: !Word16

53+ , _col :: !Word16

54+ , _context :: Context c

5755 }

5856

5957

60−type Row = Word16

61−type Col = Word16

58+data Context c

59+ = NoContext

60+ | Frame {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16 c (Context c)

6261

6362

6463

6564-- FUNCTOR

6665

6766

68−instance Functor (Parser x) where

67+instance Functor (Parser c x) where

6968 {-# INLINE fmap #-}

7069 fmap f (Parser parser) =

7170 Parser $ \state cok eok cerr eerr ->

@@ -80,28 +79,12 @@ instance Functor (Parser x) where

8079-- APPLICATIVE

8180

8281

83−instance Applicative.Applicative (Parser x) where

82+instance Applicative.Applicative (Parser c x) where

8483 {-# INLINE pure #-}

8584 pure = return

8685

8786 {-# INLINE (<*>) #-}

88− (<*>) (Parser parserFunc) (Parser parserArg) =

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

87+ (<*>) = ap

10588

10689

10790

@@ -109,74 +92,42 @@ instance Applicative.Applicative (Parser x) where

10992

11093

11194{-# INLINE oneOf #-}

112−oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a

113−oneOf toError parsers =

95+oneOf :: x -> [Parser c x a] -> Parser c x a

96+oneOf x parsers =

11497 Parser $ \state cok eok cerr eerr ->

115− oneOfHelp state cok eok cerr eerr toError parsers

98+ oneOfHelp state cok eok cerr eerr x parsers

11699

117100

118101oneOfHelp

119− :: State

120− -> (a -> State -> b)

121− -> (a -> State -> b)

122− -> (Row -> Col -> (Row -> Col -> x) -> b)

123− -> (Row -> Col -> (Row -> Col -> x) -> b)

124− -> (Row -> Col -> x)

125− -> [Parser x a]

102+ :: State c

103+ -> (a -> State c -> b)

104+ -> (a -> State c -> b)

105+ -> (Word16 -> Word16 -> Context c -> x -> b)

106+ -> (Word16 -> Word16 -> Context c -> x -> b)

107+ -> x

108+ -> [Parser c x a]

126109 -> b

127−oneOfHelp state cok eok cerr eerr toError parsers =

110+oneOfHelp state cok eok cerr eerr x parsers =

128111 case parsers of

129112 Parser parser : parsers ->

130113 let

131− eerr' _ _ _ =

132− oneOfHelp state cok eok cerr eerr toError parsers

114+ eerr' _ _ _ _ =

115+ oneOfHelp state cok eok cerr eerr x parsers

133116 in

134117 parser state cok eok cerr eerr'

135118

136119 [] ->

137120 let

138− (State _ _ _ _ row col) = state

121+ (State _ _ _ row col ctx) = state

139122 in

140− eerr row col toError

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'

123+ eerr row col ctx x

173124

174125

175126

176127-- MONAD

177128

178129

179−instance Monad (Parser x) where

130+instance Monad (Parser c x) where

180131 {-# INLINE return #-}

181132 return value =

182133 Parser $ \state _ eok _ _ ->

@@ -201,55 +152,20 @@ instance Monad (Parser x) where

201152-- FROM BYTESTRING

202153

203154

204−fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a

205−fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) =

206− B.accursedUnutterablePerformIO $

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−

155+data Result c x a

156+ = Ok !a (State c)

157+ | Err Word16 Word16 (Context c) x

229158

230−-- FROM SNIPPET

231159

232−

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

160+fromByteString :: Parser c x a -> B.ByteString -> Result c x a

161+fromByteString (Parser parser) (B.PS fp offset length) =

245162 B.accursedUnutterablePerformIO $

246163 let

247− toOk' = toOk toBadEnd

248− !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset

164+ !pos = plusPtr (unsafeForeignPtrToPtr fp) offset

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

251167 in

252− do touchForeignPtr fptr

168+ do touchForeignPtr fp

253169 return result

254170

255171

@@ -257,126 +173,127 @@ fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =

257173-- POSITION

258174

259175

260−getCol :: Parser x Word16

176+getCol :: Parser c x Word16

261177getCol =

262− Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ ->

178+ Parser $ \state@(State _ _ _ _ col _) _ eok _ _ ->

263179 eok col state

264180

265181

266182{-# INLINE getPosition #-}

267−getPosition :: Parser x A.Position

183+getPosition :: Parser c x A.Position

268184getPosition =

269− Parser $ \state@(State _ _ _ _ row col) _ eok _ _ ->

185+ Parser $ \state@(State _ _ _ row col _) _ eok _ _ ->

270186 eok (A.Position row col) state

271187

272188

273−addLocation :: Parser x a -> Parser x (A.Located a)

189+addLocation :: Parser c x a -> Parser c x (A.Located a)

274190addLocation (Parser parser) =

275− Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr ->

191+ Parser $ \state@(State _ _ _ srow scol _) cok eok cerr eerr ->

276192 let

277− cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s

278− eok' a s@(State _ _ _ _ er ec) = eok (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

194+ eok' a s@(State _ _ _ erow ecol _) = eok (A.At (A.Region (A.Position srow scol) (A.Position erow ecol)) a) s

279195 in

280196 parser state cok' eok' cerr eerr

281197

282198

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−

289199

290200-- INDENT

291201

292202

293−getIndent :: Parser x Word16

203+getIndent :: Parser c x Word16

294204getIndent =

295− Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ ->

205+ Parser $ \state@(State _ _ indent _ _ _) _ eok _ _ ->

296206 eok indent state

297207

298208

299−setIndent :: Word16 -> Parser x ()

209+setIndent :: Word16 -> Parser c x ()

300210setIndent indent =

301− Parser $ \(State src pos end _ row col) _ eok _ _ ->

211+ Parser $ \(State pos end _ row col context) _ eok _ _ ->

302212 let

303− !newState = State src pos end indent row col

213+ !newState =

214+ State pos end indent row col context

304215 in

305216 eok () newState

306217

307218

308−withIndent :: Parser x a -> Parser x a

309−withIndent (Parser parser) =

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

219+

220+-- CONTEXT

316221

317222

318−withBacksetIndent :: Word16 -> Parser x a -> Parser x a

319−withBacksetIndent backset (Parser parser) =

320− Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr ->

223+pushContext :: A.Position -> c -> Parser c x ()

224+pushContext (A.Position r c) ctx =

225+ Parser $ \(State pos end indent row col context) _ eok _ _ ->

321226 let

322− cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c)

323− eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c)

227+ !newContext = Frame r c ctx context

228+ !newState = State pos end indent row col newContext

324229 in

325− parser (State src pos end (col - backset) row col) cok' eok' cerr eerr

230+ eok () newState

326231

327232

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

328243

329−-- CONTEXT

244+ NoContext ->

245+ error "compiler error, trying to popContext on NoContext"

330246

331247

332−inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a

333−inContext addContext (Parser parserStart) (Parser parserA) =

334− Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr ->

248+inContext :: c -> Parser c x start -> Parser c x a -> Parser c x a

249+inContext tag (Parser parserStart) (Parser parserA) =

250+ Parser $ \state@(State _ _ _ frow fcol _) cok eok cerr eerr ->

335251 let

336− cerrA r c tx = cerr row col (addContext (tx r c))

337− eerrA r c tx = eerr row col (addContext (tx r c))

338−

339− cokS _ s = parserA s cok cok cerrA cerrA

340− eokS _ s = parserA s cok eok cerrA eerrA

252+ cokS _ (State pos end indent row col ctx) =

253+ let

254+ !newContext = Frame frow fcol tag ctx

255+ !newState = State pos end indent row col newContext

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

341268 in

342269 parserStart state cokS eokS cerr eerr

343270

344271

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−

355272

356273-- SYMBOLS

357274

358275

359−word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()

360−word1 word toError =

361− Parser $ \(State src pos end indent row col) cok _ _ eerr ->

276+word1 :: Word8 -> x -> Parser c x ()

277+word1 word x =

278+ Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->

362279 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

364281 cok () newState

365282 else

366− eerr row col toError

283+ eerr row col ctx x

367284

368285

369−word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()

370−word2 w1 w2 toError =

371− Parser $ \(State src pos end indent row col) cok _ _ eerr ->

286+word2 :: Word8 -> Word8 -> x -> Parser c x ()

287+word2 w1 w2 x =

288+ Parser $ \(State pos end indent row col ctx) cok _ _ eerr ->

372289 let

373290 !pos1 = plusPtr pos 1

374291 in

375292 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

377294 cok () newState

378295 else

379− eerr row col toError

296+ eerr row col ctx x

380297

381298

382299

@@ -394,8 +311,8 @@ isWord pos end word =

394311 pos < end && unsafeIndex pos == word

395312

396313

397−getCharWidth :: Word8 -> Int

398−getCharWidth word

314+getCharWidth :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int

315+getCharWidth _pos _end word

399316 | word < 0x80 = 1

400317 | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."

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

66 where

77

88

9−import qualified Data.ByteString.Internal as B

10−import qualified Data.ByteString.UTF8 as BS_UTF8

9+import qualified Data.List as List

1110import qualified Data.Map as Map

1211import qualified Data.Name as Name

13−import Data.Word (Word8)

12+import qualified Data.Utf8 as Utf8

13+import Data.Word (Word8, Word16)

1414import Foreign.Ptr (Ptr, plusPtr, minusPtr)

15−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

1615import qualified Language.GLSL.Parser as GLP

1716import qualified Language.GLSL.Syntax as GLS

1817import qualified Text.Parsec as Parsec

@@ -20,7 +19,7 @@ import qualified Text.Parsec.Error as Parsec

2019

2120import qualified AST.Source as Src

2221import qualified AST.Utils.Shader as Shader

23−import Parse.Primitives (Parser, Row, Col)

22+import Parse.Utils (Parser)

2423import qualified Parse.Primitives as P

2524import qualified Reporting.Annotation as A

2625import qualified Reporting.Error.Syntax as E

@@ -30,21 +29,22 @@ import qualified Reporting.Error.Syntax as E

3029-- SHADER

3130

3231

33−shader :: A.Position -> Parser E.Expr Src.Expr

32+shader :: A.Position -> Parser Src.Expr

3433shader start@(A.Position row col) =

3534 do block <- parseBlock

3635 shdr <- parseGlsl row col block

3736 end <- P.getPosition

38− return (A.at start end (Src.Shader (Shader.fromChars block) shdr))

37+ let src = List.intercalate "\\n" (lines block)

38+ return (A.at start end (Src.Shader (Utf8.fromChars src) shdr))

3939

4040

4141

4242-- BLOCK

4343

4444

45−parseBlock :: Parser E.Expr [Char]

45+parseBlock :: Parser String

4646parseBlock =

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

4848 let

4949 !pos6 = plusPtr pos 6

5050 in

@@ -58,23 +58,22 @@ parseBlock =

5858 then

5959 let

6060 (# status, newPos, newRow, newCol #) =

61− eatShader pos6 end row (col + 6)

61+ eatShader pos6 end row col

6262 in

6363 case status of

6464 Good ->

6565 let

66− !off = minusPtr pos6 (unsafeForeignPtrToPtr src)

67− !len = minusPtr newPos pos6

68− !block = BS_UTF8.toString (B.PS src off len)

69− !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)

66+ !size = minusPtr newPos pos

67+ !block = error "TODO get a GLSL block" size

68+ !newState = P.State (plusPtr newPos 2) end indent newRow newCol ctx

7069 in

7170 cok block newState

7271

7372 Unending ->

74− cerr row col E.EndlessShader

73+ cerr row col ctx (E.ShaderEnd col (col + 6))

7574

7675 else

77− eerr row col E.Start

76+ eerr row col ctx E.ShaderStart

7877

7978

8079data Status

@@ -82,7 +81,7 @@ data Status

8281 | Unending

8382

8483

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

8685eatShader pos end row col =

8786 if pos >= end then

8887 (# Unending, pos, row, col #)

@@ -90,13 +89,13 @@ eatShader pos end row col =

9089 else

9190 let !word = P.unsafeIndex pos in

9291 if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then

93− (# Good, pos, row, col #)

92+ (# Good, pos, row, col + 2 #)

9493

9594 else if word == 0x0A {- \n -} then

9695 eatShader (plusPtr pos 1) end (row + 1) 1

9796

9897 else

99− let !newPos = plusPtr pos (P.getCharWidth word) in

98+ let !newPos = plusPtr pos (P.getCharWidth pos end word) in

10099 eatShader newPos end row (col + 1)

101100

102101

@@ -104,7 +103,7 @@ eatShader pos end row col =

104103-- GLSL

105104

106105

107−parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types

106+parseGlsl :: Word16 -> Word16 -> String -> Parser Shader.Types

108107parseGlsl startRow startCol src =

109108 case GLP.parse src of

110109 Right (GLS.TranslationUnit decls) ->

@@ -129,10 +128,10 @@ parseGlsl startRow startCol src =

129128 else failure (startRow + row - 1) col msg

130129

131130

132−failure :: Row -> Col -> [Char] -> Parser E.Expr a

131+failure :: Word16 -> Word16 -> String -> Parser a

133132failure row col msg =

134− P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->

135− cerr row col (E.ShaderProblem msg)

133+ P.Parser $ \(P.State _ _ _ _ _ ctx) _ _ cerr _ ->

134+ cerr row col ctx (E.ShaderProblem msg)

136135

137136

138137

@@ -144,7 +143,7 @@ emptyTypes =

144143 Shader.Types Map.empty Map.empty Map.empty

145144

146145

147−addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types

146+addInput :: (GLS.StorageQualifier, Shader.Type, String) -> Shader.Types -> Shader.Types

148147addInput (qual, tipe, name) glDecls =

149148 case qual of

150149 GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }

@@ -153,7 +152,7 @@ addInput (qual, tipe, name) glDecls =

153152 _ -> error "Should never happen due to `extractInputs` function"

154153

155154

156−extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]

155+extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, String)]

157156extractInputs decl =

158157 case decl of

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

11{-# OPTIONS_GHC -Wall #-}

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

2+{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}

33module Parse.Symbol

4− ( operator

5− , BadOperator(..)

6− , binopCharSet

4+ ( wildcard

5+ , binop

76 )

87 where

98

@@ -15,40 +14,56 @@ import qualified Data.Vector as Vector

1514import Foreign.Ptr (Ptr, plusPtr, minusPtr)

1615import GHC.Word (Word8)

1716

18−import Parse.Primitives (Parser, Row, Col)

17+import Parse.Utils

18+import qualified Parse.Variable as Var

1919import qualified Parse.Primitives as P

20+import qualified Reporting.Error.Syntax as E

2021

2122

2223

23−-- OPERATOR

24+-- UNDERSCORE

2425

2526

26−data BadOperator

27− = BadDot

28− | BadPipe

29− | BadArrow

30− | BadEquals

31− | BadHasType

27+wildcard :: Parser ()

28+wildcard =

29+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

30+ if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then

31+ eerr row col ctx E.Wildcard

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

3247

3348

34−operator :: (Row -> Col -> x) -> (BadOperator -> Row -> Col -> x) -> Parser x Name.Name

35−operator toExpectation toError =

36− P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

49+binop :: Parser Name.Name

50+binop =

51+ P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

3752 let !newPos = chompOps pos end in

3853 if pos == newPos then

39− eerr row col toExpectation

54+ eerr row col ctx E.XXX

4055

4156 else

4257 case Name.fromPtr pos newPos of

43− "." -> eerr row col (toError BadDot)

44− "|" -> cerr row col (toError BadPipe)

45− "->" -> cerr row col (toError BadArrow)

46− "=" -> cerr row col (toError BadEquals)

47− ":" -> cerr row col (toError BadHasType)

58+ "." -> cerr row col ctx (E.ReservedOperator E.Dot)

59+ "|" -> cerr row col ctx (E.ReservedOperator E.Pipe)

60+ "->" -> cerr row col ctx (E.ReservedOperator E.Arrow)

61+ "=" -> cerr row col ctx (E.ReservedOperator E.Equals)

62+ ":" -> cerr row col ctx (E.ReservedOperator E.HasType)

4863 op ->

4964 let

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

5267 in

5368 cok op newState

5469

compiler/src/Parse/Type.hs+103−101

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

22{-# LANGUAGE OverloadedStrings #-}

33module Parse.Type

44 ( expression

5− , variant

5+ , unionConstructor

66 )

77 where

88

@@ -10,8 +10,8 @@ module Parse.Type

1010import qualified Data.Name as Name

1111

1212import qualified AST.Source as Src

13−import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, specialize, oneOf, oneOfWithFallback, word1, word2)

14−import qualified Parse.Space as Space

13+import Parse.Primitives (addLocation, getPosition, inContext, oneOf, word1, word2)

14+import Parse.Utils (Parser, SParser, SPos, checkSpace, spaces, whitespace)

1515import qualified Parse.Variable as Var

1616import qualified Reporting.Annotation as A

1717import qualified Reporting.Error.Syntax as E

@@ -21,13 +21,13 @@ import qualified Reporting.Error.Syntax as E

2121-- TYPE TERMS

2222

2323

24−term :: Parser E.Type Src.Type

24+term :: Parser Src.Type

2525term =

2626 do start <- getPosition

27− oneOf E.TStart

27+ oneOf E.XXX

2828 [

2929 -- types with no arguments (Int, Float, etc.)

30− do upper <- Var.foreignUpper E.TStart

30+ do upper <- Var.foreignUpper

3131 end <- getPosition

3232 let region = A.Region start end

3333 return $ A.At region $

@@ -39,40 +39,45 @@ term =

3939 Src.TTypeQual region home name []

4040 ,

4141 -- type variables

42− do var <- Var.lower E.TStart

43− addEnd start (Src.TVar var)

42+ do var <- Var.lower

43+ end <- getPosition

44+ return (A.at start end (Src.TVar var))

4445 ,

4546 -- tuples

46− inContext E.TTuple (word1 0x28 {-(-} E.TStart) $

47− oneOf E.TTupleOpen

48− [ do word1 0x29 {-)-} E.TTupleOpen

49− addEnd start Src.TUnit

50− , do Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentType1

51− (tipe, end) <- specialize E.TTupleType expression

52− Space.checkIndent end E.TTupleIndentEnd

53− chompTupleEnd start tipe []

47+ inContext E.TypeTuple (word1 0x28 {-(-} E.XXX) $

48+ oneOf E.XXX

49+ [ do word1 0x29 {-)-} E.XXX

50+ end <- getPosition

51+ return (A.at start end Src.TUnit)

52+ , do spaces

53+ (tipe, _, pos) <- expression

54+ checkSpace pos

55+ tupleEnding start tipe []

5456 ]

5557 ,

5658 -- records

57− inContext E.TRecord (word1 0x7B {- { -} E.TStart) $

58− do Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentOpen

59− oneOf E.TRecordOpen

60− [ do word1 0x7D {-}-} E.TRecordEnd

61− addEnd start (Src.TRecord [] Nothing)

62− , do name <- addLocation (Var.lower E.TRecordField)

63− Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon

64− oneOf E.TRecordColon

65− [ do word1 0x7C {-|-} E.TRecordColon

66− Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField

67− field <- chompField

68− fields <- chompRecordEnd [field]

69− addEnd start (Src.TRecord fields (Just name))

70− , do word1 0x3A {-:-} E.TRecordColon

71− Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType

72− (tipe, end) <- specialize E.TRecordType expression

73− Space.checkIndent end E.TRecordIndentEnd

74− fields <- chompRecordEnd [(name, tipe)]

75− addEnd start (Src.TRecord fields Nothing)

59+ inContext E.TypeRecord (word1 0x7B {- { -} E.XXX) $

60+ do spaces

61+ oneOf E.XXX

62+ [ do word1 0x7D {-}-} E.XXX

63+ end <- getPosition

64+ return (A.at start end (Src.TRecord [] Nothing))

65+ , do var <- addLocation Var.lower

66+ spaces

67+ oneOf E.XXX

68+ [ do word1 0x7C {-|-} E.XXX

69+ spaces

70+ firstField <- field

71+ fields <- chompFields [firstField]

72+ end <- getPosition

73+ return (A.at start end (Src.TRecord fields (Just var)))

74+ , do word1 0x3A {-:-} E.XXX

75+ spaces

76+ (tipe, _, nextPos) <- expression

77+ checkSpace nextPos

78+ fields <- chompFields [(var, tipe)]

79+ end <- getPosition

80+ return (A.at start end (Src.TRecord fields Nothing))

7681 ]

7782 ]

7883 ]

@@ -82,40 +87,37 @@ term =

8287-- TYPE EXPRESSIONS

8388

8489

85−expression :: Space.Parser E.Type Src.Type

90+expression :: SParser Src.Type

8691expression =

8792 do start <- getPosition

88− term1@(tipe1, end1) <-

89− oneOf E.TStart

93+ (tipe1, end1, pos1) <-

94+ oneOf E.XXX

9095 [ app start

91− , do eterm <- term

92− end <- getPosition

93− Space.chomp E.TSpace

94− return (eterm, end)

96+ , (,,) <$> term <*> getPosition <*> whitespace

9597 ]

96− oneOfWithFallback

97− [ do Space.checkIndent end1 E.TIndentStart -- should never trigger

98− word2 0x2D 0x3E {-->-} E.TStart -- could just be another type instead

99− Space.chompAndCheckIndent E.TSpace E.TIndentStart

100− (tipe2, end2) <- expression

98+ oneOf E.XXX

99+ [ do checkSpace pos1

100+ word2 0x2D 0x3E {-->-} E.XXX

101+ spaces

102+ (tipe2, end2, pos2) <- expression

101103 let tipe = A.at start end2 (Src.TLambda tipe1 tipe2)

102− return ( tipe, end2 )

104+ return ( tipe, end2, pos2 )

105+ , return ( tipe1, end1, pos1 )

103106 ]

104− term1

105107

106108

107109

108110-- TYPE CONSTRUCTORS

109111

110112

111−app :: A.Position -> Space.Parser E.Type Src.Type

113+app :: A.Position -> SParser Src.Type

112114app start =

113− do upper <- Var.foreignUpper E.TStart

114− upperEnd <- getPosition

115− Space.chomp E.TSpace

116− (args, end) <- chompArgs [] upperEnd

115+ do upper <- Var.foreignUpper

116+ nameEnd <- getPosition

117+ namePos <- whitespace

118+ (args, end, pos) <- eatArgs [] nameEnd namePos

117119

118− let region = A.Region start upperEnd

120+ let region = A.Region start nameEnd

119121 let tipe =

120122 case upper of

121123 Var.Unqualified name ->

@@ -124,40 +126,52 @@ app start =

124126 Var.Qualified home name ->

125127 Src.TTypeQual region home name args

126128

127− return ( A.at start end tipe, end )

129+ return ( A.at start end tipe, end, pos )

130+

128131

132+unionConstructor :: SParser (A.Located Name.Name, [Src.Type])

133+unionConstructor =

134+ do start <- getPosition

135+ name <- Var.upper

136+ nameEnd <- getPosition

137+ namePos <- whitespace

138+ (args, end, pos) <- eatArgs [] nameEnd namePos

139+ return ( (A.at start nameEnd name, args), end, pos )

129140

130−chompArgs :: [Src.Type] -> A.Position -> Space.Parser E.Type [Src.Type]

131−chompArgs args end =

132− oneOfWithFallback

133− [ do Space.checkIndent end E.TIndentStart

141+

142+eatArgs :: [Src.Type] -> A.Position -> SPos -> SParser [Src.Type]

143+eatArgs args end pos =

144+ oneOf E.XXX

145+ [ do checkSpace pos

134146 arg <- term

135147 newEnd <- getPosition

136− Space.chomp E.TSpace

137− chompArgs (arg:args) newEnd

148+ newSpace <- whitespace

149+ eatArgs (arg:args) newEnd newSpace

150+ , return ( reverse args, end, pos )

138151 ]

139− (reverse args, end)

140152

141153

142154

143155-- TUPLES

144156

145157

146−chompTupleEnd :: A.Position -> Src.Type -> [Src.Type] -> Parser E.TTuple Src.Type

147−chompTupleEnd start firstType revTypes =

148− oneOf E.TTupleEnd

149− [ do word1 0x2C {-,-} E.TTupleEnd

150− Space.chompAndCheckIndent E.TTupleSpace E.TTupleIndentTypeN

151− (tipe, end) <- specialize E.TTupleType expression

152− Space.checkIndent end E.TTupleIndentEnd

153− chompTupleEnd start firstType (tipe : revTypes)

154− , do word1 0x29 {-)-} E.TTupleEnd

158+tupleEnding :: A.Position -> Src.Type -> [Src.Type] -> Parser Src.Type

159+tupleEnding start firstType revTypes =

160+ oneOf E.XXX

161+ [ do word1 0x2C {-,-} E.XXX

162+ spaces

163+ (tipe, _, pos) <- expression

164+ checkSpace pos

165+ tupleEnding start firstType (tipe : revTypes)

166+ , do word1 0x29 {-)-} E.XXX

167+ end <- getPosition

155168 case reverse revTypes of

156169 [] ->

157170 return firstType

158171

159172 secondType : otherTypes ->

160− addEnd start (Src.TTuple firstType secondType otherTypes)

173+ return $ A.at start end $

174+ Src.TTuple firstType secondType otherTypes

161175 ]

162176

163177

@@ -168,36 +182,24 @@ chompTupleEnd start firstType revTypes =

168182type Field = ( A.Located Name.Name, Src.Type )

169183

170184

171−chompRecordEnd :: [Field] -> Parser E.TRecord [Field]

172−chompRecordEnd fields =

173− oneOf E.TRecordEnd

174− [ do word1 0x2C {-,-} E.TRecordEnd

175− Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentField

176− field <- chompField

177− chompRecordEnd (field : fields)

178− , do word1 0x7D {-}-} E.TRecordEnd

185+chompFields :: [Field] -> Parser [Field]

186+chompFields fields =

187+ oneOf E.XXX

188+ [ do word1 0x2C {-,-} E.XXX

189+ spaces

190+ f <- field

191+ chompFields (f : fields)

192+ , do word1 0x7D {-}-} E.XXX

179193 return (reverse fields)

180194 ]

181195

182196

183−chompField :: Parser E.TRecord Field

184−chompField =

185− do name <- addLocation (Var.lower E.TRecordField)

186− Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentColon

187− word1 0x3A {-:-} E.TRecordColon

188− Space.chompAndCheckIndent E.TRecordSpace E.TRecordIndentType

189− (tipe, end) <- specialize E.TRecordType expression

190− Space.checkIndent end E.TRecordIndentEnd

197+field :: Parser Field

198+field =

199+ do name <- addLocation Var.lower

200+ spaces

201+ word1 0x3A {-:-} E.XXX

202+ spaces

203+ (tipe, _, endPos) <- expression

204+ checkSpace endPos

191205 return (name, tipe)

192−

193−

194−

195−-- VARIANT

196−

197−

198−variant :: Space.Parser E.CustomType (A.Located Name.Name, [Src.Type])

199−variant =

200− do name@(A.At (A.Region _ nameEnd) _) <- addLocation (Var.upper E.CT_Variant)

201− Space.chomp E.CT_Space

202− (args, end) <- specialize E.CT_VariantArg (chompArgs [] nameEnd)

203− return ( (name, args), end )

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+31−16

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+268−113

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.