6636a97...master · elk

.github/CONTRIBUTING.md+18−20

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

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

55possible.

66

7−## Licensing

87

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

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

8+## Expectations

9+

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

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

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

13+

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

15+

1116

1217## Style Guide

1318

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

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

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

1924

20−## Branches

2125

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

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

24− should target this branch!

26+## Branches

2527

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

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

28− release from source.

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

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

30+should target this branch!

2931

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

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

3233

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

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

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

36−features.

3734

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

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

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

41−your changes maintain this compatibility.

35+## Licensing

36+

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

38+

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

40+

4241

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

.github/PULL_REQUEST_TEMPLATE.mdnew file+18

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

1+

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

3+

4+

5+## SSCCE

6+

7+```elm

8+

9+```

10+

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

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

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

14+

15+

16+## Additional Details

17+

18+???

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

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

1+name: Set Issue Expectations

2+on:

3+ issues:

4+ types: [opened]

5+jobs:

6+ comment-on-issue:

7+ name: Comment On Issue

8+ runs-on: ubuntu-latest

9+ steps:

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

11+ env:

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

13+ with:

14+ args: |

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

16+

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

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

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

20+

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

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

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

1+on:

2+ pull_request_target:

3+ types: [opened]

4+

5+jobs:

6+ comment-on-pull:

7+ name: Comment On Pull

8+ runs-on: ubuntu-latest

9+ steps:

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

11+ with:

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

13+ script: |

14+ github.issues.createComment({

15+ issue_number: context.issue.number,

16+ owner: context.repo.owner,

17+ repo: context.repo.repo,

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

19+ })

.gitignore+1

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

55cabal.sandbox.config

66.DS_Store

77*~

8+travis.log

.travis.ymlnew file+28

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

1+language: minimal

2+services: docker

3+

4+env:

5+ global:

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

7+

8+before_install:

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

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

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

12+

13+deploy:

14+ provider: releases

15+ api_key:

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

17+ file: $LINUX_ARCHIVE

18+ skip_cleanup: true

19+ on:

20+ branch: master

21+ tags: true

22+

23+notifications:

24+ email:

25+ recipients:

26+ - rlefevre@dmy.fr

27+ on_success: change

28+ on_failure: change

ContributorAgreement.pdfdeleted

Binary file not shown.

LICENSE+6−25

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

22

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

44

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

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

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

76

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

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

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

108

11− * Redistributions in binary form must reproduce the above

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

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

14− with the distribution.

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

1510

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

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

18− from this software without specific prior written permission.

19−

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

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

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

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

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

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

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

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

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

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

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

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

README.md+10−5

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

1−# The Elm Compiler

1+# Elm

22

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

3+A delightful language for reliable webapps.

44

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

6+

7+

8+<br>

59

610## Install

711

8−Follow [these instructions][installer]!

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

913

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

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

1115

16+<br>

1217

1318## Help

1419

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

1621

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

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

builder/src/BackgroundWriter.hsnew file+42

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

1+{-# LANGUAGE BangPatterns #-}

2+module BackgroundWriter

3+ ( Scope

4+ , withScope

5+ , writeBinary

6+ )

7+ where

8+

9+

10+import Control.Concurrent (forkIO)

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

12+import qualified Data.Binary as Binary

13+import Data.Foldable (traverse_)

14+

15+import qualified File

16+

17+

18+

19+-- BACKGROUND WRITER

20+

21+

22+newtype Scope =

23+ Scope (MVar [MVar ()])

24+

25+

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

27+withScope callback =

28+ do workList <- newMVar []

29+ result <- callback (Scope workList)

30+ mvars <- takeMVar workList

31+ traverse_ takeMVar mvars

32+ return result

33+

34+

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

36+writeBinary (Scope workList) path value =

37+ do mvar <- newEmptyMVar

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

39+ oldWork <- takeMVar workList

40+ let !newWork = mvar:oldWork

41+ putMVar workList newWork

42+

builder/src/Build.hsnew file+1251

@@ -0,0 +1,1251 @@

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

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

3+module Build

4+ ( fromExposed

5+ , fromPaths

6+ , fromRepl

7+ , Artifacts(..)

8+ , Root(..)

9+ , Module(..)

10+ , CachedInterface(..)

11+ , ReplArtifacts(..)

12+ , DocsGoal(..)

13+ , getRootNames

14+ )

15+ where

16+

17+

18+import Control.Concurrent (forkIO)

19+import Control.Concurrent.MVar

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

21+import qualified Data.ByteString as B

22+import qualified Data.Char as Char

23+import qualified Data.Graph as Graph

24+import qualified Data.List as List

25+import qualified Data.Map.Utils as Map

26+import qualified Data.Map.Strict as Map

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

28+import qualified Data.Maybe as Maybe

29+import qualified Data.Name as Name

30+import qualified Data.NonEmptyList as NE

31+import qualified Data.OneOrMore as OneOrMore

32+import qualified Data.Set as Set

33+import qualified System.Directory as Dir

34+import qualified System.FilePath as FP

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

36+

37+import qualified AST.Canonical as Can

38+import qualified AST.Source as Src

39+import qualified AST.Optimized as Opt

40+import qualified Compile

41+import qualified Elm.Details as Details

42+import qualified Elm.Docs as Docs

43+import qualified Elm.Interface as I

44+import qualified Elm.ModuleName as ModuleName

45+import qualified Elm.Outline as Outline

46+import qualified Elm.Package as Pkg

47+import qualified File

48+import qualified Json.Encode as E

49+import qualified Parse.Module as Parse

50+import qualified Reporting

51+import qualified Reporting.Annotation as A

52+import qualified Reporting.Error as Error

53+import qualified Reporting.Error.Docs as EDocs

54+import qualified Reporting.Error.Syntax as Syntax

55+import qualified Reporting.Error.Import as Import

56+import qualified Reporting.Exit as Exit

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

58+import qualified Stuff

59+

60+

61+

62+-- ENVIRONMENT

63+

64+

65+data Env =

66+ Env

67+ { _key :: Reporting.BKey

68+ , _root :: FilePath

69+ , _project :: Parse.ProjectType

70+ , _srcDirs :: [AbsoluteSrcDir]

71+ , _buildID :: Details.BuildID

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

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

74+ }

75+

76+

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

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

79+ case validOutline of

80+ Details.ValidApp givenSrcDirs ->

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

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

83+

84+ Details.ValidPkg pkg _ _ ->

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

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

87+

88+

89+

90+-- SOURCE DIRECTORY

91+

92+

93+newtype AbsoluteSrcDir =

94+ AbsoluteSrcDir FilePath

95+

96+

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

98+toAbsoluteSrcDir root srcDir =

99+ AbsoluteSrcDir <$> Dir.canonicalizePath

100+ (

101+ case srcDir of

102+ Outline.AbsoluteSrcDir dir -> dir

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

104+ )

105+

106+

107+addRelative :: AbsoluteSrcDir -> FilePath -> FilePath

108+addRelative (AbsoluteSrcDir srcDir) path =

109+ srcDir </> path

110+

111+

112+

113+-- FORK

114+

115+

116+-- PERF try using IORef semephore on file crawl phase?

117+-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow

118+-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead

119+--

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

121+fork work =

122+ do mvar <- newEmptyMVar

123+ _ <- forkIO $ putMVar mvar =<< work

124+ return mvar

125+

126+

127+{-# INLINE forkWithKey #-}

128+forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))

129+forkWithKey func dict =

130+ Map.traverseWithKey (\k v -> fork (func k v)) dict

131+

132+

133+

134+-- FROM EXPOSED

135+

136+

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

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

139+ Reporting.trackBuild style $ \key ->

140+ do env <- makeEnv key root details

141+ dmvar <- Details.loadInterfaces root details

142+

143+ -- crawl

144+ mvar <- newEmptyMVar

145+ let docsNeed = toDocsNeed docsGoal

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

147+ putMVar mvar roots

148+ mapM_ readMVar roots

149+ statuses <- traverse readMVar =<< readMVar mvar

150+

151+ -- compile

152+ midpoint <- checkMidpoint dmvar statuses

153+ case midpoint of

154+ Left problem ->

155+ return (Left (Exit.BuildProjectProblem problem))

156+

157+ Right foreigns ->

158+ do rmvar <- newEmptyMVar

159+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses

160+ putMVar rmvar resultMVars

161+ results <- traverse readMVar resultMVars

162+ writeDetails root details results

163+ finalizeExposed root docsGoal exposed results

164+

165+

166+

167+-- FROM PATHS

168+

169+

170+data Artifacts =

171+ Artifacts

172+ { _name :: Pkg.Name

173+ , _deps :: Dependencies

174+ , _roots :: NE.List Root

175+ , _modules :: [Module]

176+ }

177+

178+

179+data Module

180+ = Fresh ModuleName.Raw I.Interface Opt.LocalGraph

181+ | Cached ModuleName.Raw Bool (MVar CachedInterface)

182+

183+

184+type Dependencies =

185+ Map.Map ModuleName.Canonical I.DependencyInterface

186+

187+

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

189+fromPaths style root details paths =

190+ Reporting.trackBuild style $ \key ->

191+ do env <- makeEnv key root details

192+

193+ elroots <- findRoots env paths

194+ case elroots of

195+ Left problem ->

196+ return (Left (Exit.BuildProjectProblem problem))

197+

198+ Right lroots ->

199+ do -- crawl

200+ dmvar <- Details.loadInterfaces root details

201+ smvar <- newMVar Map.empty

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

203+ sroots <- traverse readMVar srootMVars

204+ statuses <- traverse readMVar =<< readMVar smvar

205+

206+ midpoint <- checkMidpointAndRoots dmvar statuses sroots

207+ case midpoint of

208+ Left problem ->

209+ return (Left (Exit.BuildProjectProblem problem))

210+

211+ Right foreigns ->

212+ do -- compile

213+ rmvar <- newEmptyMVar

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

215+ putMVar rmvar resultsMVars

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

217+ results <- traverse readMVar resultsMVars

218+ writeDetails root details results

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

220+

221+

222+

223+-- GET ROOT NAMES

224+

225+

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

227+getRootNames (Artifacts _ _ roots _) =

228+ fmap getRootName roots

229+

230+

231+getRootName :: Root -> ModuleName.Raw

232+getRootName root =

233+ case root of

234+ Inside name -> name

235+ Outside name _ _ -> name

236+

237+

238+

239+-- CRAWL

240+

241+

242+type StatusDict =

243+ Map.Map ModuleName.Raw (MVar Status)

244+

245+

246+data Status

247+ = SCached Details.Local

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

249+ | SBadImport Import.Problem

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

251+ | SForeign Pkg.Name

252+ | SKernel

253+

254+

255+crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a

256+crawlDeps env mvar deps blockedValue =

257+ do statusDict <- takeMVar mvar

258+ let depsDict = Map.fromKeys (\_ -> ()) deps

259+ let newsDict = Map.difference depsDict statusDict

260+ statuses <- Map.traverseWithKey crawlNew newsDict

261+ putMVar mvar (Map.union statuses statusDict)

262+ mapM_ readMVar statuses

263+ return blockedValue

264+ where

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

266+

267+

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

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

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

271+

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

273+

274+ case paths of

275+ [path] ->

276+ case Map.lookup name foreigns of

277+ Just (Details.Foreign dep deps) ->

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

279+

280+ Nothing ->

281+ do newTime <- File.getTime path

282+ case Map.lookup name locals of

283+ Nothing ->

284+ crawlFile env mvar docsNeed name path newTime buildID

285+

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

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

288+ then crawlFile env mvar docsNeed name path newTime lastChange

289+ else crawlDeps env mvar deps (SCached local)

290+

291+ p1:p2:ps ->

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

293+

294+ [] ->

295+ case Map.lookup name foreigns of

296+ Just (Details.Foreign dep deps) ->

297+ case deps of

298+ [] ->

299+ return $ SForeign dep

300+

301+ d:ds ->

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

303+

304+ Nothing ->

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

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

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

308+ else

309+ return $ SBadImport Import.NotFound

310+

311+

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

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

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

315+

316+ case Parse.fromByteString projectType source of

317+ Left err ->

318+ return $ SBadSyntax path time source err

319+

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

321+ case maybeActualName of

322+ Nothing ->

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

324+

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

326+ if expectedName == actualName then

327+ let

328+ deps = map Src.getImportName imports

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

330+ in

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

332+ else

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

334+

335+

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

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

338+ name == Name._main

339+

340+

341+

342+-- CHECK MODULE

343+

344+

345+type ResultDict =

346+ Map.Map ModuleName.Raw (MVar Result)

347+

348+

349+data Result

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

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

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

353+ | RNotFound Import.Problem

354+ | RProblem Error.Module

355+ | RBlocked

356+ | RForeign I.Interface

357+ | RKernel

358+

359+

360+data CachedInterface

361+ = Unneeded

362+ | Loaded I.Interface

363+ | Corrupted

364+

365+

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

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

368+ case status of

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

370+ do results <- readMVar resultsMVar

371+ depsStatus <- checkDeps root results deps lastCompile

372+ case depsStatus of

373+ DepsChange ifaces ->

374+ do source <- File.readUtf8 path

375+ case Parse.fromByteString projectType source of

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

377+ Left err ->

378+ return $ RProblem $

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

380+

381+ DepsSame _ _ ->

382+ do mvar <- newMVar Unneeded

383+ return (RCached hasMain lastChange mvar)

384+

385+ DepsBlock ->

386+ return RBlocked

387+

388+ DepsNotFound problems ->

389+ do source <- File.readUtf8 path

390+ return $ RProblem $ Error.Module name path time source $

391+ case Parse.fromByteString projectType source of

392+ Right (Src.Module _ _ _ imports _ _ _ _ _) ->

393+ Error.BadImports (toImportErrors env results imports problems)

394+

395+ Left err ->

396+ Error.BadSyntax err

397+

398+ SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->

399+ do results <- readMVar resultsMVar

400+ depsStatus <- checkDeps root results deps lastCompile

401+ case depsStatus of

402+ DepsChange ifaces ->

403+ compile env docsNeed local source ifaces modul

404+

405+ DepsSame same cached ->

406+ do maybeLoaded <- loadInterfaces root same cached

407+ case maybeLoaded of

408+ Nothing -> return RBlocked

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

410+

411+ DepsBlock ->

412+ return RBlocked

413+

414+ DepsNotFound problems ->

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

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

417+

418+ SBadImport importProblem ->

419+ return (RNotFound importProblem)

420+

421+ SBadSyntax path time source err ->

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

423+ Error.BadSyntax err

424+

425+ SForeign home ->

426+ case foreigns ! ModuleName.Canonical home name of

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

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

429+

430+ SKernel ->

431+ return RKernel

432+

433+

434+

435+-- CHECK DEPS

436+

437+

438+data DepsStatus

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

440+ | DepsSame [Dep] [CDep]

441+ | DepsBlock

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

443+

444+

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

446+checkDeps root results deps lastCompile =

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

448+

449+

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

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

452+

453+

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

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

456+ case deps of

457+ dep:otherDeps ->

458+ do result <- readMVar (results ! dep)

459+ case result of

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

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

462+

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

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

465+

466+ RCached _ lastChange mvar ->

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

468+

469+ RNotFound prob ->

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

471+

472+ RProblem _ ->

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

474+

475+ RBlocked ->

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

477+

478+ RForeign iface ->

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

480+

481+ RKernel ->

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

483+

484+

485+ [] ->

486+ case reverse importProblems of

487+ p:ps ->

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

489+

490+ [] ->

491+ if isBlocked then

492+ return $ DepsBlock

493+

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

495+ return $ DepsSame same cached

496+

497+ else

498+ do maybeLoaded <- loadInterfaces root same cached

499+ case maybeLoaded of

500+ Nothing -> return DepsBlock

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

502+

503+

504+

505+-- TO IMPORT ERROR

506+

507+

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

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

510+ let

511+ knownModules =

512+ Set.unions

513+ [ Map.keysSet foreigns

514+ , Map.keysSet locals

515+ , Map.keysSet results

516+ ]

517+

518+ unimportedModules =

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

520+

521+ regionDict =

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

523+

524+ toError (name, problem) =

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

526+ in

527+ fmap toError problems

528+

529+

530+

531+-- LOAD CACHED INTERFACES

532+

533+

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

535+loadInterfaces root same cached =

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

537+ maybeLoaded <- traverse readMVar loading

538+ case sequence maybeLoaded of

539+ Nothing ->

540+ return Nothing

541+

542+ Just loaded ->

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

544+

545+

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

547+loadInterface root (name, ciMvar) =

548+ do cachedInterface <- takeMVar ciMvar

549+ case cachedInterface of

550+ Corrupted ->

551+ do putMVar ciMvar cachedInterface

552+ return Nothing

553+

554+ Loaded iface ->

555+ do putMVar ciMvar cachedInterface

556+ return (Just (name, iface))

557+

558+ Unneeded ->

559+ do maybeIface <- File.readBinary (Stuff.elmi root name)

560+ case maybeIface of

561+ Nothing ->

562+ do putMVar ciMvar Corrupted

563+ return Nothing

564+

565+ Just iface ->

566+ do putMVar ciMvar (Loaded iface)

567+ return (Just (name, iface))

568+

569+

570+

571+-- CHECK PROJECT

572+

573+

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

575+checkMidpoint dmvar statuses =

576+ case checkForCycles statuses of

577+ Nothing ->

578+ do maybeForeigns <- readMVar dmvar

579+ case maybeForeigns of

580+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)

581+ Just fs -> return (Right fs)

582+

583+ Just (NE.List name names) ->

584+ do _ <- readMVar dmvar

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

586+

587+

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

589+checkMidpointAndRoots dmvar statuses sroots =

590+ case checkForCycles statuses of

591+ Nothing ->

592+ case checkUniqueRoots statuses sroots of

593+ Nothing ->

594+ do maybeForeigns <- readMVar dmvar

595+ case maybeForeigns of

596+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)

597+ Just fs -> return (Right fs)

598+

599+ Just problem ->

600+ do _ <- readMVar dmvar

601+ return (Left problem)

602+

603+ Just (NE.List name names) ->

604+ do _ <- readMVar dmvar

605+ return (Left (Exit.BP_Cycle name names))

606+

607+

608+

609+-- CHECK FOR CYCLES

610+

611+

612+checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)

613+checkForCycles modules =

614+ let

615+ !graph = Map.foldrWithKey addToGraph [] modules

616+ !sccs = Graph.stronglyConnComp graph

617+ in

618+ checkForCyclesHelp sccs

619+

620+

621+checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)

622+checkForCyclesHelp sccs =

623+ case sccs of

624+ [] ->

625+ Nothing

626+

627+ scc:otherSccs ->

628+ case scc of

629+ Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs

630+ Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs

631+ Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)

632+

633+

634+type Node =

635+ ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )

636+

637+

638+addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]

639+addToGraph name status graph =

640+ let

641+ dependencies =

642+ case status of

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

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

645+ SBadImport _ -> []

646+ SBadSyntax _ _ _ _ -> []

647+ SForeign _ -> []

648+ SKernel -> []

649+ in

650+ (name, name, dependencies) : graph

651+

652+

653+

654+-- CHECK UNIQUE ROOTS

655+

656+

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

658+checkUniqueRoots insides sroots =

659+ let

660+ outsidesDict =

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

662+ in

663+ case Map.traverseWithKey checkOutside outsidesDict of

664+ Left problem ->

665+ Just problem

666+

667+ Right outsides ->

668+ case sequence_ (Map.intersectionWithKey checkInside outsides insides) of

669+ Right () -> Nothing

670+ Left problem -> Just problem

671+

672+

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

674+rootStatusToNamePathPair sroot =

675+ case sroot of

676+ SInside _ -> Nothing

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

678+ SOutsideErr _ -> Nothing

679+

680+

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

682+checkOutside name paths =

683+ case OneOrMore.destruct NE.List paths of

684+ NE.List p [] -> Right p

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

686+

687+

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

689+checkInside name p1 status =

690+ case status of

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

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

693+ SBadImport _ -> Right ()

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

695+ SForeign _ -> Right ()

696+ SKernel -> Right ()

697+

698+

699+

700+-- COMPILE MODULE

701+

702+

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

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

705+ let

706+ pkg = projectTypeToPkg projectType

707+ in

708+ case Compile.compile pkg ifaces modul of

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

710+ case makeDocs docsNeed canonical of

711+ Left err ->

712+ return $ RProblem $

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

714+

715+ Right docs ->

716+ do let name = Src.getName modul

717+ let iface = I.fromModule pkg canonical annotations

718+ let elmi = Stuff.elmi root name

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

720+ maybeOldi <- File.readBinary elmi

721+ case maybeOldi of

722+ Just oldi | oldi == iface ->

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

724+ Reporting.report key Reporting.BDone

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

726+ return (RSame local iface objects docs)

727+

728+ _ ->

729+ do -- iface may be lazy still

730+ File.writeBinary elmi iface

731+ Reporting.report key Reporting.BDone

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

733+ return (RNew local iface objects docs)

734+

735+ Left err ->

736+ return $ RProblem $

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

738+

739+

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

741+projectTypeToPkg projectType =

742+ case projectType of

743+ Parse.Package pkg -> pkg

744+ Parse.Application -> Pkg.dummyName

745+

746+

747+

748+-- WRITE DETAILS

749+

750+

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

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

753+ File.writeBinary (Stuff.details root) $

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

755+

756+

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

758+addNewLocal name result locals =

759+ case result of

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

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

762+ RCached _ _ _ -> locals

763+ RNotFound _ -> locals

764+ RProblem _ -> locals

765+ RBlocked -> locals

766+ RForeign _ -> locals

767+ RKernel -> locals

768+

769+

770+

771+-- FINALIZE EXPOSED

772+

773+

774+finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)

775+finalizeExposed root docsGoal exposed results =

776+ case foldr (addImportProblems results) [] (NE.toList exposed) of

777+ p:ps ->

778+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))

779+

780+ [] ->

781+ case Map.foldr addErrors [] results of

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

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

784+

785+

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

787+addErrors result errors =

788+ case result of

789+ RNew _ _ _ _ -> errors

790+ RSame _ _ _ _ -> errors

791+ RCached _ _ _ -> errors

792+ RNotFound _ -> errors

793+ RProblem e -> e:errors

794+ RBlocked -> errors

795+ RForeign _ -> errors

796+ RKernel -> errors

797+

798+

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

800+addImportProblems results name problems =

801+ case results ! name of

802+ RNew _ _ _ _ -> problems

803+ RSame _ _ _ _ -> problems

804+ RCached _ _ _ -> problems

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

806+ RProblem _ -> problems

807+ RBlocked -> problems

808+ RForeign _ -> problems

809+ RKernel -> problems

810+

811+

812+

813+-- DOCS

814+

815+

816+data DocsGoal a where

817+ KeepDocs :: DocsGoal Docs.Documentation

818+ WriteDocs :: FilePath -> DocsGoal ()

819+ IgnoreDocs :: DocsGoal ()

820+

821+

822+newtype DocsNeed =

823+ DocsNeed { needsDocs :: Bool }

824+

825+

826+toDocsNeed :: DocsGoal a -> DocsNeed

827+toDocsNeed goal =

828+ case goal of

829+ IgnoreDocs -> DocsNeed False

830+ WriteDocs _ -> DocsNeed True

831+ KeepDocs -> DocsNeed True

832+

833+

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

835+makeDocs (DocsNeed isNeeded) modul =

836+ if isNeeded then

837+ case Docs.fromModule modul of

838+ Right docs -> Right (Just docs)

839+ Left err -> Left err

840+ else

841+ Right Nothing

842+

843+

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

845+finalizeDocs goal results =

846+ case goal of

847+ KeepDocs ->

848+ return $ Map.mapMaybe toDocs results

849+

850+ WriteDocs path ->

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

852+

853+ IgnoreDocs ->

854+ return ()

855+

856+

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

858+toDocs result =

859+ case result of

860+ RNew _ _ _ d -> d

861+ RSame _ _ _ d -> d

862+ RCached _ _ _ -> Nothing

863+ RNotFound _ -> Nothing

864+ RProblem _ -> Nothing

865+ RBlocked -> Nothing

866+ RForeign _ -> Nothing

867+ RKernel -> Nothing

868+

869+

870+

871+--------------------------------------------------------------------------------

872+------ NOW FOR SOME REPL STUFF -------------------------------------------------

873+--------------------------------------------------------------------------------

874+

875+

876+-- FROM REPL

877+

878+

879+data ReplArtifacts =

880+ ReplArtifacts

881+ { _repl_home :: ModuleName.Canonical

882+ , _repl_modules :: [Module]

883+ , _repl_localizer :: L.Localizer

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

885+ }

886+

887+

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

889+fromRepl root details source =

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

891+ case Parse.fromByteString projectType source of

892+ Left syntaxError ->

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

894+

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

896+ do dmvar <- Details.loadInterfaces root details

897+

898+ let deps = map Src.getImportName imports

899+ mvar <- newMVar Map.empty

900+ crawlDeps env mvar deps ()

901+

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

903+ midpoint <- checkMidpoint dmvar statuses

904+

905+ case midpoint of

906+ Left problem ->

907+ return $ Left $ Exit.ReplProjectProblem problem

908+

909+ Right foreigns ->

910+ do rmvar <- newEmptyMVar

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

912+ putMVar rmvar resultMVars

913+ results <- traverse readMVar resultMVars

914+ writeDetails root details results

915+ depsStatus <- checkDeps root resultMVars deps 0

916+ finalizeReplArtifacts env source modul depsStatus resultMVars results

917+

918+

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

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

921+ let

922+ pkg =

923+ projectTypeToPkg projectType

924+

925+ compileInput ifaces =

926+ case Compile.compile pkg ifaces modul of

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

928+ let

929+ h = Can._name canonical

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

931+ ms = Map.foldrWithKey addInside [] results

932+ in

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

934+

935+ Left errors ->

936+ return $ Left $ Exit.ReplBadInput source errors

937+ in

938+ case depsStatus of

939+ DepsChange ifaces ->

940+ compileInput ifaces

941+

942+ DepsSame same cached ->

943+ do maybeLoaded <- loadInterfaces root same cached

944+ case maybeLoaded of

945+ Just ifaces -> compileInput ifaces

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

947+

948+ DepsBlock ->

949+ case Map.foldr addErrors [] results of

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

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

952+

953+ DepsNotFound problems ->

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

955+ toImportErrors env resultMVars imports problems

956+

957+

958+

959+--------------------------------------------------------------------------------

960+--------------------------------------------------------------------------------

961+------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------

962+--------------------------------------------------------------------------------

963+--------------------------------------------------------------------------------

964+

965+

966+

967+-- FIND ROOT

968+

969+

970+data RootLocation

971+ = LInside ModuleName.Raw

972+ | LOutside FilePath

973+

974+

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

976+findRoots env paths =

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

978+ einfos <- traverse readMVar mvars

979+ return $ checkRoots =<< sequence einfos

980+

981+

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

983+checkRoots infos =

984+ let

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

986+ (absolute, OneOrMore.one loc)

987+

988+ fromOneOrMore loc locs =

989+ case locs of

990+ [] -> Right ()

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

992+ in

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

994+ traverse (OneOrMore.destruct fromOneOrMore) $

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

996+

997+

998+

999+-- ROOT INFO

1000+

1001+

1002+data RootInfo =

1003+ RootInfo

1004+ { _absolute :: FilePath

1005+ , _relative :: FilePath

1006+ , _location :: RootLocation

1007+ }

1008+

1009+

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

1011+getRootInfo env path =

1012+ do exists <- File.exists path

1013+ if exists

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

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

1016+

1017+

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

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

1020+ let

1021+ (dirs, file) = FP.splitFileName absolutePath

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

1023+ in

1024+ if ext /= ".elm"

1025+ then

1026+ return $ Left $ Exit.BP_WithBadExtension path

1027+ else

1028+ let

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

1030+ in

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

1032+ [] ->

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

1034+

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

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

1037+ matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs

1038+ case matchingDirs of

1039+ d1:d2:_ ->

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

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

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

1043+

1044+ _ ->

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

1046+

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

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

1049+

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

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

1052+

1053+

1054+

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

1056+isInsideSrcDirByName names srcDir =

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

1058+

1059+

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

1061+isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =

1062+ case dropPrefix (FP.splitDirectories srcDir) segments of

1063+ Nothing ->

1064+ Nothing

1065+

1066+ Just names ->

1067+ if all isGoodName names

1068+ then Just (srcDir, Right names)

1069+ else Just (srcDir, Left names)

1070+

1071+

1072+isGoodName :: [Char] -> Bool

1073+isGoodName name =

1074+ case name of

1075+ [] ->

1076+ False

1077+

1078+ char:chars ->

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

1080+

1081+

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

1083+--

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

1085+dropPrefix roots paths =

1086+ case roots of

1087+ [] ->

1088+ Just paths

1089+

1090+ r:rs ->

1091+ case paths of

1092+ [] -> Nothing

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

1094+

1095+

1096+

1097+-- CRAWL ROOTS

1098+

1099+

1100+data RootStatus

1101+ = SInside ModuleName.Raw

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

1103+ | SOutsideErr Error.Module

1104+

1105+

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

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

1108+ case root of

1109+ LInside name ->

1110+ do statusMVar <- newEmptyMVar

1111+ statusDict <- takeMVar mvar

1112+ putMVar mvar (Map.insert name statusMVar statusDict)

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

1114+ return (SInside name)

1115+

1116+ LOutside path ->

1117+ do time <- File.getTime path

1118+ source <- File.readUtf8 path

1119+ case Parse.fromByteString projectType source of

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

1121+ do let deps = map Src.getImportName imports

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

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

1124+

1125+ Left syntaxError ->

1126+ return $ SOutsideErr $

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

1128+

1129+

1130+

1131+-- CHECK ROOTS

1132+

1133+

1134+data RootResult

1135+ = RInside ModuleName.Raw

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

1137+ | ROutsideErr Error.Module

1138+ | ROutsideBlocked

1139+

1140+

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

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

1143+ case rootStatus of

1144+ SInside name ->

1145+ return (RInside name)

1146+

1147+ SOutsideErr err ->

1148+ return (ROutsideErr err)

1149+

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

1151+ do depsStatus <- checkDeps root results deps lastCompile

1152+ case depsStatus of

1153+ DepsChange ifaces ->

1154+ compileOutside env local source ifaces modul

1155+

1156+ DepsSame same cached ->

1157+ do maybeLoaded <- loadInterfaces root same cached

1158+ case maybeLoaded of

1159+ Nothing -> return ROutsideBlocked

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

1161+

1162+ DepsBlock ->

1163+ return ROutsideBlocked

1164+

1165+ DepsNotFound problems ->

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

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

1168+

1169+

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

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

1172+ let

1173+ pkg = projectTypeToPkg projectType

1174+ name = Src.getName modul

1175+ in

1176+ case Compile.compile pkg ifaces modul of

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

1178+ do Reporting.report key Reporting.BDone

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

1180+

1181+ Left errors ->

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

1183+

1184+

1185+

1186+-- TO ARTIFACTS

1187+

1188+

1189+data Root

1190+ = Inside ModuleName.Raw

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

1192+

1193+

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

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

1196+ case gatherProblemsOrMains results rootResults of

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

1198+ Left (Exit.BuildBadModules root e es)

1199+

1200+ Right roots ->

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

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

1203+

1204+

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

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

1207+ let

1208+ addResult result (es, roots) =

1209+ case result of

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

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

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

1213+ ROutsideBlocked -> ( es, roots)

1214+

1215+ errors = Map.foldr addErrors [] results

1216+ in

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

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

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

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

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

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

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

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

1225+

1226+

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

1228+addInside name result modules =

1229+ case result of

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

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

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

1233+ RNotFound _ -> error (badInside name)

1234+ RProblem _ -> error (badInside name)

1235+ RBlocked -> error (badInside name)

1236+ RForeign _ -> modules

1237+ RKernel -> modules

1238+

1239+

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

1241+badInside name =

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

1243+

1244+

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

1246+addOutside root modules =

1247+ case root of

1248+ RInside _ -> modules

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

1250+ ROutsideErr _ -> modules

1251+ ROutsideBlocked -> modules

builder/src/Deps/Bump.hsnew file+37

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

1+module Deps.Bump

2+ ( getPossibilities

3+ )

4+ where

5+

6+

7+import qualified Data.List as List

8+

9+import qualified Deps.Registry as Registry

10+import qualified Elm.Magnitude as M

11+import qualified Elm.Version as V

12+

13+

14+

15+-- GET POSSIBILITIES

16+

17+

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

19+getPossibilities (Registry.KnownVersions latest previous) =

20+ let

21+ allVersions = reverse (latest:previous)

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

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

24+ in

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

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

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

28+

29+

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

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

32+ major1 == major2

33+

34+

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

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

37+ major1 == major2 && minor1 == minor2

builder/src/Deps/Diff.hs+11−8

@@ -18,7 +18,8 @@ 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 Data.Utf8 as Utf8

21+import qualified System.Directory as Dir

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

2223

2324import qualified Deps.Website as Website

2425import qualified Elm.Compiler.Type as Type

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

203204isSameName oldFullName newFullName =

204205 let

205206 dedot name =

206− reverse (Utf8.split 0x2E {-.-} (Name.toUtf8 name))

207+ reverse (Name.splitDots name)

207208 in

208209 case ( dedot oldFullName, dedot newFullName ) of

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

@@ -356,12 +357,13 @@ changeMagnitude (Changes added changed removed) =

356357

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

358359getDocs cache manager name version =

359− do let path = Stuff.metadata cache name version "docs.json"

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

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

360362 exists <- File.exists path

361363 if exists

362364 then

363− do result <- D.fromFile Docs.decoder path

364− case result of

365+ do bytes <- File.readUtf8 path

366+ case D.fromByteString Docs.decoder bytes of

365367 Right docs ->

366368 return $ Right docs

367369

@@ -370,11 +372,12 @@ getDocs cache manager name version =

370372 return $ Left Exit.DP_Cache

371373 else

372374 do let url = Website.metadata name version "docs.json"

373− Http.post manager url [] Exit.DP_Http $ \body ->

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

374376 case D.fromByteString Docs.decoder body of

375377 Right docs ->

376− do File.writeUtf8 path body

378+ do Dir.createDirectoryIfMissing True home

379+ File.writeUtf8 path body

377380 return $ Right docs

378381

379382 Left _ ->

380− return $ Left Exit.DP_Data

383+ return $ Left $ Exit.DP_Data url body

builder/src/Deps/Plan.hsdeleted−64

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

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+40−73

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

1616import Prelude hiding (read)

1717import Control.Monad (liftM2)

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

19−import Data.Function (on)

2019import qualified Data.List as List

2120import qualified Data.Map.Strict as Map

22−import qualified Data.Name as Name

23−import qualified Data.Utf8 as Utf8

2421

2522import qualified Deps.Website as Website

2623import qualified Elm.Package as Pkg

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

2825import qualified File

2926import qualified Http

3027import qualified Json.Decode as D

31−import qualified Reporting.Exit as E

32−import qualified Reporting.Suggest as Suggest

28+import qualified Parse.Primitives as P

29+import qualified Reporting.Exit as Exit

3330import qualified Stuff

3431

3532

@@ -57,18 +54,14 @@ data KnownVersions =

5754

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

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

57+ File.readBinary (Stuff.registry cache)

6558

6659

6760

6861-- FETCH

6962

7063

71−fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)

64+fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)

7265fetch manager cache =

7366 post manager "/all-packages" allPkgsDecoder $

7467 \versions ->

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

8679

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

8881allPkgsDecoder =

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

96−

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

82+ let

83+ keyDecoder =

84+ Pkg.keyDecoder bail

10385

104− v:vs ->

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

86+ versionsDecoder =

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

10688

107− Left _ ->

108− D.failure ()

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)

10995

11096

11197

11298-- UPDATE

11399

114100

115−update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either E.RegistryProblem Registry)

101+update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)

116102update manager cache oldRegistry@(Registry size packages) =

117103 post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $

118104 \news ->

@@ -144,29 +130,33 @@ addNew (name, version) versions =

144130 Map.alter (Just . add) name versions

145131

146132

133+

134+-- NEW PACKAGE DECODER

135+

136+

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

148138newPkgDecoder =

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

139+ D.customString newPkgParser bail

140+

157141

158− Left _ ->

159− D.failure ()

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)

160148

161− _ ->

162− D.failure ()

149+

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

151+bail _ _ =

152+ ()

163153

164154

165155

166156-- LATEST

167157

168158

169−latest :: Http.Manager -> Stuff.PackageCache -> IO (Either E.RegistryProblem Registry)

159+latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)

170160latest manager cache =

171161 do maybeOldRegistry <- read cache

172162 case maybeOldRegistry of

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

190180getVersions' name (Registry _ versions) =

191181 case Map.lookup name versions of

192182 Just kvs -> Right kvs

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

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

220184

221185

222186

223187-- POST

224188

225189

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

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

227191post manager path decoder callback =

228− Http.post manager (Website.route path []) [] E.RP_Http $

192+ let

193+ url = Website.route path []

194+ in

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

229196 \body ->

230197 case D.fromByteString decoder body of

231198 Right a -> Right <$> callback a

232− Left _ -> return $ Left E.RP_Data

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

233200

234201

235202

builder/src/Deps/Solver.hs+243−121

@@ -1,16 +1,27 @@

11{-# LANGUAGE OverloadedStrings, Rank2Types #-}

22module Deps.Solver

33 ( Solver

4− , Details(..)

4+ , Result(..)

55 , Connection(..)

6− , solve

6+ --

7+ , Details(..)

8+ , verify

9+ --

10+ , AppSolution(..)

11+ , addToApp

12+ --

13+ , Env(..)

14+ , initEnv

715 )

816 where

917

1018

1119import Control.Monad (foldM)

20+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, readMVar)

1221import qualified Data.Map as Map

22+import Data.Map ((!))

1323import qualified System.Directory as Dir

24+import System.FilePath ((</>))

1425

1526import qualified Deps.Registry as Registry

1627import qualified Deps.Website as Website

@@ -21,6 +32,7 @@ import qualified Elm.Version as V

2132import qualified File

2233import qualified Http

2334import qualified Json.Decode as D

35+import qualified Reporting.Exit as Exit

2436import qualified Stuff

2537

2638

@@ -35,6 +47,7 @@ newtype Solver a =

3547 State

3648 -> (State -> a -> (State -> IO b) -> IO b)

3749 -> (State -> IO b)

50+ -> (Exit.Solver -> IO b)

3851 -> IO b

3952 )

4053

@@ -42,10 +55,9 @@ newtype Solver a =

4255data State =

4356 State

4457 { _cache :: Stuff.PackageCache

45− , _internet :: Connection

58+ , _connection :: Connection

4659 , _registry :: Registry.Registry

4760 , _constraints :: Map.Map (Pkg.Name, V.Version) Constraints

48− , _problems :: [Problem]

4961 }

5062

5163

@@ -61,46 +73,126 @@ data Connection

6173 | Offline

6274

6375

64−data Problem

65− = BadCacheData Pkg.Name V.Version

66− | BadHttpData Pkg.Name V.Version

67− | BadHttp Http.Error

68− | UnknownPackage [Pkg.Name]

69− | ImpossibleConstraint Pkg.Name C.Constraint

70− | UnavailableOffline Pkg.Name V.Version

7176

77+-- RESULT

78+

79+

80+data Result a

81+ = Ok a

82+ | NoSolution

83+ | NoOfflineSolution

84+ | Err Exit.Solver

7285

7386

74−-- SOLVE

87+

88+-- VERIFY -- used by Elm.Details

7589

7690

7791data Details =

78− Details V.Version [Pkg.Name]

92+ Details V.Version (Map.Map Pkg.Name C.Constraint)

93+

94+

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

96+verify cache connection registry constraints =

97+ Stuff.withRegistryLock cache $

98+ case try constraints of

99+ Solver solver ->

100+ solver (State cache connection registry Map.empty)

101+ (\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))

102+ (\_ -> return $ noSolution connection)

103+ (\e -> return $ Err e)

104+

105+

106+addDeps :: State -> Pkg.Name -> V.Version -> Details

107+addDeps (State _ _ _ constraints) name vsn =

108+ case Map.lookup (name, vsn) constraints of

109+ Just (Constraints _ deps) -> Details vsn deps

110+ Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"

111+

112+

113+noSolution :: Connection -> Result a

114+noSolution connection =

115+ case connection of

116+ Online _ -> NoSolution

117+ Offline -> NoOfflineSolution

118+

79119

80120

81−solve :: Stuff.PackageCache -> Connection -> Registry.Registry -> Map.Map Pkg.Name C.Constraint -> IO (Either [Problem] (Map.Map Pkg.Name Details))

82−solve cache connection registry constraints =

121+-- ADD TO APP - used in Install

122+

123+

124+data AppSolution =

125+ AppSolution

126+ { _old :: Map.Map Pkg.Name V.Version

127+ , _new :: Map.Map Pkg.Name V.Version

128+ , _app :: Outline.AppOutline

129+ }

130+

131+

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

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

134+ Stuff.withRegistryLock cache $

83135 let

84− (Solver solver) = exploreGoals (Goals constraints Map.empty)

136+ allIndirects = Map.union indirect testIndirect

137+ allDirects = Map.union direct testDirect

138+ allDeps = Map.union allDirects allIndirects

139+

140+ attempt toConstraint deps =

141+ try (Map.insert pkg C.anything (Map.map toConstraint deps))

85142 in

86− solver (State cache connection registry Map.empty [])

87− (\(State _ _ _ cs _) vs _ -> return $ Right $ getDetails vs cs)

88− (\(State _ _ _ _ ps) -> return $ Left ps)

143+ case

144+ oneOf

145+ ( attempt C.exactly allDeps )

146+ [ attempt C.exactly allDirects

147+ , attempt C.untilNextMinor allDirects

148+ , attempt C.untilNextMajor allDirects

149+ , attempt (\_ -> C.anything) allDirects

150+ ]

151+ of

152+ Solver solver ->

153+ solver (State cache connection registry Map.empty)

154+ (\s a _ -> return $ Ok (toApp s pkg outline allDeps a))

155+ (\_ -> return $ noSolution connection)

156+ (\e -> return $ Err e)

157+

158+

159+toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution

160+toApp (State _ _ _ constraints) pkg (Outline.AppOutline elm srcDirs direct _ testDirect _) old new =

161+ let

162+ d = Map.intersection new (Map.insert pkg V.one direct)

163+ i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d

164+ td = Map.intersection new (Map.delete pkg testDirect)

165+ ti = Map.difference new (Map.unions [d,i,td])

166+ in

167+ AppSolution old new (Outline.AppOutline elm srcDirs d i td ti)

89168

90169

91−getDetails :: Map.Map Pkg.Name V.Version -> Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name Details

92−getDetails solution constraints =

93− Map.mapWithKey (getDetailsHelp constraints) solution

170+getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name,V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version

171+getTransitive constraints solution unvisited visited =

172+ case unvisited of

173+ [] ->

174+ visited

94175

176+ info@(pkg,vsn) : infos ->

177+ if Map.member pkg visited

178+ then getTransitive constraints solution infos visited

179+ else

180+ let

181+ newDeps = _deps (constraints ! info)

182+ newUnvisited = Map.toList (Map.intersection solution (Map.difference newDeps visited))

183+ newVisited = Map.insert pkg vsn visited

184+ in

185+ getTransitive constraints solution infos $

186+ getTransitive constraints solution newUnvisited newVisited

95187

96−getDetailsHelp :: Map.Map (Pkg.Name, V.Version) Constraints -> Pkg.Name -> V.Version -> Details

97−getDetailsHelp constraints name vsn =

98− case Map.lookup (name, vsn) constraints of

99− Just (Constraints _ deps) ->

100− Details vsn (Map.keys deps)

101188

102− Nothing ->

103− error "compiler bug in Deps.Solver manifesting in getDetailsHelp"

189+

190+-- TRY

191+

192+

193+try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)

194+try constraints =

195+ exploreGoals (Goals constraints Map.empty)

104196

105197

106198

@@ -136,7 +228,7 @@ addVersion (Goals pending solved) name version =

136228 do newPending <- foldM (addConstraint solved) pending (Map.toList deps)

137229 return (Goals newPending (Map.insert name version solved))

138230 else

139− deadend

231+ backtrack

140232

141233

142234addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)

@@ -145,7 +237,7 @@ addConstraint solved unsolved (name, newConstraint) =

145237 Just version ->

146238 if C.satisfies newConstraint version

147239 then return unsolved

148− else deadend

240+ else backtrack

149241

150242 Nothing ->

151243 case Map.lookup name unsolved of

@@ -155,7 +247,7 @@ addConstraint solved unsolved (name, newConstraint) =

155247 Just oldConstraint ->

156248 case C.intersect oldConstraint newConstraint of

157249 Nothing ->

158− deadend

250+ backtrack

159251

160252 Just mergedConstraint ->

161253 if oldConstraint == mergedConstraint

@@ -169,18 +261,15 @@ addConstraint solved unsolved (name, newConstraint) =

169261

170262getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])

171263getRelevantVersions name constraint =

172− Solver $ \state@(State _ _ registry _ _) ok err ->

173− case Registry.getVersions' name registry of

174− Right (Registry.KnownVersions newest previous) ->

264+ Solver $ \state@(State _ _ registry _) ok back _ ->

265+ case Registry.getVersions name registry of

266+ Just (Registry.KnownVersions newest previous) ->

175267 case filter (C.satisfies constraint) (newest:previous) of

176− [] ->

177− err (addProblem (ImpossibleConstraint name constraint) state)

178−

179− v:vs ->

180− ok state (v,vs) err

268+ [] -> back state

269+ v:vs -> ok state (v,vs) back

181270

182− Left suggestions ->

183− err (addProblem (UnknownPackage suggestions) state)

271+ Nothing ->

272+ back state

184273

185274

186275

@@ -188,59 +277,57 @@ getRelevantVersions name constraint =

188277

189278

190279getConstraints :: Pkg.Name -> V.Version -> Solver Constraints

191−getConstraints name version =

192− Solver $ \state@(State cache connection registry cDict ps) ok err ->

193− do let key = (name, version)

280+getConstraints pkg vsn =

281+ Solver $ \state@(State cache connection registry cDict) ok back err ->

282+ do let key = (pkg, vsn)

194283 case Map.lookup key cDict of

195284 Just cs ->

196− ok state cs err

285+ ok state cs back

197286

198287 Nothing ->

199− do result <- getConstraintsHelp cache connection name version

200− case result of

201− Right cs ->

202− ok (State cache connection registry (Map.insert key cs cDict) ps) cs err

203−

204− Left p ->

205− err (State cache connection registry cDict (p:ps))

206−

207−

208−getConstraintsHelp :: Stuff.PackageCache -> Connection -> Pkg.Name -> V.Version -> IO (Either Problem Constraints)

209−getConstraintsHelp cache connection name version =

210− do let path = Stuff.metadata cache name version "elm.json"

211− outlineExists <- File.exists path

212− if outlineExists

213− then

214− do result <- D.fromFile constraintsDecoder path

215− case result of

216− Right cs ->

217− case connection of

218− Online _ ->

219− return $ Right cs

220−

221− Offline ->

222− do srcExists <- Dir.doesDirectoryExist (Stuff.metadata cache name version "src")

223− if srcExists

224− then return $ Right cs

225− else return $ Left (UnavailableOffline name version)

226−

227− Left _ ->

228− do File.remove path

229− return $ Left (BadCacheData name version)

230− else

231− case connection of

232− Offline ->

233− return (Left (UnavailableOffline name version))

234−

235− Online manager ->

236− Http.post manager (Website.metadata name version "elm.json") [] BadHttp $ \body ->

237− case D.fromByteString constraintsDecoder body of

238− Right cs ->

239− do File.writeUtf8 path body

240− return $ Right cs

241−

242− Left _ ->

243− return $ Left (BadHttpData name version)

288+ do let toNewState cs = State cache connection registry (Map.insert key cs cDict)

289+ let home = Stuff.package cache pkg vsn

290+ let path = home </> "elm.json"

291+ outlineExists <- File.exists path

292+ if outlineExists

293+ then

294+ do bytes <- File.readUtf8 path

295+ case D.fromByteString constraintsDecoder bytes of

296+ Right cs ->

297+ case connection of

298+ Online _ ->

299+ ok (toNewState cs) cs back

300+

301+ Offline ->

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

303+ if srcExists

304+ then ok (toNewState cs) cs back

305+ else back state

306+

307+ Left _ ->

308+ do File.remove path

309+ err (Exit.SolverBadCacheData pkg vsn)

310+ else

311+ case connection of

312+ Offline ->

313+ back state

314+

315+ Online manager ->

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

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

318+ case result of

319+ Left httpProblem ->

320+ err (Exit.SolverBadHttp pkg vsn httpProblem)

321+

322+ Right body ->

323+ case D.fromByteString constraintsDecoder body of

324+ Right cs ->

325+ do Dir.createDirectoryIfMissing True home

326+ File.writeUtf8 path body

327+ ok (toNewState cs) cs back

328+

329+ Left _ ->

330+ err (Exit.SolverBadHttpData pkg vsn url)

244331

245332

246333constraintsDecoder :: D.Decoder () Constraints

@@ -255,46 +342,83 @@ constraintsDecoder =

255342

256343

257344

345+-- ENVIRONMENT

346+

347+

348+data Env =

349+ Env Stuff.PackageCache Http.Manager Connection Registry.Registry

350+

351+

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

353+initEnv =

354+ do mvar <- newEmptyMVar

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

356+ cache <- Stuff.getPackageCache

357+ Stuff.withRegistryLock cache $

358+ do maybeRegistry <- Registry.read cache

359+ manager <- readMVar mvar

360+

361+ case maybeRegistry of

362+ Nothing ->

363+ do eitherRegistry <- Registry.fetch manager cache

364+ case eitherRegistry of

365+ Right latestRegistry ->

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

367+

368+ Left problem ->

369+ return $ Left $ problem

370+

371+ Just cachedRegistry ->

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

373+ case eitherRegistry of

374+ Right latestRegistry ->

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

376+

377+ Left _ ->

378+ return $ Right $ Env cache manager Offline cachedRegistry

379+

380+

381+

258382-- INSTANCES

259383

260384

261385instance Functor Solver where

262386 fmap func (Solver solver) =

263− Solver $ \state ok err ->

387+ Solver $ \state ok back err ->

264388 let

265− okA stateA arg errA = ok stateA (func arg) errA

389+ okA stateA arg backA = ok stateA (func arg) backA

266390 in

267− solver state okA err

391+ solver state okA back err

268392

269393

270394instance Applicative Solver where

271395 pure a =

272− Solver $ \state ok err -> ok state a err

396+ Solver $ \state ok back _ -> ok state a back

273397

274398 (<*>) (Solver solverFunc) (Solver solverArg) =

275− Solver $ \state ok err ->

399+ Solver $ \state ok back err ->

276400 let

277− okF stateF func errF =

401+ okF stateF func backF =

278402 let

279− okA stateA arg errA = ok stateA (func arg) errA

403+ okA stateA arg backA = ok stateA (func arg) backA

280404 in

281− solverArg stateF okA errF

405+ solverArg stateF okA backF err

282406 in

283− solverFunc state okF err

407+ solverFunc state okF back err

284408

285409

286410instance Monad Solver where

287411 return a =

288− Solver $ \state ok err -> ok state a err

412+ Solver $ \state ok back _ -> ok state a back

289413

290414 (>>=) (Solver solverA) callback =

291− Solver $ \state ok err ->

415+ Solver $ \state ok back err ->

292416 let

293− okA stateA a errA =

417+ okA stateA a backA =

294418 case callback a of

295− Solver solverB -> solverB stateA ok errA

419+ Solver solverB -> solverB stateA ok backA err

296420 in

297− solverA state okA err

421+ solverA state okA back err

298422

299423

300424oneOf :: Solver a -> [Solver a] -> Solver a

@@ -304,19 +428,17 @@ oneOf solver@(Solver solverHead) solvers =

304428 solver

305429

306430 s:ss ->

307− Solver $ \state0 ok err ->

308− solverHead state0 ok $ \state1 ->

309− let

310− (Solver solverTail) = oneOf s ss

311− in

312− solverTail state1 ok err

313−

314−

315−deadend :: Solver a

316−deadend =

317− Solver $ \state _ err -> err state

318−

319−

320−addProblem :: Problem -> State -> State

321−addProblem problem (State cache registry cDict maybeManager problems) =

322− State cache registry cDict maybeManager (problem:problems)

431+ Solver $ \state0 ok back err ->

432+ let

433+ tryTail state1 =

434+ let

435+ (Solver solverTail) = oneOf s ss

436+ in

437+ solverTail state1 ok back err

438+ in

439+ solverHead state0 ok tryTail err

440+

441+

442+backtrack :: Solver a

443+backtrack =

444+ Solver $ \state _ back _ -> back state

builder/src/Deps/Verify.hsdeleted−388

@@ -1,388 +0,0 @@

1−module Deps.Verify

2− ( verify

3− )

4− where

5−

6−

7−import Control.Concurrent (forkIO)

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

9−import Control.Monad (filterM, void)

10−import Control.Monad.Trans (liftIO)

11−import qualified Data.Map as Map

12−import qualified Data.Map.Merge.Strict as Map

13−import qualified Data.Set as Set

14−import System.Directory (doesDirectoryExist)

15−import System.FilePath ((</>))

16−

17−import qualified Deps.Cache as Cache

18−import qualified Deps.Explorer as Explorer

19−import qualified Deps.Solver as Solver

20−import qualified Deps.Website as Website

21−import qualified Elm.Compiler as Compiler

22−import qualified Elm.Compiler.Objects as Obj

23−import qualified Elm.Constraint as Con

24−import qualified Elm.Interface as I

25−import qualified Elm.ModuleName as ModuleName

26−import qualified Elm.Package as Pkg

27−import qualified Elm.PerUserCache as PerUserCache

28−import Elm.Project.Json (Project(..), AppInfo(..), PkgInfo(..))

29−import qualified Elm.Project.Json as Project

30−import qualified Elm.Project.Summary as Summary

31−import qualified Elm.Version as V

32−import qualified File.Args as Args

33−import qualified File.Compile as Compile

34−import qualified File.Crawl as Crawl

35−import qualified File.IO as IO

36−import qualified File.Plan as Plan

37−import qualified Generate.Artifacts as Artifacts

38−import qualified Reporting.Exit as Exit

39−import qualified Reporting.Exit.Deps as E

40−import qualified Reporting.Progress as Progress

41−import qualified Reporting.Task as Task

42−import qualified Stuff.Paths as Paths

43−

44−

45−

46−-- VERIFY

47−

48−

49−verify :: FilePath -> Project -> Task.Task Summary.Summary

50−verify root project =

51− do solution <-

52− case project of

53− Project.App info -> verifyApp info

54− Project.Pkg info -> verifyPkg info

55−

56− (RawInfo infos ifaces) <- verifyArtifacts solution

57− return (Summary.init root project infos ifaces)

58−

59−

60−throw :: E.Exit -> Task.Task a

61−throw exit =

62− Task.throw (Exit.Deps exit)

63−

64−

65−

66−-- VERIFY APP

67−

68−

69−verifyApp :: AppInfo -> Task.Task (Map.Map Pkg.Name V.Version)

70−verifyApp info =

71− if _app_elm_version info /= V.compiler then

72− throw (E.AppBadElm (_app_elm_version info))

73−

74− else

75− do oldSolution <- appToSolution info

76− let solver = Solver.solve (Map.map Con.exactly oldSolution)

77− registry <- Cache.optionalUpdate

78− maybeSolution <- Explorer.run registry (Solver.run solver)

79− case maybeSolution of

80− Nothing ->

81− throw E.BadDeps

82−

83− Just newSolution ->

84− if Map.size oldSolution == Map.size newSolution then

85− return newSolution

86− else

87− throw (E.AppMissingTrans (Map.toList (Map.difference newSolution oldSolution)))

88−

89−

90−

91−-- VERIFY PKG

92−

93−

94−verifyPkg :: PkgInfo -> Task.Task (Map.Map Pkg.Name V.Version)

95−verifyPkg info =

96− if not (Con.goodElm (_pkg_elm_version info)) then

97− throw (E.PkgBadElm (_pkg_elm_version info))

98−

99− else

100− do deps <- union noDups (_pkg_deps info) (_pkg_test_deps info)

101− let solver = Solver.solve deps

102− registry <- Cache.optionalUpdate

103− maybeSolution <- Explorer.run registry (Solver.run solver)

104− case maybeSolution of

105− Nothing ->

106− throw E.BadDeps

107−

108− Just solution ->

109− return solution

110−

111−

112−

113−-- APP TO SOLUTION

114−

115−

116−appToSolution :: Project.AppInfo -> Task.Task (Map.Map Pkg.Name V.Version)

117−appToSolution (Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =

118− do a <- union allowEqualDups depsTrans testDirect

119− b <- union noDups depsDirect testTrans

120− union noDups a b

121−

122−

123−noDups :: Pkg.Name -> a -> a -> Task.Task a

124−noDups _ _ _ =

125− throw E.BadDeps

126−

127−

128−allowEqualDups :: Pkg.Name -> V.Version -> V.Version -> Task.Task V.Version

129−allowEqualDups _ v1 v2 =

130− if v1 == v2 then

131− return v1

132− else

133− throw E.BadDeps

134−

135−

136−union :: (Pkg.Name -> a -> a -> Task.Task a) -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Task.Task (Map.Map Pkg.Name a)

137−union tieBreaker deps1 deps2 =

138− Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2

139−

140−

141−

142−-- VERIFY ARTIFACTS

143−

144−

145−verifyArtifacts :: Map.Map Pkg.Name V.Version -> Task.Task RawInfo

146−verifyArtifacts solution =

147− do Website.download =<< filterM noSrc (Map.toList solution)

148− verifyBuildArtifacts solution

149−

150−

151−noSrc :: (Pkg.Name, V.Version) -> Task.Task Bool

152−noSrc (name, version) =

153− do root <- Task.getPackageCacheDirFor name version

154− liftIO $ not <$> doesDirectoryExist (root </> "src")

155−

156−

157−

158−-- VERIFY BUILD ARTIFACTS

159−

160−

161−verifyBuildArtifacts :: Map.Map Pkg.Name V.Version -> Task.Task RawInfo

162−verifyBuildArtifacts solution =

163− do Task.report (Progress.BuildDepsStart (Map.size solution))

164− startMVar <- liftIO newEmptyMVar

165− ifacesMVar <- liftIO $ newMVar Map.empty

166− pkgInfoMVars <- Map.traverseWithKey (verifyBuild startMVar ifacesMVar) solution

167− liftIO $ putMVar startMVar pkgInfoMVars

168− answers <- liftIO $ traverse readMVar pkgInfoMVars

169− Task.report Progress.BuildDepsEnd

170− RawInfo

171− <$> Map.traverseMaybeWithKey toInfo answers

172− <*> liftIO (readMVar ifacesMVar)

173−

174−

175−data RawInfo =

176− RawInfo (Map.Map Pkg.Name PkgInfo) I.Interfaces

177−

178−

179−verifyBuild

180− :: MVar (Map.Map Pkg.Name (MVar Answer))

181− -> MVar I.Interfaces

182− -> Pkg.Name

183− -> V.Version

184− -> Task.Task (MVar Answer)

185−verifyBuild pkgInfoMVar ifacesMVar name version =

186− do mvar <- liftIO newEmptyMVar

187− info <- Cache.getElmJson name version

188− report <- Task.getReporter

189− runner <- Task.getSilentRunner

190−

191− liftIO $ void $ forkIO $

192− do allMVars <- readMVar pkgInfoMVar

193− let deps = Project._pkg_deps info

194− let depsMVars = Map.intersection allMVars deps

195− depAnswers <- traverse readMVar depsMVars

196−

197− answer <- ifNotBlocked depAnswers $ \infos ->

198− do ifacesBefore <- readMVar ifacesMVar

199− result <- runner (getIface name version info infos ifacesBefore)

200− case result of

201− Right ifaces ->

202− do ifacesNow <- takeMVar ifacesMVar

203− putMVar ifacesMVar (Map.union ifacesNow ifaces)

204− return (Ok info)

205−

206− Left _ ->

207− return (Err name version)

208−

209− report Progress.BuildDepsProgress

210− putMVar mvar answer

211−

212− return mvar

213−

214−

215−

216−-- ANSWERS

217−

218−

219−data Answer

220− = Ok PkgInfo

221− | Blocked

222− | Err Pkg.Name V.Version

223−

224−

225−toInfo :: Pkg.Name -> Answer -> Task.Task (Maybe PkgInfo)

226−toInfo _ answer =

227− case answer of

228− Ok info ->

229− return (Just info)

230−

231− Blocked ->

232− return Nothing

233−

234− Err name version ->

235− do elmHome <- liftIO PerUserCache.getElmHome

236− throw (E.BuildFailure elmHome name version)

237−

238−

239−ifNotBlocked :: Map.Map Pkg.Name Answer -> (Map.Map Pkg.Name PkgInfo -> IO Answer) -> IO Answer

240−ifNotBlocked answers callback =

241− case traverse isOk answers of

242− Nothing ->

243− return Blocked

244−

245− Just infos ->

246− callback infos

247−

248−

249−isOk :: Answer -> Maybe PkgInfo

250−isOk answer =

251− case answer of

252− Ok info -> Just info

253− Blocked -> Nothing

254− Err _ _ -> Nothing

255−

256−

257−

258−-- GET INTERFACE

259−

260−

261−getIface

262− :: Pkg.Name

263− -> V.Version

264− -> PkgInfo

265− -> Map.Map Pkg.Name PkgInfo

266− -> I.Interfaces

267− -> Task.Task I.Interfaces

268−getIface name version info infos depIfaces =

269− do root <- Task.getPackageCacheDirFor name version

270− let solution = Map.map _pkg_version infos

271−

272− cached <- liftIO $ isCached root solution

273−

274− if cached

275− then

276− do maybeIfaces <- liftIO $ IO.readBinary (root </> "ifaces.dat")

277− maybe (Task.throw (error "TODO corrupt binary 1")) return maybeIfaces

278− else

279− do Paths.removeStuff root

280− let summary = Summary.cheapInit root info infos depIfaces

281− args <- Args.fromSummary summary

282− graph <- Crawl.crawl summary args

283− (dirty, cachedIfaces) <- Plan.plan summary graph

284− answers <- Compile.compile (Pkg info) cachedIfaces dirty

285− results <- Artifacts.ignore answers

286− Paths.removeStuff root

287−

288− updateCache root name info solution graph results

289−

290−

291−

292−-- IS CACHED?

293−

294−

295−isCached :: FilePath -> Map.Map Pkg.Name V.Version -> IO Bool

296−isCached root solution =

297− IO.andM

298− [ IO.exists (root </> "cached.dat")

299− , IO.exists (root </> "ifaces.dat")

300− , IO.exists (root </> "objs.dat")

301− , isCachedHelp solution <$> IO.readBinary (root </> "cached.dat")

302− ]

303−

304−

305−isCachedHelp :: Map.Map Pkg.Name V.Version -> Maybe (Map.Map Pkg.Name (Set.Set V.Version)) -> Bool

306−isCachedHelp solution maybeCachedDeps =

307− case maybeCachedDeps of

308− Nothing ->

309− False

310−

311− Just cachedDeps ->

312− let

313− matches =

314− Map.intersectionWith Set.member solution cachedDeps

315− in

316− Map.size solution == Map.size matches

317− && Map.foldr (&&) True matches

318−

319−

320−

321−-- UPDATE CACHE

322−

323−

324−updateCache

325− :: FilePath

326− -> Pkg.Name

327− -> PkgInfo

328− -> Map.Map Pkg.Name V.Version

329− -> Crawl.Result

330− -> Map.Map ModuleName.Raw Compiler.Artifacts

331− -> Task.Task I.Interfaces

332−updateCache root name info solution graph results =

333− do let path = root </> "cached.dat"

334− let deps = Map.map Set.singleton solution

335− let elmi = crush name info results

336−

337− exists <- liftIO $ IO.exists path

338−

339− if exists

340− then

341− do maybeOldDeps <- liftIO $ IO.readBinary path

342− oldDeps <- maybe (error "TODO corrupt binary 2") return maybeOldDeps

343− liftIO $ IO.writeBinary path (Map.unionWith Set.union deps oldDeps)

344− else

345− liftIO $

346− do IO.writeBinary (root </> "ifaces.dat") elmi

347− IO.writeBinary path deps

348− IO.writeBinary (root </> "objs.dat") $

349− Map.foldr addGraph (objGraphFromKernels graph) results

350−

351− return elmi

352−

353−

354−

355−-- CRUSH INTERFACES

356−

357−

358−crush :: Pkg.Name -> PkgInfo -> Map.Map ModuleName.Raw Compiler.Artifacts -> I.Interfaces

359−crush pkg info results =

360− let

361− exposed =

362− Set.fromList (Project.getExposed info)

363− in

364− Map.mapKeys (ModuleName.Canonical pkg) $

365− Map.mapMaybeWithKey (crushHelp exposed) results

366−

367−

368−crushHelp :: Set.Set ModuleName.Raw -> ModuleName.Raw -> Compiler.Artifacts -> Maybe I.Interface

369−crushHelp exposed name (Compiler.Artifacts elmi _) =

370− if Set.member name exposed then

371− Just elmi

372−

373− else

374− Nothing

375−

376−

377−

378−-- OBJECT GRAPH

379−

380−

381−addGraph :: Compiler.Artifacts -> Obj.Graph -> Obj.Graph

382−addGraph (Compiler.Artifacts _ elmo) graph =

383− Obj.union elmo graph

384−

385−

386−objGraphFromKernels :: Crawl.Result -> Obj.Graph

387−objGraphFromKernels (Crawl.Graph _ _ kernels _ _) =

388− Obj.fromKernels kernels

builder/src/Elm/Bump.hsdeleted−137

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

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+746−17

@@ -1,28 +1,49 @@

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

23module Elm.Details

34 ( Details(..)

5+ , BuildID

46 , ValidOutline(..)

57 , Local(..)

68 , Foreign(..)

9+ , load

10+ , loadObjects

11+ , loadInterfaces

12+ , verifyInstall

713 )

814 where

915

1016

1117import Control.Concurrent (forkIO)

12−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)

13−import Control.Monad (liftM, liftM2, liftM3, liftM4)

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

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

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

21+import qualified Data.Either as Either

1522import qualified Data.Map as Map

23+import qualified Data.Map.Utils as Map

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

25+import qualified Data.Maybe as Maybe

26+import qualified Data.Name as Name

27+import qualified Data.NonEmptyList as NE

28+import qualified Data.OneOrMore as OneOrMore

1729import qualified Data.Set as Set

1830import qualified Data.Utf8 as Utf8

19−import System.Directory (doesDirectoryExist)

20−import System.FilePath ((</>))

31+import Data.Word (Word64)

32+import qualified System.Directory as Dir

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

2134

35+import qualified AST.Canonical as Can

36+import qualified AST.Source as Src

37+import qualified AST.Optimized as Opt

38+import qualified BackgroundWriter as BW

39+import qualified Compile

2240import qualified Deps.Registry as Registry

2341import qualified Deps.Solver as Solver

42+import qualified Deps.Website as Website

2443import qualified Elm.Constraint as Con

44+import qualified Elm.Docs as Docs

2545import qualified Elm.Interface as I

46+import qualified Elm.Kernel as Kernel

2647import qualified Elm.ModuleName as ModuleName

2748import qualified Elm.Outline as Outline

2849import qualified Elm.Package as Pkg

@@ -30,8 +51,11 @@ import qualified Elm.Version as V

3051import qualified File

3152import qualified Http

3253import qualified Json.Decode as D

54+import qualified Json.Encode as E

55+import qualified Parse.Module as Parse

56+import qualified Reporting

57+import qualified Reporting.Annotation as A

3358import qualified Reporting.Exit as Exit

34−import qualified Reporting.Progress as Progress

3559import qualified Reporting.Task as Task

3660import qualified Stuff

3761

@@ -44,21 +68,42 @@ data Details =

4468 Details

4569 { _outlineTime :: File.Time

4670 , _outline :: ValidOutline

71+ , _buildID :: BuildID

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

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

74+ , _extras :: Extras

4975 }

5076

5177

78+type BuildID = Word64

79+

80+

5281data ValidOutline

53− = ValidApp Outline.AppOutline

54− | ValidPkg Outline.PkgOutline (Map.Map Pkg.Name V.Version)

82+ = ValidApp (NE.List Outline.SrcDir)

83+ | ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})

5584

5685

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

5799data Local =

58100 Local

59101 { _path :: FilePath

60102 , _time :: File.Time

61103 , _deps :: [ModuleName.Raw]

104+ , _main :: Bool

105+ , _lastChange :: BuildID

106+ , _lastCompile :: BuildID

62107 }

63108

64109

@@ -66,32 +111,711 @@ data Foreign =

66111 Foreign Pkg.Name [Pkg.Name]

67112

68113

114+data Extras

115+ = ArtifactsCached

116+ | ArtifactsFresh Interfaces Opt.GlobalGraph

117+

118+

119+type Interfaces =

120+ Map.Map ModuleName.Canonical I.DependencyInterface

121+

122+

123+

124+-- LOAD ARTIFACTS

125+

126+

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

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

129+ case extras of

130+ ArtifactsFresh _ o -> newMVar (Just o)

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

132+

133+

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

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

136+ case extras of

137+ ArtifactsFresh i _ -> newMVar (Just i)

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

139+

140+

141+

142+-- VERIFY INSTALL -- used by Install

143+

144+

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

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

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

148+ let key = Reporting.ignorer

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

150+ case outline of

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

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

153+

154+

155+

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

157+

158+

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

160+load style scope root =

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

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

163+ case maybeDetails of

164+ Nothing ->

165+ generate style scope root newTime

166+

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

168+ if oldTime == newTime

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

170+ else generate style scope root newTime

171+

172+

173+

174+-- GENERATE

175+

176+

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

178+generate style scope root time =

179+ Reporting.trackDetails style $ \key ->

180+ do result <- initEnv key scope root

181+ case result of

182+ Left exit ->

183+ return (Left exit)

184+

185+ Right (env, outline) ->

186+ case outline of

187+ Outline.Pkg pkg -> Task.run (verifyPkg env time pkg)

188+ Outline.App app -> Task.run (verifyApp env time app)

189+

190+

191+

192+-- ENV

193+

194+

195+data Env =

196+ Env

197+ { _key :: Reporting.DKey

198+ , _scope :: BW.Scope

199+ , _root :: FilePath

200+ , _cache :: Stuff.PackageCache

201+ , _manager :: Http.Manager

202+ , _connection :: Solver.Connection

203+ , _registry :: Registry.Registry

204+ }

205+

206+

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

208+initEnv key scope root =

209+ do mvar <- fork Solver.initEnv

210+ eitherOutline <- Outline.read root

211+ case eitherOutline of

212+ Left problem ->

213+ return $ Left $ Exit.DetailsBadOutline problem

214+

215+ Right outline ->

216+ do maybeEnv <- readMVar mvar

217+ case maybeEnv of

218+ Left problem ->

219+ return $ Left $ Exit.DetailsCannotGetRegistry problem

220+

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

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

223+

224+

225+

226+-- VERIFY PROJECT

227+

228+

229+type Task a = Task.Task Exit.Details a

230+

231+

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

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

234+ if Con.goodElm elm

235+ then

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

237+ let exposedList = Outline.flattenExposed exposed

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

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

240+ else

241+ Task.throw $ Exit.DetailsBadElmInPkg elm

242+

243+

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

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

246+ if elmVersion == V.compiler

247+ then

248+ do stated <- checkAppDeps outline

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

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

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

252+ else Task.throw $ Exit.DetailsHandEditedDependencies

253+ else

254+ Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion

255+

256+

257+checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)

258+checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =

259+ do x <- union allowEqualDups indirect testDirect

260+ y <- union noDups direct testIndirect

261+ union noDups x y

262+

263+

264+

265+-- VERIFY CONSTRAINTS

266+

267+

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

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

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

271+ case result of

272+ Solver.Ok details -> return details

273+ Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution

274+ Solver.NoOfflineSolution -> Task.throw $ Exit.DetailsNoOfflineSolution

275+ Solver.Err exit -> Task.throw $ Exit.DetailsSolverProblem exit

276+

277+

278+

279+-- UNION

280+

281+

282+union :: (Ord k) => (k -> v -> v -> Task v) -> Map.Map k v -> Map.Map k v -> Task (Map.Map k v)

283+union tieBreaker deps1 deps2 =

284+ Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2

285+

286+

287+noDups :: k -> v -> v -> Task v

288+noDups _ _ _ =

289+ Task.throw Exit.DetailsHandEditedDependencies

290+

291+

292+allowEqualDups :: (Eq v) => k -> v -> v -> Task v

293+allowEqualDups _ v1 v2 =

294+ if v1 == v2

295+ then return v1

296+ else Task.throw Exit.DetailsHandEditedDependencies

297+

298+

299+

300+-- FORK

301+

302+

303+fork :: IO a -> IO (MVar a)

304+fork work =

305+ do mvar <- newEmptyMVar

306+ _ <- forkIO $ putMVar mvar =<< work

307+ return mvar

308+

309+

310+

311+-- VERIFY DEPENDENCIES

312+

313+

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

315+verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps =

316+ Task.eio id $

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

318+ mvar <- newEmptyMVar

319+ mvars <- Stuff.withRegistryLock cache $

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

321+ putMVar mvar mvars

322+ deps <- traverse readMVar mvars

323+ case sequence deps of

324+ Left _ ->

325+ do home <- Stuff.getElmHome

326+ return $ Left $ Exit.DetailsBadDeps home $

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

328+

329+ Right artifacts ->

330+ let

331+ objs = Map.foldr addObjects Opt.empty artifacts

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

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

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

335+ in

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

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

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

339+ return (Right details)

340+

341+

342+addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph

343+addObjects (Artifacts _ objs) graph =

344+ Opt.addGlobalGraph objs graph

345+

346+

347+addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces

348+addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =

349+ Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $

350+ if Map.member pkg directDeps

351+ then ifaces

352+ else Map.map I.privatize ifaces

353+

354+

355+gatherForeigns :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore Pkg.Name)

356+gatherForeigns pkg (Artifacts ifaces _) foreigns =

357+ let

358+ isPublic di =

359+ case di of

360+ I.Public _ -> Just (OneOrMore.one pkg)

361+ I.Private _ _ _ -> Nothing

362+ in

363+ Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)

364+

365+

366+

367+-- VERIFY DEPENDENCY

368+

369+

370+data Artifacts =

371+ Artifacts

372+ { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface

373+ , _objects :: Opt.GlobalGraph

374+ }

375+

376+

377+type Dep =

378+ Either (Maybe Exit.DetailsBadDep) Artifacts

379+

380+

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

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

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

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

385+ if exists

386+ then

387+ do Reporting.report key Reporting.DCached

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

389+ case maybeCache of

390+ Nothing ->

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

392+

393+ Just (ArtifactCache fingerprints artifacts) ->

394+ if Set.member fingerprint fingerprints

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

396+ else build key cache depsMVar pkg details fingerprint fingerprints

397+ else

398+ do Reporting.report key Reporting.DRequested

399+ result <- downloadPackage cache manager pkg vsn

400+ case result of

401+ Left problem ->

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

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

404+

405+ Right () ->

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

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

408+

409+

410+

411+-- ARTIFACT CACHE

412+

413+

414+data ArtifactCache =

415+ ArtifactCache

416+ { _fingerprints :: Set.Set Fingerprint

417+ , _artifacts :: Artifacts

418+ }

419+

420+

421+type Fingerprint =

422+ Map.Map Pkg.Name V.Version

423+

424+

425+

426+-- BUILD

427+

428+

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

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

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

432+ case eitherOutline of

433+ Left _ ->

434+ do Reporting.report key Reporting.DBroken

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

436+

437+ Right (Outline.App _) ->

438+ do Reporting.report key Reporting.DBroken

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

440+

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

442+ do allDeps <- readMVar depsMVar

443+ directDeps <- traverse readMVar (Map.intersection allDeps deps)

444+ case sequence directDeps of

445+ Left _ ->

446+ do Reporting.report key Reporting.DBroken

447+ return $ Left $ Nothing

448+

449+ Right directArtifacts ->

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

451+ let foreignDeps = gatherForeignInterfaces directArtifacts

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

453+ docsStatus <- getDocsStatus cache pkg vsn

454+ mvar <- newEmptyMVar

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

456+ putMVar mvar mvars

457+ mapM_ readMVar mvars

458+ maybeStatuses <- traverse readMVar =<< readMVar mvar

459+ case sequence maybeStatuses of

460+ Nothing ->

461+ do Reporting.report key Reporting.DBroken

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

463+

464+ Just statuses ->

465+ do rmvar <- newEmptyMVar

466+ rmvars <- traverse (fork . compile pkg rmvar) statuses

467+ putMVar rmvar rmvars

468+ maybeResults <- traverse readMVar rmvars

469+ case sequence maybeResults of

470+ Nothing ->

471+ do Reporting.report key Reporting.DBroken

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

473+

474+ Just results ->

475+ let

476+ path = Stuff.package cache pkg vsn </> "artifacts.dat"

477+ ifaces = gatherInterfaces exposedDict results

478+ objects = gatherObjects results

479+ artifacts = Artifacts ifaces objects

480+ fingerprints = Set.insert f fs

481+ in

482+ do writeDocs cache pkg vsn docsStatus results

483+ File.writeBinary path (ArtifactCache fingerprints artifacts)

484+ Reporting.report key Reporting.DBuilt

485+ return (Right artifacts)

486+

487+

488+

489+-- GATHER

490+

491+

492+gatherObjects :: Map.Map ModuleName.Raw Result -> Opt.GlobalGraph

493+gatherObjects results =

494+ Map.foldrWithKey addLocalGraph Opt.empty results

495+

496+

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

498+addLocalGraph name status graph =

499+ case status of

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

501+ RForeign _ -> graph

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

503+ RKernelForeign -> graph

504+

505+

506+gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface

507+gatherInterfaces exposed artifacts =

508+ let

509+ onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces")

510+ onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface)

511+ onBoth = Map.zipWithMaybeMatched (\_ () iface -> toLocalInterface I.public iface)

512+ in

513+ Map.merge onLeft onRight onBoth exposed artifacts

514+

515+

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

517+toLocalInterface func result =

518+ case result of

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

520+ RForeign _ -> Nothing

521+ RKernelLocal _ -> Nothing

522+ RKernelForeign -> Nothing

523+

524+

525+

526+-- GATHER FOREIGN INTERFACES

527+

528+

529+data ForeignInterface

530+ = ForeignAmbiguous

531+ | ForeignSpecific I.Interface

532+

533+

534+gatherForeignInterfaces :: Map.Map Pkg.Name Artifacts -> Map.Map ModuleName.Raw ForeignInterface

535+gatherForeignInterfaces directArtifacts =

536+ Map.map (OneOrMore.destruct finalize) $

537+ Map.foldrWithKey gather Map.empty directArtifacts

538+ where

539+ finalize :: I.Interface -> [I.Interface] -> ForeignInterface

540+ finalize i is =

541+ case is of

542+ [] -> ForeignSpecific i

543+ _:_ -> ForeignAmbiguous

544+

545+ gather :: Pkg.Name -> Artifacts -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface) -> Map.Map ModuleName.Raw (OneOrMore.OneOrMore I.Interface)

546+ gather _ (Artifacts ifaces _) buckets =

547+ Map.unionWith OneOrMore.more buckets (Map.mapMaybe isPublic ifaces)

548+

549+ isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)

550+ isPublic di =

551+ case di of

552+ I.Public iface -> Just (OneOrMore.one iface)

553+ I.Private _ _ _ -> Nothing

554+

555+

556+

557+-- CRAWL

558+

559+

560+type StatusDict =

561+ Map.Map ModuleName.Raw (MVar (Maybe Status))

562+

563+

564+data Status

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

566+ | SForeign I.Interface

567+ | SKernelLocal [Kernel.Chunk]

568+ | SKernelForeign

569+

570+

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

572+crawlModule foreignDeps mvar pkg src docsStatus name =

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

574+ exists <- File.exists path

575+ case Map.lookup name foreignDeps of

576+ Just ForeignAmbiguous ->

577+ return Nothing

578+

579+ Just (ForeignSpecific iface) ->

580+ if exists

581+ then return Nothing

582+ else return (Just (SForeign iface))

583+

584+ Nothing ->

585+ if exists then

586+ crawlFile foreignDeps mvar pkg src docsStatus name path

587+

588+ else if Pkg.isKernel pkg && Name.isKernel name then

589+ crawlKernel foreignDeps mvar pkg src name

590+

591+ else

592+ return Nothing

593+

594+

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

596+crawlFile foreignDeps mvar pkg src docsStatus expectedName path =

597+ do bytes <- File.readUtf8 path

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

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

600+ do deps <- crawlImports foreignDeps mvar pkg src imports

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

602+

603+ _ ->

604+ return Nothing

605+

606+

607+crawlImports :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> [Src.Import] -> IO (Map.Map ModuleName.Raw ())

608+crawlImports foreignDeps mvar pkg src imports =

609+ do statusDict <- takeMVar mvar

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

611+ let news = Map.difference deps statusDict

612+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src DocsNotNeeded) news

613+ putMVar mvar (Map.union mvars statusDict)

614+ mapM_ readMVar mvars

615+ return deps

616+

617+

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

619+crawlKernel foreignDeps mvar pkg src name =

620+ do let path = src </> ModuleName.toFilePath name <.> "js"

621+ exists <- File.exists path

622+ if exists

623+ then

624+ do bytes <- File.readUtf8 path

625+ case Kernel.fromByteString pkg (Map.mapMaybe getDepHome foreignDeps) bytes of

626+ Nothing ->

627+ return Nothing

628+

629+ Just (Kernel.Content imports chunks) ->

630+ do _ <- crawlImports foreignDeps mvar pkg src imports

631+ return (Just (SKernelLocal chunks))

632+ else

633+ return (Just SKernelForeign)

634+

635+

636+getDepHome :: ForeignInterface -> Maybe Pkg.Name

637+getDepHome fi =

638+ case fi of

639+ ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg

640+ ForeignAmbiguous -> Nothing

641+

642+

643+

644+-- COMPILE

645+

646+

647+data Result

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

649+ | RForeign I.Interface

650+ | RKernelLocal [Kernel.Chunk]

651+ | RKernelForeign

652+

653+

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

655+compile pkg mvar status =

656+ case status of

657+ SLocal docsStatus deps modul ->

658+ do resultsDict <- readMVar mvar

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

660+ case sequence maybeResults of

661+ Nothing ->

662+ return Nothing

663+

664+ Just results ->

665+ case Compile.compile pkg (Map.mapMaybe getInterface results) modul of

666+ Left _ ->

667+ return Nothing

668+

669+ Right (Compile.Artifacts canonical annotations objects) ->

670+ let

671+ ifaces = I.fromModule pkg canonical annotations

672+ docs = makeDocs docsStatus canonical

673+ in

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

675+

676+ SForeign iface ->

677+ return (Just (RForeign iface))

678+

679+ SKernelLocal chunks ->

680+ return (Just (RKernelLocal chunks))

681+

682+ SKernelForeign ->

683+ return (Just RKernelForeign)

684+

685+

686+getInterface :: Result -> Maybe I.Interface

687+getInterface result =

688+ case result of

689+ RLocal iface _ _ -> Just iface

690+ RForeign iface -> Just iface

691+ RKernelLocal _ -> Nothing

692+ RKernelForeign -> Nothing

693+

694+

695+

696+-- MAKE DOCS

697+

698+

699+data DocsStatus

700+ = DocsNeeded

701+ | DocsNotNeeded

702+

703+

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

705+getDocsStatus cache pkg vsn =

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

707+ if exists

708+ then return DocsNotNeeded

709+ else return DocsNeeded

710+

711+

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

713+makeDocs status modul =

714+ case status of

715+ DocsNeeded ->

716+ case Docs.fromModule modul of

717+ Right docs -> Just docs

718+ Left _ -> Nothing

719+

720+ DocsNotNeeded ->

721+ Nothing

722+

723+

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

725+writeDocs cache pkg vsn status results =

726+ case status of

727+ DocsNeeded ->

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

729+ Docs.encode $ Map.mapMaybe toDocs results

730+

731+ DocsNotNeeded ->

732+ return ()

733+

734+

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

736+toDocs result =

737+ case result of

738+ RLocal _ _ docs -> docs

739+ RForeign _ -> Nothing

740+ RKernelLocal _ -> Nothing

741+ RKernelForeign -> Nothing

742+

743+

744+

745+-- DOWNLOAD PACKAGE

746+

747+

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

749+downloadPackage cache manager pkg vsn =

750+ let

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

752+ in

753+ do eitherByteString <-

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

755+

756+ case eitherByteString of

757+ Left err ->

758+ return $ Left $ Exit.PP_BadEndpointRequest err

759+

760+ Right byteString ->

761+ case D.fromByteString endpointDecoder byteString of

762+ Left _ ->

763+ return $ Left $ Exit.PP_BadEndpointContent url

764+

765+ Right (endpoint, expectedHash) ->

766+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $

767+ \(sha, archive) ->

768+ if expectedHash == Http.shaToChars sha

769+ then Right <$> File.writePackage (Stuff.package cache pkg vsn) archive

770+ else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha)

771+

772+

773+endpointDecoder :: D.Decoder e (String, String)

774+endpointDecoder =

775+ do url <- D.field "url" D.string

776+ hash <- D.field "hash" D.string

777+ return (Utf8.toChars url, Utf8.toChars hash)

778+

779+

69780

70781-- BINARY

71782

72783

73784instance Binary Details where

74− get = liftM4 Details get get get get

75− put (Details a b c d) = put a >> put b >> put c >> put d

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)

76793

77794

78795instance Binary ValidOutline where

79796 put outline =

80797 case outline of

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

82− ValidPkg a b -> putWord8 1 >> put a >> put b

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

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

83800

84801 get =

85802 do n <- getWord8

86803 case n of

87804 0 -> liftM ValidApp get

88− 1 -> liftM2 ValidPkg get get

89− _ -> error "binary encoding of ValidOutline was corrupted"

805+ 1 -> liftM3 ValidPkg get get get

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

90807

91808

92809instance Binary Local where

93− get = liftM3 Local get get get

94− put (Local a b c) = put a >> put b >> put c

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)

95819

96820

97821instance Binary Foreign where

@@ -100,5 +824,10 @@ instance Binary Foreign where

100824

101825

102826instance Binary Artifacts where

103− get = liftM3 Artifacts get get get

104− put (Artifacts a b c) = put a >> put b >> put c

827+ get = liftM2 Artifacts get get

828+ put (Artifacts a b) = put a >> put b

829+

830+

831+instance Binary ArtifactCache where

832+ get = liftM2 ArtifactCache get get

833+ put (ArtifactCache a b) = put a >> put b

builder/src/Elm/Diff.hsdeleted−284

@@ -1,284 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Elm.Diff

4− ( Args(..)

5− , diff

6− )

7− where

8−

9−

10−import Control.Monad.Except (liftIO)

11−import qualified Data.List as List

12−import qualified Data.Map as Map

13−import qualified Data.Maybe as Maybe

14−import qualified Data.Name as Name

15−

16−import qualified Deps.Cache as Cache

17−import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))

18−import qualified Deps.Diff as Diff

19−import qualified Elm.Compiler.Type as Type

20−import qualified Elm.Docs as Docs

21−import qualified Elm.ModuleName as ModuleName

22−import qualified Elm.Package as Pkg

23−import qualified Elm.Project as Project

24−import qualified Elm.Project.Json as Project

25−import qualified Elm.Project.Summary as Summary

26−import qualified Elm.Version as V

27−import Reporting.Doc ((<>), (<+>))

28−import qualified Reporting.Doc as D

29−import qualified Reporting.Exit as Exit

30−import qualified Reporting.Exit.Diff as E

31−import qualified Reporting.Exit.Help as Help

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

33−import qualified Reporting.Task as Task

34−

35−

36−

37−-- DIFF

38−

39−

40−data Args

41− = CodeVsLatest

42− | CodeVsExactly V.Version

43− | LocalInquiry V.Version V.Version

44− | GlobalInquiry Pkg.Name V.Version V.Version

45−

46−

47−diff :: Args -> Task.Task ()

48−diff args =

49− case args of

50− GlobalInquiry name v1 v2 ->

51− do registry <- Cache.mandatoryUpdate

52− case Cache.getVersions name registry of

53− Left suggestions ->

54− throw $ E.UnknownPackage name suggestions

55−

56− Right vsns ->

57− do oldDocs <- getDocs name vsns (min v1 v2)

58− newDocs <- getDocs name vsns (max v1 v2)

59− writeDiff oldDocs newDocs

60−

61− LocalInquiry v1 v2 ->

62− do (_, name, vsns) <- getPackageInfo

63− oldDocs <- getDocs name vsns (min v1 v2)

64− newDocs <- getDocs name vsns (max v1 v2)

65− writeDiff oldDocs newDocs

66−

67− CodeVsLatest ->

68− do (summary, name, vsns) <- getPackageInfo

69− oldDocs <- getDocs name vsns (maximum vsns)

70− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)

71− writeDiff oldDocs newDocs

72−

73− CodeVsExactly version ->

74− do (summary, name, vsns) <- getPackageInfo

75− oldDocs <- getDocs name vsns version

76− newDocs <- Task.silently (error "TODO Project.generateDocs summary" summary)

77− writeDiff oldDocs newDocs

78−

79−

80−throw :: E.Exit -> Task.Task a

81−throw exit =

82− Task.throw $ Exit.Diff exit

83−

84−

85−

86−-- DIFF HELPERS

87−

88−

89−getDocs :: Pkg.Name -> [V.Version] -> V.Version -> Task.Task Docs.Documentation

90−getDocs name allVersions version =

91− if elem version allVersions then

92− Cache.getDocs name version

93− else

94− throw $ E.UnknownVersion name version allVersions

95−

96−

97−getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [V.Version])

98−getPackageInfo =

99− do summary <- Project.getRoot

100− case Summary._project summary of

101− Project.App _ ->

102− throw $ E.Application

103−

104− Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->

105− do registry <- Cache.mandatoryUpdate

106− case Cache.getVersions name registry of

107− Right vsns ->

108− return ( summary, name, vsns )

109−

110− Left _ ->

111− throw E.Unpublished

112−

113−

114−

115−-- WRITE DOC

116−

117−

118−writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()

119−writeDiff oldDocs newDocs =

120− let

121− changes = Diff.diff oldDocs newDocs

122− localizer = L.fromNames (Map.union oldDocs newDocs)

123− in

124− liftIO $ Help.toStdout (toDoc localizer changes <> "\n")

125−

126−

127−

128−-- TO DOC

129−

130−

131−toDoc :: L.Localizer -> PackageChanges -> D.Doc

132−toDoc localizer changes@(PackageChanges added changed removed) =

133− if null added && Map.null changed && null removed then

134− "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."

135− else

136− let

137− magDoc =

138− D.fromChars (Diff.magnitudeToString (Diff.toMagnitude changes))

139−

140− header =

141− "This is a" <+> D.green magDoc <+> "change."

142−

143− addedChunk =

144− if null added then [] else

145− [ Chunk "ADDED MODULES" MINOR $

146− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) added

147− ]

148−

149− removedChunk =

150− if null removed then [] else

151− [ Chunk "REMOVED MODULES" MAJOR $

152− D.vcat $ map (D.fromUtf8 . ModuleName.nameToString) removed

153− ]

154−

155− chunks =

156− addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)

157− in

158− D.vcat (header : "" : map chunkToDoc chunks)

159−

160−

161−data Chunk =

162− Chunk

163− { _title :: String

164− , _magnitude :: Magnitude

165− , _details :: D.Doc

166− }

167−

168−

169−chunkToDoc :: Chunk -> D.Doc

170−chunkToDoc (Chunk title magnitude details) =

171− let

172− magDoc =

173− Diff.magnitudeToString magnitude

174−

175− header =

176− "----" <+> D.fromChars title <+> "-" <+> D.fromChars magDoc <+> "----"

177− in

178− D.vcat

179− [ D.dullcyan header

180− , ""

181− , D.indent 4 details

182− , ""

183− , ""

184− ]

185−

186−

187−changesToChunk :: L.Localizer -> (Name.Name, ModuleChanges) -> Chunk

188−changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =

189− let

190− magnitude =

191− Diff.moduleChangeMagnitude changes

192−

193− (unionAdd, unionChange, unionRemove) =

194− changesToDocTriple (unionToDoc localizer) unions

195−

196− (aliasAdd, aliasChange, aliasRemove) =

197− changesToDocTriple (aliasToDoc localizer) aliases

198−

199− (valueAdd, valueChange, valueRemove) =

200− changesToDocTriple (valueToDoc localizer) values

201−

202− (binopAdd, binopChange, binopRemove) =

203− changesToDocTriple (binopToDoc localizer) binops

204− in

205− Chunk (Name.toChars name) magnitude $

206− D.vcat $ List.intersperse "" $ Maybe.catMaybes $

207− [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd

208− , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove

209− , changesToDoc "Changed" unionChange aliasChange valueChange binopChange

210− ]

211−

212−

213−changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])

214−changesToDocTriple entryToDoc (Changes added changed removed) =

215− let

216− indented (name, value) =

217− D.indent 4 (entryToDoc name value)

218−

219− diffed (name, (oldValue, newValue)) =

220− D.vcat

221− [ " - " <> entryToDoc name oldValue

222− , " + " <> entryToDoc name newValue

223− , ""

224− ]

225− in

226− ( map indented (Map.toList added)

227− , map diffed (Map.toList changed)

228− , map indented (Map.toList removed)

229− )

230−

231−

232−changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc

233−changesToDoc categoryName unions aliases values binops =

234− if null unions && null aliases && null values && null binops then

235− Nothing

236−

237− else

238− Just $ D.vcat $

239− D.fromChars categoryName <> ":" : unions ++ aliases ++ binops ++ values

240−

241−

242−unionToDoc :: L.Localizer -> Name.Name -> Docs.Union -> D.Doc

243−unionToDoc localizer name (Docs.Union _ tvars ctors) =

244− let

245− setup =

246− "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)

247−

248− ctorDoc (ctor, tipes) =

249− typeDoc localizer (Type.Type ctor tipes)

250− in

251− D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))

252−

253−

254−aliasToDoc :: L.Localizer -> Name.Name -> Docs.Alias -> D.Doc

255−aliasToDoc localizer name (Docs.Alias _ tvars tipe) =

256− let

257− declaration =

258− "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="

259− in

260− D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])

261−

262−

263−valueToDoc :: L.Localizer -> Name.Name -> Docs.Value -> D.Doc

264−valueToDoc localizer name (Docs.Value _ tipe) =

265− D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]

266−

267−

268−binopToDoc :: L.Localizer -> Name.Name -> Docs.Binop -> D.Doc

269−binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =

270− "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details

271− where

272− details =

273− " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"

274−

275− assoc =

276− case associativity of

277− Docs.Left -> "left"

278− Docs.Non -> "non"

279− Docs.Right -> "right"

280−

281−

282−typeDoc :: L.Localizer -> Type.Type -> D.Doc

283−typeDoc localizer tipe =

284− Type.toDoc localizer Type.None tipe

builder/src/Elm/Install.hsdeleted−448

@@ -1,448 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Elm.Install

3− ( install

4− )

5− where

6−

7−

8−import Control.Monad (filterM, foldM, forM, msum, void)

9−import Control.Monad.Except (catchError, lift, liftIO)

10−import Data.Map ((!))

11−import qualified Data.Map as Map

12−import qualified Data.Map.Merge.Lazy as Map

13−

14−import qualified Elm.Package as Pkg

15−

16−import qualified Deps.Cache as Cache

17−import Deps.Explorer (Explorer)

18−import qualified Deps.Explorer as Explorer

19−import qualified Deps.Verify as Verify

20−import qualified Deps.Solver as Solver

21−import qualified Elm.Constraint as C

22−import qualified Elm.Project.Json as Project

23−import qualified Elm.Project.Root as Root

24−import qualified Elm.Version as V

25−import Reporting.Doc ((<>), (<+>))

26−import qualified Reporting.Doc as D

27−import qualified Reporting.Exit as Exit

28−import qualified Reporting.Exit.Install as E

29−import qualified Reporting.Task as Task

30−

31−

32−

33−-- INSTALL

34−

35−

36−install :: Pkg.Name -> Task.Task ()

37−install pkg =

38− do (root, oldProject) <- Root.unsafeGet

39− registry <- Cache.optionalUpdate

40−

41− case oldProject of

42− Project.App info ->

43− do changes <- makeAppPlan registry pkg info

44− attemptElmJsonChange root oldProject V.toChars changes

45−

46− Project.Pkg info ->

47− do changes <- makePkgPlan registry pkg info

48− attemptElmJsonChange root oldProject C.toChars changes

49−

50−

51−attemptElmJsonChange :: FilePath -> Project.Project -> (a -> String) -> Changes a -> Task.Task ()

52−attemptElmJsonChange root oldProject toChars changes =

53− let

54− attempt newProject question =

55− do approved <- Task.getApproval question

56− if approved

57− then upgrade newProject `catchError` revert

58− else liftIO $ putStrLn "Okay, I did not change anything!"

59−

60− upgrade newProject =

61− do liftIO $ Project.write root newProject

62− void $ Verify.verify root newProject

63−

64− revert err =

65− do liftIO $ Project.write root oldProject

66− Task.throw err

67− in

68− case changes of

69− AlreadyInstalled ->

70− do liftIO $ putStrLn "It is already installed!"

71−

72− PromoteTrans newProject ->

73− attempt newProject $

74− D.vcat

75− [ D.fillSep

76− ["I","found","it","in","your","elm.json","file,"

77− ,"but","in","the",D.dullyellow "\"indirect\"","dependencies."

78− ]

79− , D.fillSep

80− ["Should","I","move","it","into",D.green "\"direct\""

81− ,"dependencies","for","more","general","use?","[Y/n]: "

82− ]

83− ]

84−

85− PromoteTest newProject ->

86− attempt newProject $

87− D.vcat

88− [ D.fillSep

89− ["I","found","it","in","your","elm.json","file,"

90− ,"but","in","the",D.dullyellow "\"test-dependencies\"","field."

91− ]

92− , D.fillSep

93− ["Should","I","move","it","into",D.green "\"dependencies\""

94− ,"for","more","general","use?","[Y/n]: "

95− ]

96− ]

97−

98− Changes changeDict newProject ->

99− let

100− widths = Map.foldrWithKey (widen toChars) (Widths 0 0 0) changeDict

101− changeDocs = Map.foldrWithKey (addChange toChars widths) (Docs [] [] []) changeDict

102− in

103− attempt newProject $ D.vcat $

104− [ "Here is my plan:"

105− , viewChangeDocs changeDocs

106− , ""

107− , "Would you like me to update your elm.json accordingly? [Y/n]: "

108− ]

109−

110−

111−

112−-- MAKE PLANS

113−

114−

115−data Changes vsn

116− = AlreadyInstalled

117− | PromoteTest Project.Project

118− | PromoteTrans Project.Project

119− | Changes (Map.Map Pkg.Name (Change vsn)) Project.Project

120−

121−

122−makeAppPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Changes V.Version)

123−makeAppPlan registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =

124− if Map.member pkg depsDirect then

125− return AlreadyInstalled

126− else

127− do (AppAnswer old new newInfo) <- toAppAnswer registry pkg info

128−

129− return $

130− if Map.member pkg depsTrans then

131− PromoteTrans (Project.App newInfo)

132−

133− else if Map.member pkg testDirect || Map.member pkg testTrans then

134− PromoteTest (Project.App newInfo)

135−

136− else

137− Changes (detectChanges old new) (Project.App newInfo)

138−

139−

140−makePkgPlan :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Changes C.Constraint)

141−makePkgPlan registry pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) =

142− if Map.member pkg deps then

143− return AlreadyInstalled

144− else

145− case Map.lookup pkg test of

146− Just con ->

147− return $ PromoteTest $ Project.Pkg $

148− info

149− { Project._pkg_deps = Map.insert pkg con deps

150− , Project._pkg_test_deps = Map.delete pkg test

151− }

152−

153− Nothing ->

154− do changes <- addToPkg registry pkg info

155− let news = Map.mapMaybe keepNew changes

156− return $ Changes changes $ Project.Pkg $

157− info

158− { Project._pkg_deps = addNews (Just pkg) news deps

159− , Project._pkg_test_deps = addNews Nothing news test

160− }

161−

162−

163−addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a

164−addNews pkg new old =

165− Map.merge

166− Map.preserveMissing

167− (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))

168− (Map.zipWithMatched (\_ _ n -> n))

169− old

170− new

171−

172−

173−

174−-- CHANGES

175−

176−

177−data Change a

178− = Insert a

179− | Change a a

180− | Remove a

181−

182−

183−detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)

184−detectChanges old new =

185− Map.merge

186− (Map.mapMissing (\_ v -> Remove v))

187− (Map.mapMissing (\_ v -> Insert v))

188− (Map.zipWithMaybeMatched keepChange)

189− old

190− new

191−

192−

193−keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)

194−keepChange _ old new =

195− if old == new then

196− Nothing

197− else

198− Just (Change old new)

199−

200−

201−keepNew :: Change a -> Maybe a

202−keepNew change =

203− case change of

204− Insert a ->

205− Just a

206−

207− Change _ a ->

208− Just a

209−

210− Remove _ ->

211− Nothing

212−

213−

214−

215−-- ADD TO APP

216−

217−

218−data AppAnswer =

219− AppAnswer

220− { _old :: Map.Map Pkg.Name V.Version

221− , _new :: Map.Map Pkg.Name V.Version

222− , _info :: Project.AppInfo

223− }

224−

225−

226−toAppAnswer :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task AppAnswer

227−toAppAnswer registry pkg info@(Project.AppInfo _ _ depsDirect depsTrans testDirect testTrans) =

228− Explorer.run registry $

229− do Explorer.exists pkg

230− result <- Solver.run (toAppAnswerHelp pkg info)

231− case result of

232− Just answer ->

233− return answer

234−

235− Nothing ->

236− do badNames <-

237− filterM isBadElm $

238− pkg : Map.keys depsDirect

239− ++ Map.keys depsTrans

240− ++ Map.keys testDirect

241− ++ Map.keys testTrans

242− lift $ Task.throw (Exit.Install (E.NoSolution badNames))

243−

244−

245−toAppAnswerHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver AppAnswer

246−toAppAnswerHelp pkg (Project.AppInfo elm srcDirs depsDirect depsTrans testDirect testTrans) =

247− let

248− directs =

249− Map.union depsDirect testDirect

250−

251− directAndTrans =

252− Map.union directs (Map.union depsTrans testTrans)

253−

254− try toConstraint deps =

255− do solution <- Solver.solve $ Map.insert pkg C.anything (Map.map toConstraint deps)

256− let newDepsDirect = Map.intersection solution (Map.insert pkg V.one depsDirect)

257− newDeps <- lift $ foldM (collectTransitive solution) Map.empty (Map.keys newDepsDirect)

258− return $

259− AppAnswer

260− { _old = directAndTrans

261− , _new = solution

262− , _info =

263− Project.AppInfo

264− elm

265− srcDirs

266− newDepsDirect

267− (Map.difference newDeps newDepsDirect)

268− (Map.intersection solution testDirect)

269− (Map.difference (Map.difference solution newDeps) testDirect)

270− }

271− in

272− msum

273− [ try C.exactly directAndTrans

274− , try C.exactly directs

275− , try C.untilNextMinor directs

276− , try C.untilNextMajor directs

277− , try (\_ -> C.anything) directs

278− ]

279−

280−

281−collectTransitive

282− :: Map.Map Pkg.Name V.Version

283− -> Map.Map Pkg.Name V.Version

284− -> Pkg.Name

285− -> Explorer (Map.Map Pkg.Name V.Version)

286−collectTransitive solution state name =

287− do let version = solution ! name

288− (Explorer.Info _ trans) <- Explorer.getConstraints name version

289− foldM

290− (collectTransitive solution)

291− (Map.insert name version state)

292− (Map.keys trans)

293−

294−

295−

296−

297−

298−-- ADD TO PKG

299−

300−

301−addToPkg :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Map.Map Pkg.Name (Change C.Constraint))

302−addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =

303− Explorer.run registry $

304− do Explorer.exists pkg

305− let old = Map.union deps tests

306− result <- Solver.run (addToPkgHelp pkg info)

307− case result of

308− Just new ->

309− return $ detectChanges old new

310−

311− Nothing ->

312− do let pkgs = Map.keys deps ++ Map.keys tests

313− badNames <- filterM isBadElm (pkg : pkgs)

314− lift $ Task.throw (Exit.Install (E.NoSolution badNames))

315−

316−

317−addToPkgHelp :: Pkg.Name -> Project.PkgInfo -> Solver.Solver (Map.Map Pkg.Name C.Constraint)

318−addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =

319− do let directs = Map.union deps tests

320− let newCons = Map.insert pkg C.anything directs

321− solution <- Solver.solve newCons

322− let con = C.untilNextMajor (solution ! pkg)

323− return $ Map.insert pkg con directs

324−

325−

326−

327−-- FAILURE HINTS

328−

329−

330−isBadElm :: Pkg.Name -> Explorer Bool

331−isBadElm name =

332− do versions <- Explorer.getVersions name

333−

334− elmVersions <- forM versions $ \vsn ->

335− Explorer._elm <$> Explorer.getConstraints name vsn

336−

337− return (not (any C.goodElm elmVersions))

338−

339−

340−

341−-- VIEW CHANGE DOCS

342−

343−

344−data ChangeDocs =

345− Docs

346− { _doc_inserts :: [D.Doc]

347− , _doc_changes :: [D.Doc]

348− , _doc_removes :: [D.Doc]

349− }

350−

351−

352−viewChangeDocs :: ChangeDocs -> D.Doc

353−viewChangeDocs (Docs inserts changes removes) =

354− D.indent 2 $ D.vcat $ concat $

355− [ viewNonZero "Add:" inserts

356− , viewNonZero "Change:" changes

357− , viewNonZero "Remove:" removes

358− ]

359−

360−

361−viewNonZero :: String -> [D.Doc] -> [D.Doc]

362−viewNonZero title entries =

363− if null entries then

364− []

365− else

366− [ ""

367− , D.fromChars title

368− , D.indent 2 (D.vcat entries)

369− ]

370−

371−

372−

373−-- VIEW CHANGE

374−

375−

376−addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs

377−addChange toChars widths name change (Docs inserts changes removes) =

378− case change of

379− Insert new ->

380− Docs (viewInsert toChars widths name new : inserts) changes removes

381−

382− Change old new ->

383− Docs inserts (viewChange toChars widths name old new : changes) removes

384−

385− Remove old ->

386− Docs inserts changes (viewRemove toChars widths name old : removes)

387−

388−

389−viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc

390−viewInsert toChars (Widths nameWidth leftWidth _) name new =

391− viewName nameWidth name <+> pad leftWidth (toChars new)

392−

393−

394−viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc

395−viewChange toChars (Widths nameWidth leftWidth rightWidth) name old new =

396− D.hsep

397− [ viewName nameWidth name

398− , pad leftWidth (toChars old)

399− , "=>"

400− , pad rightWidth (toChars new)

401− ]

402−

403−

404−viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc

405−viewRemove toChars (Widths nameWidth leftWidth _) name old =

406− viewName nameWidth name <+> pad leftWidth (toChars old)

407−

408−

409−viewName :: Int -> Pkg.Name -> D.Doc

410−viewName width name =

411− D.fill (width + 3) (D.fromUtf8 (Pkg.toString name))

412−

413−

414−pad :: Int -> String -> D.Doc

415−pad width string =

416− D.fromChars (replicate (width - length string) ' ') <> D.fromChars string

417−

418−

419−

420−-- WIDTHS

421−

422−

423−data Widths =

424− Widths

425− { _name :: !Int

426− , _left :: !Int

427− , _right :: !Int

428− }

429−

430−

431−widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths

432−widen toChars pkg change (Widths name left right) =

433− let

434− toLength a =

435− length (toChars a)

436−

437− newName =

438− max name (length (Pkg.toChars pkg))

439− in

440− case change of

441− Insert new ->

442− Widths newName (max left (toLength new)) right

443−

444− Change old new ->

445− Widths newName (max left (toLength old)) (max right (toLength new))

446−

447− Remove old ->

448− Widths newName (max left (toLength old)) right

builder/src/Elm/Outline.hs+160−150

@@ -1,18 +1,17 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

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

33module Elm.Outline

44 ( Outline(..)

55 , AppOutline(..)

66 , PkgOutline(..)

77 , Exposed(..)

8+ , SrcDir(..)

89 , read

910 , write

1011 , encode

1112 , decoder

1213 , defaultSummary

13− , isPlatformPackage

14− , getName

15− , getExposed

14+ , flattenExposed

1615 )

1716 where

1817

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

2019import Prelude hiding (read)

2120import Control.Monad (filterM, liftM)

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

23−import Data.Foldable (traverse_)

2422import qualified Data.Map as Map

25−import qualified Data.Utf8 as Utf8

23+import qualified Data.NonEmptyList as NE

24+import qualified Data.OneOrMore as OneOrMore

25+import Foreign.Ptr (minusPtr)

2626import qualified System.Directory as Dir

27+import qualified System.FilePath as FP

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

2829

2930import qualified Elm.Constraint as Con

@@ -31,10 +32,13 @@ import qualified Elm.Licenses as Licenses

3132import qualified Elm.ModuleName as ModuleName

3233import qualified Elm.Package as Pkg

3334import qualified Elm.Version as V

35+import qualified File

3436import qualified Json.Decode as D

3537import qualified Json.Encode as E

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

39+import qualified Json.String as Json

40+import qualified Parse.Primitives as P

3641import qualified Reporting.Exit as Exit

37−import qualified Reporting.Exit.Assets as E

3842

3943

4044

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

4953data AppOutline =

5054 AppOutline

5155 { _app_elm_version :: V.Version

52− , _app_source_dirs :: [FilePath]

56+ , _app_source_dirs :: NE.List SrcDir

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

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

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

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

6064data PkgOutline =

6165 PkgOutline

6266 { _pkg_name :: Pkg.Name

63− , _pkg_summary :: Utf8.String

67+ , _pkg_summary :: Json.String

6468 , _pkg_license :: Licenses.License

6569 , _pkg_version :: V.Version

6670 , _pkg_exposed :: Exposed

@@ -72,45 +76,29 @@ data PkgOutline =

7276

7377data Exposed

7478 = ExposedList [ModuleName.Raw]

75− | ExposedDict [(Utf8.String, [ModuleName.Raw])]

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

7680

7781

78−

79−-- DEFAULTS

80−

81−

82−defaultSummary :: Utf8.String

83−defaultSummary =

84− "helpful summary of your project, less than 80 characters"

85−

82+data SrcDir

83+ = AbsoluteSrcDir FilePath

84+ | RelativeSrcDir FilePath

8685

8786

88−-- QUERIES

8987

88+-- DEFAULTS

9089

91−isPlatformPackage :: Outline -> Bool

92−isPlatformPackage outline =

93− case outline of

94− App _ ->

95− False

9690

97− Pkg pkgOutline ->

98− let author = Pkg._author (_pkg_name pkgOutline) in

99− author == "elm" || author == "elm-explorations"

91+defaultSummary :: Json.String

92+defaultSummary =

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

10094

10195

102−getName :: Outline -> Pkg.Name

103−getName outline =

104− case outline of

105− App _ ->

106− Pkg.dummyName

10796

108− Pkg (PkgOutline name _ _ _ _ _ _ _) ->

109− name

97+-- HELPERS

11098

11199

112−getExposed :: PkgOutline -> [ModuleName.Raw]

113−getExposed (PkgOutline _ _ _ _ exposed _ _ _) =

100+flattenExposed :: Exposed -> [ModuleName.Raw]

101+flattenExposed exposed =

114102 case exposed of

115103 ExposedList names ->

116104 names

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

137125 case outline of

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

139127 E.object

140− [ "type" ==> E.string "application"

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

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

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

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

143131 , "dependencies" ==>

144132 E.object

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

154142

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

156144 E.object

157− [ "type" ==> E.string "package"

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

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

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

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

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

166154 ]

167155

168156

169−(==>) :: a -> b -> (a, b)

170−(==>) a b =

171− (a, b)

172−

173−

174157encodeExposed :: Exposed -> E.Value

175158encodeExposed exposed =

176159 case exposed of

@@ -188,35 +171,95 @@ encodeModule name =

188171

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

190173encodeDeps encodeValue deps =

191− E.dict Pkg.toString 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

192182

193183

194184

195185-- PARSE AND VERIFY

196186

197187

198−read :: FilePath -> IO (Either Exit.OutlineProblem Outline)

188+read :: FilePath -> IO (Either Exit.Outline Outline)

199189read root =

200− do result <- D.fromFile decoder (root </> "elm.json")

201− case result of

190+ do bytes <- File.readUtf8 (root </> "elm.json")

191+ case D.fromByteString decoder bytes of

202192 Left err ->

203− return $ Left (Exit.BadOutlineStructure err)

193+ return $ Left (Exit.OutlineHasBadStructure err)

204194

205195 Right outline ->

206196 case outline of

207− Pkg _ ->

208− return $ Right outline

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+

209237

210− App (AppOutline _ srcDirs _ _ _ _) ->

211− do badDirs <- filterM (isBadSrcDir root) srcDirs

212− case badDirs of

213− [] -> return $ Right outline

214− d:ds -> return $ Left (Exit.BadOutlineSrcDirs d ds)

238+toAbsolute :: FilePath -> SrcDir -> FilePath

239+toAbsolute root srcDir =

240+ case srcDir of

241+ AbsoluteSrcDir dir -> dir

242+ RelativeSrcDir dir -> root </> dir

215243

216244

217−isBadSrcDir :: FilePath -> FilePath -> IO Bool

218−isBadSrcDir root dir =

219− not <$> Dir.doesDirectoryExist (root </> dir)

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

246+detectDuplicates root srcDirs =

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

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

249+ Map.fromListWith OneOrMore.more pairs

250+

251+

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

253+toPair root srcDir =

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

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

256+

257+

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

259+isDup paths =

260+ case paths of

261+ OneOrMore.One _ -> Nothing

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

220263

221264

222265

@@ -224,28 +267,26 @@ isBadSrcDir root dir =

224267

225268

226269type Decoder a =

227− D.Decoder E.BadElmJsonContent a

270+ D.Decoder Exit.OutlineProblem a

228271

229272

230273decoder :: Decoder Outline

231274decoder =

275+ let

276+ application = Json.fromChars "application"

277+ package = Json.fromChars "package"

278+ in

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

233− case tipe of

234− "application" ->

235− App <$> appDecoder

236−

237− "package" ->

238− Pkg <$> pkgDecoder

239−

240− other ->

241− D.failure (E.BadType other)

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

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

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

242283

243284

244285appDecoder :: Decoder AppOutline

245286appDecoder =

246287 AppOutline

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

248− <*> D.field "source-directories" (D.list dirDecoder)

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

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

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

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

@@ -255,9 +296,9 @@ appDecoder =

255296pkgDecoder :: Decoder PkgOutline

256297pkgDecoder =

257298 PkgOutline

258− <$> D.field "name" (D.mapError E.BadPkgName Pkg.decoder)

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

259300 <*> D.field "summary" summaryDecoder

260− <*> D.field "license" (Licenses.decoder E.BadLicense)

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

261302 <*> D.field "version" versionDecoder

262303 <*> D.field "exposed-modules" exposedDecoder

263304 <*> D.field "dependencies" (depsDecoder constraintDecoder)

@@ -269,44 +310,43 @@ pkgDecoder =

269310-- JSON DECODE HELPERS

270311

271312

272−summaryDecoder :: Decoder Utf8.String

313+nameDecoder :: Decoder Pkg.Name

314+nameDecoder =

315+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder

316+

317+

318+summaryDecoder :: Decoder Json.String

273319summaryDecoder =

274− do summary <- D.string

275− if Utf8.size summary < 80

276− then return summary

277− else D.failure E.BadSummaryTooLong

320+ D.customString

321+ (boundParser 80 Exit.OP_BadSummaryTooLong)

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

278323

279324

280325versionDecoder :: Decoder V.Version

281326versionDecoder =

282− D.mapError E.BadVersion V.decoder

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

283328

284329

285330constraintDecoder :: Decoder Con.Constraint

286331constraintDecoder =

287− D.mapError E.BadConstraint Con.decoder

332+ D.mapError Exit.OP_BadConstraint Con.decoder

288333

289334

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

291336depsDecoder valueDecoder =

292− Map.fromList <$> (

293− traverse validateKey =<< D.pairs valueDecoder

294− )

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

295338

296339

297−validateKey :: (Utf8.String, a) -> Decoder (Pkg.Name, a)

298−validateKey (key, value) =

299− case Pkg.fromString key of

300− Right name ->

301− return (name, value)

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

341+dirsDecoder =

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

302343

303− Left _ ->

304− D.failure (E.BadDependencyName key)

305344

306−

307−dirDecoder :: Decoder FilePath

308−dirDecoder =

309− Utf8.toChars <$> D.string

345+toSrcDir :: FilePath -> SrcDir

346+toSrcDir path =

347+ if FP.isRelative path

348+ then RelativeSrcDir path

349+ else AbsoluteSrcDir path

310350

311351

312352

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

317357exposedDecoder =

318358 D.oneOf

319359 [ ExposedList <$> D.list moduleDecoder

320− , do pairs <- D.pairs (D.list moduleDecoder)

321− traverse_ (checkHeader . fst) pairs

322− return (ExposedDict pairs)

360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)

323361 ]

324362

325363

326364moduleDecoder :: Decoder ModuleName.Raw

327365moduleDecoder =

328− D.mapError E.BadModuleName ModuleName.decoder

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

329367

330368

331−checkHeader :: Utf8.String -> Decoder ()

332−checkHeader header =

333− if Utf8.size header < 20

334− then return ()

335− else D.failure (E.BadModuleHeaderTooLong header)

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

370+headerKeyDecoder =

371+ D.KeyDecoder

372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)

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

336374

337375

338376

339−-- BINARY

377+-- BOUND PARSER

340378

341379

342−instance Binary Outline where

343− put outline =

344− case outline of

345− App a -> putWord8 0 >> put a

346− Pkg a -> putWord8 1 >> put a

347−

348− get =

349− do n <- getWord8

350− case n of

351− 0 -> liftM App get

352− 1 -> liftM Pkg get

353− _ -> error "binary encoding of Outline was corrupted"

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)

354390

355391

356−instance Binary AppOutline where

357− put (AppOutline a b c d e f) =

358− put a >> put b >> put c >> put d >> put e >> put f

359−

360− get =

361− do a <- get

362− b <- get

363− c <- get

364− d <- get

365− e <- get

366− f <- get

367− return (AppOutline a b c d e f)

368392

393+-- BINARY

369394

370−instance Binary PkgOutline where

371− put (PkgOutline a b c d e f g h) =

372− put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h

373395

374− get =

375− do a <- get

376− b <- get

377− c <- get

378− d <- get

379− e <- get

380− f <- get

381− g <- get

382− h <- get

383− return (PkgOutline a b c d e f g h)

384−

385−

386−instance Binary Exposed where

387− put exposed =

388− case exposed of

389− ExposedList a -> putWord8 0 >> put a

390− ExposedDict a -> putWord8 1 >> put a

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

391401

392402 get =

393403 do n <- getWord8

394404 case n of

395− 0 -> liftM ExposedList get

396− 1 -> liftM ExposedDict get

397− _ -> error "binary encoding of ProjectDeps was corrupted"

405+ 0 -> liftM AbsoluteSrcDir get

406+ 1 -> liftM RelativeSrcDir get

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

builder/src/Elm/PerUserCache.hsdeleted−46

@@ -1,46 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Elm.PerUserCache

3− ( getPackageRoot

4− , getReplRoot

5− , getElmHome

6− )

7− where

8−

9−import qualified System.Directory as Dir

10−import qualified System.Environment as Env

11−import System.FilePath ((</>))

12−

13−import qualified Elm.Version as V

14−

15−

16−

17−-- ROOTS

18−

19−

20−getPackageRoot :: IO FilePath

21−getPackageRoot =

22− getRoot "package"

23−

24−

25−getReplRoot :: IO FilePath

26−getReplRoot =

27− getRoot "repl"

28−

29−

30−getRoot :: FilePath -> IO FilePath

31−getRoot projectName =

32− do home <- getElmHome

33− let root = home </> version </> projectName

34− Dir.createDirectoryIfMissing True root

35− return root

36−

37−

38−version :: FilePath

39−version =

40− V.toChars V.compiler

41−

42−

43−getElmHome :: IO FilePath

44−getElmHome =

45− do maybeHome <- Env.lookupEnv "ELM_HOME"

46− maybe (Dir.getAppUserDataDirectory "elm") return maybeHome

builder/src/Elm/Publish.hsdeleted−255

@@ -1,255 +0,0 @@

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+67−17

@@ -1,12 +1,13 @@

11module File

22 ( Time

33 , getTime

4− , withLock

4+ , zeroTime

55 , writeBinary

66 , readBinary

77 , writeUtf8

88 , readUtf8

99 , writeBuilder

10+ , writePackage

1011 , exists

1112 , remove

1213 , removeDir

@@ -14,18 +15,22 @@ module File

1415 where

1516

1617

18+import qualified Codec.Archive.Zip as Zip

1719import Control.Exception (catch)

1820import qualified Data.Binary as Binary

1921import qualified Data.ByteString as BS

2022import qualified Data.ByteString.Internal as BS

2123import qualified Data.ByteString.Builder as B

24+import qualified Data.ByteString.Lazy as LBS

2225import qualified Data.Fixed as Fixed

26+import qualified Data.List as List

27+import qualified Data.Time.Clock as Time

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

2429import qualified Foreign.ForeignPtr as FPtr

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

2631import qualified System.Directory as Dir

27−import qualified System.FileLock as Lock

2832import qualified System.FilePath as FP

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

2934import qualified System.IO as IO

3035import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)

3136

@@ -41,26 +46,21 @@ newtype Time = Time Fixed.Pico

4146getTime :: FilePath -> IO Time

4247getTime path =

4348 fmap

44− (Time . realToFrac . Time.utcTimeToPOSIXSeconds)

45−-- TODO (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

49+ (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

4650 (Dir.getModificationTime path)

4751

4852

53+zeroTime :: Time

54+zeroTime =

55+ Time 0

56+

57+

4958instance Binary.Binary Time where

5059 put (Time time) = Binary.put time

5160 get = Time <$> Binary.get

5261

5362

5463

55−-- LOCK

56−

57−

58−withLock :: FilePath -> IO a -> IO a

59−withLock path work =

60− Lock.withFileLock path Lock.Exclusive (\_ -> work)

61−

62−

63−

6464-- BINARY

6565

6666

@@ -73,10 +73,28 @@ writeBinary path value =

7373

7474readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)

7575readBinary path =

76− do result <- Binary.decodeFileOrFail path

77− case result of

78− Right a -> return (Just a)

79− Left _ -> return Nothing

76+ do pathExists <- Dir.doesFileExist path

77+ if pathExists

78+ then

79+ do result <- Binary.decodeFileOrFail path

80+ case result of

81+ Right a ->

82+ return (Just a)

83+

84+ Left (offset, message) ->

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

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

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

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

89+ , "| Message: " ++ message

90+ , "|"

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

92+ , "| Trying to continue anyway."

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

94+ ]

95+ return Nothing

96+ else

97+ return Nothing

8098

8199

82100

@@ -153,6 +171,38 @@ writeBuilder path builder =

153171

154172

155173

174+-- WRITE PACKAGE

175+

176+

177+writePackage :: FilePath -> Zip.Archive -> IO ()

178+writePackage destination archive =

179+ case Zip.zEntries archive of

180+ [] ->

181+ return ()

182+

183+ entry:entries ->

184+ do let root = length (Zip.eRelativePath entry)

185+ mapM_ (writeEntry destination root) entries

186+

187+

188+writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()

189+writeEntry destination root entry =

190+ let

191+ path = drop root (Zip.eRelativePath entry)

192+ in

193+ if List.isPrefixOf "src/" path

194+ || path == "LICENSE"

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

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

197+ then

198+ if not (null path) && last path == '/'

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

200+ else LBS.writeFile (destination </> path) (Zip.fromEntry entry)

201+ else

202+ return ()

203+

204+

205+

156206-- EXISTS

157207

158208

builder/src/Generate.hsnew file+211

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

1+{-# LANGUAGE BangPatterns #-}

2+module Generate

3+ ( debug

4+ , dev

5+ , prod

6+ , repl

7+ )

8+ where

9+

10+

11+import Prelude hiding (cycle, print)

12+import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)

13+import Control.Monad (liftM2)

14+import qualified Data.ByteString.Builder as B

15+import Data.Map ((!))

16+import qualified Data.Map as Map

17+import qualified Data.Maybe as Maybe

18+import qualified Data.Name as N

19+import qualified Data.NonEmptyList as NE

20+

21+import qualified AST.Optimized as Opt

22+import qualified Build

23+import qualified Elm.Compiler.Type.Extract as Extract

24+import qualified Elm.Details as Details

25+import qualified Elm.Interface as I

26+import qualified Elm.ModuleName as ModuleName

27+import qualified Elm.Package as Pkg

28+import qualified File

29+import qualified Generate.JavaScript as JS

30+import qualified Generate.Mode as Mode

31+import qualified Nitpick.Debug as Nitpick

32+import qualified Reporting.Exit as Exit

33+import qualified Reporting.Task as Task

34+import qualified Stuff

35+

36+

37+-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be

38+-- desireable to have Repl and Reactor to keep foreign objects in memory

39+-- to make things a bit faster?

40+

41+

42+

43+-- GENERATORS

44+

45+

46+type Task a =

47+ Task.Task Exit.Generate a

48+

49+

50+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder

51+debug root details (Build.Artifacts pkg ifaces roots modules) =

52+ do loading <- loadObjects root details modules

53+ types <- loadTypes root ifaces modules

54+ objects <- finalizeObjects loading

55+ let mode = Mode.Dev (Just types)

56+ let graph = objectsToGlobalGraph objects

57+ let mains = gatherMains pkg objects roots

58+ return $ JS.generate mode graph mains

59+

60+

61+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder

62+dev root details (Build.Artifacts pkg _ roots modules) =

63+ do objects <- finalizeObjects =<< loadObjects root details modules

64+ let mode = Mode.Dev Nothing

65+ let graph = objectsToGlobalGraph objects

66+ let mains = gatherMains pkg objects roots

67+ return $ JS.generate mode graph mains

68+

69+

70+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder

71+prod root details (Build.Artifacts pkg _ roots modules) =

72+ do objects <- finalizeObjects =<< loadObjects root details modules

73+ checkForDebugUses objects

74+ let graph = objectsToGlobalGraph objects

75+ let mode = Mode.Prod (Mode.shortenFieldNames graph)

76+ let mains = gatherMains pkg objects roots

77+ return $ JS.generate mode graph mains

78+

79+

80+repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder

81+repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name =

82+ do objects <- finalizeObjects =<< loadObjects root details modules

83+ let graph = objectsToGlobalGraph objects

84+ return $ JS.generateForRepl ansi localizer graph home name (annotations ! name)

85+

86+

87+

88+-- CHECK FOR DEBUG

89+

90+

91+checkForDebugUses :: Objects -> Task ()

92+checkForDebugUses (Objects _ locals) =

93+ case Map.keys (Map.filter Nitpick.hasDebugUses locals) of

94+ [] -> return ()

95+ m:ms -> Task.throw (Exit.GenerateCannotOptimizeDebugValues m ms)

96+

97+

98+

99+-- GATHER MAINS

100+

101+

102+gatherMains :: Pkg.Name -> Objects -> NE.List Build.Root -> Map.Map ModuleName.Canonical Opt.Main

103+gatherMains pkg (Objects _ locals) roots =

104+ Map.fromList $ Maybe.mapMaybe (lookupMain pkg locals) (NE.toList roots)

105+

106+

107+lookupMain :: Pkg.Name -> Map.Map ModuleName.Raw Opt.LocalGraph -> Build.Root -> Maybe (ModuleName.Canonical, Opt.Main)

108+lookupMain pkg locals root =

109+ let

110+ toPair name (Opt.LocalGraph maybeMain _ _) =

111+ (,) (ModuleName.Canonical pkg name) <$> maybeMain

112+ in

113+ case root of

114+ Build.Inside name -> toPair name =<< Map.lookup name locals

115+ Build.Outside name _ g -> toPair name g

116+

117+

118+

119+-- LOADING OBJECTS

120+

121+

122+data LoadingObjects =

123+ LoadingObjects

124+ { _foreign_mvar :: MVar (Maybe Opt.GlobalGraph)

125+ , _local_mvars :: Map.Map ModuleName.Raw (MVar (Maybe Opt.LocalGraph))

126+ }

127+

128+

129+loadObjects :: FilePath -> Details.Details -> [Build.Module] -> Task LoadingObjects

130+loadObjects root details modules =

131+ Task.io $

132+ do mvar <- Details.loadObjects root details

133+ mvars <- traverse (loadObject root) modules

134+ return $ LoadingObjects mvar (Map.fromList mvars)

135+

136+

137+loadObject :: FilePath -> Build.Module -> IO (ModuleName.Raw, MVar (Maybe Opt.LocalGraph))

138+loadObject root modul =

139+ case modul of

140+ Build.Fresh name _ graph ->

141+ do mvar <- newMVar (Just graph)

142+ return (name, mvar)

143+

144+ Build.Cached name _ _ ->

145+ do mvar <- newEmptyMVar

146+ _ <- forkIO $ putMVar mvar =<< File.readBinary (Stuff.elmo root name)

147+ return (name, mvar)

148+

149+

150+

151+-- FINALIZE OBJECTS

152+

153+

154+data Objects =

155+ Objects

156+ { _foreign :: Opt.GlobalGraph

157+ , _locals :: Map.Map ModuleName.Raw Opt.LocalGraph

158+ }

159+

160+

161+finalizeObjects :: LoadingObjects -> Task Objects

162+finalizeObjects (LoadingObjects mvar mvars) =

163+ Task.eio id $

164+ do result <- readMVar mvar

165+ results <- traverse readMVar mvars

166+ case liftM2 Objects result (sequence results) of

167+ Just loaded -> return (Right loaded)

168+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)

169+

170+

171+objectsToGlobalGraph :: Objects -> Opt.GlobalGraph

172+objectsToGlobalGraph (Objects globals locals) =

173+ foldr Opt.addLocalGraph globals locals

174+

175+

176+

177+-- LOAD TYPES

178+

179+

180+loadTypes :: FilePath -> Map.Map ModuleName.Canonical I.DependencyInterface -> [Build.Module] -> Task Extract.Types

181+loadTypes root ifaces modules =

182+ Task.eio id $

183+ do mvars <- traverse (loadTypesHelp root) modules

184+ let !foreigns = Extract.mergeMany (Map.elems (Map.mapWithKey Extract.fromDependencyInterface ifaces))

185+ results <- traverse readMVar mvars

186+ case sequence results of

187+ Just ts -> return (Right (Extract.merge foreigns (Extract.mergeMany ts)))

188+ Nothing -> return (Left Exit.GenerateCannotLoadArtifacts)

189+

190+

191+loadTypesHelp :: FilePath -> Build.Module -> IO (MVar (Maybe Extract.Types))

192+loadTypesHelp root modul =

193+ case modul of

194+ Build.Fresh name iface _ ->

195+ newMVar (Just (Extract.fromInterface name iface))

196+

197+ Build.Cached name _ ciMVar ->

198+ do cachedInterface <- readMVar ciMVar

199+ case cachedInterface of

200+ Build.Unneeded ->

201+ do mvar <- newEmptyMVar

202+ _ <- forkIO $

203+ do maybeIface <- File.readBinary (Stuff.elmi root name)

204+ putMVar mvar (Extract.fromInterface name <$> maybeIface)

205+ return mvar

206+

207+ Build.Loaded iface ->

208+ newMVar (Just (Extract.fromInterface name iface))

209+

210+ Build.Corrupted ->

211+ newMVar Nothing

builder/src/Http.hs+86−115

@@ -3,22 +3,21 @@ module Http

33 ( Manager

44 , getManager

55 , toUrl

6+ -- fetch

7+ , get

68 , post

7− , post'

89 , Header

910 , accept

10− , Timeout(..)

11− , Body(..)

12− , Multi.Part

13− , filePart

14− , stringPart

15− , BodyReader

16− , readByteString

11+ , Error(..)

12+ -- archives

1713 , Sha

1814 , shaToChars

19− , readArchive

20− , writeArchive

21− , Error(..)

15+ , getArchive

16+ -- upload

17+ , upload

18+ , filePart

19+ , jsonPart

20+ , stringPart

2221 )

2322 where

2423

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

2827import Control.Exception (SomeException, handle)

2928import qualified Data.Binary as Binary

3029import qualified Data.Binary.Get as Binary

30+import qualified Data.ByteString.Builder as B

3131import qualified Data.ByteString.Char8 as BS

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

3333import qualified Data.String as String

@@ -35,10 +35,11 @@ import Network.HTTP (urlEncodeVars)

3535import Network.HTTP.Client

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

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

38−import Network.HTTP.Types.Method (methodPost)

38+import Network.HTTP.Types.Method (Method, methodGet, methodPost)

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

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

40−import qualified System.Directory as Dir

4141

42+import qualified Json.Encode as Encode

4243import qualified Elm.Version as V

4344

4445

@@ -63,23 +64,27 @@ toUrl url params =

6364

6465

6566

66−-- POST

67+-- FETCH

6768

6869

69−post

70− :: Manager

71− -> String

72− -> [Header]

73− -> (Error -> e)

74− -> (BS.ByteString -> IO (Either e a))

75− -> IO (Either e a)

76−post manager url headers onError onSuccess =

70+get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)

71+get =

72+ fetch methodGet

73+

74+

75+post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)

76+post =

77+ fetch methodPost

78+

79+

80+fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)

81+fetch methodVerb manager url headers onError onSuccess =

7782 handle (handleSomeException url onError) $

7883 handle (handleHttpException url onError) $

7984 do req0 <- parseUrlThrow url

8085 let req1 =

8186 req0

82− { method = methodPost

87+ { method = methodVerb

8388 , requestHeaders = addDefaultHeaders headers

8489 }

8590 withResponse req1 manager $ \response ->

@@ -87,33 +92,6 @@ post manager url headers onError onSuccess =

8792 onSuccess (BS.concat chunks)

8893

8994

90−post'

91− :: Manager

92− -> String

93− -> [Header]

94− -> Timeout

95− -> Body

96− -> (Error -> e)

97− -> (BodyReader -> IO (Either e a))

98− -> IO (Either e a)

99−post' manager url headers timeout body onError onSuccess =

100− handle (handleSomeException url onError) $

101− handle (handleHttpException url onError) $

102− do req0 <- parseUrlThrow url

103− req1 <-

104− addBody body $

105− addTimeout timeout $

106− req0

107− { method = methodPost

108− , requestHeaders = addDefaultHeaders headers

109− }

110− withResponse req1 manager (onSuccess . responseBody)

111−

112−

113−

114−-- HEADERS

115−

116−

11795addDefaultHeaders :: [Header] -> [Header]

11896addDefaultHeaders headers =

11997 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers

@@ -131,54 +109,6 @@ accept mime =

131109

132110

133111

134−-- TIMEOUT

135−

136−

137−data Timeout

138− = DefaultTimeout

139− | NeverTimeout

140−

141−

142−addTimeout :: Timeout -> Request -> Request

143−addTimeout timeout req =

144− case timeout of

145− DefaultTimeout ->

146− req

147−

148− NeverTimeout ->

149− req { responseTimeout = responseTimeoutNone }

150−

151−

152−

153−-- BODY

154−

155−

156−data Body

157− = NoBody

158− | FormDataBody [Multi.Part]

159−

160−

161−addBody :: Body -> Request -> IO Request

162−addBody body req =

163− case body of

164− NoBody ->

165− return req

166−

167− FormDataBody parts ->

168− Multi.formDataBody parts req

169−

170−

171−filePart :: String -> FilePath -> Multi.Part

172−filePart name filePath =

173− Multi.partFileSource (String.fromString name) filePath

174−

175−

176−stringPart :: String -> String -> Multi.Part

177−stringPart name string =

178− Multi.partBS (String.fromString name) (BS.pack string)

179−

180−

181−

182112-- EXCEPTIONS

183113

184114

@@ -204,12 +134,7 @@ handleSomeException url onError exception =

204134

205135

206136

207−-- BODY READERS

208−

209−

210−readByteString :: BodyReader -> IO BS.ByteString

211−readByteString bodyReader =

212− BS.concat <$> brConsume bodyReader

137+-- SHA

213138

214139

215140type Sha = SHA.Digest SHA.SHA1State

@@ -220,6 +145,33 @@ shaToChars =

220145 SHA.showDigest

221146

222147

148+

149+-- FETCH ARCHIVE

150+

151+

152+getArchive

153+ :: Manager

154+ -> String

155+ -> (Error -> e)

156+ -> e

157+ -> ((Sha, Zip.Archive) -> IO (Either e a))

158+ -> IO (Either e a)

159+getArchive manager url onError err onSuccess =

160+ handle (handleSomeException url onError) $

161+ handle (handleHttpException url onError) $

162+ do req0 <- parseUrlThrow url

163+ let req1 =

164+ req0

165+ { method = methodGet

166+ , requestHeaders = addDefaultHeaders []

167+ }

168+ withResponse req1 manager $ \response ->

169+ do result <- readArchive (responseBody response)

170+ case result of

171+ Nothing -> return (Left err)

172+ Just shaAndArchive -> onSuccess shaAndArchive

173+

174+

223175readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))

224176readArchive body =

225177 readArchiveHelp body $

@@ -254,20 +206,39 @@ readArchiveHelp body (AS len sha zip) =

254206

255207

256208

257−-- WRITE ARCHIVE

209+-- UPLOAD

258210

259211

260−writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()

261−writeArchive archive destination newRoot =

262− do Dir.createDirectoryIfMissing True destination

263− let opts = [Zip.OptDestination destination]

264− mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)

212+upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())

213+upload manager url parts =

214+ handle (handleSomeException url id) $

215+ handle (handleHttpException url id) $

216+ do req0 <- parseUrlThrow url

217+ req1 <-

218+ Multi.formDataBody parts $

219+ req0

220+ { method = methodPost

221+ , requestHeaders = addDefaultHeaders []

222+ , responseTimeout = responseTimeoutNone

223+ }

224+ withResponse req1 manager $ \_ ->

225+ return (Right ())

226+

227+

228+filePart :: String -> FilePath -> Multi.Part

229+filePart name filePath =

230+ Multi.partFileSource (String.fromString name) filePath

265231

266232

267−replaceRoot :: String -> Zip.Entry -> Zip.Entry

268−replaceRoot root entry =

233+jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part

234+jsonPart name filePath value =

269235 let

270− rootless =

271− dropWhile (/='/') (Zip.eRelativePath entry)

236+ body =

237+ Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value

272238 in

273− entry { Zip.eRelativePath = root ++ rootless }

239+ Multi.partFileRequestBody (String.fromString name) filePath body

240+

241+

242+stringPart :: String -> String -> Multi.Part

243+stringPart name string =

244+ Multi.partBS (String.fromString name) (BS.pack string)

builder/src/Reporting.hsnew file+474

@@ -0,0 +1,474 @@

1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}

2+module Reporting

3+ ( Style

4+ , silent

5+ , json

6+ , terminal

7+ --

8+ , attempt

9+ , attemptWithStyle

10+ --

11+ , Key

12+ , report

13+ , ignorer

14+ , ask

15+ --

16+ , DKey

17+ , DMsg(..)

18+ , trackDetails

19+ --

20+ , BKey

21+ , BMsg(..)

22+ , trackBuild

23+ --

24+ , reportGenerate

25+ )

26+ where

27+

28+

29+import Control.Concurrent

30+import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)

31+import Control.Monad (when)

32+import qualified Data.ByteString.Builder as B

33+import qualified Data.NonEmptyList as NE

34+import qualified System.Exit as Exit

35+import qualified System.Info as Info

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

37+

38+import qualified Elm.ModuleName as ModuleName

39+import qualified Elm.Package as Pkg

40+import qualified Elm.Version as V

41+import qualified Json.Encode as Encode

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

43+import qualified Reporting.Doc as D

44+import qualified Reporting.Exit as Exit

45+import qualified Reporting.Exit.Help as Help

46+

47+

48+

49+-- STYLE

50+

51+

52+data Style

53+ = Silent

54+ | Json

55+ | Terminal (MVar ())

56+

57+

58+silent :: Style

59+silent =

60+ Silent

61+

62+

63+json :: Style

64+json =

65+ Json

66+

67+

68+terminal :: IO Style

69+terminal =

70+ Terminal <$> newMVar ()

71+

72+

73+

74+-- ATTEMPT

75+

76+

77+attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a

78+attempt toReport work =

79+ do result <- work `catch` reportExceptionsNicely

80+ case result of

81+ Right a ->

82+ return a

83+

84+ Left x ->

85+ do Exit.toStderr (toReport x)

86+ Exit.exitFailure

87+

88+

89+attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a

90+attemptWithStyle style toReport work =

91+ do result <- work `catch` reportExceptionsNicely

92+ case result of

93+ Right a ->

94+ return a

95+

96+ Left x ->

97+ case style of

98+ Silent ->

99+ do Exit.exitFailure

100+

101+ Json ->

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

103+ Exit.exitFailure

104+

105+ Terminal mvar ->

106+ do readMVar mvar

107+ Exit.toStderr (toReport x)

108+ Exit.exitFailure

109+

110+

111+

112+-- MARKS

113+

114+

115+goodMark :: D.Doc

116+goodMark =

117+ D.green $ if isWindows then "+" else "●"

118+

119+

120+badMark :: D.Doc

121+badMark =

122+ D.red $ if isWindows then "X" else "✗"

123+

124+

125+isWindows :: Bool

126+isWindows =

127+ Info.os == "mingw32"

128+

129+

130+

131+-- KEY

132+

133+

134+newtype Key msg = Key (msg -> IO ())

135+

136+

137+report :: Key msg -> msg -> IO ()

138+report (Key send) msg =

139+ send msg

140+

141+

142+ignorer :: Key msg

143+ignorer =

144+ Key (\_ -> return ())

145+

146+

147+

148+-- ASK

149+

150+

151+ask :: D.Doc -> IO Bool

152+ask doc =

153+ do Help.toStdout doc

154+ askHelp

155+

156+

157+askHelp :: IO Bool

158+askHelp =

159+ do hFlush stdout

160+ input <- getLine

161+ case input of

162+ "" -> return True

163+ "Y" -> return True

164+ "y" -> return True

165+ "n" -> return False

166+ _ ->

167+ do putStr "Must type 'y' for yes or 'n' for no: "

168+ askHelp

169+

170+

171+-- DETAILS

172+

173+

174+type DKey = Key DMsg

175+

176+

177+trackDetails :: Style -> (DKey -> IO a) -> IO a

178+trackDetails style callback =

179+ case style of

180+ Silent ->

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

182+

183+ Json ->

184+ callback (Key (\_ -> return ()))

185+

186+ Terminal mvar ->

187+ do chan <- newChan

188+

189+ _ <- forkIO $

190+ do takeMVar mvar

191+ detailsLoop chan (DState 0 0 0 0 0 0 0)

192+ putMVar mvar ()

193+

194+ answer <- callback (Key (writeChan chan . Just))

195+ writeChan chan Nothing

196+ return answer

197+

198+

199+detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()

200+detailsLoop chan state@(DState total _ _ _ _ built _) =

201+ do msg <- readChan chan

202+ case msg of

203+ Just dmsg ->

204+ detailsLoop chan =<< detailsStep dmsg state

205+

206+ Nothing ->

207+ putStrLn $ clear (toBuildProgress total total) $

208+ if built == total

209+ then "Dependencies ready!"

210+ else "Dependency problem!"

211+

212+

213+data DState =

214+ DState

215+ { _total :: !Int

216+ , _cached :: !Int

217+ , _requested :: !Int

218+ , _received :: !Int

219+ , _failed :: !Int

220+ , _built :: !Int

221+ , _broken :: !Int

222+ }

223+

224+

225+data DMsg

226+ = DStart Int

227+ | DCached

228+ | DRequested

229+ | DReceived Pkg.Name V.Version

230+ | DFailed Pkg.Name V.Version

231+ | DBuilt

232+ | DBroken

233+

234+

235+detailsStep :: DMsg -> DState -> IO DState

236+detailsStep msg (DState total cached rqst rcvd failed built broken) =

237+ case msg of

238+ DStart numDependencies ->

239+ return (DState numDependencies 0 0 0 0 0 0)

240+

241+ DCached ->

242+ putTransition (DState total (cached + 1) rqst rcvd failed built broken)

243+

244+ DRequested ->

245+ do when (rqst == 0) (putStrLn "Starting downloads...\n")

246+ return (DState total cached (rqst + 1) rcvd failed built broken)

247+

248+ DReceived pkg vsn ->

249+ do putDownload goodMark pkg vsn

250+ putTransition (DState total cached rqst (rcvd + 1) failed built broken)

251+

252+ DFailed pkg vsn ->

253+ do putDownload badMark pkg vsn

254+ putTransition (DState total cached rqst rcvd (failed + 1) built broken)

255+

256+ DBuilt ->

257+ putBuilt (DState total cached rqst rcvd failed (built + 1) broken)

258+

259+ DBroken ->

260+ putBuilt (DState total cached rqst rcvd failed built (broken + 1))

261+

262+

263+putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()

264+putDownload mark pkg vsn =

265+ Help.toStdout $ D.indent 2 $

266+ mark

267+ <+> D.fromPackage pkg

268+ <+> D.fromVersion vsn

269+ <> "\n"

270+

271+

272+putTransition :: DState -> IO DState

273+putTransition state@(DState total cached _ rcvd failed built broken) =

274+ if cached + rcvd + failed < total then

275+ return state

276+

277+ else

278+ do let char = if rcvd + failed == 0 then '\r' else '\n'

279+ putStrFlush (char : toBuildProgress (built + broken + failed) total)

280+ return state

281+

282+

283+putBuilt :: DState -> IO DState

284+putBuilt state@(DState total cached _ rcvd failed built broken) =

285+ do when (total == cached + rcvd + failed) $

286+ putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total

287+ return state

288+

289+

290+toBuildProgress :: Int -> Int -> [Char]

291+toBuildProgress built total =

292+ "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"

293+

294+

295+clear :: [Char] -> [Char] -> [Char]

296+clear before after =

297+ '\r' : replicate (length before) ' ' ++ '\r' : after

298+

299+

300+

301+-- BUILD

302+

303+

304+type BKey = Key BMsg

305+

306+type BResult a = Either Exit.BuildProblem a

307+

308+

309+trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)

310+trackBuild style callback =

311+ case style of

312+ Silent ->

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

314+

315+ Json ->

316+ callback (Key (\_ -> return ()))

317+

318+ Terminal mvar ->

319+ do chan <- newChan

320+

321+ _ <- forkIO $

322+ do takeMVar mvar

323+ putStrFlush "Compiling ..."

324+ buildLoop chan 0

325+ putMVar mvar ()

326+

327+ result <- callback (Key (writeChan chan . Left))

328+ writeChan chan (Right result)

329+ return result

330+

331+

332+data BMsg

333+ = BDone

334+

335+

336+buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()

337+buildLoop chan done =

338+ do msg <- readChan chan

339+ case msg of

340+ Left BDone ->

341+ do let !done1 = done + 1

342+ putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"

343+ buildLoop chan done1

344+

345+ Right result ->

346+ let

347+ !message = toFinalMessage done result

348+ !width = 12 + length (show done)

349+ in

350+ putStrLn $

351+ if length message < width

352+ then '\r' : replicate width ' ' ++ '\r' : message

353+ else '\r' : message

354+

355+

356+toFinalMessage :: Int -> BResult a -> [Char]

357+toFinalMessage done result =

358+ case result of

359+ Right _ ->

360+ case done of

361+ 0 -> "Success!"

362+ 1 -> "Success! Compiled 1 module."

363+ n -> "Success! Compiled " ++ show n ++ " modules."

364+

365+ Left problem ->

366+ case problem of

367+ Exit.BuildBadModules _ _ [] ->

368+ "Detected problems in 1 module."

369+

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

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

372+

373+ Exit.BuildProjectProblem _ ->

374+ "Detected a problem."

375+

376+

377+

378+-- GENERATE

379+

380+

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

382+reportGenerate style names output =

383+ case style of

384+ Silent ->

385+ return ()

386+

387+ Json ->

388+ return ()

389+

390+ Terminal mvar ->

391+ do readMVar mvar

392+ let cnames = fmap ModuleName.toChars names

393+ putStrLn ('\n' : toGenDiagram cnames output)

394+

395+

396+toGenDiagram :: NE.List [Char] -> FilePath -> [Char]

397+toGenDiagram (NE.List name names) output =

398+ let

399+ width = 3 + foldr (max . length) (length name) names

400+ in

401+ case names of

402+ [] ->

403+ toGenLine width name ('>' : ' ' : output ++ "\n")

404+

405+ _:_ ->

406+ unlines $

407+ toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)

408+ : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))

409+

410+

411+toGenLine :: Int -> [Char] -> [Char] -> [Char]

412+toGenLine width name end =

413+ " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end

414+

415+

416+hbar :: Char

417+hbar = if isWindows then '-' else '─'

418+

419+vtop :: Char

420+vtop = if isWindows then '+' else '┬'

421+

422+vmiddle :: Char

423+vmiddle = if isWindows then '+' else '┤'

424+

425+vbottom :: Char

426+vbottom = if isWindows then '+' else '┘'

427+

428+

429+--

430+

431+

432+putStrFlush :: String -> IO ()

433+putStrFlush str =

434+ hPutStr stdout str >> hFlush stdout

435+

436+

437+

438+-- REPORT EXCEPTIONS NICELY

439+

440+

441+reportExceptionsNicely :: SomeException -> IO a

442+reportExceptionsNicely e =

443+ case fromException e of

444+ Just UserInterrupt -> throw e

445+ _ -> putException e >> throw e

446+

447+

448+putException :: SomeException -> IO ()

449+putException e = do

450+ hPutStrLn stderr ""

451+ Help.toStderr $ D.stack $

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

453+ , D.reflow $

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

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

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

457+ , D.reflow $

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

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

460+ \ unstuck quickly."

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

462+ , D.reflow $

463+ "If you are feeling up to it, please try to get your code down to the smallest\

464+ \ version that still triggers this message. Ideally in a single Main.elm and\

465+ \ elm.json file."

466+ , D.reflow $

467+ "From there open a NEW issue at https://github.com/elm/compiler/issues with\

468+ \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\

469+ \ worry about if someone else saw something similar. More examples is better!"

470+ , D.reflow $

471+ "This kind of error is usually tied up in larger architectural choices that are\

472+ \ hard to change, so even when we have a couple good examples, it can take some\

473+ \ time to resolve in a solid way."

474+ ]

builder/src/Reporting/Exit.hs+2015−64

@@ -1,6 +1,27 @@

11{-# LANGUAGE OverloadedStrings #-}

22module Reporting.Exit

3− ( Exit(..)

3+ ( Init(..), initToReport

4+ , Diff(..), diffToReport

5+ , Make(..), makeToReport

6+ , Bump(..), bumpToReport

7+ , Repl(..), replToReport

8+ , Publish(..), publishToReport

9+ , Install(..), installToReport

10+ , Reactor(..), reactorToReport

11+ , newPackageOverview

12+ --

13+ , Solver(..)

14+ , Outline(..)

15+ , OutlineProblem(..)

16+ , Details(..)

17+ , DetailsBadDep(..)

18+ , PackageProblem(..)

19+ , RegistryProblem(..)

20+ , BuildProblem(..)

21+ , BuildProjectProblem(..)

22+ , DocsProblem(..)

23+ , Generate(..)

24+ --

425 , toString

526 , toStderr

627 , toJson

@@ -8,66 +29,1579 @@ module Reporting.Exit

829 where

930

1031

32+import qualified Data.ByteString as BS

33+import qualified Data.ByteString.UTF8 as BS_UTF8

34+import qualified Data.List as List

35+import qualified Data.Map as Map

36+import qualified Data.Name as N

37+import qualified Data.NonEmptyList as NE

38+import qualified Network.HTTP.Client as HTTP

39+import qualified Network.HTTP.Types.Header as HTTP

40+import qualified Network.HTTP.Types.Status as HTTP

41+import qualified System.FilePath as FP

42+import System.FilePath ((</>), (<.>))

43+

44+import qualified Elm.Constraint as C

45+import qualified Elm.Magnitude as M

1146import qualified Elm.ModuleName as ModuleName

47+import qualified Elm.Package as Pkg

48+import qualified Elm.Version as V

49+import qualified File

50+import qualified Http

51+import qualified Json.Decode as Decode

1252import qualified Json.Encode as Encode

53+import qualified Json.String as Json

54+import Parse.Primitives (Row, Col)

55+import qualified Reporting.Annotation as A

56+import Reporting.Doc ((<>))

1357import qualified Reporting.Doc as D

14−import qualified Reporting.Exit.Assets as Asset

15−import qualified Reporting.Exit.Bump as Bump

16−import qualified Reporting.Exit.Compile as Compile

17−import qualified Reporting.Exit.Crawl as Crawl

18−import qualified Reporting.Exit.Deps as Deps

19−import qualified Reporting.Exit.Diff as Diff

58+import qualified Reporting.Error.Import as Import

59+import qualified Reporting.Error.Json as Json

2060import qualified Reporting.Exit.Help as Help

21−import qualified Reporting.Exit.Http as Http

22−import qualified Reporting.Exit.Make as Make

23−import qualified Reporting.Exit.Init as Init

24−import qualified Reporting.Exit.Install as Install

25−import qualified Reporting.Exit.Publish as Publish

61+import qualified Reporting.Error as Error

62+import qualified Reporting.Render.Code as Code

2663

2764

2865

29−-- ALL POSSIBLE ERRORS

66+-- RENDERERS

3067

3168

32−data Exit

33− = NoElmJson

34− | Assets Asset.Exit

35− | Bump Bump.Exit

36− | Compile Compile.Exit [Compile.Exit]

37− | Crawl Crawl.Exit

38− | Cycle [ModuleName.Raw] -- TODO write docs to help with this scenario

39− | Deps Deps.Exit

40− | Diff Diff.Exit

41− | Make Make.Exit

42− | Init Init.Exit

43− | Install Install.Exit

44− | Publish Publish.Exit

45− | BadHttp String Http.Exit

69+toString :: Help.Report -> String

70+toString report =

71+ Help.toString (Help.reportToDoc report)

4672

4773

74+toStderr :: Help.Report -> IO ()

75+toStderr report =

76+ Help.toStderr (Help.reportToDoc report)

4877

49−-- RENDERERS

5078

79+toJson :: Help.Report -> Encode.Value

80+toJson report =

81+ Help.reportToJson report

82+

83+

84+

85+-- INIT

86+

87+

88+data Init

89+ = InitNoSolution [Pkg.Name]

90+ | InitNoOfflineSolution [Pkg.Name]

91+ | InitSolverProblem Solver

92+ | InitAlreadyExists

93+ | InitRegistryProblem RegistryProblem

94+

95+

96+initToReport :: Init -> Help.Report

97+initToReport exit =

98+ case exit of

99+ InitNoSolution pkgs ->

100+ Help.report "NO SOLUTION" Nothing

101+ "I tried to create an elm.json with the following direct dependencies:"

102+ [ D.indent 4 $ D.vcat $

103+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs

104+ , D.reflow $

105+ "I could not find compatible versions though! This should not happen, so please\

106+ \ ask around one of the community forums at https://elm-lang.org/community to learn\

107+ \ what is going on!"

108+ ]

109+

110+ InitNoOfflineSolution pkgs ->

111+ Help.report "NO OFFLINE SOLUTION" Nothing

112+ "I tried to create an elm.json with the following direct dependencies:"

113+ [ D.indent 4 $ D.vcat $

114+ map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs

115+ , D.reflow $

116+ "I could not find compatible versions though, but that may be because I could not\

117+ \ connect to https://package.elm-lang.org to get the latest list of packages. Are\

118+ \ you able to connect to the internet? Please ask around one of the community\

119+ \ forums at https://elm-lang.org/community for help!"

120+ ]

121+

122+ InitSolverProblem solver ->

123+ toSolverReport solver

124+

125+ InitAlreadyExists ->

126+ Help.report "EXISTING PROJECT" Nothing

127+ "You already have an elm.json file, so there is nothing for me to initialize!"

128+ [ D.fillSep

129+ ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"

130+ ,"you","figure","out","what","to","do","next?"

131+ ]

132+ ]

133+

134+ InitRegistryProblem problem ->

135+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

136+ "I need the list of published packages before I can start initializing projects"

137+

138+

139+

140+-- DIFF

141+

142+

143+data Diff

144+ = DiffNoOutline

145+ | DiffBadOutline Outline

146+ | DiffApplication

147+ | DiffNoExposed

148+ | DiffUnpublished

149+ | DiffUnknownPackage Pkg.Name [Pkg.Name]

150+ | DiffUnknownVersion Pkg.Name V.Version [V.Version]

151+ | DiffDocsProblem V.Version DocsProblem

152+ | DiffMustHaveLatestRegistry RegistryProblem

153+ | DiffBadDetails Details

154+ | DiffBadBuild BuildProblem

155+

156+

157+diffToReport :: Diff -> Help.Report

158+diffToReport diff =

159+ case diff of

160+ DiffNoOutline ->

161+ Help.report "DIFF WHAT?" Nothing

162+ "I cannot find an elm.json so I am not sure what you want me to diff.\

163+ \ Normally you run `elm diff` from within a project!"

164+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"

165+ , D.indent 4 $ D.green $ "elm diff elm/http 1.0.0 2.0.0"

166+ ]

167+

168+ DiffBadOutline outline ->

169+ toOutlineReport outline

170+

171+ DiffApplication ->

172+ Help.report "CANNOT DIFF APPLICATIONS" (Just "elm.json")

173+ "Your elm.json says this project is an application, but `elm diff` only works\

174+ \ with packages. That way there are previously published versions of the API to\

175+ \ diff against!"

176+ [ D.reflow $ "If you are just curious to see a diff, try running this command:"

177+ , D.indent 4 $ D.dullyellow $ "elm diff elm/json 1.0.0 1.1.2"

178+ ]

179+

180+ DiffNoExposed ->

181+ Help.report "NO EXPOSED MODULES" (Just "elm.json")

182+ "Your elm.json has no \"exposed-modules\" which means there is no public API at\

183+ \ all right now! What am I supposed to diff?"

184+ [ D.reflow $

185+ "Try adding some modules back to the \"exposed-modules\" field."

186+ ]

187+

188+ DiffUnpublished ->

189+ Help.report "UNPUBLISHED" Nothing

190+ "This package is not published yet. There is nothing to diff against!"

191+ []

192+

193+ DiffUnknownPackage pkg suggestions ->

194+ Help.report "UNKNOWN PACKAGE" Nothing

195+ ( "I cannot find a package called:"

196+ )

197+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg

198+ , "Maybe you want one of these instead?"

199+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Pkg.toChars) suggestions

200+ , "But check <https://package.elm-lang.org> to see all possibilities!"

201+ ]

202+

203+ DiffUnknownVersion _pkg vsn realVersions ->

204+ Help.docReport "UNKNOWN VERSION" Nothing

205+ ( D.fillSep $

206+ [ "Version", D.red (D.fromVersion vsn)

207+ , "has", "never", "been", "published,", "so", "I"

208+ , "cannot", "diff", "against", "it."

209+ ]

210+ )

211+ [ "Here are all the versions that HAVE been published:"

212+ , D.indent 4 $ D.dullyellow $ D.vcat $

213+ let

214+ sameMajor v1 v2 = V._major v1 == V._major v2

215+ mkRow vsns = D.hsep $ map D.fromVersion vsns

216+ in

217+ map mkRow $ List.groupBy sameMajor (List.sort realVersions)

218+ , "Want one of those instead?"

219+ ]

220+

221+ DiffDocsProblem version problem ->

222+ toDocsProblemReport problem $

223+ "I need the docs for " ++ V.toChars version ++ " to compute this diff"

224+

225+ DiffMustHaveLatestRegistry problem ->

226+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

227+ "I need the latest list of published packages before I do this diff"

228+

229+ DiffBadDetails details ->

230+ toDetailsReport details

231+

232+ DiffBadBuild buildProblem ->

233+ toBuildProblemReport buildProblem

234+

235+

236+

237+-- BUMP

238+

239+

240+data Bump

241+ = BumpNoOutline

242+ | BumpBadOutline Outline

243+ | BumpApplication

244+ | BumpUnexpectedVersion V.Version [V.Version]

245+ | BumpMustHaveLatestRegistry RegistryProblem

246+ | BumpCannotFindDocs Pkg.Name V.Version DocsProblem

247+ | BumpBadDetails Details

248+ | BumpNoExposed

249+ | BumpBadBuild BuildProblem

250+

251+

252+bumpToReport :: Bump -> Help.Report

253+bumpToReport bump =

254+ case bump of

255+ BumpNoOutline ->

256+ Help.report "BUMP WHAT?" Nothing

257+ "I cannot find an elm.json so I am not sure what you want me to bump."

258+ [ D.reflow $

259+ "Elm packages always have an elm.json that says current the version number. If\

260+ \ you run this command from a directory with an elm.json file, I will try to bump\

261+ \ the version in there based on the API changes."

262+ ]

263+

264+ BumpBadOutline outline ->

265+ toOutlineReport outline

266+

267+ BumpApplication ->

268+ Help.report "CANNOT BUMP APPLICATIONS" (Just "elm.json")

269+ "Your elm.json says this is an application. That means it cannot be published\

270+ \ on <https://package.elm-lang.org> and therefore has no version to bump!"

271+ []

272+

273+ BumpUnexpectedVersion vsn versions ->

274+ Help.docReport "CANNOT BUMP" (Just "elm.json")

275+ ( D.fillSep

276+ ["Your","elm.json","says","I","should","bump","relative","to","version"

277+ ,D.red (D.fromVersion vsn) <> ","

278+ ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."

279+ ,"That","means","there","is","no","API","for","me","to","diff","against","and"

280+ ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."

281+ ]

282+ )

283+ [ D.fillSep $

284+ ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]

285+ ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]

286+ , D.vcat $ map (D.green . D.fromVersion) versions

287+ ]

288+

289+ BumpMustHaveLatestRegistry problem ->

290+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

291+ "I need the latest list of published packages before I can bump any versions"

292+

293+ BumpCannotFindDocs _ version problem ->

294+ toDocsProblemReport problem $

295+ "I need the docs for " ++ V.toChars version ++ " to compute the next version number"

296+

297+ BumpBadDetails details ->

298+ toDetailsReport details

299+

300+ BumpNoExposed ->

301+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")

302+ ( D.fillSep $

303+ [ "To", "bump", "a", "package,", "the"

304+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"

305+ , "elm.json", "must", "list", "at", "least", "one", "module."

306+ ]

307+ )

308+ [ D.reflow $

309+ "Try adding some modules back to the \"exposed-modules\" field."

310+ ]

311+

312+ BumpBadBuild problem ->

313+ toBuildProblemReport problem

314+

315+

316+

317+-- OVERVIEW OF VERSIONING

318+

319+

320+newPackageOverview :: String

321+newPackageOverview =

322+ unlines

323+ [ "This package has never been published before. Here's how things work:"

324+ , ""

325+ , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"

326+ , ""

327+ , " - All packages start with initial version " ++ V.toChars V.one

328+ , ""

329+ , " - Versions are incremented based on how the API changes:"

330+ , ""

331+ , " PATCH = the API is the same, no risk of breaking code"

332+ , " MINOR = values have been added, existing values are unchanged"

333+ , " MAJOR = existing values have been changed or removed"

334+ , ""

335+ , " - I will bump versions for you, automatically enforcing these rules"

336+ , ""

337+ ]

338+

339+

340+

341+-- PUBLISH

342+

343+

344+data Publish

345+ = PublishNoOutline

346+ | PublishBadOutline Outline

347+ | PublishBadDetails Details

348+ | PublishMustHaveLatestRegistry RegistryProblem

349+ | PublishApplication

350+ | PublishNotInitialVersion V.Version

351+ | PublishAlreadyPublished V.Version

352+ | PublishInvalidBump V.Version V.Version

353+ | PublishBadBump V.Version V.Version M.Magnitude V.Version M.Magnitude

354+ | PublishNoSummary

355+ | PublishNoExposed

356+ | PublishNoReadme

357+ | PublishShortReadme

358+ | PublishNoLicense

359+ | PublishBuildProblem BuildProblem

360+ | PublishMissingTag V.Version

361+ | PublishCannotGetTag V.Version Http.Error

362+ | PublishCannotGetTagData V.Version String BS.ByteString

363+ | PublishCannotGetZip Http.Error

364+ | PublishCannotDecodeZip String

365+ | PublishCannotGetDocs V.Version V.Version DocsProblem

366+ | PublishCannotRegister Http.Error

367+ | PublishNoGit

368+ | PublishLocalChanges V.Version

369+ --

370+ | PublishZipBadDetails Details

371+ | PublishZipApplication

372+ | PublishZipNoExposed

373+ | PublishZipBuildProblem BuildProblem

374+

375+

376+publishToReport :: Publish -> Help.Report

377+publishToReport publish =

378+ case publish of

379+ PublishNoOutline ->

380+ Help.report "PUBLISH WHAT?" Nothing

381+ "I cannot find an elm.json so I am not sure what you want me to publish."

382+ [ D.reflow $

383+ "Elm packages always have an elm.json that states the version number,\

384+ \ dependencies, exposed modules, etc."

385+ ]

386+

387+ PublishBadOutline outline ->

388+ toOutlineReport outline

389+

390+ PublishBadDetails problem ->

391+ toDetailsReport problem

392+

393+ PublishMustHaveLatestRegistry problem ->

394+ toRegistryProblemReport "PROBLEM UPDATING PACKAGE LIST" problem $

395+ "I need the latest list of published packages to make sure this is safe to publish"

396+

397+ PublishApplication ->

398+ Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []

399+

400+ PublishNotInitialVersion vsn ->

401+ Help.docReport "INVALID VERSION" Nothing

402+ ( D.fillSep

403+ ["I","cannot","publish"

404+ ,D.red (D.fromVersion vsn)

405+ ,"as","the","initial","version."

406+ ]

407+ )

408+ [ D.fillSep

409+ ["Change","it","to",D.green "1.0.0","which","is"

410+ ,"the","initial","version","for","all","Elm","packages."

411+ ]

412+ ]

413+

414+ PublishAlreadyPublished vsn ->

415+ Help.docReport "ALREADY PUBLISHED" Nothing

416+ ( D.vcat

417+ [ D.fillSep

418+ [ "Version", D.green (D.fromVersion vsn)

419+ , "has", "already", "been", "published.", "You", "cannot"

420+ , "publish", "it", "again!"

421+ ]

422+ , "Try using the `bump` command:"

423+ ]

424+ )

425+ [ D.dullyellow $ D.indent 4 "elm bump"

426+ , D.reflow $

427+ "It computes the version number based on API changes, ensuring\

428+ \ that no breaking changes end up in PATCH releases!"

429+ ]

430+

431+ PublishInvalidBump statedVersion latestVersion ->

432+ Help.docReport "INVALID VERSION" (Just "elm.json")

433+ ( D.fillSep $

434+ ["Your","elm.json","says","the","next","version","should","be"

435+ ,D.red (D.fromVersion statedVersion) <> ","

436+ ,"but","that","is","not","valid","based","on","the","previously"

437+ ,"published","versions."

438+ ]

439+ )

440+ [ D.fillSep $

441+ ["Change","the","version","back","to"

442+ ,D.green (D.fromVersion latestVersion)

443+ ,"which","is","the","most","recently","published","version."

444+ ,"From","there,","have","Elm","bump","the","version","by","running:"

445+ ]

446+ , D.indent 4 $ D.green "elm bump"

447+ , D.reflow $

448+ "If you want more insight on the API changes Elm detects, you\

449+ \ can run `elm diff` at this point as well."

450+ ]

451+

452+ PublishBadBump old new magnitude realNew realMagnitude ->

453+ Help.docReport "INVALID VERSION" (Just "elm.json")

454+ (

455+ D.fillSep $

456+ ["Your","elm.json","says","the","next","version","should","be"

457+ ,D.red (D.fromVersion new) <> ","

458+ ,"indicating","a",D.fromChars (M.toChars magnitude)

459+ ,"change","to","the","public","API."

460+ ,"This","does","not","match","the","API","diff","given","by:"

461+ ]

462+ )

463+ [ D.indent 4 $ D.fromChars $

464+ "elm diff " ++ V.toChars old

465+

466+ , D.fillSep $

467+ ["This","command","says","this","is","a"

468+ ,D.fromChars (M.toChars realMagnitude)

469+ ,"change,","so","the","next","version","should","be"

470+ ,D.green (D.fromVersion realNew) <> "."

471+ ,"Double","check","everything","to","make","sure","you"

472+ ,"are","publishing","what","you","want!"

473+ ]

474+ , D.reflow $

475+ "Also, next time use `elm bump` and I'll figure all this out for you!"

476+ ]

477+

478+ PublishNoSummary ->

479+ Help.docReport "NO SUMMARY" (Just "elm.json")

480+ ( D.fillSep $

481+ [ "To", "publish", "a", "package,", "your", "elm.json", "must"

482+ , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"

483+ , "a", "consice", "overview", "of", "your", "project."

484+ ]

485+ )

486+ [ D.reflow $

487+ "The summary must be less than 80 characters. It should describe\

488+ \ the concrete use of your package as clearly and as plainly as possible."

489+ ]

490+

491+ PublishNoExposed ->

492+ Help.docReport "NO EXPOSED MODULES" (Just "elm.json")

493+ ( D.fillSep $

494+ [ "To", "publish", "a", "package,", "the"

495+ , D.dullyellow "\"exposed-modules\"", "field", "of", "your"

496+ , "elm.json", "must", "list", "at", "least", "one", "module."

497+ ]

498+ )

499+ [ D.reflow $

500+ "Which modules do you want users of the package to have access to? Add their\

501+ \ names to the \"exposed-modules\" list."

502+ ]

503+

504+ PublishNoReadme ->

505+ toBadReadmeReport "NO README" $

506+ "Every published package must have a helpful README.md\

507+ \ file, but I do not see one in your project."

508+

509+ PublishShortReadme ->

510+ toBadReadmeReport "SHORT README" $

511+ "This README.md is too short. Having more details will help\

512+ \ people assess your package quickly and fairly."

513+

514+ PublishNoLicense ->

515+ Help.report "NO LICENSE FILE" (Just "LICENSE")

516+ "By publishing a package you are inviting the Elm community to build\

517+ \ upon your work. But without knowing your license, we have no idea if\

518+ \ that is legal!"

519+ [ D.reflow $

520+ "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\

521+ \ you must share that choice in two places. First, the license\

522+ \ identifier must appear in your elm.json file. Second, the full\

523+ \ license text must appear in the root of your project in a file\

524+ \ named LICENSE. Add that file and you will be all set!"

525+ ]

526+

527+ PublishBuildProblem buildProblem ->

528+ toBuildProblemReport buildProblem

529+

530+ PublishMissingTag version ->

531+ let vsn = V.toChars version in

532+ Help.docReport "NO TAG" Nothing

533+ ( D.fillSep $

534+ [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"

535+ , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."

536+ ]

537+ )

538+ [ D.vcat

539+ [ "These tags make it possible to find this specific version on GitHub."

540+ , "To tag the most recent commit and push it to GitHub, run this:"

541+ ]

542+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $

543+ [ "git tag -a " ++ vsn ++ " -m \"new release\""

544+ , "git push origin " ++ vsn

545+ ]

546+ , "The -m flag is for a helpful message. Try to make it more informative!"

547+ ]

548+

549+ PublishCannotGetTag version httpError ->

550+ case httpError of

551+ Http.BadHttp _ (HTTP.StatusCodeException response _)

552+ | HTTP.statusCode (HTTP.responseStatus response) == 404 ->

553+ let vsn = V.toChars version in

554+ Help.report "NO TAG ON GITHUB" Nothing

555+ ("You have version " ++ vsn ++ " tagged locally, but not on GitHub.")

556+ [ D.reflow

557+ "Run the following command to make this tag available on GitHub:"

558+ , D.indent 4 $ D.dullyellow $ D.fromChars $

559+ "git push origin " ++ vsn

560+ , D.reflow

561+ "This will make it possible to find your code online based on the version number."

562+ ]

563+

564+ _ ->

565+ toHttpErrorReport "PROBLEM VERIFYING TAG" httpError

566+ "I need to check that the version tag is registered on GitHub"

567+

568+ PublishCannotGetTagData version url body ->

569+ Help.report "PROBLEM VERIFYING TAG" Nothing

570+ ("I need to check that version " ++ V.toChars version ++ " is tagged on GitHub, so I fetched:")

571+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

572+ , D.reflow $

573+ "I got the data back, but it was not what I was expecting. The response\

574+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

575+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

576+ , D.indent 4 $ D.dullyellow $ D.fromChars $

577+ if BS.length body <= 76

578+ then BS_UTF8.toString body

579+ else take 73 (BS_UTF8.toString body) ++ "..."

580+ , D.reflow $

581+ "Does this error keep showing up? Maybe there is something weird with your\

582+ \ internet connection. We have gotten reports that schools, businesses,\

583+ \ airports, etc. sometimes intercept requests and add things to the body\

584+ \ or change its contents entirely. Could that be the problem?"

585+ ]

586+

587+ PublishCannotGetZip httpError ->

588+ toHttpErrorReport "PROBLEM DOWNLOADING CODE" httpError $

589+ "I need to check that folks can download and build the source code when they\

590+ \ install this package"

591+

592+ PublishCannotDecodeZip url ->

593+ Help.report "PROBLEM DOWNLOADING CODE" Nothing

594+ "I need to check that folks can download and build the source code when they\

595+ \ install this package, so I downloaded the code from:"

596+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

597+ , D.reflow $

598+ "I was unable to unzip the archive though. Maybe there is something weird with\

599+ \ your internet connection. We have gotten reports that schools, businesses,\

600+ \ airports, etc. sometimes intercept requests and add things to the body or\

601+ \ change its contents entirely. Could that be the problem?"

602+ ]

603+

604+ PublishCannotGetDocs old new docsProblem ->

605+ toDocsProblemReport docsProblem $

606+ "I need the docs for " ++ V.toChars old ++ " to verify that "

607+ ++ V.toChars new ++ " really does come next"

608+

609+ PublishCannotRegister httpError ->

610+ toHttpErrorReport "PROBLEM PUBLISHING PACKAGE" httpError $

611+ "I need to send information about your package to the package website"

612+

613+ PublishNoGit ->

614+ Help.report "NO GIT" Nothing

615+ "I searched your PATH environment variable for `git` and could not\

616+ \ find it. Is it available through your PATH?"

617+ [ D.reflow $

618+ "Who cares about this? Well, I currently use `git` to check if there\

619+ \ are any local changes in your code. Local changes are a good sign\

620+ \ that some important improvements have gotten mistagged, so this\

621+ \ check can be extremely helpful for package authors!"

622+ , D.toSimpleNote $

623+ "We plan to do this without the `git` binary in a future release."

624+ ]

625+

626+ PublishLocalChanges version ->

627+ let vsn = V.toChars version in

628+ Help.docReport "LOCAL CHANGES" Nothing

629+ ( D.fillSep $

630+ [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"

631+ , "git", "does", "not", "match", "the", "code", "in", "your"

632+ , "working", "directory.", "This", "means", "you", "have"

633+ , "commits", "or", "local", "changes", "that", "are", "not"

634+ , "going", "to", "be", "published!"

635+ ]

636+ )

637+ [ D.toSimpleNote $

638+ "If you are sure everything is in order, you can run `git checkout "

639+ ++ vsn ++ "` and publish your code from there."

640+ ]

641+

642+ PublishZipBadDetails _ ->

643+ badZipReport

644+

645+ PublishZipApplication ->

646+ badZipReport

647+

648+ PublishZipNoExposed ->

649+ badZipReport

650+

651+ PublishZipBuildProblem _ ->

652+ badZipReport

653+

654+

655+toBadReadmeReport :: String -> String -> Help.Report

656+toBadReadmeReport title summary =

657+ Help.report title (Just "README.md") summary

658+ [ D.reflow $

659+ "When people look at your README, they are wondering:"

660+ , D.vcat

661+ [ " - What does this package even do?"

662+ , " - Will it help me solve MY problems?"

663+ ]

664+ , D.reflow $

665+ "So I recommend starting your README with a small example of the\

666+ \ most common usage scenario. Show people what they can expect if\

667+ \ they learn more!"

668+ , D.toSimpleNote $

669+ "By publishing your package, you are inviting people to invest time in\

670+ \ understanding your work. Spending an hour on your README to communicate your\

671+ \ knowledge more clearly can save the community days or weeks of time in\

672+ \ aggregate, and saving time in aggregate is the whole point of publishing\

673+ \ packages! People really appreciate it, and it makes the whole ecosystem feel\

674+ \ nicer!"

675+ ]

676+

677+

678+badZipReport :: Help.Report

679+badZipReport =

680+ Help.report "PROBLEM VERIFYING PACKAGE" Nothing

681+ "Before publishing packages, I download the code from GitHub and try to build it\

682+ \ from scratch. That way I can be more confident that it will work for other\

683+ \ people too. But I am not able to build it!"

684+ [ D.reflow $

685+ "I was just able to build your local copy though. Is there some way the version\

686+ \ on GitHub could be different?"

687+ ]

688+

689+

690+

691+-- DOCS

692+

693+

694+data DocsProblem

695+ = DP_Http Http.Error

696+ | DP_Data String BS.ByteString

697+ | DP_Cache

698+

699+

700+toDocsProblemReport :: DocsProblem -> String -> Help.Report

701+toDocsProblemReport problem context =

702+ case problem of

703+ DP_Http httpError ->

704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context

705+

706+ DP_Data url body ->

707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")

708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

709+ , D.reflow $

710+ "I got the data back, but it was not what I was expecting. The response\

711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

713+ , D.indent 4 $ D.dullyellow $ D.fromChars $

714+ if BS.length body <= 76

715+ then BS_UTF8.toString body

716+ else take 73 (BS_UTF8.toString body) ++ "..."

717+ , D.reflow $

718+ "Does this error keep showing up? Maybe there is something weird with your\

719+ \ internet connection. We have gotten reports that schools, businesses,\

720+ \ airports, etc. sometimes intercept requests and add things to the body\

721+ \ or change its contents entirely. Could that be the problem?"

722+ ]

723+

724+ DP_Cache ->

725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")

726+ [ D.reflow $

727+ "I deleted the cached version, so the next run should download a fresh copy of\

728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\

729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\

730+ \ for some reason."

731+ ]

51732

52−toString :: Exit -> String

53−toString exit =

54− Help.toString (Help.reportToDoc (toReport exit))

55733

56734

57−toStderr :: Exit -> IO ()

58−toStderr exit =

59− Help.toStderr (Help.reportToDoc (toReport exit))

735+-- INSTALL

60736

61737

62−toJson :: Exit -> Encode.Value

63−toJson exit =

64− Help.reportToJson (toReport exit)

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

65751

66752

67−toReport :: Exit -> Help.Report

68−toReport exit =

753+installToReport :: Install -> Help.Report

754+installToReport exit =

69755 case exit of

70− NoElmJson ->

756+ InstallNoOutline ->

757+ Help.report "NEW PROJECT?" Nothing

758+ "Are you trying to start a new project? Try this command instead:"

759+ [ D.indent 4 $ D.green "elm init"

760+ , D.reflow "It will help you get started!"

761+ ]

762+

763+ InstallBadOutline outline ->

764+ toOutlineReport outline

765+

766+ InstallBadRegistry problem ->

767+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

768+ "I need the list of published packages to figure out how to install things"

769+

770+ InstallNoArgs elmHome ->

771+ Help.report "INSTALL WHAT?" Nothing

772+ "I am expecting commands like:"

773+ [ D.green $ D.indent 4 $ D.vcat $

774+ [ "elm install elm/http"

775+ , "elm install elm/json"

776+ , "elm install elm/random"

777+ ]

778+ , D.toFancyHint

779+ ["In","JavaScript","folks","run","`npm install`","to","start","projects."

780+ ,"\"Gotta","download","everything!\"","But","why","download","packages"

781+ ,"again","and","again?","Instead,","Elm","caches","packages","in"

782+ ,D.dullyellow (D.fromChars elmHome)

783+ ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."

784+ ,"Elm","projects","check","that","cache","before","trying","the","internet."

785+ ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"

786+ ,"easier","to","work","offline.","As","a","result"

787+ ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"

788+ ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"

789+ ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"

790+ ]

791+ ]

792+

793+ InstallNoOnlineAppSolution pkg ->

794+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")

795+ (

796+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\

797+ \ with your existing dependencies."

798+ )

799+ [ D.reflow $

800+ "I checked all the published versions. When that failed, I tried to find any\

801+ \ compatible combination of these packages, even if it meant changing all your\

802+ \ existing dependencies! That did not work either!"

803+ , D.reflow $

804+ "This is most likely to happen when a package is not upgraded yet. Maybe a new\

805+ \ version of Elm came out recently? Maybe a common package was changed recently?\

806+ \ Maybe a better package came along, so there was no need to upgrade this one?\

807+ \ Try asking around https://elm-lang.org/community to learn what might be going on\

808+ \ with this package."

809+ , D.toSimpleNote $

810+ "Whatever the case, please be kind to the relevant package authors! Having\

811+ \ friendly interactions with users is great motivation, and conversely, getting\

812+ \ berated by strangers on the internet sucks your soul dry. Furthermore, package\

813+ \ authors are humans with families, friends, jobs, vacations, responsibilities,\

814+ \ goals, etc. They face obstacles outside of their technical work you will never\

815+ \ know about, so please assume the best and try to be patient and supportive!"

816+ ]

817+

818+ InstallNoOfflineAppSolution pkg ->

819+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")

820+ (

821+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\

822+ \ with your existing dependencies."

823+ )

824+ [ D.reflow $

825+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\

826+ \ able to look through packages that you have downloaded in the past."

827+ , D.reflow $

828+ "Try again later when you have internet!"

829+ ]

830+

831+ InstallNoOnlinePkgSolution pkg ->

832+ Help.report "CANNOT FIND COMPATIBLE VERSION" (Just "elm.json")

833+ (

834+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\

835+ \ with your existing constraints."

836+ )

837+ [ D.reflow $

838+ "With applications, I try to broaden the constraints to see if anything works,\

839+ \ but messing with package constraints is much more delicate business. E.g. making\

840+ \ your constraints stricter may make it harder for applications to find compatible\

841+ \ dependencies. So fixing something here may break it for a lot of other people!"

842+ , D.reflow $

843+ "So I recommend making an application with the same dependencies as your package.\

844+ \ See if there is a solution at all. From there it may be easier to figure out\

845+ \ how to proceed in a way that will disrupt your users as little as possible. And\

846+ \ the solution may be to help other package authors to get their packages updated,\

847+ \ or to drop a dependency entirely."

848+ ]

849+

850+ InstallNoOfflinePkgSolution pkg ->

851+ Help.report "CANNOT FIND COMPATIBLE VERSION LOCALLY" (Just "elm.json")

852+ (

853+ "I cannot find a version of " ++ Pkg.toChars pkg ++ " that is compatible\

854+ \ with your existing constraints."

855+ )

856+ [ D.reflow $

857+ "I was not able to connect to https://package.elm-lang.org/ though, so I was only\

858+ \ able to look through packages that you have downloaded in the past."

859+ , D.reflow $

860+ "Try again later when you have internet!"

861+ ]

862+

863+ InstallHadSolverTrouble solver ->

864+ toSolverReport solver

865+

866+ InstallUnknownPackageOnline pkg suggestions ->

867+ Help.docReport "UNKNOWN PACKAGE" Nothing

868+ (

869+ D.fillSep

870+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]

871+ )

872+ [ D.reflow $

873+ "I looked through https://package.elm-lang.org for packages with similar names\

874+ \ and found these:"

875+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions

876+ , D.reflow $ "Maybe you want one of these instead?"

877+ ]

878+

879+ InstallUnknownPackageOffline pkg suggestions ->

880+ Help.docReport "UNKNOWN PACKAGE" Nothing

881+ (

882+ D.fillSep

883+ ["I","cannot","find","a","package","named",D.red (D.fromPackage pkg) <> "."]

884+ )

885+ [ D.reflow $

886+ "I could not connect to https://package.elm-lang.org though, so new packages may\

887+ \ have been published since I last updated my local cache of package names."

888+ , D.reflow $

889+ "Looking through the locally cached names, the closest ones are:"

890+ , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromPackage suggestions

891+ , D.reflow $ "Maybe you want one of these instead?"

892+ ]

893+

894+ InstallBadDetails details ->

895+ toDetailsReport details

896+

897+

898+

899+-- SOLVER

900+

901+

902+data Solver

903+ = SolverBadCacheData Pkg.Name V.Version

904+ | SolverBadHttpData Pkg.Name V.Version String

905+ | SolverBadHttp Pkg.Name V.Version Http.Error

906+

907+

908+toSolverReport :: Solver -> Help.Report

909+toSolverReport problem =

910+ case problem of

911+ SolverBadCacheData pkg vsn ->

912+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing

913+ (

914+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\

915+ \ help me search for a set of compatible packages. I had it cached locally, but\

916+ \ it looks like the file was corrupted!"

917+ )

918+ [ D.reflow $

919+ "I deleted the cached version, so the next run should download a fresh copy.\

920+ \ Hopefully that will get you unstuck, but it will not resolve the root\

921+ \ problem if a 3rd party tool is modifing cached files for some reason."

922+ ]

923+

924+ SolverBadHttpData pkg vsn url ->

925+ Help.report "PROBLEM SOLVING PACKAGE CONSTRAINTS" Nothing

926+ (

927+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn ++ " to\

928+ \ help me search for a set of compatible packages, but I ran into corrupted\

929+ \ information from:"

930+ )

931+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

932+ , D.reflow $

933+ "Is something weird with your internet connection. We have gotten reports that\

934+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\

935+ \ to the body or change its contents entirely. Could that be the problem?"

936+ ]

937+

938+ SolverBadHttp pkg vsn httpError ->

939+ toHttpErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" httpError $

940+ "I need the elm.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn

941+ ++ " to help me search for a set of compatible packages"

942+

943+

944+

945+-- OUTLINE

946+

947+

948+data Outline

949+ = OutlineHasBadStructure (Decode.Error OutlineProblem)

950+ | OutlineHasMissingSrcDirs FilePath [FilePath]

951+ | OutlineHasDuplicateSrcDirs FilePath FilePath FilePath

952+ | OutlineNoPkgCore

953+ | OutlineNoAppCore

954+ | OutlineNoAppJson

955+

956+

957+data OutlineProblem

958+ = OP_BadType

959+ | OP_BadPkgName Row Col

960+ | OP_BadVersion Row Col

961+ | OP_BadConstraint C.Error

962+ | OP_BadModuleName Row Col

963+ | OP_BadModuleHeaderTooLong

964+ | OP_BadDependencyName Row Col

965+ | OP_BadLicense Json.String [Json.String]

966+ | OP_BadSummaryTooLong

967+ | OP_NoSrcDirs

968+

969+

970+toOutlineReport :: Outline -> Help.Report

971+toOutlineReport problem =

972+ case problem of

973+ OutlineHasBadStructure decodeError ->

974+ Json.toReport "elm.json" (Json.FailureToReport toOutlineProblemReport) decodeError $

975+ Json.ExplicitReason "I ran into a problem with your elm.json file."

976+

977+ OutlineHasMissingSrcDirs dir dirs ->

978+ case dirs of

979+ [] ->

980+ Help.report "MISSING SOURCE DIRECTORY" (Just "elm.json")

981+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directory:"

982+ [ D.indent 4 $ D.red $ D.fromChars dir

983+ , D.reflow $

984+ "I cannot find it though. Is it missing? Is there a typo?"

985+ ]

986+

987+ _:_ ->

988+ Help.report "MISSING SOURCE DIRECTORIES" (Just "elm.json")

989+ "I need a valid elm.json file, but the \"source-directories\" field lists the following directories:"

990+ [ D.indent 4 $ D.vcat $

991+ map (D.red . D.fromChars) (dir:dirs)

992+ , D.reflow $

993+ "I cannot find them though. Are they missing? Are there typos?"

994+ ]

995+

996+ OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2 ->

997+ if dir1 == dir2 then

998+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")

999+ "I need a valid elm.json file, but the \"source-directories\" field lists the same directory twice:"

1000+ [ D.indent 4 $ D.vcat $

1001+ map (D.red . D.fromChars) [dir1,dir2]

1002+ , D.reflow $

1003+ "Remove one of the entries!"

1004+ ]

1005+ else

1006+ Help.report "REDUNDANT SOURCE DIRECTORIES" (Just "elm.json")

1007+ "I need a valid elm.json file, but the \"source-directories\" field has some redundant directories:"

1008+ [ D.indent 4 $ D.vcat $

1009+ map (D.red . D.fromChars) [dir1,dir2]

1010+ , D.reflow $

1011+ "These are two different ways of refering to the same directory:"

1012+ , D.indent 4 $ D.dullyellow $ D.fromChars canonicalDir

1013+ , D.reflow $

1014+ "Remove one of the redundant entries from your \"source-directories\" field."

1015+ ]

1016+

1017+ OutlineNoPkgCore ->

1018+ Help.report "MISSING DEPENDENCY" (Just "elm.json")

1019+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\

1020+ \ of `List` and `Maybe` do not work without it."

1021+ [ D.reflow $

1022+ "If you modified your elm.json by hand, try to change it back! And if you are\

1023+ \ having trouble getting back to a working elm.json, it may be easier to find a\

1024+ \ working package and start fresh with their elm.json file."

1025+ ]

1026+

1027+ OutlineNoAppCore ->

1028+ Help.report "MISSING DEPENDENCY" (Just "elm.json")

1029+ "I need to see an \"elm/core\" dependency your elm.json file. The default imports\

1030+ \ of `List` and `Maybe` do not work without it."

1031+ [ D.reflow $

1032+ "If you modified your elm.json by hand, try to change it back! And if you are\

1033+ \ having trouble getting back to a working elm.json, it may be easier to delete it\

1034+ \ and use `elm init` to start fresh."

1035+ ]

1036+

1037+ OutlineNoAppJson ->

1038+ Help.report "MISSING DEPENDENCY" (Just "elm.json")

1039+ "I need to see an \"elm/json\" dependency your elm.json file. It helps me handle\

1040+ \ flags and ports."

1041+ [ D.reflow $

1042+ "If you modified your elm.json by hand, try to change it back! And if you are\

1043+ \ having trouble getting back to a working elm.json, it may be easier to delete it\

1044+ \ and use `elm init` to start fresh."

1045+ ]

1046+

1047+

1048+toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report

1049+toOutlineProblemReport path source _ region problem =

1050+ let

1051+ toHighlight row col =

1052+ Just $ A.Region (A.Position row col) (A.Position row col)

1053+

1054+ toSnippet title highlight pair =

1055+ Help.jsonReport title (Just path) $

1056+ Code.toSnippet source region highlight pair

1057+ in

1058+ case problem of

1059+ OP_BadType ->

1060+ toSnippet "UNEXPECTED TYPE" Nothing

1061+ ( D.reflow $

1062+ "I got stuck while reading your elm.json file. I cannot handle a \"type\" like this:"

1063+ , D.fillSep

1064+ ["Try","changing","the","\"type\"","to"

1065+ ,D.green "\"application\"","or",D.green "\"package\"","instead."

1066+ ]

1067+ )

1068+

1069+ OP_BadPkgName row col ->

1070+ toSnippet "INVALID PACKAGE NAME" (toHighlight row col)

1071+ ( D.reflow $

1072+ "I got stuck while reading your elm.json file. I ran into trouble with the package name:"

1073+ , D.stack

1074+ [ D.fillSep

1075+ ["Package","names","are","always","written","as"

1076+ ,D.green "\"author/project\""

1077+ ,"so","I","am","expecting","to","see","something","like:"

1078+ ]

1079+ , D.dullyellow $ D.indent 4 $ D.vcat $

1080+ [ "\"mdgriffith/elm-ui\""

1081+ , "\"w0rm/elm-physics\""

1082+ , "\"Microsoft/elm-json-tree-view\""

1083+ , "\"FordLabs/elm-star-rating\""

1084+ , "\"1602/json-schema\""

1085+ ]

1086+ , D.reflow

1087+ "The author name should match your GitHub name exactly, and the project name\

1088+ \ needs to follow these rules:"

1089+ , D.indent 4 $ D.vcat $

1090+ [ "+--------------------------------------+-----------+-----------+"

1091+ , "| RULE | BAD | GOOD |"

1092+ , "+--------------------------------------+-----------+-----------+"

1093+ , "| only lower case, digits, and hyphens | elm-HTTP | elm-http |"

1094+ , "| no leading digits | 3D | elm-3d |"

1095+ , "| no non-ASCII characters | elm-bjørn | elm-bear |"

1096+ , "| no underscores | elm_ui | elm-ui |"

1097+ , "| no double hyphens | elm--hash | elm-hash |"

1098+ , "| no starting or ending hyphen | -elm-tar- | elm-tar |"

1099+ , "+--------------------------------------+-----------+-----------+"

1100+ ]

1101+ , D.toSimpleNote $

1102+ "These rules only apply to the project name, so you should never need\

1103+ \ to change your GitHub name!"

1104+ ]

1105+ )

1106+

1107+ OP_BadVersion row col ->

1108+ toSnippet "PROBLEM WITH VERSION" (toHighlight row col)

1109+ ( D.reflow $

1110+ "I got stuck while reading your elm.json file. I was expecting a version number here:"

1111+ , D.fillSep

1112+ ["I","need","something","like",D.green "\"1.0.0\"","or",D.green "\"2.0.4\""

1113+ ,"that","explicitly","states","all","three","numbers!"

1114+ ]

1115+ )

1116+

1117+ OP_BadConstraint constraintError ->

1118+ case constraintError of

1119+ C.BadFormat row col ->

1120+ toSnippet "PROBLEM WITH CONSTRAINT" (toHighlight row col)

1121+ ( D.reflow $

1122+ "I got stuck while reading your elm.json file. I do not understand this version constraint:"

1123+ , D.stack

1124+ [ D.fillSep

1125+ ["I","need","something","like",D.green "\"1.0.0 <= v < 2.0.0\""

1126+ ,"that","explicitly","lists","the","lower","and","upper","bounds."

1127+ ]

1128+ , D.toSimpleNote $

1129+ "The spaces in there are required! Taking them out will confuse me. Adding\

1130+ \ extra spaces confuses me too. I recommend starting with a valid example\

1131+ \ and just changing the version numbers."

1132+ ]

1133+ )

1134+

1135+ C.InvalidRange before after ->

1136+ if before == after then

1137+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing

1138+ ( D.reflow $

1139+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"

1140+ , D.fillSep

1141+ ["Elm","checks","that","all","package","APIs","follow","semantic","versioning,"

1142+ ,"so","it","is","best","to","use","wide","constraints.","I","recommend"

1143+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor after) <> "\""

1144+ ,"since","it","is","guaranteed","that","breaking","API","changes","cannot"

1145+ ,"happen","in","any","of","the","versions","in","that","range."

1146+ ]

1147+ )

1148+

1149+ else

1150+ toSnippet "PROBLEM WITH CONSTRAINT" Nothing

1151+ ( D.reflow $

1152+ "I got stuck while reading your elm.json file. I ran into an invalid version constraint:"

1153+ , D.fillSep

1154+ ["Maybe","you","want","something","like"

1155+ ,D.green $ "\"" <> D.fromVersion before <> " <= v < " <> D.fromVersion (V.bumpMajor before) <> "\""

1156+ ,"instead?","Elm","checks","that","all","package","APIs","follow","semantic"

1157+ ,"versioning,","so","it","is","guaranteed","that","breaking","API","changes"

1158+ ,"cannot","happen","in","any","of","the","versions","in","that","range."

1159+ ]

1160+ )

1161+

1162+ OP_BadModuleName row col ->

1163+ toSnippet "PROBLEM WITH MODULE NAME" (toHighlight row col)

1164+ ( D.reflow $

1165+ "I got stuck while reading your elm.json file. I was expecting a module name here:"

1166+ , D.fillSep

1167+ ["I","need","something","like",D.green "\"Html.Events\""

1168+ ,"or",D.green "\"Browser.Navigation\""

1169+ ,"where","each","segment","starts","with","a","capital"

1170+ ,"letter","and","the","segments","are","separated","by","dots."

1171+ ]

1172+ )

1173+

1174+ OP_BadModuleHeaderTooLong ->

1175+ toSnippet "HEADER TOO LONG" Nothing

1176+ ( D.reflow $

1177+ "I got stuck while reading your elm.json file. This section header is too long:"

1178+ , D.stack

1179+ [ D.fillSep

1180+ ["I","need","it","to","be"

1181+ ,D.green "under",D.green "20",D.green "bytes"

1182+ ,"so","it","renders","nicely","on","the","package","website!"

1183+ ]

1184+ , D.toSimpleNote

1185+ "I count the length in bytes, so using non-ASCII characters costs extra.\

1186+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\

1187+ \ overly restrictive for your needs."

1188+ ]

1189+ )

1190+

1191+ OP_BadDependencyName row col ->

1192+ toSnippet "PROBLEM WITH DEPENDENCY NAME" (toHighlight row col)

1193+ ( D.reflow $

1194+ "I got stuck while reading your elm.json file. There is something wrong with this dependency name:"

1195+ , D.stack

1196+ [ D.fillSep

1197+ ["Package","names","always","include","the","name","of","the","author,"

1198+ ,"so","I","am","expecting","to","see","dependencies","like"

1199+ ,D.dullyellow "\"mdgriffith/elm-ui\"","and"

1200+ ,D.dullyellow "\"Microsoft/elm-json-tree-view\"" <> "."

1201+ ]

1202+ , D.fillSep $

1203+ ["I","generally","recommend","finding","the","package","you","want","on"

1204+ ,"the","package","website,","and","installing","it","with","the"

1205+ ,D.green "elm install","command!"

1206+ ]

1207+ ]

1208+ )

1209+

1210+ OP_BadLicense _ suggestions ->

1211+ toSnippet "UNKNOWN LICENSE" Nothing

1212+ ( D.reflow $

1213+ "I got stuck while reading your elm.json file. I do not know about this type of license:"

1214+ ,

1215+ D.stack

1216+ [ D.fillSep

1217+ ["Elm","packages","generally","use"

1218+ ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\"" <> ","

1219+ ,"but","I","accept","any","OSI","approved","SPDX","license."

1220+ ,"Here","some","that","seem","close","to","what","you","wrote:"

1221+ ]

1222+ , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromChars . Json.toChars) suggestions

1223+ , D.reflow $

1224+ "Check out https://spdx.org/licenses/ for the full list of options."

1225+ ]

1226+ )

1227+

1228+ OP_BadSummaryTooLong ->

1229+ toSnippet "SUMMARY TOO LONG" Nothing

1230+ ( D.reflow $

1231+ "I got stuck while reading your elm.json file. Your \"summary\" is too long:"

1232+ , D.stack

1233+ [ D.fillSep

1234+ ["I","need","it","to","be"

1235+ ,D.green "under",D.green "80",D.green "bytes"

1236+ ,"so","it","renders","nicely","on","the","package","website!"

1237+ ]

1238+ , D.toSimpleNote

1239+ "I count the length in bytes, so using non-ASCII characters costs extra.\

1240+ \ Please report your case at https://github.com/elm/compiler/issues if this seems\

1241+ \ overly restrictive for your needs."

1242+ ]

1243+ )

1244+

1245+ OP_NoSrcDirs ->

1246+ toSnippet "NO SOURCE DIRECTORIES" Nothing

1247+ ( D.reflow $

1248+ "I got stuck while reading your elm.json file. You do not have any \"source-directories\" listed here:"

1249+ , D.fillSep

1250+ ["I","need","something","like",D.green "[\"src\"]"

1251+ ,"so","I","know","where","to","look","for","your","modules!"

1252+ ]

1253+ )

1254+

1255+

1256+

1257+-- DETAILS

1258+

1259+

1260+data Details

1261+ = DetailsNoSolution

1262+ | DetailsNoOfflineSolution

1263+ | DetailsSolverProblem Solver

1264+ | DetailsBadElmInPkg C.Constraint

1265+ | DetailsBadElmInAppOutline V.Version

1266+ | DetailsHandEditedDependencies

1267+ | DetailsBadOutline Outline

1268+ | DetailsCannotGetRegistry RegistryProblem

1269+ | DetailsBadDeps FilePath [DetailsBadDep]

1270+

1271+

1272+data DetailsBadDep

1273+ = BD_BadDownload Pkg.Name V.Version PackageProblem

1274+ | BD_BadBuild Pkg.Name V.Version (Map.Map Pkg.Name V.Version)

1275+

1276+

1277+toDetailsReport :: Details -> Help.Report

1278+toDetailsReport details =

1279+ case details of

1280+ DetailsNoSolution ->

1281+ Help.report "INCOMPATIBLE DEPENDENCIES" (Just "elm.json")

1282+ "The dependencies in your elm.json are not compatible."

1283+ [ D.fillSep

1284+ ["Did","you","change","them","by","hand?","Try","to","change","it","back!"

1285+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."

1286+ ]

1287+ , D.reflow $

1288+ "Please ask for help on the community forums if you try those paths and are still\

1289+ \ having problems!"

1290+ ]

1291+

1292+ DetailsNoOfflineSolution ->

1293+ Help.report "TROUBLE VERIFYING DEPENDENCIES" (Just "elm.json")

1294+ "I could not connect to https://package.elm-lang.org to get the latest list of\

1295+ \ packages, and I was unable to verify your dependencies with the information I\

1296+ \ have cached locally."

1297+ [ D.reflow $

1298+ "Are you able to connect to the internet? These dependencies may work once you\

1299+ \ get access to the registry!"

1300+ , D.toFancyNote

1301+ ["If","you","changed","your","dependencies","by","hand,","try","to","change","them","back!"

1302+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."

1303+ ]

1304+ ]

1305+

1306+ DetailsSolverProblem solver ->

1307+ toSolverReport solver

1308+

1309+ DetailsBadElmInPkg constraint ->

1310+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")

1311+ "Your elm.json says this package needs a version of Elm in this range:"

1312+ [ D.indent 4 $ D.dullyellow $ D.fromChars $ C.toChars constraint

1313+ , D.fillSep

1314+ [ "But", "you", "are", "using", "Elm"

1315+ , D.red (D.fromVersion V.compiler)

1316+ , "right", "now."

1317+ ]

1318+ ]

1319+

1320+ DetailsBadElmInAppOutline version ->

1321+ Help.report "ELM VERSION MISMATCH" (Just "elm.json")

1322+ "Your elm.json says this application needs a different version of Elm."

1323+ [ D.fillSep

1324+ [ "It", "requires"

1325+ , D.green (D.fromVersion version) <> ","

1326+ , "but", "you", "are", "using"

1327+ , D.red (D.fromVersion V.compiler)

1328+ , "right", "now."

1329+ ]

1330+ ]

1331+

1332+ DetailsHandEditedDependencies ->

1333+ Help.report "ERROR IN DEPENDENCIES" (Just "elm.json")

1334+ "It looks like the dependencies elm.json in were edited by hand (or by a 3rd\

1335+ \ party tool) leaving them in an invalid state."

1336+ [ D.fillSep

1337+ ["Try","to","change","them","back","to","what","they","were","before!"

1338+ ,"It","is","much","more","reliable","to","add","dependencies","with",D.green "elm install" <> "."

1339+ ]

1340+ , D.reflow $

1341+ "Please ask for help on the community forums if you try those paths and are still\

1342+ \ having problems!"

1343+ ]

1344+

1345+ DetailsBadOutline outline ->

1346+ toOutlineReport outline

1347+

1348+ DetailsCannotGetRegistry problem ->

1349+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

1350+ "I need the list of published packages to verify your dependencies"

1351+

1352+ DetailsBadDeps cacheDir deps ->

1353+ case List.sortOn toBadDepRank deps of

1354+ [] ->

1355+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing

1356+ "I am not sure what is going wrong though."

1357+ [ D.reflow $

1358+ "I would try deleting the " ++ cacheDir ++ " and elm-stuff/ directories, then\

1359+ \ trying to build again. That will work if some cached files got corrupted\

1360+ \ somehow."

1361+ , D.reflow $

1362+ "If that does not work, go to https://elm-lang.org/community and ask for\

1363+ \ help. This is a weird case!"

1364+ ]

1365+

1366+ d:_ ->

1367+ case d of

1368+ BD_BadDownload pkg vsn packageProblem ->

1369+ toPackageProblemReport pkg vsn packageProblem

1370+

1371+ BD_BadBuild pkg vsn fingerprint ->

1372+ Help.report "PROBLEM BUILDING DEPENDENCIES" Nothing

1373+ "I ran into a compilation error when trying to build the following package:"

1374+ [ D.indent 4 $ D.red $ D.fromChars $ Pkg.toChars pkg ++ " " ++ V.toChars vsn

1375+ , D.reflow $

1376+ "This probably means it has package constraints that are too wide. It may be\

1377+ \ possible to tweak your elm.json to avoid the root problem as a stopgap. Head\

1378+ \ over to https://elm-lang.org/community to get help figuring out how to take\

1379+ \ this path!"

1380+ , D.toSimpleNote $

1381+ "To help with the root problem, please report this to the package author along\

1382+ \ with the following information:"

1383+ , D.indent 4 $ D.vcat $

1384+ map (\(p,v) -> D.fromChars $ Pkg.toChars p ++ " " ++ V.toChars v) $

1385+ Map.toList fingerprint

1386+ , D.reflow $

1387+ "If you want to help out even more, try building the package locally. That should\

1388+ \ give you much more specific information about why this package is failing to\

1389+ \ build, which will in turn make it easier for the package author to fix it!"

1390+ ]

1391+

1392+

1393+toBadDepRank :: DetailsBadDep -> Int -- lower is better

1394+toBadDepRank badDep =

1395+ case badDep of

1396+ BD_BadDownload _ _ _ -> 0

1397+ BD_BadBuild _ _ _ -> 1

1398+

1399+

1400+

1401+-- PACKAGE PROBLEM

1402+

1403+

1404+data PackageProblem

1405+ = PP_BadEndpointRequest Http.Error

1406+ | PP_BadEndpointContent String

1407+ | PP_BadArchiveRequest Http.Error

1408+ | PP_BadArchiveContent String

1409+ | PP_BadArchiveHash String String String

1410+

1411+

1412+toPackageProblemReport :: Pkg.Name -> V.Version -> PackageProblem -> Help.Report

1413+toPackageProblemReport pkg vsn problem =

1414+ let

1415+ thePackage =

1416+ Pkg.toChars pkg ++ " " ++ V.toChars vsn

1417+ in

1418+ case problem of

1419+ PP_BadEndpointRequest httpError ->

1420+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $

1421+ "I need to find the latest download link for " ++ thePackage

1422+

1423+ PP_BadEndpointContent url ->

1424+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing

1425+ (

1426+ "I need to find the latest download link for " ++ thePackage ++ ", but I ran into corrupted information from:"

1427+ )

1428+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

1429+ , D.reflow $

1430+ "Is something weird with your internet connection. We have gotten reports that\

1431+ \ schools, businesses, airports, etc. sometimes intercept requests and add things\

1432+ \ to the body or change its contents entirely. Could that be the problem?"

1433+ ]

1434+

1435+ PP_BadArchiveRequest httpError ->

1436+ toHttpErrorReport "PROBLEM DOWNLOADING PACKAGE" httpError $

1437+ "I was trying to download the source code for " ++ thePackage

1438+

1439+ PP_BadArchiveContent url ->

1440+ Help.report "PROBLEM DOWNLOADING PACKAGE" Nothing

1441+ (

1442+ "I downloaded the source code for " ++ thePackage ++ " from:"

1443+ )

1444+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

1445+ , D.reflow $

1446+ "But I was unable to unzip the data. Maybe there is something weird with\

1447+ \ your internet connection. We have gotten reports that schools, businesses,\

1448+ \ airports, etc. sometimes intercept requests and add things to the body or\

1449+ \ change its contents entirely. Could that be the problem?"

1450+ ]

1451+

1452+ PP_BadArchiveHash url expectedHash actualHash ->

1453+ Help.report "CORRUPT PACKAGE DATA" Nothing

1454+ (

1455+ "I downloaded the source code for " ++ thePackage ++ " from:"

1456+ )

1457+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

1458+ , D.reflow "But it looks like the hash of the archive has changed since publication:"

1459+ , D.vcat $ map D.fromChars $

1460+ [ " Expected: " ++ expectedHash

1461+ , " Actual: " ++ actualHash

1462+ ]

1463+ , D.reflow $

1464+ "This usually means that the package author moved the version\

1465+ \ tag, so report it to them and see if that is the issue. Folks\

1466+ \ on Elm slack can probably help as well."

1467+ ]

1468+

1469+

1470+

1471+-- REGISTRY PROBLEM

1472+

1473+

1474+data RegistryProblem

1475+ = RP_Http Http.Error

1476+ | RP_Data String BS.ByteString

1477+

1478+

1479+toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report

1480+toRegistryProblemReport title problem context =

1481+ case problem of

1482+ RP_Http err ->

1483+ toHttpErrorReport title err context

1484+

1485+ RP_Data url body ->

1486+ Help.report title Nothing (context ++ ", so I fetched:")

1487+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

1488+ , D.reflow $

1489+ "I got the data back, but it was not what I was expecting. The response\

1490+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

1491+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

1492+ , D.indent 4 $ D.dullyellow $ D.fromChars $

1493+ if BS.length body <= 76

1494+ then BS_UTF8.toString body

1495+ else take 73 (BS_UTF8.toString body) ++ "..."

1496+ , D.reflow $

1497+ "Does this error keep showing up? Maybe there is something weird with your\

1498+ \ internet connection. We have gotten reports that schools, businesses,\

1499+ \ airports, etc. sometimes intercept requests and add things to the body\

1500+ \ or change its contents entirely. Could that be the problem?"

1501+ ]

1502+

1503+

1504+toHttpErrorReport :: String -> Http.Error -> String -> Help.Report

1505+toHttpErrorReport title err context =

1506+ let

1507+ toHttpReport intro url details =

1508+ Help.report title Nothing intro $

1509+ D.indent 4 (D.dullyellow (D.fromChars url)) : details

1510+ in

1511+ case err of

1512+ Http.BadUrl url reason ->

1513+ toHttpReport (context ++ ", so I wanted to fetch:") url

1514+ [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"

1515+ , D.indent 4 $ D.fromChars reason

1516+ , D.reflow $

1517+ "This may indicate that there is some problem in the compiler, so please open an\

1518+ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\

1519+ \ version, the command you ran, the terminal output, and any additional information\

1520+ \ that might help others reproduce the error."

1521+ ]

1522+

1523+ Http.BadHttp url httpExceptionContent ->

1524+ case httpExceptionContent of

1525+ HTTP.StatusCodeException response body ->

1526+ let

1527+ (HTTP.Status code message) = HTTP.responseStatus response

1528+ in

1529+ toHttpReport (context ++ ", so I tried to fetch:") url

1530+ [ D.fillSep $

1531+ ["But","it","came","back","as",D.red (D.fromInt code)]

1532+ ++ map D.fromChars (words (BS_UTF8.toString message))

1533+ , D.indent 4 $ D.reflow $ BS_UTF8.toString body

1534+ , D.reflow $

1535+ "This may mean some online endpoint changed in an unexpected way, so if does not\

1536+ \ seem like something on your side is causing this (e.g. firewall) please report\

1537+ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\

1538+ \ version, the command you ran, the terminal output, and any additional information\

1539+ \ that can help others reproduce the error!"

1540+ ]

1541+

1542+ HTTP.TooManyRedirects responses ->

1543+ toHttpReport (context ++ ", so I tried to fetch:") url

1544+ [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"

1545+ , D.indent 4 $ D.vcat $ map toRedirectDoc responses

1546+ , D.reflow $

1547+ "Is it possible that your internet connection intercepts certain requests? That\

1548+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\

1549+ \ and certain countries. Try asking for help locally or in a community forum!"

1550+ ]

1551+

1552+ otherException ->

1553+ toHttpReport (context ++ ", so I tried to fetch:") url

1554+ [ D.reflow $ "But my HTTP library is giving me the following error message:"

1555+ , D.indent 4 $ D.fromChars (show otherException)

1556+ , D.reflow $

1557+ "Are you somewhere with a slow internet connection? Or no internet?\

1558+ \ Does the link I am trying to fetch work in your browser? Maybe the\

1559+ \ site is down? Does your internet connection have a firewall that\

1560+ \ blocks certain domains? It is usually something like that!"

1561+ ]

1562+

1563+ Http.BadMystery url someException ->

1564+ toHttpReport (context ++ ", so I tried to fetch:") url

1565+ [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"

1566+ , D.indent 4 $ D.fromChars (show someException)

1567+ , D.reflow $

1568+ "Is it possible that your internet connection intercepts certain requests? That\

1569+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\

1570+ \ and certain countries. Try asking for help locally or in a community forum!"

1571+ ]

1572+

1573+

1574+toRedirectDoc :: HTTP.Response body -> D.Doc

1575+toRedirectDoc response =

1576+ let

1577+ (HTTP.Status code message) = HTTP.responseStatus response

1578+ in

1579+ case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of

1580+ Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)

1581+ Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)

1582+

1583+

1584+

1585+-- MAKE

1586+

1587+

1588+data Make

1589+ = MakeNoOutline

1590+ | MakeCannotOptimizeAndDebug

1591+ | MakeBadDetails Details

1592+ | MakeAppNeedsFileNames

1593+ | MakePkgNeedsExposing

1594+ | MakeMultipleFilesIntoHtml

1595+ | MakeNoMain

1596+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]

1597+ | MakeCannotBuild BuildProblem

1598+ | MakeBadGenerate Generate

1599+

1600+

1601+makeToReport :: Make -> Help.Report

1602+makeToReport make =

1603+ case make of

1604+ MakeNoOutline ->

711605 Help.report "NO elm.json FILE" Nothing

721606 "It looks like you are starting a new Elm project. Very exciting! Try running:"

731607 [ D.indent 4 $ D.green $ "elm init"

@@ -75,44 +1609,461 @@ toReport exit =

751609 "It will help you get set up. It is really simple!"

761610 ]

771611

78− Assets assetExit ->

79− Asset.toReport assetExit

1612+ MakeCannotOptimizeAndDebug ->

1613+ Help.docReport "CLASHING FLAGS" Nothing

1614+ ( D.fillSep

1615+ ["I","cannot","compile","with",D.red "--optimize","and"

1616+ ,D.red "--debug","at","the","same","time."

1617+ ]

1618+ )

1619+ [ D.reflow

1620+ "I need to take away information to optimize things, and I need to\

1621+ \ add information to add the debugger. It is impossible to do both\

1622+ \ at once though! Pick just one of those flags and it should work!"

1623+ ]

1624+

1625+ MakeBadDetails detailsProblem ->

1626+ toDetailsReport detailsProblem

1627+

1628+ MakeAppNeedsFileNames ->

1629+ Help.report "NO INPUT" Nothing

1630+ "What should I make though? I need specific files like:"

1631+ [ D.vcat

1632+ [ D.indent 4 $ D.green "elm make src/Main.elm"

1633+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

1634+ ]

1635+ , D.reflow $

1636+ "I recommend reading through https://guide.elm-lang.org for guidance on what to\

1637+ \ actually put in those files!"

1638+ ]

1639+

1640+ MakePkgNeedsExposing ->

1641+ Help.report "NO INPUT" Nothing

1642+ "What should I make though? I need specific files like:"

1643+ [ D.vcat

1644+ [ D.indent 4 $ D.green "elm make src/Main.elm"

1645+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

1646+ ]

1647+ , D.reflow $

1648+ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\

1649+ \ I will try to compile the relevant files."

1650+ ]

1651+

1652+ MakeMultipleFilesIntoHtml ->

1653+ Help.report "TOO MANY FILES" Nothing

1654+ (

1655+ "When producing an HTML file, I can only handle one file."

1656+ )

1657+ [ D.fillSep

1658+ ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"

1659+ ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"

1660+ ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."

1661+ ]

1662+ , D.fillSep

1663+ ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"

1664+ ,"`main`","values","available","in","a","single","JavaScript","file.","Then"

1665+ ,"you","can","make","your","own","customized","HTML","file","that","embeds"

1666+ ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"

1667+ ,"dependencies","between","modules,","so","it","should","be","smaller","than"

1668+ ,"compiling","each","module","separately."

1669+ ]

1670+ ]

1671+

1672+ MakeNoMain ->

1673+ Help.report "NO MAIN" Nothing

1674+ (

1675+ "When producing an HTML file, I require that the given file has a `main` value.\

1676+ \ That way I have something to show on screen!"

1677+ )

1678+ [ D.reflow $

1679+ "Try adding a `main` value to your file? Or if you just want to verify that this\

1680+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\

1681+ \ altogether."

1682+ , D.toSimpleNote $

1683+ "Adding a `main` value can be as brief as adding something like this:"

1684+ , D.vcat

1685+ [ D.fillSep [D.cyan "import","Html"]

1686+ , ""

1687+ , D.fillSep [D.green "main","="]

1688+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]

1689+ ]

1690+ , D.reflow $

1691+ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\

1692+ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\

1693+ \ the `main` value."

1694+ ]

1695+

1696+ MakeNonMainFilesIntoJavaScript m ms ->

1697+ case ms of

1698+ [] ->

1699+ Help.report "NO MAIN" Nothing

1700+ (

1701+ "When producing a JS file, I require that the given file has a `main` value. That\

1702+ \ way Elm." ++ ModuleName.toChars m ++ ".init() is definitely defined in the\

1703+ \ resulting file!"

1704+ )

1705+ [ D.reflow $

1706+ "Try adding a `main` value to your file? Or if you just want to verify that this\

1707+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\

1708+ \ altogether."

1709+ , D.toSimpleNote $

1710+ "Adding a `main` value can be as brief as adding something like this:"

1711+ , D.vcat

1712+ [ D.fillSep [D.cyan "import","Html"]

1713+ , ""

1714+ , D.fillSep [D.green "main","="]

1715+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]

1716+ ]

1717+ , D.reflow $

1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\

1719+ \ make a `main` with no user interface."

1720+ ]

1721+

1722+ _:_ ->

1723+ Help.report "NO MAIN" Nothing

1724+ (

1725+ "When producing a JS file, I require that given files all have `main` values.\

1726+ \ That way functions like Elm." ++ ModuleName.toChars m ++ ".init() are\

1727+ \ definitely defined in the resulting file. I am missing `main` values in:"

1728+ )

1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)

1730+ , D.reflow $

1731+ "Try adding a `main` value to them? Or if you just want to verify that these\

1732+ \ modules compile, switch to --output=/dev/null to skip the code gen phase\

1733+ \ altogether."

1734+ , D.toSimpleNote $

1735+ "Adding a `main` value can be as brief as adding something like this:"

1736+ , D.vcat

1737+ [ D.fillSep [D.cyan "import","Html"]

1738+ , ""

1739+ , D.fillSep [D.green "main","="]

1740+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]

1741+ ]

1742+ , D.reflow $

1743+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\

1744+ \ make a `main` with no user interface."

1745+ ]

1746+

1747+ MakeCannotBuild buildProblem ->

1748+ toBuildProblemReport buildProblem

1749+

1750+ MakeBadGenerate generateProblem ->

1751+ toGenerateReport generateProblem

1752+

1753+

1754+

1755+-- BUILD PROBLEM

1756+

1757+

1758+data BuildProblem

1759+ = BuildBadModules FilePath Error.Module [Error.Module]

1760+ | BuildProjectProblem BuildProjectProblem

1761+

1762+

1763+data BuildProjectProblem

1764+ = BP_PathUnknown FilePath

1765+ | BP_WithBadExtension FilePath

1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath

1767+ | BP_MainPathDuplicate FilePath FilePath

1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath

1769+ | BP_RootNameInvalid FilePath FilePath [String]

1770+ | BP_CannotLoadDependencies

1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]

1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))

1773+

1774+

1775+toBuildProblemReport :: BuildProblem -> Help.Report

1776+toBuildProblemReport problem =

1777+ case problem of

1778+ BuildBadModules root e es ->

1779+ Help.compilerReport root e es

1780+

1781+ BuildProjectProblem projectProblem ->

1782+ toProjectProblemReport projectProblem

1783+

1784+

1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report

1786+toProjectProblemReport projectProblem =

1787+ case projectProblem of

1788+ BP_PathUnknown path ->

1789+ Help.report "FILE NOT FOUND" Nothing

1790+ "I cannot find this file:"

1791+ [ D.indent 4 $ D.red $ D.fromChars path

1792+ , D.reflow $ "Is there a typo?"

1793+ , D.toSimpleNote $

1794+ "If you are just getting started, try working through the examples in the\

1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\

1796+ \ that typically go in a src/Main.elm file."

1797+ ]

1798+

1799+ BP_WithBadExtension path ->

1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing

1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"

1802+ [ D.indent 4 $ D.red $ D.fromChars path

1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"

1804+ ]

1805+

1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->

1807+ Help.report "CONFUSING FILE" Nothing

1808+ "I am getting confused when I try to compile this file:"

1809+ [ D.indent 4 $ D.red $ D.fromChars path

1810+ , D.reflow $

1811+ "I always check if files appear in any of the \"source-directories\" listed in\

1812+ \ your elm.json to see if there might be some cached information about them. That\

1813+ \ can help me compile faster! But in this case, it looks like this file may be in\

1814+ \ either of these directories:"

1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]

1816+ , D.reflow $

1817+ "Try to make it so no source directory contains another source directory!"

1818+ ]

801819

81− Bump bumpExit ->

82− Bump.toReport bumpExit

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

831846

84− Compile e es ->

85− Help.compilerReport e es

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

861864

87− Crawl crawlExit ->

88− Crawl.toReport crawlExit

1865+ BP_CannotLoadDependencies ->

1866+ corruptCacheReport

891867

90− Cycle names ->

1868+ BP_Cycle name names ->

911869 Help.report "IMPORT CYCLE" Nothing

921870 "Your module imports form a cycle:"

93− [ D.cycle 4 names

1871+ [ D.cycle 4 name names

941872 , D.reflow $

951873 "Learn more about why this is disallowed and how to break cycles here:"

961874 ++ D.makeLink "import-cycles"

971875 ]

981876

99− Deps depsExit ->

100− Deps.toReport depsExit

1877+ BP_MissingExposed (NE.List (name, problem) _) ->

1878+ case problem of

1879+ Import.NotFound ->

1880+ Help.report "MISSING MODULE" (Just "elm.json")

1881+ "The \"exposed-modules\" of your elm.json lists the following module:"

1882+ [ D.indent 4 $ D.red $ D.fromName name

1883+ , D.reflow $

1884+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"

1885+ ]

1886+

1887+ Import.Ambiguous _ _ pkg _ ->

1888+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

1889+ "The \"exposed-modules\" of your elm.json lists the following module:"

1890+ [ D.indent 4 $ D.red $ D.fromName name

1891+ , D.reflow $

1892+ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\

1893+ \ choosing a different name for your local file."

1894+ ]

1895+

1896+ Import.AmbiguousLocal path1 path2 paths ->

1897+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

1898+ "The \"exposed-modules\" of your elm.json lists the following module:"

1899+ [ D.indent 4 $ D.red $ D.fromName name

1900+ , D.reflow $

1901+ "But I found multiple files with that name:"

1902+ , D.dullyellow $ D.indent 4 $ D.vcat $

1903+ map D.fromChars (path1:path2:paths)

1904+ , D.reflow $

1905+ "Change the module names to be distinct!"

1906+ ]

1907+

1908+ Import.AmbiguousForeign _ _ _ ->

1909+ Help.report "MISSING MODULE" (Just "elm.json")

1910+ "The \"exposed-modules\" of your elm.json lists the following module:"

1911+ [ D.indent 4 $ D.red $ D.fromName name

1912+ , D.reflow $

1913+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"

1914+ , D.toSimpleNote $

1915+ "It is not possible to \"re-export\" modules from other packages. You can only\

1916+ \ expose modules that you define in your own code."

1917+ ]

1918+

1919+

1920+toModuleNameConventionTable :: FilePath -> [String] -> D.Doc

1921+toModuleNameConventionTable srcDir names =

1922+ let

1923+ toPair name =

1924+ ( name

1925+ , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"

1926+ )

1927+

1928+ namePairs = map toPair names

1929+ nameWidth = maximum (11 : map (length . fst) namePairs)

1930+ pathWidth = maximum ( 9 : map (length . snd) namePairs)

1931+

1932+ padded width str =

1933+ str ++ replicate (width - length str) ' '

1934+

1935+ toRow (name, path) =

1936+ D.fromChars $

1937+ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"

1938+

1939+ bar =

1940+ D.fromChars $

1941+ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"

1942+ in

1943+ D.indent 4 $ D.vcat $

1944+ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]

1945+

1946+

1947+

1948+-- GENERATE

1949+

1950+

1951+data Generate

1952+ = GenerateCannotLoadArtifacts

1953+ | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]

1954+

1955+

1956+toGenerateReport :: Generate -> Help.Report

1957+toGenerateReport problem =

1958+ case problem of

1959+ GenerateCannotLoadArtifacts ->

1960+ corruptCacheReport

1961+

1962+ GenerateCannotOptimizeDebugValues m ms ->

1963+ Help.report "DEBUG REMNANTS" Nothing

1964+ "There are uses of the `Debug` module in the following modules:"

1965+ [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)

1966+ , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"

1967+ , D.toSimpleNote $

1968+ "The issue is that --optimize strips out info needed by `Debug` functions.\

1969+ \ Here are two examples:"

1970+ , D.indent 4 $ D.reflow $

1971+ "(1) It shortens record field names. This makes the generated JavaScript\

1972+ \ smaller, but `Debug.toString` cannot know the real field names anymore."

1973+ , D.indent 4 $ D.reflow $

1974+ "(2) Values like `type Height = Height Float` are unboxed. This reduces\

1975+ \ allocation, but it also means that `Debug.toString` cannot tell if it is\

1976+ \ looking at a `Height` or `Float` value."

1977+ , D.reflow $

1978+ "There are a few other cases like that, and it will be much worse once we start\

1979+ \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\

1980+ \ resulting in unpredictable behavior. I hope that clarifies why this restriction\

1981+ \ exists!"

1982+ ]

1983+

1984+

1985+

1986+-- CORRUPT CACHE

1987+

1988+

1989+corruptCacheReport :: Help.Report

1990+corruptCacheReport =

1991+ Help.report "CORRUPT CACHE" Nothing

1992+ "It looks like some of the information cached in elm-stuff/ has been corrupted."

1993+ [ D.reflow $

1994+ "Try deleting your elm-stuff/ directory to get unstuck."

1995+ , D.toSimpleNote $

1996+ "This almost certainly means that a 3rd party tool (or editor plugin) is\

1997+ \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\

1998+ \ one by one until you figure out which it is!"

1999+ ]

2000+

2001+

2002+

2003+-- REACTOR

2004+

2005+

2006+data Reactor

2007+ = ReactorNoOutline

2008+ | ReactorBadDetails Details

2009+ | ReactorBadBuild BuildProblem

2010+ | ReactorBadGenerate Generate

2011+

2012+

2013+reactorToReport :: Reactor -> Help.Report

2014+reactorToReport problem =

2015+ case problem of

2016+ ReactorNoOutline ->

2017+ Help.report "NEW PROJECT?" Nothing

2018+ "Are you trying to start a new project? Try this command in the terminal:"

2019+ [ D.indent 4 $ D.green "elm init"

2020+ , D.reflow "It will help you get started!"

2021+ ]

2022+

2023+ ReactorBadDetails details ->

2024+ toDetailsReport details

2025+

2026+ ReactorBadBuild buildProblem ->

2027+ toBuildProblemReport buildProblem

2028+

2029+ ReactorBadGenerate generate ->

2030+ toGenerateReport generate

2031+

2032+

2033+

2034+-- REPL

2035+

2036+

2037+data Repl

2038+ = ReplBadDetails Details

2039+ | ReplBadInput BS.ByteString Error.Error

2040+ | ReplBadLocalDeps FilePath Error.Module [Error.Module]

2041+ | ReplProjectProblem BuildProjectProblem

2042+ | ReplBadGenerate Generate

2043+ | ReplBadCache

2044+ | ReplBlocked

2045+

2046+

2047+replToReport :: Repl -> Help.Report

2048+replToReport problem =

2049+ case problem of

2050+ ReplBadDetails details ->

2051+ toDetailsReport details

1012052

102− Diff commandsExit ->

103− Diff.toReport commandsExit

2053+ ReplBadInput source err ->

2054+ Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []

1042055

105− Make makeExit ->

106− Make.toReport makeExit

2056+ ReplBadLocalDeps root e es ->

2057+ Help.compilerReport root e es

1072058

108− Init initExit ->

109− Init.toReport initExit

2059+ ReplProjectProblem projectProblem ->

2060+ toProjectProblemReport projectProblem

1102061

111− Install installExit ->

112− Install.toReport installExit

2062+ ReplBadGenerate generate ->

2063+ toGenerateReport generate

1132064

114− Publish publishExit ->

115− Publish.toReport publishExit

2065+ ReplBadCache ->

2066+ corruptCacheReport

1162067

117− BadHttp url httpExit ->

118− Http.toReport url httpExit

2068+ ReplBlocked ->

2069+ corruptCacheReport

builder/src/Reporting/Exit/Assets.hsdeleted−227

@@ -1,227 +0,0 @@

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/Bump.hsdeleted−51

@@ -1,51 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Bump

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import qualified Elm.Version as V

10−import Reporting.Doc ((<>))

11−import qualified Reporting.Doc as D

12−import qualified Reporting.Exit.Help as Help

13−

14−

15−

16−-- EXITS

17−

18−

19−data Exit

20− = Application

21− | Unbumpable V.Version [V.Version]

22−

23−

24−

25−-- TO REPORT

26−

27−

28−toReport :: Exit -> Help.Report

29−toReport exit =

30− case exit of

31− Application ->

32− Help.report "UNBUMPABLE" (Just "elm.json")

33− "Your elm.json says this is an application. That means it cannot be published\

34− \ on <https://package.elm-lang.org> and therefore has no version to bump!"

35− []

36−

37− Unbumpable vsn versions ->

38− Help.docReport "UNBUMPABLE" (Just "elm.json")

39− ( D.fillSep

40− ["Your","elm.json","says","I","should","bump","relative","to","version"

41− ,D.red (D.fromUtf8 (V.toString vsn)) <> ","

42− ,"but","I","cannot","find","that","version","on","<https://package.elm-lang.org>."

43− ,"That","means","there","is","no","API","for","me","to","diff","against","and"

44− ,"figure","out","if","these","are","MAJOR,","MINOR,","or","PATCH","changes."

45− ]

46− )

47− [ D.fillSep $

48− ["Try","bumping","again","after","changing","the",D.dullyellow "\"version\"","in","elm.json"]

49− ++ if length versions == 1 then ["to:"] else ["to","one","of","these:"]

50− , D.vcat $ map (D.green . D.fromUtf8 . V.toString) versions

51− ]

builder/src/Reporting/Exit/Compile.hsdeleted−104

@@ -1,104 +0,0 @@

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.hsdeleted−345

@@ -1,345 +0,0 @@

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.hsdeleted−123

@@ -1,123 +0,0 @@

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/Diff.hsdeleted−73

@@ -1,73 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Diff

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import qualified Data.List as List

10−

11−import qualified Elm.Package as Pkg

12−import qualified Elm.Version as V

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

23− | Unpublished

24− | UnknownPackage Pkg.Name [Pkg.Name]

25− | UnknownVersion Pkg.Name V.Version [V.Version]

26−

27−

28−

29−-- TO DOC

30−

31−

32−toReport :: Exit -> Help.Report

33−toReport exit =

34− case exit of

35− Application ->

36− Help.report "CANNOT DIFF APPLICATIONS" Nothing

37− "I cannot perform diffs on applications, only packages! If you are\

38− \ just curious to see a diff, try running this command:"

39− [ D.indent 4 $ D.green $ "elm diff elm/html 5.1.1 6.0.0"

40− ]

41−

42− Unpublished ->

43− Help.report "UNPUBLISHED" Nothing

44− "This package is not published yet. There is nothing to diff against!"

45− []

46−

47− UnknownPackage pkg suggestions ->

48− Help.report "UNKNOWN PACKAGE" Nothing

49− ( "I cannot find a package called:"

50− )

51− [ D.indent 4 $ D.red $ D.fromUtf8 $ Pkg.toString pkg

52− , "Maybe you want one of these instead?"

53− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromUtf8 . Pkg.toString) suggestions

54− , "But check <https://package.elm-lang.org> to see all possibilities!"

55− ]

56−

57− UnknownVersion _pkg vsn realVersions ->

58− Help.docReport "UNKNOWN VERSION" Nothing

59− ( D.fillSep $

60− [ "Version", D.red (D.fromUtf8 (V.toString vsn))

61− , "has", "never", "been", "published,", "so", "I"

62− , "cannot", "diff", "against", "it."

63− ]

64− )

65− [ "Here are all the versions that HAVE been published:"

66− , D.indent 4 $ D.dullyellow $ D.vcat $

67− let

68− sameMajor v1 v2 = V._major v1 == V._major v2

69− mkRow vsns = D.hsep $ map (D.fromUtf8 . V.toString) vsns

70− in

71− map mkRow $ List.groupBy sameMajor (List.sort realVersions)

72− , "Want one of those instead?"

73− ]

builder/src/Reporting/Exit/Help.hs+11−12

@@ -14,7 +14,6 @@ module Reporting.Exit.Help

1414 where

1515

1616

17−import qualified Data.Utf8 as Utf8

1817import GHC.IO.Handle (hIsTerminalDevice)

1918import System.IO (Handle, hPutStr, stderr, stdout)

2019

@@ -22,7 +21,7 @@ import qualified Json.Encode as E

2221import Json.Encode ((==>))

2322import Reporting.Doc ((<+>))

2423import qualified Reporting.Doc as D

25−import qualified Reporting.Exit.Compile as Compile

24+import qualified Reporting.Error as Error

2625

2726

2827

@@ -30,7 +29,7 @@ import qualified Reporting.Exit.Compile as Compile

3029

3130

3231data Report

33− = CompilerReport Compile.Exit [Compile.Exit]

32+ = CompilerReport FilePath Error.Module [Error.Module]

3433 | Report

3534 { _title :: String

3635 , _path :: Maybe FilePath

@@ -53,7 +52,7 @@ jsonReport =

5352 Report

5453

5554

56−compilerReport :: Compile.Exit -> [Compile.Exit] -> Report

55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report

5756compilerReport =

5857 CompilerReport

5958

@@ -65,8 +64,8 @@ compilerReport =

6564reportToDoc :: Report -> D.Doc

6665reportToDoc report_ =

6766 case report_ of

68− CompilerReport e es ->

69− Compile.toDoc e es

67+ CompilerReport root e es ->

68+ Error.toDoc root e es

7069

7170 Report title maybePath message ->

7271 let

@@ -95,17 +94,17 @@ reportToDoc report_ =

9594reportToJson :: Report -> E.Value

9695reportToJson report_ =

9796 case report_ of

98− CompilerReport e es ->

97+ CompilerReport _ e es ->

9998 E.object

100− [ "type" ==> E.string "compile-errors"

101− , "errors" ==> E.list Compile.toJson (e:es)

99+ [ "type" ==> E.chars "compile-errors"

100+ , "errors" ==> E.list Error.toJson (e:es)

102101 ]

103102

104103 Report title maybePath message ->

105104 E.object

106− [ "type" ==> E.string "error"

107− , "path" ==> maybe E.null (E.string . Utf8.fromChars) maybePath

108− , "title" ==> E.string (Utf8.fromChars title)

105+ [ "type" ==> E.chars "error"

106+ , "path" ==> maybe E.null E.chars maybePath

107+ , "title" ==> E.chars title

109108 , "message" ==> D.encode message

110109 ]

111110

builder/src/Reporting/Exit/Http.hsdeleted−104

@@ -1,104 +0,0 @@

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/Exit/Init.hsdeleted−48

@@ -1,48 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Init

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import qualified Elm.Package as Pkg

10−import qualified Reporting.Doc as D

11−import qualified Reporting.Exit.Help as Help

12−

13−

14−

15−-- EXITS

16−

17−

18−data Exit

19− = NoSolution [Pkg.Name]

20− | AlreadyStarted

21−

22−

23−

24−-- TO REPORT

25−

26−

27−toReport :: Exit -> Help.Report

28−toReport exit =

29− case exit of

30− NoSolution pkgs ->

31− Help.report "NO SOLUTION" Nothing

32− "I tried to create an elm.json with the following direct dependencies:"

33− [ D.indent 4 $ D.vcat $

34− map (D.dullyellow . D.fromChars . Pkg.toChars) pkgs

35− , D.reflow $

36− "I could not find compatible versions though! This should not happen, so please\

37− \ ask around one of the community forums <http://elm-lang.org/community> to learn\

38− \ what is going on!"

39− ]

40−

41− AlreadyStarted ->

42− Help.report "EXISTING PROJECT" Nothing

43− "You already have an elm.json file, so there is nothing for me to initialize!"

44− [ D.fillSep

45− ["Maybe",D.green (D.fromChars (D.makeLink "init")),"can","help"

46− ,"you","figure","out","what","to","do","next?"

47− ]

48− ]

builder/src/Reporting/Exit/Install.hsdeleted−82

@@ -1,82 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Install

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import qualified Elm.Package as Pkg

10−import qualified Elm.Version as V

11−import qualified Reporting.Doc as D

12−import qualified Reporting.Exit.Help as Help

13−

14−

15−

16−-- EXITS

17−

18−

19−data Exit

20− = NoArgs FilePath

21− | NoSolution [Pkg.Name]

22−

23−

24−

25−-- TO REPORT

26−

27−

28−toReport :: Exit -> Help.Report

29−toReport exit =

30− case exit of

31− NoArgs elmHome ->

32− Help.report "INSTALL WHAT?" Nothing

33− "I am expecting commands like:"

34− [ D.green $ D.indent 4 $ D.vcat $

35− [ "elm install elm/http"

36− , "elm install elm/json"

37− , "elm install elm/random"

38− ]

39− , D.toFancyHint

40− ["In","JavaScript","folks","run","`npm install`","to","start","projects."

41− ,"\"Gotta","download","everything!\"","But","why","download","packages"

42− ,"again","and","again?","Instead,","Elm","caches","packages","in"

43− ,D.dullyellow (D.fromChars elmHome)

44− ,"so","each","one","is","downloaded","and","built","ONCE","on","your","machine."

45− ,"Elm","projects","check","that","cache","before","trying","the","internet."

46− ,"This","reduces","build","times,","reduces","server","costs,","and","makes","it"

47− ,"easier","to","work","offline.","As","a","result"

48− ,D.dullcyan "elm install","is","only","for","adding","dependencies","to","elm.json,"

49− ,"whereas",D.dullcyan "elm make","is","in","charge","of","gathering","dependencies"

50− ,"and","building","everything.","So","maybe","try",D.green "elm make","instead?"

51− ]

52− ]

53−

54− NoSolution badPackages ->

55− case badPackages of

56− [] ->

57− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json")

58− "This usually happens if you try to modify dependency constraints by\

59− \ hand. I recommend deleting any dependency you added recently (or all\

60− \ of them if things are bad) and then adding them again with:"

61− [ D.indent 4 $ D.green "elm install"

62− , D.reflow $

63− "And do not be afaid to ask for help on Slack if you get stuck!"

64− ]

65−

66− _:_ ->

67− Help.report "OLD DEPENDENCIES" (Just "elm.json")

68− ( "The following packages do not work with Elm " ++ V.toChars V.compiler ++ " right now:"

69− )

70− [ D.indent 4 $ D.vcat $ map (D.red . D.fromUtf8 . Pkg.toString) badPackages

71− , D.reflow $

72− "This may be because it is not upgraded yet. It may be because a\

73− \ better solution came along, so there was no need to upgrade it.\

74− \ Etc. Try asking around on Slack to learn more about the topic."

75− , D.toSimpleNote

76− "Whatever the case, please be kind to the relevant package authors! Having\

77− \ friendly interactions with users is great motivation, and conversely, getting\

78− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\

79− \ authors are humans with families, friends, jobs, vacations, responsibilities,\

80− \ goals, etc. They face obstacles outside of their technical work you will never\

81− \ know about, so please assume the best and try to be patient and supportive!"

82− ]

builder/src/Reporting/Exit/Make.hsdeleted−75

@@ -1,75 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Make

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import qualified Elm.ModuleName as ModuleName

10−import qualified Reporting.Doc as D

11−import qualified Reporting.Exit.Help as Help

12−

13−

14−

15−-- EXITS

16−

17−

18−data Exit

19− = CannotMakeNothing

20− | CannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]

21− | CannotOptimizeAndDebug

22−

23−

24−

25−-- TO REPORT

26−

27−

28−toReport :: Exit -> Help.Report

29−toReport exit =

30− case exit of

31− CannotMakeNothing ->

32− Help.report "NO INPUT" Nothing

33− "What should I make though? I need more information, like:"

34− [ D.vcat

35− [ D.indent 4 $ D.green "elm make src/Main.elm"

36− , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

37− ]

38− , D.reflow

39− "However many files you give, I will create one JS file out of them."

40− ]

41−

42− CannotOptimizeDebugValues m ms ->

43− Help.report "DEBUG REMNANTS" Nothing

44− "There are uses of the `Debug` module in the following modules:"

45− [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.nameToChars) (m:ms)

46− , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"

47− , D.toSimpleNote $

48− "The issue is that --optimize strips out info needed by `Debug` functions.\

49− \ Here are two examples:"

50− , D.indent 4 $ D.reflow $

51− "(1) It shortens record field names. This makes the generated JavaScript is\

52− \ smaller, but `Debug.toString` cannot know the real field names anymore."

53− , D.indent 4 $ D.reflow $

54− "(2) Values like `type Height = Height Float` are unboxed. This reduces\

55− \ allocation, but it also means that `Debug.toString` cannot tell if it is\

56− \ looking at a `Height` or `Float` value."

57− , D.reflow $

58− "There are a few other cases like that, and it will be much worse once we start\

59− \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\

60− \ resulting in unpredictable behavior. I hope that clarifies why this restriction\

61− \ exists!"

62− ]

63−

64− CannotOptimizeAndDebug ->

65− Help.docReport "CLASHING FLAGS" Nothing

66− ( D.fillSep

67− ["I","cannot","compile","with",D.red "--optimize","and"

68− ,D.red "--debug","at","the","same","time."

69− ]

70− )

71− [ D.reflow

72− "I need to take away information to optimize things, and I need to\

73− \ add information to add the debugger. It is impossible to do both\

74− \ at once, so pick just one of those flags."

75− ]

builder/src/Reporting/Exit/Publish.hsdeleted−241

@@ -1,241 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Publish

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import Deps.Diff (Magnitude, magnitudeToString)

10−import qualified Elm.Version as V

11−import Reporting.Doc ((<>))

12−import qualified Reporting.Doc as D

13−import qualified Reporting.Exit.Help as Help

14−

15−

16−

17−-- EXITS

18−

19−

20−data Exit

21− = Application

22− | NotInitialVersion V.Version

23− | AlreadyPublished V.Version

24− | InvalidBump V.Version V.Version

25− | BadBump V.Version V.Version Magnitude V.Version Magnitude

26− | NoSummary

27− | NoExposed

28− | NoReadme

29− | ShortReadme

30− | NoLicense

31− | MissingTag V.Version

32− | NoGit

33− | LocalChanges V.Version

34−

35−

36−

37−-- TO REPORT

38−

39−

40−toReport :: Exit -> Help.Report

41−toReport exit =

42− case exit of

43− Application ->

44− Help.report "UNPUBLISHABLE" Nothing "I cannot publish applications, only packages!" []

45−

46− NotInitialVersion vsn ->

47− Help.docReport "INVALID VERSION" Nothing

48− ( D.fillSep

49− ["I","cannot","publish"

50− ,D.red (D.fromUtf8 (V.toString vsn))

51− ,"as","the","initial","version."

52− ]

53− )

54− [ D.fillSep

55− ["Change","it","to",D.green "1.0.0","which","is"

56− ,"the","initial","version","for","all","Elm","packages."

57− ]

58− ]

59−

60− AlreadyPublished vsn ->

61− Help.docReport "ALREADY PUBLISHED" Nothing

62− ( D.vcat

63− [ D.fillSep

64− [ "Version", D.green (D.fromUtf8 (V.toString vsn))

65− , "has", "already", "been", "published.", "You", "cannot"

66− , "publish", "it", "again!"

67− ]

68− , "Try using the `bump` command:"

69− ]

70− )

71− [ D.dullyellow $ D.indent 4 "elm bump"

72− , D.reflow $

73− "It computes the version number based on API changes, ensuring\

74− \ that no breaking changes end up in PATCH releases!"

75− ]

76−

77− InvalidBump statedVersion latestVersion ->

78− Help.docReport "INVALID VERSION" (Just "elm.json")

79− ( D.fillSep $

80− ["Your","elm.json","says","the","next","version","should","be"

81− ,D.red (D.fromUtf8 (V.toString statedVersion)) <> ","

82− ,"but","that","is","not","valid","based","on","the","previously"

83− ,"published","versions."

84− ]

85− )

86− [ D.fillSep $

87− ["Change","the","version","back","to"

88− ,D.green (D.fromUtf8 (V.toString latestVersion))

89− ,"which","is","the","most","recently","published","version."

90− ,"From","there,","have","Elm","bump","the","version","by","running:"

91− ]

92− , D.indent 4 $ D.green "elm bump"

93− , D.reflow $

94− "If you want more insight on the API changes Elm detects, you\

95− \ can run `elm diff` at this point as well."

96− ]

97−

98− BadBump old new magnitude realNew realMagnitude ->

99− Help.docReport "INVALID VERSION" (Just "elm.json")

100− (

101− D.fillSep $

102− ["Your","elm.json","says","the","next","version","should","be"

103− ,D.red (D.fromUtf8 (V.toString new)) <> ","

104− ,"indicating","a",D.fromChars (magnitudeToString magnitude)

105− ,"change","to","the","public","API."

106− ,"This","does","not","match","the","API","diff","given","by:"

107− ]

108− )

109− [ D.indent 4 $ D.fromChars $

110− "elm diff " ++ V.toChars old

111−

112− , D.fillSep $

113− ["This","command","says","this","is","a"

114− ,D.fromChars (magnitudeToString realMagnitude)

115− ,"change,","so","the","next","version","should","be"

116− ,D.green (D.fromUtf8 (V.toString realNew)) <> "."

117− ,"Double","check","everything","to","make","sure","you"

118− ,"are","publishing","what","you","want!"

119− ]

120− , D.reflow $

121− "Also, next time use `elm bump` and I'll figure all this out for you!"

122− ]

123−

124− NoSummary ->

125− Help.docReport "NO SUMMARY" (Just "elm.json")

126− ( D.fillSep $

127− [ "To", "publish", "a", "package,", "your", "elm.json", "must"

128− , "have", "a", D.dullyellow "\"summary\"", "field", "that", "gives"

129− , "a", "consice", "overview", "of", "your", "project."

130− ]

131− )

132− [ D.reflow $

133− "The summary must be less than 80 characters. It should describe\

134− \ the concrete use of your package as clearly and as plainly as possible."

135− ]

136−

137− NoExposed ->

138− Help.docReport "NO EXPOSED MODULES" (Just "elm.json")

139− ( D.fillSep $

140− [ "To", "publish", "a", "package,", "the"

141− , D.dullyellow "\"exposed-modules\"", "field", "of", "your"

142− , "elm.json", "must", "list", "at", "least", "one", "module."

143− ]

144− )

145− [ D.reflow $

146− "What is the point of a package that has no modules?!"

147− ]

148−

149− NoReadme ->

150− badReadmeReport "NO README" $

151− "Every published package must have a helpful README.md\

152− \ file, but I do not see one in your project."

153−

154− ShortReadme ->

155− badReadmeReport "SHORT README" $

156− "This README.md is too short. Having more details will help\

157− \ people assess your package quickly and fairly."

158−

159− NoLicense ->

160− Help.report "NO LICENSE FILE" (Just "LICENSE")

161− "By publishing a package you are inviting the Elm community to build\

162− \ upon your work. But without knowing your license, we have no idea if\

163− \ that is legal!"

164− [ D.reflow $

165− "Once you pick an OSI approved license from <https://spdx.org/licenses/>,\

166− \ you must share that choice in two places. First, the license\

167− \ identifier must appear in your elm.json file. Second, the full\

168− \ license text must appear in the root of your project in a file\

169− \ named LICENSE. Add that file and you will be all set!"

170− ]

171−

172− MissingTag version ->

173− let vsn = V.toChars version in

174− Help.docReport "NO TAG" Nothing

175− ( D.fillSep $

176− [ "Packages", "must", "be", "tagged", "in", "git,", "but", "I"

177− , "cannot", "find", "a", D.green (D.fromChars vsn), "tag."

178− ]

179− )

180− [ D.vcat

181− [ "These tags make it possible to find this specific version on GitHub."

182− , "To tag the most recent commit and push it to GitHub, run this:"

183− ]

184− , D.indent 4 $ D.dullyellow $ D.vcat $ map D.fromChars $

185− [ "git tag -a " ++ vsn ++ " -m \"new release\""

186− , "git push origin " ++ vsn

187− ]

188− , "The -m flag is for a helpful message. Try to make it more informative!"

189− ]

190−

191− NoGit ->

192− Help.report "NO GIT" Nothing

193− "I searched your PATH environment variable for `git` and could not\

194− \ find it. Is it available through your PATH?"

195− [ D.reflow $

196− "Who cares about this? Well, I currently use `git` to check if there\

197− \ are any local changes in your code. Local changes are a good sign\

198− \ that some important improvements have gotten mistagged, so this\

199− \ check can be extremely helpful for package authors!"

200− , D.toSimpleNote $

201− "We plan to do this without the `git` binary in a future release."

202− ]

203−

204− LocalChanges version ->

205− let vsn = V.toChars version in

206− Help.docReport "LOCAL CHANGES" Nothing

207− ( D.fillSep $

208− [ "The", "code", "tagged", "as", D.green (D.fromChars vsn), "in"

209− , "git", "does", "not", "match", "the", "code", "in", "your"

210− , "working", "directory.", "This", "means", "you", "have"

211− , "commits", "or", "local", "changes", "that", "are", "not"

212− , "going", "to", "be", "published!"

213− ]

214− )

215− [ D.toSimpleNote $

216− "If you are sure everything is in order, you can run `git checkout "

217− ++ vsn ++ "` and publish your code from there."

218− ]

219−

220−

221−badReadmeReport :: String -> String -> Help.Report

222−badReadmeReport title summary =

223− Help.report title (Just "README.md") summary

224− [ D.reflow $

225− "When people look at your README, they are wondering:"

226− , D.vcat

227− [ " - What does this package even do?"

228− , " - Will it help me solve MY problems?"

229− ]

230− , D.reflow $

231− "So I recommend starting your README with a small example of the\

232− \ most common usage scenario. Show people what they can expect if\

233− \ they learn more!"

234− , D.toSimpleNote $

235− "By publishing your package, you are inviting people to invest time\

236− \ in understanding your work. Spending an hour to communicate your\

237− \ knowledge more clearly can save the community days or weeks of time\

238− \ in aggregate, and saving time in aggregate is the whole point of\

239− \ publishing packages! People really appreciate it, and it makes the\

240− \ whole ecosystem feel nicer!"

241− ]

builder/src/Reporting/Progress.hsdeleted−118

@@ -1,118 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Reporting.Progress

3− ( Reporter(..)

4− , makeReporter

5− , silentReporter

6− , Msg(..)

7− , Progress(..)

8− , Outcome(..)

9− , PublishPhase(..)

10− , BumpPhase(..)

11− )

12− where

13−

14−

15−import Control.Concurrent.Chan (Chan, writeChan)

16−import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar)

17−import qualified Elm.ModuleName as ModuleName

18−import Deps.Diff (Magnitude)

19−import qualified Elm.Package as Pkg

20−import qualified Elm.Version as V

21−import qualified Reporting.Doc as D

22−import Reporting.Exit (Exit)

23−

24−

25−

26−-- REPORTER

27−

28−

29−data Reporter =

30− Reporter

31− { _tell :: Progress -> IO ()

32− , _ask :: D.Doc -> IO Bool

33− , _end :: Maybe Exit -> IO ()

34− }

35−

36−

37−makeReporter :: Chan Msg -> MVar () -> Reporter

38−makeReporter chan mvar =

39− let

40− tell progress =

41− writeChan chan (Progress progress)

42−

43− ask doc =

44− do var <- newEmptyMVar

45− writeChan chan (Ask doc var)

46− readMVar var

47−

48− end maybeError =

49− do writeChan chan (End maybeError)

50− readMVar mvar

51− in

52− Reporter tell ask end

53−

54−

55−silentReporter :: Reporter

56−silentReporter =

57− Reporter

58− (\_ -> return ())

59− (\_ -> return True)

60− (\_ -> return ())

61−

62−

63−

64−-- MESSAGES

65−

66−

67−data Msg

68− = Progress Progress

69− | Ask D.Doc (MVar Bool)

70− | End (Maybe Exit)

71−

72−

73−data Progress

74− -- download packages

75− = DownloadSkip

76− | DownloadStart [(Pkg.Name, V.Version)]

77− | DownloadPkgStart Pkg.Name V.Version

78− | DownloadPkgEnd Pkg.Name V.Version Outcome

79− | DownloadEnd Outcome

80−

81− -- build dependencies

82− | BuildDepsStart Int

83− | BuildDepsProgress

84− | BuildDepsEnd

85−

86− -- compile files

87− | CompileStart Int

88− | CompileFileStart ModuleName.Raw

89− | CompileFileEnd ModuleName.Raw Outcome

90− | CompileEnd

91−

92− -- publish

93− | PublishStart Pkg.Name V.Version (Maybe [V.Version])

94− | PublishCheckBump V.Version BumpPhase

95− | PublishProgress PublishPhase (Maybe Outcome)

96− | PublishEnd

97−

98− -- solver

99− | UnableToLoadLatestPackages

100−

101−

102−data Outcome = Good | Bad

103−

104−

105−data PublishPhase

106− = CheckReadme

107− | CheckLicense

108− | CheckTag V.Version

109− | CheckDownload

110− | CheckBuild

111− | CheckChanges

112−

113−

114−data BumpPhase

115− = StatedVersion

116− | GoodStart

117− | GoodBump V.Version Magnitude

118− | BadBump

builder/src/Reporting/Progress/Json.hsdeleted−34

@@ -1,34 +0,0 @@

1−module Reporting.Progress.Json

2− ( reporter

3− )

4− where

5−

6−

7−import qualified Data.ByteString.Builder as B

8−import System.IO (stderr)

9−

10−import qualified Reporting.Exit as Exit

11−import qualified Reporting.Progress as Progress

12−import qualified Json.Encode as Encode

13−

14−

15−

16−-- REPORTER

17−

18−

19−reporter :: Progress.Reporter

20−reporter =

21− Progress.Reporter

22− (\_ -> return ())

23− (\_ -> return True)

24− end

25−

26−

27−end :: Maybe Exit.Exit -> IO ()

28−end maybeExit =

29− case maybeExit of

30− Just exit ->

31− B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson exit))

32−

33− Nothing ->

34− return ()

builder/src/Reporting/Progress/Repl.hsdeleted−30

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

1−module Reporting.Progress.Repl

2− ( reporter

3− )

4− where

5−

6−

7−import qualified Reporting.Exit as Exit

8−import qualified Reporting.Progress as Progress

9−

10−

11−

12−-- REPORTER

13−

14−

15−reporter :: Progress.Reporter

16−reporter =

17− Progress.Reporter

18− (\_ -> return ())

19− (\_ -> return True)

20− end

21−

22−

23−end :: Maybe Exit.Exit -> IO ()

24−end maybeExit =

25− case maybeExit of

26− Just exit ->

27− Exit.toStderr exit

28−

29− Nothing ->

30− return ()

builder/src/Reporting/Progress/Terminal.hsdeleted−379

@@ -1,379 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Progress.Terminal

3− ( create

4− , newPackageOverview

5− )

6− where

7−

8−

9−import Control.Concurrent (forkIO)

10−import Control.Concurrent.Chan (Chan, newChan, readChan)

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

12−import qualified System.Info as Info

13−import System.IO (hFlush, hPutStr, stdout)

14−import qualified Elm.Package as Pkg

15−import qualified Elm.Version as V

16−

17−import qualified Deps.Diff as Diff

18−import Reporting.Doc ((<>), (<+>))

19−import qualified Reporting.Doc as D

20−import qualified Reporting.Exit as Exit

21−import qualified Reporting.Exit.Help as Help

22−import Reporting.Progress (Msg(..), Progress(..), Outcome(..), PublishPhase(..), BumpPhase(..))

23−import qualified Reporting.Progress as Progress

24−import qualified Reporting.Progress.Bar as Bar

25−

26−

27−

28−-- CREATE

29−

30−

31−create :: IO Progress.Reporter

32−create =

33− do chan <- newChan

34− mvar <- newEmptyMVar

35− _ <- forkIO (loop chan (State 0 0 0) >>= putMVar mvar)

36− return (Progress.makeReporter chan mvar)

37−

38−

39−

40−-- STATE

41−

42−

43−data State =

44− State

45− { _total :: !Int

46− , _good :: !Int

47− , _bad :: !Int

48− }

49−

50−

51−

52−-- LOOP

53−

54−

55−loop :: Chan Msg -> State -> IO ()

56−loop chan state =

57− do msg <- readChan chan

58− case msg of

59− End (Just exit) ->

60− Exit.toStderr exit

61−

62− End Nothing ->

63− return ()

64−

65− Ask doc mvar ->

66− do Help.toStdout doc

67− putMVar mvar =<< getApproval

68− loop chan state

69−

70− Progress progress ->

71− loopHelp chan progress state

72−

73−

74−getApproval :: IO Bool

75−getApproval =

76− do hFlush stdout

77− input <- getLine

78− case input of

79− "" -> return True

80− "Y" -> return True

81− "y" -> return True

82− "n" -> return False

83− _ ->

84− do putStr "Must type 'y' for yes or 'n' for no: "

85− getApproval

86−

87−

88−loopHelp :: Chan Msg -> Progress -> State -> IO ()

89−loopHelp chan progress state@(State total good bad) =

90− case progress of

91−

92−

93− -- DOWNLOADS

94−

95− DownloadSkip ->

96− do putStrLn "Dependencies loaded from local cache."

97− loop chan state

98−

99− DownloadStart [] ->

100− loop chan state

101−

102− DownloadStart _ ->

103− do putStrLn "Starting downloads...\n"

104− loop chan state

105−

106− DownloadPkgStart _name _version ->

107− loop chan state

108−

109− DownloadPkgEnd name version outcome ->

110− do Help.toStdout (makeBullet name version outcome)

111− loop chan state

112−

113− DownloadEnd Bad ->

114− do putStrLn ""

115− loop chan state

116−

117− DownloadEnd Good ->

118− do putStrLn ""

119− loop chan state

120−

121−

122− -- BUILD DEPS

123−

124− BuildDepsStart size ->

125− do hPutStr stdout "Verifying dependencies..."

126− hFlush stdout

127− loop chan (State size 0 0)

128−

129− BuildDepsProgress ->

130− do let n = good + 1

131− let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"

132− hPutStr stdout msg

133− hFlush stdout

134− loop chan (State total n 0)

135−

136− BuildDepsEnd ->

137− do putStrLn "\rDependencies ready! "

138− loop chan (State 0 0 0)

139−

140−

141− -- COMPILE

142−

143− CompileStart size ->

144− loop chan (State size 0 0)

145−

146− CompileFileStart _ ->

147− loop chan state

148−

149− CompileFileEnd _ Good ->

150− do hPutStr stdout $ Bar.render (good + 1) bad total

151− hFlush stdout

152− loop chan (State total (good + 1) bad)

153−

154− CompileFileEnd _ Bad ->

155− do hPutStr stdout $ Bar.render good (bad + 1) total

156− hFlush stdout

157− loop chan (State total good (bad + 1))

158−

159− CompileEnd ->

160− let

161− message =

162− case (bad, total) of

163− (0, 0) -> "Success!"

164− (0, 1) -> "Success! Compiled 1 module."

165− (0, n) -> "Success! Compiled " ++ show n ++ " modules."

166− (1, _) -> "Detected errors in 1 module."

167− (n, _) -> "Detected errors in " ++ show n ++ " modules."

168− in

169− do hPutStr stdout $ Bar.clear

170− putStrLn message

171− loop chan (State 0 0 0)

172−

173−

174− -- PUBLISH

175−

176− PublishStart name version maybePublishedVersions ->

177− case maybePublishedVersions of

178− Nothing ->

179− do putStrLn newPackageOverview

180− putStrLn "I will now verify that everything is in order..."

181− putStrLn ""

182− loop chan state

183−

184− Just _ ->

185− do putStrLn $ unwords [ "Verifying", Pkg.toChars name, V.toChars version, "..." ]

186− putStrLn ""

187− loop chan state

188−

189− PublishCheckBump version bumpPhase ->

190− do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase

191− hFlush stdout

192− loop chan state

193−

194− PublishProgress phase status ->

195− do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)

196− hFlush stdout

197− loop chan state

198−

199− PublishEnd ->

200− do putStrLn "Success!"

201− loop chan state

202−

203−

204− -- SOLVER

205−

206− UnableToLoadLatestPackages ->

207− do putStrLn ""

208− Help.toStdout $ D.dullyellow "WARNING:" <+> "I normally check <https://package.elm-lang.org> for new packages\n"

209− putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"

210− loop chan state

211−

212−

213−

214−-- BULLETS

215−

216−

217−makeBullet :: Pkg.Name -> V.Version -> Outcome -> D.Doc

218−makeBullet name version outcome =

219− let

220− nm = D.fromUtf8 (Pkg.toString name)

221− vsn = D.fromUtf8 (V.toString version)

222−

223− bullet =

224− case outcome of

225− Good -> goodMark

226− Bad -> badMark

227− in

228− D.indent 2 $ bullet <+> nm <+> vsn <> "\n"

229−

230−

231−goodMark :: D.Doc

232−goodMark =

233− D.green $

234− if Info.os == "mingw32" then "+" else "●"

235−

236−

237−badMark :: D.Doc

238−badMark =

239− D.red $

240− if Info.os == "mingw32" then "X" else "✗"

241−

242−

243−waitingMark :: D.Doc

244−waitingMark =

245− D.dullyellow $

246− if Info.os == "mingw32" then "-" else "→"

247−

248−

249−

250−-- OVERVIEW OF VERSIONING

251−

252−

253−newPackageOverview :: String

254−newPackageOverview =

255− unlines

256− [ "This package has never been published before. Here's how things work:"

257− , ""

258− , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"

259− , ""

260− , " - All packages start with initial version " ++ V.toChars V.one

261− , ""

262− , " - Versions are incremented based on how the API changes:"

263− , ""

264− , " PATCH = the API is the same, no risk of breaking code"

265− , " MINOR = values have been added, existing values are unchanged"

266− , " MAJOR = existing values have been changed or removed"

267− , ""

268− , " - I will bump versions for you, automatically enforcing these rules"

269− , ""

270− ]

271−

272−

273−

274−-- CHECKLIST

275−

276−

277−toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc

278−toChecklistDoc status (ChecklistMessages waiting success failure) =

279− let

280− padded message =

281− message ++ replicate (length waiting - length message) ' '

282− in

283− case status of

284− Nothing ->

285− " " <> waitingMark <+> D.fromChars waiting

286−

287− Just Good ->

288− "\r " <> goodMark <+> D.fromChars (padded success ++ "\n")

289−

290− Just Bad ->

291− "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n")

292−

293−

294−data ChecklistMessages =

295− ChecklistMessages

296− { _waiting :: String

297− , _success :: String

298− , _failure :: String

299− }

300−

301−

302−toChecklistMessages :: PublishPhase -> ChecklistMessages

303−toChecklistMessages phase =

304− case phase of

305− CheckReadme ->

306− ChecklistMessages

307− "Looking for README.md"

308− "Found README.md"

309− "Problem with your README.md"

310−

311− CheckLicense ->

312− ChecklistMessages

313− "Looking for LICENSE"

314− "Found LICENSE"

315− "Problem with your LICENSE"

316−

317− CheckTag version ->

318− ChecklistMessages

319− ("Is version " ++ V.toChars version ++ " tagged on GitHub?")

320− ("Version " ++ V.toChars version ++ " is tagged on GitHub")

321− ("Version " ++ V.toChars version ++ " is not tagged on GitHub!")

322−

323− CheckDownload ->

324− ChecklistMessages

325− "Downloading code from GitHub..."

326− "Code downloaded successfully from GitHub"

327− "Could not download code from GitHub!"

328−

329− CheckBuild ->

330− ChecklistMessages

331− "Building downloaded code and generated docs..."

332− "Downloaded code compiles successfully / docs generated\n"

333− "Cannot compile downloaded code!"

334−

335− CheckChanges ->

336− ChecklistMessages

337− "Checking for uncommitted changes..."

338− "No uncommitted changes in local code"

339− "Your local code is different than the code tagged on GitHub"

340−

341−

342−

343−-- BUMP PHASE

344−

345−

346−bumpPhaseToChecklistDoc :: V.Version -> BumpPhase -> D.Doc

347−bumpPhaseToChecklistDoc version bumpPhase =

348− let

349− mkMsgs success =

350− ChecklistMessages

351− ("Checking semantic versioning rules. Is " ++ V.toChars version ++ " correct?")

352− success

353− ("Version " ++ V.toChars version ++ " is not correct!")

354− in

355−

356− case bumpPhase of

357− StatedVersion ->

358− toChecklistDoc Nothing $ mkMsgs ""

359−

360− GoodStart ->

361− toChecklistDoc (Just Good) $ mkMsgs $

362− "All packages start at version " ++ V.toChars V.one

363−

364− GoodBump old magnitude ->

365− toChecklistDoc (Just Good) $ mkMsgs $

366− toCheckVersionSuccessMessage old version magnitude

367−

368− BadBump ->

369− toChecklistDoc (Just Bad) $ mkMsgs ""

370−

371−

372−toCheckVersionSuccessMessage :: V.Version -> V.Version -> Diff.Magnitude -> String

373−toCheckVersionSuccessMessage oldVersion newVersion magnitude =

374− let

375− old = V.toChars oldVersion

376− new = V.toChars newVersion

377− mag = Diff.magnitudeToString magnitude

378− in

379− "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"

builder/src/Reporting/Task.hs+40−76

@@ -1,78 +1,42 @@

1−{-# LANGUAGE OverloadedStrings, Rank2Types #-}

1+{-# LANGUAGE Rank2Types #-}

22module Reporting.Task

33 ( Task

44 , run

55 , throw

6− -- progress

7− , notify

8− , ask

9− -- io

6+ , mapError

7+ --

108 , io

9+ , mio

1110 , eio

12− , withKey

1311 )

1412 where

1513

1614

17−import qualified System.Exit as Exit

18−

19−import qualified Reporting.Doc as D

20−import qualified Reporting.Exit as Exit

21−import qualified Reporting.Progress as Progress

22−

23−

2415

2516-- TASKS

2617

2718

28−newtype Task a =

19+newtype Task x a =

2920 Task

3021 (

31− forall result.

32− Env

33− -> (a -> IO result)

34− -> (Exit.Exit -> IO result)

35− -> IO result

22+ forall result. (a -> IO result) -> (x -> IO result) -> IO result

3623 )

3724

3825

39−data Env =

40− Env

41− { _tell :: Progress.Progress -> IO ()

42− , _ask :: D.Doc -> IO Bool

43− }

44−

45−

46−run :: Progress.Reporter -> Task a -> IO ()

47−run (Progress.Reporter pTell pAsk pEnd) (Task task) =

48− task (Env pTell pAsk)

49− (\_ ->

50− do pEnd Nothing

51− return ()

52− )

53− (\exit ->

54− do pEnd (Just exit)

55− Exit.exitFailure

56− )

57−

58−

59−throw :: Exit.Exit -> Task a

60−throw exit =

61− Task $ \_ _ err -> err exit

26+run :: Task x a -> IO (Either x a)

27+run (Task task) =

28+ task (return . Right) (return . Left)

6229

6330

31+throw :: x -> Task x a

32+throw x =

33+ Task $ \_ err -> err x

6434

65−-- PROGRESS

6635

67−

68−notify :: Progress.Progress -> Task ()

69−notify progress =

70− Task $ \(Env pTell _) ok _ -> pTell progress >>= ok

71−

72−

73−ask :: D.Doc -> Task Bool

74−ask question =

75− Task $ \(Env _ pAsk) ok _ -> pAsk question >>= ok

36+mapError :: (x -> y) -> Task x a -> Task y a

37+mapError func (Task task) =

38+ Task $ \ok err ->

39+ task ok (err . func)

7640

7741

7842

@@ -80,71 +44,71 @@ ask question =

8044

8145

8246{-# INLINE io #-}

83−io :: IO a -> Task a

47+io :: IO a -> Task x a

8448io work =

85− Task $ \_ ok _ -> work >>= ok

49+ Task $ \ok _ -> work >>= ok

8650

8751

88−eio :: (x -> Exit.Exit) -> IO (Either x a) -> Task a

89−eio func work =

90− Task $ \_ ok err ->

52+mio :: x -> IO (Maybe a) -> Task x a

53+mio x work =

54+ Task $ \ok err ->

9155 do result <- work

9256 case result of

93− Right a -> ok a

94− Left e -> err (func e)

57+ Just a -> ok a

58+ Nothing -> err x

9559

9660

97−withKey :: (Progress.Key -> IO (Either Exit.Exit a)) -> Task a

98−withKey callback =

99− Task $ \(Env pTell _) ok err ->

100− do result <- callback (Progress.Key pTell)

61+eio :: (x -> y) -> IO (Either x a) -> Task y a

62+eio func work =

63+ Task $ \ok err ->

64+ do result <- work

10165 case result of

10266 Right a -> ok a

103− Left e -> err e

67+ Left x -> err (func x)

10468

10569

10670

10771-- INSTANCES

10872

10973

110−instance Functor Task where

74+instance Functor (Task x) where

11175 {-# INLINE fmap #-}

11276 fmap func (Task taskA) =

113− Task $ \env ok err ->

77+ Task $ \ok err ->

11478 let

11579 okA arg = ok (func arg)

11680 in

117− taskA env okA err

81+ taskA okA err

11882

11983

120−instance Applicative Task where

84+instance Applicative (Task x) where

12185 {-# INLINE pure #-}

12286 pure a =

123− Task $ \_ ok _ -> ok a

87+ Task $ \ok _ -> ok a

12488

12589 {-# INLINE (<*>) #-}

12690 (<*>) (Task taskFunc) (Task taskArg) =

127− Task $ \env ok err ->

91+ Task $ \ok err ->

12892 let

12993 okFunc func =

13094 let

13195 okArg arg = ok (func arg)

13296 in

133− taskArg env okArg err

97+ taskArg okArg err

13498 in

135− taskFunc env okFunc err

99+ taskFunc okFunc err

136100

137101

138−instance Monad Task where

102+instance Monad (Task x) where

139103 {-# INLINE return #-}

140104 return = pure

141105

142106 {-# INLINE (>>=) #-}

143107 (>>=) (Task taskA) callback =

144− Task $ \env ok err ->

108+ Task $ \ok err ->

145109 let

146110 okA a =

147111 case callback a of

148− Task taskB -> taskB env ok err

112+ Task taskB -> taskB ok err

149113 in

150− taskA env okA err

114+ taskA okA err

builder/src/Stuff.hs+49−29

@@ -7,18 +7,22 @@ module Stuff

77 , elmi

88 , elmo

99 , temp

10− , getRoot

10+ , findRoot

11+ , withRootLock

12+ , withRegistryLock

1113 , PackageCache

1214 , getPackageCache

1315 , registry

1416 , package

1517 , getReplCache

18+ , getElmHome

1619 )

1720 where

1821

1922

2023import qualified System.Directory as Dir

2124import qualified System.Environment as Env

25+import qualified System.FileLock as Lock

2226import qualified System.FilePath as FP

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

2428

@@ -31,29 +35,29 @@ import qualified Elm.Version as V

3135-- PATHS

3236

3337

34−stuff :: FilePath

35−stuff =

36− "elm-stuff" </> compilerVersion

38+stuff :: FilePath -> FilePath

39+stuff root =

40+ root </> "elm-stuff" </> compilerVersion

3741

3842

39−details :: FilePath

40−details =

41− stuff </> "d.dat"

43+details :: FilePath -> FilePath

44+details root =

45+ stuff root </> "d.dat"

4246

4347

44−interfaces :: FilePath

45−interfaces =

46− stuff </> "i.dat"

48+interfaces :: FilePath -> FilePath

49+interfaces root =

50+ stuff root </> "i.dat"

4751

4852

49−objects :: FilePath

50−objects =

51− stuff </> "o.dat"

53+objects :: FilePath -> FilePath

54+objects root =

55+ stuff root </> "o.dat"

5256

5357

54−prepublishDir :: FilePath

55−prepublishDir =

56− stuff </> "prepublish"

58+prepublishDir :: FilePath -> FilePath

59+prepublishDir root =

60+ stuff root </> "prepublish"

5761

5862

5963compilerVersion :: FilePath

@@ -77,39 +81,55 @@ elmo root name =

7781

7882toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath

7983toArtifactPath root name ext =

80− root </> stuff </> ModuleName.toHyphenPath name <.> ext

84+ stuff root </> ModuleName.toHyphenPath name <.> ext

8185

8286

8387

8488-- TEMP

8589

8690

87−temp :: String -> FilePath

88−temp ext =

89− stuff </> "temp" <.> ext

91+temp :: FilePath -> String -> FilePath

92+temp root ext =

93+ stuff root </> "temp" <.> ext

9094

9195

9296

93−-- GET ROOT

97+-- ROOT

9498

9599

96−getRoot :: IO (Maybe FilePath)

97−getRoot =

100+findRoot :: IO (Maybe FilePath)

101+findRoot =

98102 do dir <- Dir.getCurrentDirectory

99− getRootHelp (FP.splitDirectories dir)

103+ findRootHelp (FP.splitDirectories dir)

100104

101105

102−getRootHelp :: [String] -> IO (Maybe FilePath)

103−getRootHelp dirs =

106+findRootHelp :: [String] -> IO (Maybe FilePath)

107+findRootHelp dirs =

104108 case dirs of

105109 [] ->

106110 return Nothing

107111

108112 _:_ ->

109− do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")

110− if exists_

113+ do exists <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")

114+ if exists

111115 then return (Just (FP.joinPath dirs))

112− else getRootHelp (init dirs)

116+ else findRootHelp (init dirs)

117+

118+

119+

120+-- LOCKS

121+

122+

123+withRootLock :: FilePath -> IO a -> IO a

124+withRootLock root work =

125+ do let dir = stuff root

126+ Dir.createDirectoryIfMissing True dir

127+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

128+

129+

130+withRegistryLock :: PackageCache -> IO a -> IO a

131+withRegistryLock (PackageCache dir) work =

132+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

113133

114134

115135

cabal.confignew file+2

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

1+profiling: False

2+library-profiling: True

compiler/src/AST/Canonical.hs+12−9

@@ -56,12 +56,14 @@ 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

6059

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

6465import qualified Elm.ModuleName as ModuleName

66+import qualified Elm.String as ES

6567import qualified Reporting.Annotation as A

6668

6769

@@ -82,10 +84,10 @@ data Expr_

8284 | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation

8385 | VarDebug ModuleName.Canonical Name Annotation

8486 | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization

85− | Chr Utf8.String

86− | Str Utf8.String

87+ | Chr ES.String

88+ | Str ES.String

8789 | Int Int

88− | Float (Utf8.Under256 Float)

90+ | Float EF.Float

8991 | List [Expr]

9092 | Negate Expr

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

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

128130

129131data Decls

130132 = Declare Def Decls

131− | DeclareRec [Def] Decls

133+ | DeclareRec Def [Def] Decls

132134 | SaveTheEnvironment

133135

134136

@@ -150,8 +152,8 @@ data Pattern_

150152 | PList [Pattern]

151153 | PCons Pattern Pattern

152154 | PBool Union Bool

153− | PChr Utf8.String

154− | PStr Utf8.String

155+ | PChr ES.String

156+ | PStr ES.String

155157 | PInt Int

156158 | PCtor

157159 { _p_home :: ModuleName.Canonical

@@ -231,6 +233,7 @@ data Module =

231233 Module

232234 { _name :: ModuleName.Canonical

233235 , _exports :: Exports

236+ , _docs :: Src.Docs

234237 , _decls :: Decls

235238 , _unions :: Map.Map Name Union

236239 , _aliases :: Map.Map Name Alias

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

339342 0 -> return Normal

340343 1 -> return Enum

341344 2 -> return Unbox

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

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

343346

344347

345348instance Binary Annotation where

@@ -390,7 +393,7 @@ instance Binary AliasType where

390393 case n of

391394 0 -> liftM Holey get

392395 1 -> liftM Filled get

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

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

394397

395398

396399instance Binary FieldType where

compiler/src/AST/Optimized.hs+101−40

@@ -7,30 +7,35 @@ module AST.Optimized

77 , Destructor(..)

88 , Decider(..)

99 , Choice(..)

10− , Graph(..)

10+ , GlobalGraph(..)

11+ , LocalGraph(..)

1112 , Main(..)

1213 , Node(..)

1314 , EffectsType(..)

1415 , empty

15− , union

16− , unions

16+ , addGlobalGraph

17+ , addLocalGraph

18+ , addKernel

19+ , toKernelGlobal

1720 )

1821 where

1922

2023

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

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

23−import qualified Data.List as List

2426import qualified Data.Map as Map

27+import qualified Data.Name as Name

2528import Data.Name (Name)

2629import qualified Data.Set as Set

27−import qualified Data.Utf8 as Utf8

2830

2931import qualified AST.Canonical as Can

3032import qualified AST.Utils.Shader as Shader

3133import qualified Data.Index as Index

34+import qualified Elm.Float as EF

3235import qualified Elm.Kernel as K

3336import qualified Elm.ModuleName as ModuleName

37+import qualified Elm.Package as Pkg

38+import qualified Elm.String as ES

3439import qualified Optimize.DecisionTree as DT

3540import qualified Reporting.Annotation as A

3641

@@ -41,10 +46,10 @@ import qualified Reporting.Annotation as A

4146

4247data Expr

4348 = Bool Bool

44− | Chr Utf8.String

45− | Str Utf8.String

49+ | Chr ES.String

50+ | Str ES.String

4651 | Int Int

47− | Float (Utf8.Under256 Float)

52+ | Float EF.Float

4853 | VarLocal Name

4954 | VarGlobal Global

5055 | VarEnum Global Index.ZeroBased

@@ -70,7 +75,6 @@ data Expr

7075

7176

7277data Global = Global ModuleName.Canonical Name

73− deriving (Eq, Ord)

7478

7579

7680

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

121125-- OBJECT GRAPH

122126

123127

124−data Graph =

125− Graph

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

127− , _nodes :: Map.Map Global Node

128− , _fields :: Map.Map Name Int

128+data GlobalGraph =

129+ GlobalGraph

130+ { _g_nodes :: Map.Map Global Node

131+ , _g_fields :: Map.Map Name Int

132+ }

133+

134+

135+data LocalGraph =

136+ LocalGraph

137+ { _l_main :: Maybe Main

138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name

139+ , _l_fields :: Map.Map Name Int

129140 }

130141

131142

@@ -159,27 +170,72 @@ data EffectsType = Cmd | Sub | Fx

159170

160171

161172{-# NOINLINE empty #-}

162−empty :: Graph

173+empty :: GlobalGraph

163174empty =

164− Graph Map.empty Map.empty Map.empty

175+ GlobalGraph Map.empty Map.empty

176+

177+

178+addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph

179+addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) =

180+ GlobalGraph

181+ { _g_nodes = Map.union nodes1 nodes2

182+ , _g_fields = Map.union fields1 fields2

183+ }

184+

185+

186+addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph

187+addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) =

188+ GlobalGraph

189+ { _g_nodes = Map.union nodes1 nodes2

190+ , _g_fields = Map.union fields1 fields2

191+ }

192+

165193

194+addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph

195+addKernel shortName chunks (GlobalGraph nodes fields) =

196+ let

197+ global = toKernelGlobal shortName

198+ node = Kernel chunks (foldr addKernelDep Set.empty chunks)

199+ in

200+ GlobalGraph

201+ { _g_nodes = Map.insert global node nodes

202+ , _g_fields = Map.union (K.countFields chunks) fields

203+ }

204+

205+

206+addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global

207+addKernelDep chunk deps =

208+ case chunk of

209+ K.JS _ -> deps

210+ K.ElmVar home name -> Set.insert (Global home name) deps

211+ K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps

212+ K.ElmField _ -> deps

213+ K.JsField _ -> deps

214+ K.JsEnum _ -> deps

215+ K.Debug -> deps

216+ K.Prod -> deps

217+

218+

219+toKernelGlobal :: Name.Name -> Global

220+toKernelGlobal shortName =

221+ Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar

166222

167−union :: Graph -> Graph -> Graph

168−union (Graph mains1 graph1 fields1) (Graph mains2 graph2 fields2) =

169− Graph

170− (Map.union mains1 mains2)

171− (Map.union graph1 graph2)

172− (Map.union fields1 fields2)

173223

174224

175−unions :: [Graph] -> Graph

176−unions graphs =

177− case graphs of

178− [] ->

179− empty

225+-- INSTANCES

180226

181− g:gs ->

182− List.foldl' union g gs

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

183239

184240

185241

@@ -252,7 +308,7 @@ instance Binary Expr where

252308 24 -> pure Unit

253309 25 -> liftM3 Tuple get get get

254310 26 -> liftM3 Shader get get get

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

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

256312

257313

258314instance Binary Def where

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

266322 case word of

267323 0 -> liftM2 Def get get

268324 1 -> liftM3 TailDef get get get

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

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

270326

271327

272328instance Binary Destructor where

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

289345 1 -> liftM2 Field get get

290346 2 -> liftM Unbox get

291347 3 -> liftM Root get

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

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

293349

294350

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

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

305361 0 -> liftM Leaf get

306362 1 -> liftM3 Chain get get get

307363 2 -> liftM3 FanOut get get get

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

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

309365

310366

311367instance Binary Choice where

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

319375 case word of

320376 0 -> liftM Inline get

321377 1 -> liftM Jump get

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

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

379+

380+

323381

382+instance Binary GlobalGraph where

383+ get = liftM2 GlobalGraph get get

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

324385

325386

326−instance Binary Graph where

327− get = liftM3 Graph get get get

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

387+instance Binary LocalGraph where

388+ get = liftM3 LocalGraph get get get

389+ put (LocalGraph a b c) = put a >> put b >> put c

329390

330391

331392instance Binary Main where

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

339400 case word of

340401 0 -> return Static

341402 1 -> liftM2 Dynamic get get

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

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

343404

344405

345406instance Binary Node where

@@ -371,7 +432,7 @@ instance Binary Node where

371432 8 -> liftM2 Kernel get get

372433 9 -> liftM2 PortIncoming get get

373434 10 -> liftM2 PortOutgoing get get

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

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

375436

376437

377438instance Binary EffectsType where

@@ -387,4 +448,4 @@ instance Binary EffectsType where

387448 0 -> return Cmd

388449 1 -> return Sub

389450 2 -> return Fx

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

451+ _ -> fail "problem getting Opt.EffectsType binary"

compiler/src/AST/Source.hs+39−22

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

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

32module AST.Source

43 ( Expr, Expr_(..), VarType(..)

54 , Def(..)

@@ -7,15 +6,17 @@ module AST.Source

76 , Type, Type_(..)

87 , Module(..)

98 , getName

10− , getImport

9+ , getImportName

1110 , Import(..)

1211 , Value(..)

1312 , Union(..)

1413 , Alias(..)

15− , Binop(..)

14+ , Infix(..)

1615 , Port(..)

1716 , Effects(..)

1817 , Manager(..)

18+ , Docs(..)

19+ , Comment(..)

1920 , Exposing(..)

2021 , Exposed(..)

2122 , Privacy(..)

@@ -24,10 +25,13 @@ module AST.Source

2425

2526

2627import Data.Name (Name)

27−import qualified Data.Utf8 as Utf8

28+import qualified Data.Name as Name

2829

2930import qualified AST.Utils.Binop as Binop

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

3135import qualified Reporting.Annotation as A

3236

3337

@@ -39,10 +43,10 @@ type Expr = A.Located Expr_

3943

4044

4145data Expr_

42− = Chr Utf8.String

43− | Str Utf8.String

46+ = Chr ES.String

47+ | Str ES.String

4448 | Int Int

45− | Float (Utf8.Under256 Float)

49+ | Float EF.Float

4650 | Var VarType Name

4751 | VarQual VarType Name Name

4852 | List [Expr]

@@ -93,8 +97,8 @@ data Pattern_

9397 | PCtorQual A.Region Name Name [Pattern]

9498 | PList [Pattern]

9599 | PCons Pattern Pattern

96− | PChr Utf8.String

97− | PStr Utf8.String

100+ | PChr ES.String

101+ | PStr ES.String

98102 | PInt Int

99103

100104

@@ -122,26 +126,30 @@ data Type_

122126

123127data Module =

124128 Module

125− { _name :: Maybe Name

129+ { _name :: Maybe (A.Located Name)

126130 , _exports :: A.Located Exposing

131+ , _docs :: Docs

127132 , _imports :: [Import]

128133 , _values :: [A.Located Value]

129134 , _unions :: [A.Located Union]

130135 , _aliases :: [A.Located Alias]

131− , _binops :: [A.Located Binop]

136+ , _binops :: [A.Located Infix]

132137 , _effects :: Effects

133138 }

134139

135140

136141getName :: Module -> Name

137−getName (Module maybeName _ _ _ _ _ _ _) =

142+getName (Module maybeName _ _ _ _ _ _ _ _) =

138143 case maybeName of

139− Just name -> name

140− Nothing -> "Main"

144+ Just (A.At _ name) ->

145+ name

141146

147+ Nothing ->

148+ Name._Main

142149

143−getImport :: Import -> Name

144−getImport (Import (A.At _ name) _ _) =

150+

151+getImportName :: Import -> Name

152+getImportName (Import (A.At _ name) _ _) =

145153 name

146154

147155

@@ -156,7 +164,7 @@ data Import =

156164data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)

157165data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]

158166data Alias = Alias (A.Located Name) [A.Located Name] Type

159−data Binop = Binop Name Binop.Associativity Binop.Precedence Name

167+data Infix = Infix Name Binop.Associativity Binop.Precedence Name

160168data Port = Port (A.Located Name) Type

161169

162170

@@ -172,21 +180,30 @@ data Manager

172180 | Fx (A.Located Name) (A.Located Name)

173181

174182

183+data Docs

184+ = NoDocs A.Region

185+ | YesDocs Comment [(Name, Comment)]

186+

187+

188+newtype Comment =

189+ Comment P.Snippet

190+

191+

175192

176193-- EXPOSING

177194

178195

179196data Exposing

180197 = Open

181− | Explicit [A.Located Exposed]

198+ | Explicit [Exposed]

182199

183200

184201data Exposed

185− = Lower Name

186− | Upper Name Privacy

187− | Operator Name

202+ = Lower (A.Located Name)

203+ | Upper (A.Located Name) Privacy

204+ | Operator A.Region Name

188205

189206

190207data Privacy

191− = Public

208+ = Public A.Region

192209 | Private

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

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

4141instance Binary Associativity where

4242 get =

4343 do n <- getWord8

44− return $

45− case n of

46− 0 -> Left

47− 1 -> Non

48− 2 -> Right

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

44+ case n of

45+ 0 -> return Left

46+ 1 -> return Non

47+ 2 -> return Right

48+ _ -> fail "Error reading valid associativity from serialized string"

5049

5150 put assoc =

5251 putWord8 $

compiler/src/AST/Utils/Shader.hs+51−4

@@ -4,22 +4,27 @@ module AST.Utils.Shader

44 ( Source

55 , Types(..)

66 , Type(..)

7+ , fromChars

8+ , toJsStringBuilder

79 )

810 where

911

1012

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

1118import qualified Data.Map as Map

1219import qualified Data.Name as Name

13−import qualified Data.Utf8 as Utf8

1420

1521

1622

1723-- SOURCE

1824

1925

20−type Source = Utf8.VeryLong SOURCE

21−

22−data SOURCE

26+newtype Source =

27+ Source BS.ByteString

2328

2429

2530

@@ -42,3 +47,45 @@ data Type

4247 | V4

4348 | M4

4449 | 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,5 +1,4 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

32module AST.Utils.Type

43 ( delambda

54 , dealias

compiler/src/Canonicalize/Environment.hs+50−20

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

44 ( Env(..)

55 , Exposed

66 , Qualified

7+ , Info(..)

8+ , mergeInfo

79 , Var(..)

810 , Type(..)

911 , Ctor(..)

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

2022

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

2224import qualified Data.Map.Strict as Map

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

2425import qualified Data.Name as Name

26+import qualified Data.OneOrMore as OneOrMore

2527

2628import qualified AST.Utils.Binop as Binop

2729import qualified AST.Canonical as Can

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

5860

5961

6062type Exposed a =

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

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

6264

6365

6466type Qualified a =

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

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

68+

69+

70+

71+-- INFO

72+

73+

74+data Info a

75+ = Specific ModuleName.Canonical a

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

77+

78+

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

80+mergeInfo info1 info2 =

81+ case info1 of

82+ Specific h1 _ ->

83+ case info2 of

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

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

86+

87+ Ambiguous h1 hs1 ->

88+ case info2 of

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

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

6691

6792

6893

@@ -72,7 +97,8 @@ type Qualified a =

7297data Var

7398 = Local A.Region

7499 | TopLevel A.Region

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

100+ | Foreign ModuleName.Canonical Can.Annotation

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

76102

77103

78104

@@ -139,7 +165,10 @@ addLocalLeft _ region =

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

140166addLocalBoth name region var =

141167 case var of

142− Foreign _ ->

168+ Foreign _ _ ->

169+ Result.ok (Local region)

170+

171+ Foreigns _ _ ->

143172 Result.ok (Local region)

144173

145174 Local parentRegion ->

@@ -150,17 +179,18 @@ addLocalBoth name region var =

150179

151180

152181

182+

153183-- FIND TYPE

154184

155185

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

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

158188 case Map.lookup name ts of

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

189+ Just (Specific _ tipe) ->

160190 Result.ok tipe

161191

162− Just homes ->

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

192+ Just (Ambiguous h hs) ->

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

164194

165195 Nothing ->

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

@@ -171,11 +201,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

171201 case Map.lookup prefix qts of

172202 Just qualified ->

173203 case Map.lookup name qualified of

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

204+ Just (Specific _ tipe) ->

175205 Result.ok tipe

176206

177− Just homes ->

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

207+ Just (Ambiguous h hs) ->

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

179209

180210 Nothing ->

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

@@ -191,11 +221,11 @@ findTypeQual region (Env _ _ ts _ _ _ qts _) prefix name =

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

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

193223 case Map.lookup name cs of

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

224+ Just (Specific _ ctor) ->

195225 Result.ok ctor

196226

197− Just homes ->

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

227+ Just (Ambiguous h hs) ->

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

199229

200230 Nothing ->

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

@@ -206,11 +236,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

206236 case Map.lookup prefix qcs of

207237 Just qualified ->

208238 case Map.lookup name qualified of

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

239+ Just (Specific _ pattern) ->

210240 Result.ok pattern

211241

212− Just homes ->

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

242+ Just (Ambiguous h hs) ->

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

214244

215245 Nothing ->

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

@@ -226,11 +256,11 @@ findCtorQual region (Env _ _ _ cs _ _ _ qcs) prefix name =

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

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

228258 case Map.lookup name binops of

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

259+ Just (Specific _ binop) ->

230260 Result.ok binop

231261

232− Just homes ->

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

262+ Just (Ambiguous h hs) ->

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

234264

235265 Nothing ->

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

compiler/src/Canonicalize/Environment/Dups.hs+6−3

@@ -57,8 +57,11 @@ detectHelp toError name values =

5757 OneOrMore.One (Info _ value) ->

5858 return value

5959

60− OneOrMore.More _ _ ->

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

60+ OneOrMore.More left right ->

61+ let

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

63+ OneOrMore.getFirstTwo left right

64+ in

6265 Result.throw (toError name r1 r2)

6366

6467

@@ -102,7 +105,7 @@ one name region value =

102105

103106insert :: Name.Name -> A.Region -> a -> Dict a -> Dict a

104107insert name region value dict =

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

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

106109

107110

108111union :: Dict a -> Dict a -> Dict a

compiler/src/Canonicalize/Environment/Foreign.hs+80−82

@@ -10,6 +10,7 @@ module Canonicalize.Environment.Foreign

1010import Control.Monad (foldM)

1111import qualified Data.List as List

1212import qualified Data.Map.Strict as Map

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

1314import qualified Data.Name as Name

1415

1516import qualified AST.Canonical as Can

@@ -17,6 +18,7 @@ import qualified AST.Source as Src

1718import qualified Canonicalize.Environment as Env

1819import qualified Elm.Interface as I

1920import qualified Elm.ModuleName as ModuleName

21+import qualified Elm.Package as Pkg

2022import qualified Reporting.Annotation as A

2123import qualified Reporting.Error.Canonicalize as Error

2224import qualified Reporting.Result as Result

@@ -30,24 +32,17 @@ type Result i w a =

3032 Result.Result i w Error.Error a

3133

3234

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

36+createInitialEnv home ifaces imports =

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

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

3339

34−-- CREATE ENVIRONMENT

3540

36−

37−type ImportDict =

38− Map.Map Name.Name ModuleName.Canonical

39−

40−

41−createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result i w Env.Env

42−createInitialEnv home importDict interfaces sourceImports =

43− do imports <- traverse (verifyImport importDict interfaces) (filter isNotKernel sourceImports)

44− (State vs ts cs bs qvs qts qcs) <- foldM addImport emptyState imports

45− Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)

46−

47−

48−isNotKernel :: Src.Import -> Bool

49−isNotKernel (Src.Import (A.At _ name) _ _) =

50− not (Name.isKernel name)

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

5146

5247

5348

@@ -73,23 +68,49 @@ emptyState =

7368

7469emptyTypes :: Env.Exposed Env.Type

7570emptyTypes =

76− Map.singleton "List" (Map.singleton ModuleName.list (Env.Union 1 ModuleName.list))

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

72+

73+

74+

75+-- TO SAFE IMPORTS

76+

77+

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

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

80+ if Pkg.isKernel pkg

81+ then filter isNormal imports

82+ else imports

83+

84+

85+isNormal :: Src.Import -> Bool

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

87+ if Name.isKernel name

88+ then

89+ case maybeAlias of

90+ Nothing -> False

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

92+ else

93+ True

7794

7895

7996

8097-- ADD IMPORTS

8198

8299

83−addImport :: State -> Import -> Result i w State

84−addImport (State vs ts cs bs qvs qts qcs) (Import home (I.Interface defs unions aliases binops) prefix exposing) =

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

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

85102 let

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

104+ !prefix = maybe name id maybeAlias

105+ !home = ModuleName.Canonical pkg name

106+

86107 !rawTypeInfo =

87108 Map.union

88109 (Map.mapMaybeWithKey (unionToType home) unions)

89110 (Map.mapMaybeWithKey (aliasToType home) aliases)

90111

91− !vars = Map.map (Map.singleton home) defs

92− !types = Map.map (Map.singleton home . fst) rawTypeInfo

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

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

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

94115

95116 !qvs2 = addQualified prefix vars qvs

@@ -115,7 +136,7 @@ addImport (State vs ts cs bs qvs qts qcs) (Import home (I.Interface defs unions

115136

116137addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a

117138addExposed =

118− Map.unionWith Map.union

139+ Map.unionWith Env.mergeInfo

119140

120141

121142addQualified :: Name.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a

@@ -136,7 +157,7 @@ unionToTypeHelp :: ModuleName.Canonical -> Name.Name -> Can.Union -> (Env.Type,

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

137158 let

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

139− Map.insert ctor (Map.singleton home (Env.Ctor home name union index args)) dict

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

140161 in

141162 ( Env.Union (length vars) home

142163 , List.foldl' addCtor Map.empty ctors

@@ -167,7 +188,7 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =

167188 (Can.TAlias home name avars (Can.Filled tipe))

168189 (Can.fieldsToList fields)

169190 in

170− Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))

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

171192

172193 _ ->

173194 Map.empty

@@ -178,9 +199,9 @@ aliasToTypeHelp home name (Can.Alias vars tipe) =

178199-- BINOP

179200

180201

181−binopToBinop :: ModuleName.Canonical -> Name.Name -> I.Binop -> Map.Map ModuleName.Canonical Env.Binop

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

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

183− Map.singleton home (Env.Binop op home name annotation associativity precedence)

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

184205

185206

186207

@@ -193,19 +214,19 @@ addExposedValue

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

194215 -> Map.Map Name.Name I.Binop

195216 -> State

196− -> A.Located Src.Exposed

217+ -> Src.Exposed

197218 -> Result i w State

198−addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =

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

199220 case exposed of

200− Src.Lower name ->

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

201222 case Map.lookup name vars of

202223 Just info ->

203− Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)

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

204225

205226 Nothing ->

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

207228

208− Src.Upper name privacy ->

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

209230 case privacy of

210231 Src.Private ->

211232 case Map.lookup name types of

@@ -213,43 +234,43 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg

213234 case tipe of

214235 Env.Union _ _ ->

215236 let

216− !ts2 = Map.insert name (Map.singleton home tipe) ts

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

217238 in

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

219240

220241 Env.Alias _ _ _ _ ->

221242 let

222− !ts2 = Map.insert name (Map.singleton home tipe) ts

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

223244 !cs2 = addExposed cs ctors

224245 in

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

226247

227248 Nothing ->

228− case Map.lookup name (toCtors types) of

229− Just tipe ->

249+ case checkForCtorMistake name types of

250+ tipe:_ ->

230251 Result.throw $ Error.ImportCtorByName region name tipe

231252

232− Nothing ->

253+ [] ->

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

234255

235− Src.Public ->

256+ Src.Public dotDotRegion ->

236257 case Map.lookup name types of

237258 Just (tipe, ctors) ->

238259 case tipe of

239260 Env.Union _ _ ->

240261 let

241− !ts2 = Map.insert name (Map.singleton home tipe) ts

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

242263 !cs2 = addExposed cs ctors

243264 in

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

245266

246267 Env.Alias _ _ _ _ ->

247− Result.throw (Error.ImportOpenAlias region name)

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

248269

249270 Nothing ->

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

251272

252− Src.Operator op ->

273+ Src.Operator region op ->

253274 case Map.lookup op binops of

254275 Just binop ->

255276 let

@@ -261,46 +282,23 @@ addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At reg

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

262283

263284

264−

265−toCtors :: Map.Map Name.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map Name.Name Name.Name

266−toCtors types =

267− Map.foldr addCtors Map.empty types

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

268288 where

269− addCtors (_, exposedCtors) dict =

270− Map.foldrWithKey addCtor dict exposedCtors

271−

272− addCtor ctorName homes dict =

273− case Map.elems homes of

274− [Env.Ctor _ tipeName _ _ _] ->

275− Map.insert ctorName tipeName dict

276−

277− _ ->

278− dict

279−

280−

281−

282−-- VERIFY IMPORT

283−

284−

285−data Import =

286− Import

287− { _name :: ModuleName.Canonical

288− , _interface :: I.Interface

289− , _prefix :: Name.Name

290− , _exposing :: Src.Exposing

291− }

292−

293−

294−verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result i w Import

295−verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing) =

296− case Map.lookup name importDict of

297− Just canonicalName ->

298− case Map.lookup canonicalName interfaces of

299− Just interface ->

300− Result.ok (Import canonicalName interface (maybe name id alias) exposing)

301−

302− Nothing ->

303− Result.throw $ Error.ImportNotFound region name (Map.keys interfaces)

304−

305− Nothing ->

306− Result.throw $ Error.ImportNotFound region name (Map.elems importDict)

289+ addMatches (_, exposedCtors) matches =

290+ Map.foldrWithKey addMatch matches exposedCtors

291+

292+ addMatch ctorName info matches =

293+ if ctorName /= givenName

294+ then matches

295+ else

296+ case info of

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

298+ tipeName : matches

299+

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

301+ matches

302+

303+ Env.Ambiguous _ _ ->

304+ matches

compiler/src/Canonicalize/Environment/Local.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 q

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 = Map.singleton home (Env.Union arity home)

113+ let one = Env.Specific 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 = Map.singleton home (Env.Alias (length args) home args ctype)

136+ let one = Env.Specific 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 q

281281 )

282282

283283

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

284+type CtorDups = Dups.Dict (Env.Info 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 (Map.singleton home (toRecordCtor home name vars fields))

300+ Dups.one name region (Env.Specific 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 $ Map.singleton home $

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

355355 Env.Ctor home typeName union index args

compiler/src/Canonicalize/Expression.hs+6−7

@@ -14,7 +14,6 @@ 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

1817import qualified Data.Name as Name

1918

2019import qualified AST.Canonical as Can

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

696695 Env.TopLevel _ ->

697696 logVar name (Can.VarTopLevel localHome name)

698697

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

698+ Env.Foreign home annotation ->

700699 Result.ok $

701700 if home == ModuleName.debug then

702701 Can.VarDebug localHome name annotation

703702 else

704703 Can.VarForeign home name annotation

705704

706− Env.Foreign homes ->

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

705+ Env.Foreigns h hs ->

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

708707

709708 Nothing ->

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

@@ -715,15 +714,15 @@ findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =

715714 case Map.lookup prefix qvs of

716715 Just qualified ->

717716 case Map.lookup name qualified of

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

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

719718 Result.ok $

720719 if home == ModuleName.debug then

721720 Can.VarDebug localHome name annotation

722721 else

723722 Can.VarForeign home name annotation

724723

725− Just homes ->

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

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

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

727726

728727 Nothing ->

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

compiler/src/Canonicalize/Module.hs+35−28

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

4141-- MODULES

4242

4343

44−canonicalize

45− :: Pkg.Name

46− -> Map.Map Name.Name ModuleName.Canonical

47− -> I.Interfaces

48− -> Src.Module

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

50−canonicalize pkg importDict interfaces module_@(Src.Module name exports imports values _ _ binops effects) =

51− do let home = ModuleName.Canonical pkg name

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

45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =

46+ do let home = ModuleName.Canonical pkg (Src.getName modul)

5247 let cbinops = Map.fromList (map canonicalizeBinop binops)

5348

5449 (env, cunions, caliases) <-

55− Local.add module_ =<<

56− Foreign.createInitialEnv home importDict interfaces imports

50+ Local.add modul =<<

51+ Foreign.createInitialEnv home ifaces imports

5752

5853 cvalues <- canonicalizeValues env values

5954 ceffects <- Effects.canonicalize env values cunions effects

6055 cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports

6156

62− return $ Can.Module home cexports cvalues cunions caliases cbinops ceffects

57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects

6358

6459

6560

6661-- CANONICALIZE BINOP

6762

6863

69−canonicalizeBinop :: A.Located Src.Binop -> ( Name.Name, Can.Binop )

70−canonicalizeBinop (A.At _ (Src.Binop op associativity precedence func)) =

64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )

65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =

7166 ( op, Can.Binop_ associativity precedence func )

7267

7368

@@ -98,13 +93,11 @@ detectCycles sccs =

9893 Graph.AcyclicSCC (def, _, _) ->

9994 Can.Declare def <$> detectCycles otherSccs

10095

101− Graph.CyclicSCC [] ->

102− detectCycles otherSccs

103−

10496 Graph.CyclicSCC subNodes ->

105− Can.DeclareRec

106− <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)

107− <*> detectCycles otherSccs

97+ do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)

98+ case defs of

99+ [] -> detectCycles otherSccs

100+ d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs

108101

109102

110103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def

@@ -113,8 +106,22 @@ detectBadCycles scc =

113106 Graph.AcyclicSCC def ->

114107 Result.ok def

115108

116− Graph.CyclicSCC cyclicValueDefs ->

117− Result.throw (Error.RecursiveDecl cyclicValueDefs)

109+ Graph.CyclicSCC [] ->

110+ error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"

111+

112+ Graph.CyclicSCC (def:defs) ->

113+ let

114+ (A.At region name) = extractDefName def

115+ names = map (A.toValue . extractDefName) defs

116+ in

117+ Result.throw (Error.RecursiveDecl region name names)

118+

119+

120+extractDefName :: Can.Def -> A.Located Name.Name

121+extractDefName def =

122+ case def of

123+ Can.Def name _ _ -> name

124+ Can.TypedDef name _ _ _ _ -> name

118125

119126

120127

@@ -229,11 +236,11 @@ checkExposed

229236 -> Map.Map Name.Name alias

230237 -> Map.Map Name.Name binop

231238 -> Can.Effects

232− -> A.Located Src.Exposed

239+ -> Src.Exposed

233240 -> Result i w (Dups.Dict (A.Located Can.Export))

234−checkExposed values unions aliases binops effects (A.At region exposed) =

241+checkExposed values unions aliases binops effects exposed =

235242 case exposed of

236− Src.Lower name ->

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

237244 if Map.member name values then

238245 ok name region Can.ExportValue

239246 else

@@ -245,23 +252,23 @@ checkExposed values unions aliases binops effects (A.At region exposed) =

245252 Result.throw $ Error.ExportNotFound region Error.BadVar name $

246253 ports ++ Map.keys values

247254

248− Src.Operator name ->

255+ Src.Operator region name ->

249256 if Map.member name binops then

250257 ok name region Can.ExportBinop

251258 else

252259 Result.throw $ Error.ExportNotFound region Error.BadOp name $

253260 Map.keys binops

254261

255− Src.Upper name Src.Public ->

262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->

256263 if Map.member name unions then

257264 ok name region Can.ExportUnionOpen

258265 else if Map.member name aliases then

259− Result.throw $ Error.ExportOpenAlias region name

266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name

260267 else

261268 Result.throw $ Error.ExportNotFound region Error.BadType name $

262269 Map.keys unions ++ Map.keys aliases

263270

264− Src.Upper name Src.Private ->

271+ Src.Upper (A.At region name) Src.Private ->

265272 if Map.member name unions then

266273 ok name region Can.ExportUnionClosed

267274 else if Map.member name aliases then

compiler/src/Canonicalize/Pattern.hs+3−2

@@ -8,6 +8,7 @@ module Canonicalize.Pattern

88 where

99

1010

11+import qualified Data.List as List

1112import qualified Data.Map.Strict as Map

1213import qualified Data.Name as Name

1314

@@ -173,8 +174,8 @@ logVar name region value =

173174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a

174175logFields fields value =

175176 let

176− addField (A.At region name) dict =

177+ addField dict (A.At region name) =

177178 Dups.insert name region region dict

178179 in

179180 Result.Result $ \bindings warnings _ ok ->

180− ok (foldr addField bindings fields) warnings value

181+ ok (List.foldl' addField bindings fields) warnings value

compiler/src/Compile.hs+42−53

@@ -1,15 +1,15 @@

11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

22module Compile

3− ( compile

4− , Artifacts(..)

3+ ( Artifacts(..)

4+ , compile

55 )

66 where

77

88

9−import qualified Data.ByteString as BS

109import qualified Data.Map as Map

1110import qualified Data.Name as Name

1211

12+import qualified AST.Source as Src

1313import qualified AST.Canonical as Can

1414import qualified AST.Optimized as Opt

1515import qualified Canonicalize.Module as Canonicalize

@@ -18,11 +18,9 @@ import qualified Elm.ModuleName as ModuleName

1818import qualified Elm.Package as Pkg

1919import qualified Nitpick.PatternMatches as PatternMatches

2020import qualified Optimize.Module as Optimize

21−import qualified Parse.Module as Parse

22−import qualified Reporting.Error as Error

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

24−import qualified Reporting.Result as Result

25−import qualified Reporting.Warning as Warning

21+import qualified Reporting.Error as E

22+import qualified Reporting.Result as R

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

2624import qualified Type.Constrain.Module as Type

2725import qualified Type.Solve as Type

2826

@@ -33,71 +31,62 @@ import System.IO.Unsafe (unsafePerformIO)

3331-- COMPILE

3432

3533

36−type Result i a =

37− Result.Result i [Warning.Warning] Error.Error a

38−

39−

40−type ImportDict =

41− Map.Map Name.Name ModuleName.Canonical

42−

43−

4434data Artifacts =

4535 Artifacts

46− { _elmi :: I.Interface

47− , _elmo :: Opt.Graph

36+ { _modul :: Can.Module

37+ , _types :: Map.Map Name.Name Can.Annotation

38+ , _graph :: Opt.LocalGraph

4839 }

4940

5041

51−compile :: Pkg.Name -> ImportDict -> I.Interfaces -> BS.ByteString -> Result i Artifacts

52−compile pkg importDict interfaces source =

53− do

54− valid <- Result.mapError Error.Syntax $

55− Parse.fromByteString pkg source

42+compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts

43+compile pkg ifaces modul =

44+ do canonical <- canonicalize pkg ifaces modul

45+ annotations <- typeCheck modul canonical

46+ () <- nitpick canonical

47+ objects <- optimize modul annotations canonical

48+ return (Artifacts canonical annotations objects)

5649

57− canonical <- Result.mapError Error.Canonicalize $

58− Canonicalize.canonicalize pkg importDict interfaces valid

5950

60− let localizer = L.fromModule valid -- TODO should this be strict for GC?

6151

62− annotations <-

63− runTypeInference localizer canonical

52+-- PHASES

6453

65− () <-

66− exhaustivenessCheck canonical

6754

68− graph <- Result.mapError (Error.Main localizer) $

69− Optimize.optimize annotations canonical

55+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Can.Module

56+canonicalize pkg ifaces modul =

57+ case snd $ R.run $ Canonicalize.canonicalize pkg ifaces modul of

58+ Right canonical ->

59+ Right canonical

7060

71− Result.ok $

72− Artifacts

73− { _elmi = I.fromModule annotations canonical

74− , _elmo = graph

75− }

76−

77−

78−

79−-- TYPE INFERENCE

61+ Left errors ->

62+ Left $ E.BadNames errors

8063

8164

82−runTypeInference :: L.Localizer -> Can.Module -> Result i (Map.Map Name.Name Can.Annotation)

83−runTypeInference localizer canonical =

65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)

66+typeCheck modul canonical =

8467 case unsafePerformIO (Type.run =<< Type.constrain canonical) of

8568 Right annotations ->

86− Result.ok annotations

69+ Right annotations

8770

8871 Left errors ->

89− Result.throw (Error.Type localizer errors)

72+ Left (E.BadTypes (Localizer.fromModule modul) errors)

9073

9174

75+nitpick :: Can.Module -> Either E.Error ()

76+nitpick canonical =

77+ case PatternMatches.check canonical of

78+ Right () ->

79+ Right ()

9280

93−-- EXHAUSTIVENESS CHECK

81+ Left errors ->

82+ Left (E.BadPatterns errors)

9483

9584

96−exhaustivenessCheck :: Can.Module -> Result i ()

97−exhaustivenessCheck canonical =

98− case PatternMatches.check canonical of

99− Left errors ->

100− Result.throw (Error.Pattern errors)

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

10190

102− Right () ->

103− Result.ok ()

91+ Left errors ->

92+ Left (E.BadMains (Localizer.fromModule modul) errors)

compiler/src/Data/Map/Utils.hsnew file+43

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

1+module Data.Map.Utils

2+ ( fromKeys

3+ , fromKeysA

4+ , fromValues

5+ , any

6+ )

7+ where

8+

9+

10+import Prelude hiding (any)

11+import qualified Data.Map as Map

12+import Data.Map.Internal (Map(..))

13+

14+

15+

16+-- FROM KEYS

17+

18+

19+fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v

20+fromKeys toValue keys =

21+ Map.fromList $ map (\k -> (k, toValue k)) keys

22+

23+

24+fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v)

25+fromKeysA toValue keys =

26+ Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys

27+

28+

29+fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v

30+fromValues toKey values =

31+ Map.fromList $ map (\v -> (toKey v, v)) values

32+

33+

34+

35+-- ANY

36+

37+

38+{-# INLINE any #-}

39+any :: (v -> Bool) -> Map.Map k v -> Bool

40+any isGood = go

41+ where

42+ go Tip = False

43+ go (Bin _ _ v l r) = isGood v || go l || go r

compiler/src/Data/Name.hs+166−177

@@ -1,130 +1,119 @@

11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, MagicHash, OverloadedStrings, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

33module Data.Name

44 ( Name

5− , toUtf8

6− , fromUtf8

7− , toEscapedBuilder

8− , Utf8.toBuilder

9− , Utf8.fromPtr

10− , Utf8.fromChars

11− , Utf8.toChars

12− -- misc

5+ --

6+ , toChars

7+ , toElmString

8+ , toBuilder

9+ --

10+ , fromPtr

11+ , fromChars

12+ --

1313 , getKernel

1414 , hasDot

15+ , splitDots

1516 , isKernel

1617 , isNumberType

1718 , isComparableType

1819 , isAppendableType

1920 , isCompappendType

2021 , fromVarIndex

21− , fromReplCount

2222 , fromWords

2323 , fromManyNames

2424 , fromTypeVariable

2525 , fromTypeVariableScheme

2626 , sepBy

27− -- interned

27+ --

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, dollar, identity

34− , replModule

33+ , node, program, _main, _Main, dollar, identity

34+ , replModule, replValueToPrint

3535 )

3636 where

3737

3838

3939import Prelude hiding (length, maybe, negate)

4040import Control.Exception (assert)

41+import qualified Data.Binary as Binary

4142import qualified Data.ByteString.Builder.Internal as B

42−import Data.Coerce (coerce)

43+import qualified Data.Coerce as Coerce

4344import qualified Data.List as List

45+import qualified Data.String as Chars

4446import qualified Data.Utf8 as Utf8

45−import Foreign.Ptr (plusPtr, minusPtr)

4647import GHC.Exts

47− ( Int(I#), Ptr(Ptr)

48− , RealWorld

48+ ( Int(I#), Ptr

4949 , MutableByteArray#

5050 , isTrue#

5151 , newByteArray#

5252 , sizeofByteArray#

53− , writeWord8OffAddr#

54− , copyByteArrayToAddr#

5553 , unsafeFreezeByteArray#

5654 )

57−import GHC.IO

5855import GHC.ST (ST(ST), runST)

5956import GHC.Prim

6057import GHC.Word (Word8(W8#))

6158

59+import qualified Elm.String as ES

60+

6261

6362

6463-- NAME

6564

6665

67−type Name = Utf8.Under256 NAME

66+type Name =

67+ Utf8.Utf8 ELM_NAME

6868

6969

70−data NAME

70+data ELM_NAME

7171

7272

73−toUtf8 :: Name -> Utf8.String

74−toUtf8 =

75− coerce

7673

74+-- INSTANCES

7775

78−fromUtf8 :: Utf8.String -> Name

79−fromUtf8 =

80− coerce

8176

77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where

78+ fromString = Utf8.fromChars

8279

80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where

81+ get = Utf8.getUnder256

82+ put = Utf8.putUnder256

8383

84−-- TO ESCAPED BUILDER

8584

8685

87−{-# INLINE toEscapedBuilder #-}

88−toEscapedBuilder :: Word8 -> Word8 -> Name -> B.Builder

89−toEscapedBuilder before after =

90− \name -> B.builder (toEscapedBuilderHelp before after name)

86+-- TO

9187

9288

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)

89+toChars :: Name -> [Char]

90+toChars =

91+ Utf8.toChars

12592

126− else

127− return ()

93+

94+toElmString :: Name -> ES.String

95+toElmString =

96+ Coerce.coerce

97+

98+

99+{-# INLINE toBuilder #-}

100+toBuilder :: Name -> B.Builder

101+toBuilder =

102+ Utf8.toBuilder

103+

104+

105+

106+-- FROM

107+

108+

109+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name

110+fromPtr =

111+ Utf8.fromPtr

112+

113+

114+fromChars :: [Char] -> Name

115+fromChars =

116+ Utf8.fromChars

128117

129118

130119

@@ -133,7 +122,12 @@ escape before@(W8# before#) after ptr name@(Utf8.Utf8 ba#) offset@(I# offset#) l

133122

134123hasDot :: Name -> Bool

135124hasDot name =

136− Utf8.contains 0x2E {- . -} (coerce name)

125+ Utf8.contains 0x2E {- . -} name

126+

127+

128+splitDots :: Name -> [Name]

129+splitDots name =

130+ Utf8.split 0x2E {- . -} name

137131

138132

139133

@@ -181,23 +175,23 @@ isCompappendType = Utf8.startsWith prefix_compappend

181175

182176{-# NOINLINE prefix_kernel #-}

183177prefix_kernel :: Name

184−prefix_kernel = "Elm.Kernel."

178+prefix_kernel = fromChars "Elm.Kernel."

185179

186180{-# NOINLINE prefix_number #-}

187181prefix_number :: Name

188−prefix_number = "number"

182+prefix_number = fromChars "number"

189183

190184{-# NOINLINE prefix_comparable #-}

191185prefix_comparable :: Name

192−prefix_comparable = "comparable"

186+prefix_comparable = fromChars "comparable"

193187

194188{-# NOINLINE prefix_appendable #-}

195189prefix_appendable :: Name

196−prefix_appendable = "appendable"

190+prefix_appendable = fromChars "appendable"

197191

198192{-# NOINLINE prefix_compappend #-}

199193prefix_compappend :: Name

200−prefix_compappend = "compappend"

194+prefix_compappend = fromChars "compappend"

201195

202196

203197

@@ -208,11 +202,11 @@ fromVarIndex :: Int -> Name

208202fromVarIndex n =

209203 runST

210204 (

211− do let !size = getIndexSize n

205+ do let !size = 2 + getIndexSize n

212206 mba <- newByteArray size

213207 writeWord8 mba 0 0x5F {- _ -}

214208 writeWord8 mba 1 0x76 {- v -}

215− writeDigits mba (size - 1) n

209+ writeDigitsAtEnd mba size n

216210 freeze mba

217211 )

218212

@@ -220,19 +214,20 @@ fromVarIndex n =

220214{-# INLINE getIndexSize #-}

221215getIndexSize :: Int -> Int

222216getIndexSize n

223− | n < 10 = 3

224− | n < 100 = 4

225− | True = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)

217+ | n < 10 = 1

218+ | n < 100 = 2

219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

226220

227221

228222

229−writeDigits :: MBA s -> Int -> Int -> ST s ()

230−writeDigits !mba !offset !n =

223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()

224+writeDigitsAtEnd !mba !oldOffset !n =

231225 do let (q,r) = quotRem n 10

232− writeWord8 mba offset (0x30 + fromIntegral r)

226+ let !newOffset = oldOffset - 1

227+ writeWord8 mba newOffset (0x30 + fromIntegral r)

233228 if q <= 0

234229 then return ()

235− else writeDigits mba (offset-1) q

230+ else writeDigitsAtEnd mba newOffset q

236231

237232

238233

@@ -255,7 +250,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =

255250 mba <- newByteArray size

256251 copyToMBA name mba

257252 writeWord8 mba (I# len#) 0x5F {- _ -}

258− writeDigits mba (size - 1) index

253+ writeDigitsAtEnd mba size index

259254 freeze mba

260255 )

261256 else

@@ -264,7 +259,7 @@ fromTypeVariable name@(Utf8.Utf8 ba#) index =

264259 do let !size = I# len# + getIndexSize index

265260 mba <- newByteArray size

266261 copyToMBA name mba

267− writeDigits mba (size - 1) index

262+ writeDigitsAtEnd mba size index

268263 freeze mba

269264 )

270265

@@ -283,61 +278,61 @@ fromTypeVariableScheme scheme =

283278 freeze mba

284279 else

285280 do let (extra, letter) = quotRem scheme 26

286− let !size = getIndexSize extra

281+ let !size = 1 + getIndexSize extra

287282 mba <- newByteArray size

288283 writeWord8 mba 0 (0x61 + fromIntegral letter)

289− writeDigits mba (size - 1) extra

284+ writeDigitsAtEnd mba size extra

290285 freeze mba

291286 )

292287

293288

294289

295−-- FROM REPL COUNT

296−

297−

298−fromReplCount :: Int -> Name

299−fromReplCount n =

300− Utf8.fromChars ("repl_value_" ++ show n)

301−

302−

303−

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

305300

306301

307302fromManyNames :: [Name] -> Name

308303fromManyNames names =

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

322−

323−

324−writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s

325−writeNames mba# !offset# names s =

326304 case names of

327305 [] ->

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

306+ blank

307+ -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)

308+ -- but maybe unused patterns should be stripped out instead

309+

310+ Utf8.Utf8 ba# : _ ->

311+ let

312+ len# = sizeofByteArray# ba#

313+ in

314+ runST

315+ (

316+ ST $ \s ->

317+ case newByteArray# (len# +# 3#) s of

318+ (# s, mba# #) ->

319+ case writeWord8Array# mba# 0# 0x5F## {-_-} s of

320+ s ->

321+ case writeWord8Array# mba# 1# 0x4D## {-M-} s of

322+ s ->

323+ case writeWord8Array# mba# 2# 0x24## {-$-} s of

324+ s ->

325+ case copyByteArray# ba# 0# mba# 3# len# s of

326+ s ->

327+ case unsafeFreezeByteArray# mba# s of

328+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

329+ )

330+

331+

332+{-# NOINLINE blank #-}

333+blank :: Name

334+blank =

335+ fromWords [0x5F,0x4D,0x24] {-_M$-}

341336

342337

343338

@@ -423,22 +418,6 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

423418 s -> (# s, () #)

424419

425420

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−

442421{-# INLINE copyToMBA #-}

443422copyToMBA :: Name -> MBA s -> ST s ()

444423copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

@@ -453,169 +432,179 @@ copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

453432

454433{-# NOINLINE int #-}

455434int :: Name

456−int = "Int"

435+int = fromChars "Int"

457436

458437

459438{-# NOINLINE float #-}

460439float :: Name

461−float = "Float"

440+float = fromChars "Float"

462441

463442

464443{-# NOINLINE bool #-}

465444bool :: Name

466−bool = "Bool"

445+bool = fromChars "Bool"

467446

468447

469448{-# NOINLINE char #-}

470449char :: Name

471−char = "Char"

450+char = fromChars "Char"

472451

473452

474453{-# NOINLINE string #-}

475454string :: Name

476−string = "String"

455+string = fromChars "String"

477456

478457

479458{-# NOINLINE maybe #-}

480459maybe :: Name

481−maybe = "Maybe"

460+maybe = fromChars "Maybe"

482461

483462

484463{-# NOINLINE result #-}

485464result :: Name

486−result = "Result"

465+result = fromChars "Result"

487466

488467

489468{-# NOINLINE list #-}

490469list :: Name

491−list = "List"

470+list = fromChars "List"

492471

493472

494473{-# NOINLINE array #-}

495474array :: Name

496−array = "Array"

475+array = fromChars "Array"

497476

498477

499478{-# NOINLINE dict #-}

500479dict :: Name

501−dict = "Dict"

480+dict = fromChars "Dict"

502481

503482

504483{-# NOINLINE tuple #-}

505484tuple :: Name

506−tuple = "Tuple"

485+tuple = fromChars "Tuple"

507486

508487

509488{-# NOINLINE jsArray #-}

510489jsArray :: Name

511−jsArray = "JsArray"

490+jsArray = fromChars "JsArray"

512491

513492

514493{-# NOINLINE task #-}

515494task :: Name

516−task = "Task"

495+task = fromChars "Task"

517496

518497

519498{-# NOINLINE router #-}

520499router :: Name

521−router = "Router"

500+router = fromChars "Router"

522501

523502

524503{-# NOINLINE cmd #-}

525504cmd :: Name

526−cmd = "Cmd"

505+cmd = fromChars "Cmd"

527506

528507

529508{-# NOINLINE sub #-}

530509sub :: Name

531−sub = "Sub"

510+sub = fromChars "Sub"

532511

533512

534513{-# NOINLINE platform #-}

535514platform :: Name

536−platform = "Platform"

515+platform = fromChars "Platform"

537516

538517

539518{-# NOINLINE virtualDom #-}

540519virtualDom :: Name

541−virtualDom = "VirtualDom"

520+virtualDom = fromChars "VirtualDom"

542521

543522

544523{-# NOINLINE shader #-}

545524shader :: Name

546−shader = "Shader"

525+shader = fromChars "Shader"

547526

548527

549528{-# NOINLINE debug #-}

550529debug :: Name

551−debug = "Debug"

530+debug = fromChars "Debug"

552531

553532

554533{-# NOINLINE debugger #-}

555534debugger :: Name

556−debugger = "Debugger"

535+debugger = fromChars "Debugger"

557536

558537

559538{-# NOINLINE bitwise #-}

560539bitwise :: Name

561−bitwise = "Bitwise"

540+bitwise = fromChars "Bitwise"

562541

563542

564543{-# NOINLINE basics #-}

565544basics :: Name

566−basics = "Basics"

545+basics = fromChars "Basics"

567546

568547

569548{-# NOINLINE utils #-}

570549utils :: Name

571−utils = "Utils"

550+utils = fromChars "Utils"

572551

573552

574553{-# NOINLINE negate #-}

575554negate :: Name

576−negate = "negate"

555+negate = fromChars "negate"

577556

578557

579558{-# NOINLINE true #-}

580559true :: Name

581−true = "True"

560+true = fromChars "True"

582561

583562

584563{-# NOINLINE false #-}

585564false :: Name

586−false = "False"

565+false = fromChars "False"

587566

588567

589568{-# NOINLINE value #-}

590569value :: Name

591−value = "Value"

570+value = fromChars "Value"

592571

593572

594573{-# NOINLINE node #-}

595574node :: Name

596−node = "Node"

575+node = fromChars "Node"

597576

598577

599578{-# NOINLINE program #-}

600579program :: Name

601−program = "Program"

580+program = fromChars "Program"

581+

602582

583+{-# NOINLINE _main #-}

584+_main :: Name

585+_main = fromChars "main"

603586

604−{-# NOINLINE main #-}

605−main :: Name

606−main = "main"

587+

588+{-# NOINLINE _Main #-}

589+_Main :: Name

590+_Main = fromChars "Main"

607591

608592

609593{-# NOINLINE dollar #-}

610594dollar :: Name

611−dollar = "$"

595+dollar = fromChars "$"

612596

613597

614598{-# NOINLINE identity #-}

615599identity :: Name

616−identity = "identity"

600+identity = fromChars "identity"

617601

618602

619603{-# NOINLINE replModule #-}

620604replModule :: Name

621−replModule = "Elm_Repl"

605+replModule = fromChars "Elm_Repl"

606+

607+

608+{-# NOINLINE replValueToPrint #-}

609+replValueToPrint :: Name

610+replValueToPrint = fromChars "repl_input_value_"

compiler/src/Data/NonEmptyList.hsnew file+78

@@ -0,0 +1,78 @@

1+module Data.NonEmptyList

2+ ( List(..)

3+ , singleton

4+ , toList

5+ , sortBy

6+ )

7+ where

8+

9+

10+import Control.Monad (liftM2)

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

12+import qualified Data.List as List

13+

14+

15+

16+-- LIST

17+

18+

19+data List a =

20+ List a [a]

21+

22+

23+singleton :: a -> List a

24+singleton a =

25+ List a []

26+

27+

28+toList :: List a -> [a]

29+toList (List x xs) =

30+ x:xs

31+

32+

33+

34+-- INSTANCES

35+

36+

37+instance Functor List where

38+ fmap func (List x xs) = List (func x) (map func xs)

39+

40+

41+instance Traversable List where

42+ traverse func (List x xs) = List <$> func x <*> traverse func xs

43+

44+

45+instance Foldable List where

46+ foldr step state (List x xs) = step x (foldr step state xs)

47+ foldl step state (List x xs) = foldl step (step state x) xs

48+ foldl1 step (List x xs) = foldl step x xs

49+

50+

51+

52+-- SORT BY

53+

54+

55+sortBy :: (Ord b) => (a -> b) -> List a -> List a

56+sortBy toRank (List x xs) =

57+ let

58+ comparison a b =

59+ compare (toRank a) (toRank b)

60+ in

61+ case List.sortBy comparison xs of

62+ [] ->

63+ List x []

64+

65+ y:ys ->

66+ case comparison x y of

67+ LT -> List x (y:ys)

68+ EQ -> List x (y:ys)

69+ GT -> List y (List.insertBy comparison x ys)

70+

71+

72+

73+-- BINARY

74+

75+

76+instance (Binary a) => Binary (List a) where

77+ put (List x xs) = put x >> put xs

78+ get = liftM2 List get get

compiler/src/Data/OneOrMore.hs+39−24

@@ -3,9 +3,9 @@ module Data.OneOrMore

33 ( OneOrMore(..)

44 , one

55 , more

6− , toList

76 , map

87 , destruct

8+ , getFirstTwo

99 )

1010 where

1111

@@ -33,25 +33,6 @@ 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−

5536-- MAP

5637

5738

@@ -71,14 +52,48 @@ map func oneOrMore =

7152

7253destruct :: (a -> [a] -> b) -> OneOrMore a -> b

7354destruct func oneOrMore =

74− destructHelp func oneOrMore []

55+ destructLeft func oneOrMore []

7556

7657

77−destructHelp :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

78−destructHelp func oneOrMore xs =

58+destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

59+destructLeft func oneOrMore xs =

7960 case oneOrMore of

8061 One x ->

8162 func x xs

8263

8364 More a b ->

84− destructHelp func a (toListHelp b xs)

65+ destructLeft func a (destructRight b xs)

66+

67+

68+destructRight :: OneOrMore a -> [a] -> [a]

69+destructRight oneOrMore xs =

70+ case oneOrMore of

71+ One x ->

72+ x : xs

73+

74+ More a b ->

75+ destructRight a (destructRight b xs)

76+

77+

78+

79+-- GET FIRST TWO

80+

81+

82+getFirstTwo :: OneOrMore a -> OneOrMore a -> (a,a)

83+getFirstTwo left right =

84+ case left of

85+ One x ->

86+ (x, getFirstOne right)

87+

88+ More lleft lright ->

89+ getFirstTwo lleft lright

90+

91+

92+getFirstOne :: OneOrMore a -> a

93+getFirstOne oneOrMore =

94+ case oneOrMore of

95+ One x ->

96+ x

97+

98+ More left _ ->

99+ getFirstOne left

compiler/src/Data/Utf8.hs+158−300

@@ -1,36 +1,42 @@

11{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2−{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}

33module Data.Utf8

4− ( String

5− , Utf8(..)

6− , VeryLong

7− , Under256

4+ ( Utf8(..)

85 , isEmpty

6+ , empty

97 , size

108 , contains

11− , containsDouble

129 , startsWith

1310 , startsWithChar

14− , endsWithWord

11+ , endsWithWord8

1512 , split

1613 , join

17− , all

18− , any

19− , toWord16

20− , fromWord16

21− -- conversions

22− , fromChars

14+ --

15+ , getUnder256

16+ , putUnder256

17+ --

18+ , getVeryLong

19+ , putVeryLong

20+ --

2321 , toChars

2422 , toBuilder

23+ , toEscapedBuilder

24+ --

2525 , fromPtr

26− , fromChunks

27− , Chunk(..)

26+ , fromSnippet

27+ , fromChars

28+ --

29+ , MBA

30+ , newByteArray

31+ , copyFromPtr

32+ , writeWord8

33+ , freeze

2834 )

2935 where

3036

3137

3238import Prelude hiding (String, all, any, concat)

33−import Data.Binary (Binary(..), Get, getWord8, putWord8)

39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)

3440import Data.Binary.Put (putBuilder)

3541import Data.Binary.Get.Internal (readN)

3642import Data.Bits ((.&.), shiftR)

@@ -38,7 +44,6 @@ import qualified Data.ByteString.Internal as B

3844import qualified Data.ByteString.Builder.Internal as B

3945import qualified Data.Char as Char

4046import qualified Data.List as List

41−import Data.String (IsString(..))

4247import Foreign.ForeignPtr (touchForeignPtr)

4348import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

4449import Foreign.Ptr (minusPtr, plusPtr)

@@ -53,36 +58,35 @@ import GHC.Exts

5358 , copyByteArray#

5459 , copyAddrToByteArray#

5560 , copyByteArrayToAddr#

56− , writeWord8Array#,

61+ , writeWord8Array#

5762 )

5863import GHC.IO

5964import GHC.ST (ST(ST), runST)

6065import GHC.Prim

61−import GHC.Word (Word8(W8#), Word16(W16#))

66+import GHC.Word (Word8(W8#))

67+

68+import qualified Parse.Primitives as P

6269

6370

6471

6572-- UTF-8

6673

6774

68−data Utf8 size tipe =

75+data Utf8 tipe =

6976 Utf8 ByteArray#

7077

7178

72−type String = Utf8 VERY_LONG STRING

73−type VeryLong t = Utf8 VERY_LONG t

74−type Under256 t = Utf8 UNDER_256 t

75−

76−data STRING

77−data VERY_LONG

78−data UNDER_256

7979

80+-- EMPTY

8081

8182

82−-- IS EMPTY

83+{-# NOINLINE empty #-}

84+empty :: Utf8 t

85+empty =

86+ runST (freeze =<< newByteArray 0)

8387

8488

85−isEmpty :: Utf8 l t -> Bool

89+isEmpty :: Utf8 t -> Bool

8690isEmpty (Utf8 ba#) =

8791 isTrue# (sizeofByteArray# ba# ==# 0#)

8892

@@ -91,7 +95,7 @@ isEmpty (Utf8 ba#) =

9195-- SIZE

9296

9397

94−size :: Utf8 l t -> Int

98+size :: Utf8 t -> Int

9599size (Utf8 ba#) =

96100 I# (sizeofByteArray# ba#)

97101

@@ -100,7 +104,7 @@ size (Utf8 ba#) =

100104-- CONTAINS

101105

102106

103−contains :: Word8 -> Utf8 l t -> Bool

107+contains :: Word8 -> Utf8 t -> Bool

104108contains (W8# word#) (Utf8 ba#) =

105109 containsHelp word# ba# 0# (sizeofByteArray# ba#)

106110

@@ -116,32 +120,11 @@ containsHelp word# ba# !offset# len# =

116120

117121

118122

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−

140123-- STARTS WITH

141124

142125

143126{-# INLINE startsWith #-}

144−startsWith :: Utf8 l t -> Utf8 l t -> Bool

127+startsWith :: Utf8 t -> Utf8 t -> Bool

145128startsWith (Utf8 ba1#) (Utf8 ba2#) =

146129 let

147130 !len1# = sizeofByteArray# ba1#

@@ -156,9 +139,9 @@ startsWith (Utf8 ba1#) (Utf8 ba2#) =

156139-- STARTS WITH CHAR

157140

158141

159−startsWithChar :: (Char -> Bool) -> Utf8 l t -> Bool

160−startsWithChar isGood str@(Utf8 ba#) =

161− if isEmpty str then

142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool

143+startsWithChar isGood bytes@(Utf8 ba#) =

144+ if isEmpty bytes then

162145 False

163146 else

164147 let

@@ -176,8 +159,8 @@ startsWithChar isGood str@(Utf8 ba#) =

176159-- ENDS WITH WORD

177160

178161

179−endsWithWord :: Word8 -> Utf8 l t -> Bool

180−endsWithWord (W8# w#) (Utf8 ba#) =

162+endsWithWord8 :: Word8 -> Utf8 t -> Bool

163+endsWithWord8 (W8# w#) (Utf8 ba#) =

181164 let len# = sizeofByteArray# ba# in

182165 isTrue# (len# ># 0#)

183166 &&

@@ -188,12 +171,12 @@ endsWithWord (W8# w#) (Utf8 ba#) =

188171-- SPLIT

189172

190173

191−split :: Word8 -> String -> [String]

174+split :: Word8 -> Utf8 t -> [Utf8 t]

192175split (W8# divider#) str@(Utf8 ba#) =

193176 splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

194177

195178

196−splitHelp :: String -> Int -> [Int] -> [String]

179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]

197180splitHelp str start offsets =

198181 case offsets of

199182 [] ->

@@ -214,7 +197,7 @@ findDividers divider# ba# !offset# len# revOffsets =

214197 reverse revOffsets

215198

216199

217−unsafeSlice :: String -> Int -> Int -> String

200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t

218201unsafeSlice str start end =

219202 let !len = end - start in

220203 if len == 0 then

@@ -230,7 +213,7 @@ unsafeSlice str start end =

230213-- JOIN

231214

232215

233−join :: Word8 -> [String] -> String

216+join :: Word8 -> [Utf8 t] -> Utf8 t

234217join sep strings =

235218 case strings of

236219 [] ->

@@ -244,7 +227,7 @@ join sep strings =

244227 freeze mba

245228

246229

247−joinHelp :: Word8 -> MBA s -> Int -> String -> [String] -> ST s ()

230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()

248231joinHelp sep mba offset str strings =

249232 let

250233 !len = size str

@@ -262,46 +245,10 @@ joinHelp sep mba offset str strings =

262245

263246

264247

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−

301248-- EQUAL

302249

303250

304−instance Eq (Utf8 l t) where

251+instance Eq (Utf8 t) where

305252 (==) (Utf8 ba1#) (Utf8 ba2#) =

306253 let

307254 !len1# = sizeofByteArray# ba1#

@@ -314,9 +261,11 @@ instance Eq (Utf8 l t) where

314261

315262

316263-- COMPARE

264+--

265+-- TODO: is it fine to sort by length and only compare bytes on length ties?

266+--

317267

318−

319−instance Ord (Utf8 l t) where

268+instance Ord (Utf8 t) where

320269 compare (Utf8 ba1#) (Utf8 ba2#) =

321270 let

322271 !len1# = sizeofByteArray# ba1#

@@ -333,84 +282,20 @@ instance Ord (Utf8 l t) where

333282

334283

335284

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−

395285-- FROM STRING

396286

397287

398−fromChars :: [Char] -> Utf8 l t

399−fromChars =

400− fromString

401−

402−

403−instance IsString (Utf8 l t) where

404− fromString str =

405− runST

406− (

407− do mba <- newByteArray (sum (map getWidth str))

408− writeString mba 0 str

409− )

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

410295

411296

412−writeString :: MBA s -> Int -> [Char] -> ST s (Utf8 l t)

413−writeString !mba !offset chars =

297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)

298+writeChars !mba !offset chars =

414299 case chars of

415300 [] ->

416301 freeze mba

@@ -418,25 +303,25 @@ writeString !mba !offset chars =

418303 char : chars

419304 | n < 0x80 ->

420305 do writeWord8 mba (offset ) (fromIntegral n)

421− writeString mba (offset + 1) chars

306+ writeChars mba (offset + 1) chars

422307

423308 | n < 0x800 ->

424309 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

425310 writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

426− writeString mba (offset + 2) chars

311+ writeChars mba (offset + 2) chars

427312

428313 | n < 0x10000 ->

429314 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

430315 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

431316 writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

432− writeString mba (offset + 3) chars

317+ writeChars mba (offset + 3) chars

433318

434319 | otherwise ->

435320 do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

436321 writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

437322 writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

438323 writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

439− writeString mba (offset + 4) chars

324+ writeChars mba (offset + 4) chars

440325

441326 where

442327 n = Char.ord char

@@ -454,10 +339,10 @@ getWidth char

454339

455340

456341

457−-- TO STRING

342+-- TO CHARS

458343

459344

460−toChars :: Utf8 l t -> [Char]

345+toChars :: Utf8 t -> [Char]

461346toChars (Utf8 ba#) =

462347 toCharsHelp ba# 0# (sizeofByteArray# ba#)

463348

@@ -527,13 +412,13 @@ chr4 ba# offset# firstWord# =

527412

528413

529414{-# INLINE toBuilder #-}

530−toBuilder :: Utf8 l t -> B.Builder

415+toBuilder :: Utf8 t -> B.Builder

531416toBuilder =

532417 \bytes -> B.builder (toBuilderHelp bytes)

533418

534419

535420{-# INLINE toBuilderHelp #-}

536−toBuilderHelp :: Utf8 l t -> B.BuildStep a -> B.BuildStep a

421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a

537422toBuilderHelp !bytes@(Utf8 ba#) k =

538423 go 0 (I# (sizeofByteArray# ba#))

539424 where

@@ -553,144 +438,109 @@ toBuilderHelp !bytes@(Utf8 ba#) k =

553438

554439

555440

556−-- FROM PTR

441+-- TO ESCAPED BUILDER

557442

558443

559−fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 l t

560−fromPtr pos end =

561− unsafeDupablePerformIO (stToIO (

562− do let !len = minusPtr end pos

563− mba <- newByteArray len

564− copyFromPtr pos mba 0 len

565− freeze mba

566− ))

444+{-# INLINE toEscapedBuilder #-}

445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder

446+toEscapedBuilder before after =

447+ \name -> B.builder (toEscapedBuilderHelp before after name)

567448

568449

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

569485

570−-- FROM CHUNKS

571486

572487

573−data Chunk

574− = Slice (Ptr Word8) Int

575− | Escape Word8

576− | CodePoint Int

488+-- FROM PTR

577489

578490

579−fromChunks :: [Chunk] -> Utf8 l t

580−fromChunks chunks =

491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t

492+fromPtr pos end =

581493 unsafeDupablePerformIO (stToIO (

582− do let !len = sum (map chunkToWidth chunks)

494+ do let !len = minusPtr end pos

583495 mba <- newByteArray len

584− writeChunks mba 0 chunks

496+ copyFromPtr pos mba 0 len

585497 freeze mba

586498 ))

587499

588500

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)

649501

502+-- FROM SNIPPET

650503

651504

652−-- UNDER 256 BINARY

653−

654−

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

505+fromSnippet :: P.Snippet -> Utf8 t

506+fromSnippet (P.Snippet fptr off len _ _) =

507+ unsafeDupablePerformIO (stToIO (

508+ do mba <- newByteArray len

509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off

510+ copyFromPtr pos mba 0 len

511+ freeze mba

512+ ))

661513

662514

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)

668515

516+-- BINARY

669517

670518

671−-- VERY LONG BINARY

519+putUnder256 :: Utf8 t -> Put

520+putUnder256 bytes =

521+ do putWord8 (fromIntegral (size bytes))

522+ putBuilder (toBuilder bytes)

672523

673524

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

525+getUnder256 :: Get (Utf8 t)

526+getUnder256 =

527+ do word <- getWord8

528+ let !n = fromIntegral word

529+ readN n (copyFromByteString n)

680530

681531

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

532+putVeryLong :: Utf8 t -> Put

533+putVeryLong bytes =

534+ do put (size bytes)

535+ putBuilder (toBuilder bytes)

688536

689537

690−{-# NOINLINE empty #-}

691−empty :: Utf8 l t

692−empty =

693− runST (freeze =<< newByteArray 0)

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

694544

695545

696546

@@ -698,7 +548,7 @@ empty =

698548

699549

700550{-# INLINE copyFromByteString #-}

701−copyFromByteString :: Int -> B.ByteString -> Utf8 l t

551+copyFromByteString :: Int -> B.ByteString -> Utf8 t

702552copyFromByteString len (B.PS fptr offset _) =

703553 unsafeDupablePerformIO

704554 (

@@ -717,21 +567,21 @@ data MBA s =

717567 MBA# (MutableByteArray# s)

718568

719569

720−newByteArray :: Int -> ST s (MBA s) -- TODO see if newPinnedByteArray for len > 256 is positive

570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive

721571newByteArray (I# len#) =

722572 ST $ \s ->

723573 case newByteArray# len# s of

724574 (# s, mba# #) -> (# s, MBA# mba# #)

725575

726576

727−freeze :: MBA s -> ST s (Utf8 l t)

577+freeze :: MBA s -> ST s (Utf8 t)

728578freeze (MBA# mba#) =

729579 ST $ \s ->

730580 case unsafeFreezeByteArray# mba# s of

731581 (# s, ba# #) -> (# s, Utf8 ba# #)

732582

733583

734−copy :: Utf8 l t -> Int -> MBA s -> Int -> Int -> ST s ()

584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()

735585copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

736586 ST $ \s ->

737587 case copyByteArray# ba# offset# mba# i# len# s of

@@ -745,11 +595,11 @@ copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =

745595 s -> (# s, () #)

746596

747597

748−copyToPtr :: Utf8 l t -> Int -> Ptr a -> Int -> IO ()

598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()

749599copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

750− IO $ \s ->

751− case copyByteArrayToAddr# ba# offset# mba# len# s of

752− s -> (# s, () #)

600+ IO $ \s ->

601+ case copyByteArrayToAddr# ba# offset# mba# len# s of

602+ s -> (# s, () #)

753603

754604

755605{-# INLINE writeWord8 #-}

@@ -758,3 +608,11 @@ writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

758608 ST $ \s ->

759609 case writeWord8Array# mba# offset# w# s of

760610 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.hsdeleted−99

@@ -1,99 +0,0 @@

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+4−13

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

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Elm.Compiler.Imports

4− ( addDefaults

4+ ( defaults

55 )

66 where

77

@@ -14,15 +14,6 @@ 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−

2617-- DEFAULTS

2718

2819

@@ -58,14 +49,14 @@ closed =

5849

5950typeOpen :: Name.Name -> Src.Exposing

6051typeOpen name =

61− Src.Explicit [ A.At A.zero (Src.Upper name Src.Public) ]

52+ Src.Explicit [ Src.Upper (A.At A.zero name) (Src.Public A.zero) ]

6253

6354

6455typeClosed :: Name.Name -> Src.Exposing

6556typeClosed name =

66− Src.Explicit [ A.At A.zero (Src.Upper name Src.Private) ]

57+ Src.Explicit [ Src.Upper (A.At A.zero name) Src.Private ]

6758

6859

6960operator :: Name.Name -> Src.Exposing

7061operator op =

71− Src.Explicit [ A.At A.zero (Src.Operator op) ]

62+ Src.Explicit [ Src.Operator A.zero op ]

compiler/src/Elm/Compiler/Type.hs+33−35

@@ -15,21 +15,19 @@ module Elm.Compiler.Type

1515

1616

1717import qualified Data.Name as Name

18−import qualified Data.Text as Text

19−import qualified Data.Text.Encoding as Text

2018

2119import qualified AST.Source as Src

22−import qualified Parse.Primitives as Parse

20+import qualified Json.Decode as D

21+import qualified Json.Encode as E

22+import Json.Encode ((==>))

23+import qualified Json.String as Json

24+import qualified Parse.Primitives as P

2325import qualified Parse.Type as Type

2426import qualified Reporting.Annotation as A

2527import qualified Reporting.Doc as D

2628import qualified Reporting.Render.Type as RT

2729import qualified Reporting.Render.Type.Localizer as L

2830

29−import qualified Json.Decode as Decode

30−import qualified Json.Encode as Encode

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

32−

3331

3432

3533-- TYPES

@@ -113,20 +111,18 @@ collectLambdas tipe =

113111-- JSON for TYPE

114112

115113

116−encode :: Type -> Encode.Value

114+encode :: Type -> E.Value

117115encode tipe =

118− Encode.text $ Text.pack $ D.toLine (toDoc L.empty RT.None tipe)

116+ E.chars $ D.toLine (toDoc L.empty RT.None tipe)

119117

120118

121−decoder :: Decode.Decoder () Type

119+decoder :: D.Decoder () Type

122120decoder =

123− do txt <- Decode.text

124− case Parse.run Type.expression (Text.encodeUtf8 (Text.replace "'" "_" txt)) of

125− Left _ ->

126− Decode.fail ()

127−

128− Right (tipe, _, _) ->

129− Decode.succeed (fromRawType tipe)

121+ let

122+ parser =

123+ P.specialize (\_ _ _ -> ()) (fromRawType . fst <$> Type.expression)

124+ in

125+ D.customString parser (\_ _ -> ())

130126

131127

132128fromRawType :: Src.Type -> Type

@@ -164,33 +160,35 @@ fromRawType (A.At _ astType) =

164160-- JSON for PROGRAM

165161

166162

167−encodeMetadata :: DebugMetadata -> Encode.Value

163+encodeMetadata :: DebugMetadata -> E.Value

168164encodeMetadata (DebugMetadata msg aliases unions) =

169− Encode.object

165+ E.object

170166 [ "message" ==> encode msg

171− , "aliases" ==> Encode.object (map toAliasField aliases)

172− , "unions" ==> Encode.object (map toUnionField unions)

167+ , "aliases" ==> E.object (map toTypeAliasField aliases)

168+ , "unions" ==> E.object (map toCustomTypeField unions)

173169 ]

174170

175171

176−toAliasField :: Alias -> ( Text.Text, Encode.Value )

177−toAliasField (Alias name args tipe) =

178− Name.toText name ==>

179− Encode.object

180− [ "args" ==> Encode.list Encode.name args

172+toTypeAliasField :: Alias -> ( Json.String, E.Value )

173+toTypeAliasField (Alias name args tipe) =

174+ ( Json.fromName name

175+ , E.object

176+ [ "args" ==> E.list E.name args

181177 , "type" ==> encode tipe

182178 ]

179+ )

183180

184181

185−toUnionField :: Union -> ( Text.Text, Encode.Value )

186−toUnionField (Union name args constructors) =

187− Name.toText name ==>

188− Encode.object

189− [ "args" ==> Encode.list Encode.name args

190− , "tags" ==> Encode.object (map toCtorObject constructors)

182+toCustomTypeField :: Union -> ( Json.String, E.Value )

183+toCustomTypeField (Union name args constructors) =

184+ ( Json.fromName name

185+ , E.object

186+ [ "args" ==> E.list E.name args

187+ , "tags" ==> E.object (map toVariantObject constructors)

191188 ]

189+ )

192190

193191

194−toCtorObject :: (Name.Name, [Type]) -> ( Text.Text, Encode.Value )

195−toCtorObject (name, args) =

196− Name.toText name ==> Encode.list encode args

192+toVariantObject :: (Name.Name, [Type]) -> ( Json.String, E.Value )

193+toVariantObject (name, args) =

194+ ( Json.fromName name, E.list encode args )

compiler/src/Elm/Compiler/Type/Extract.hs+69−20

@@ -1,15 +1,20 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE Rank2Types #-}

2+{-# LANGUAGE BangPatterns, OverloadedStrings, Rank2Types #-}

43module Elm.Compiler.Type.Extract

54 ( fromAnnotation

65 , fromType

6+ , Types(..)

7+ , mergeMany

8+ , merge

9+ , fromInterface

10+ , fromDependencyInterface

711 , fromMsg

812 )

913 where

1014

1115

1216import Data.Map ((!))

17+import qualified Data.Map as Map

1318import qualified Data.Maybe as Maybe

1419import qualified Data.Name as Name

1520import qualified Data.Set as Set

@@ -77,23 +82,70 @@ toPublicName (ModuleName.Canonical _ home) name =

7782

7883

7984

85+-- TRANSITIVELY AVAILABLE TYPES

86+

87+

88+newtype Types =

89+ Types (Map.Map ModuleName.Canonical Types_)

90+ -- PERF profile Opt.Global representation

91+ -- current representation needs less allocation

92+ -- but maybe the lookup is much worse

93+

94+

95+data Types_ =

96+ Types_

97+ { _union_info :: Map.Map Name.Name Can.Union

98+ , _alias_info :: Map.Map Name.Name Can.Alias

99+ }

100+

101+

102+mergeMany :: [Types] -> Types

103+mergeMany listOfTypes =

104+ case listOfTypes of

105+ [] -> Types Map.empty

106+ t:ts -> foldr merge t ts

107+

108+

109+merge :: Types -> Types -> Types

110+merge (Types types1) (Types types2) =

111+ Types (Map.union types1 types2)

112+

113+

114+fromInterface :: ModuleName.Raw -> I.Interface -> Types

115+fromInterface name (I.Interface pkg _ unions aliases _) =

116+ Types $ Map.singleton (ModuleName.Canonical pkg name) $

117+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)

118+

119+

120+fromDependencyInterface :: ModuleName.Canonical -> I.DependencyInterface -> Types

121+fromDependencyInterface home di =

122+ Types $ Map.singleton home $

123+ case di of

124+ I.Public (I.Interface _ _ unions aliases _) ->

125+ Types_ (Map.map I.extractUnion unions) (Map.map I.extractAlias aliases)

126+

127+ I.Private _ unions aliases ->

128+ Types_ unions aliases

129+

130+

131+

80132-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES

81133

82134

83−fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata

84−fromMsg interfaces message =

135+fromMsg :: Types -> Can.Type -> T.DebugMetadata

136+fromMsg types message =

85137 let

86138 (msgDeps, msgType) =

87139 run (extract message)

88140

89141 (aliases, unions) =

90− extractTransitive interfaces noDeps msgDeps

142+ extractTransitive types noDeps msgDeps

91143 in

92144 T.DebugMetadata msgType aliases unions

93145

94146

95−extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )

96−extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =

147+extractTransitive :: Types -> Deps -> Deps -> ( [T.Alias], [T.Union] )

148+extractTransitive types (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =

97149 let

98150 aliases = Set.difference nextAliases seenAliases

99151 unions = Set.difference nextUnions seenUnions

@@ -106,39 +158,36 @@ extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nex

106158 (newDeps, result) =

107159 run $

108160 (,)

109− <$> traverse (extractAlias interfaces) (Set.toList aliases)

110− <*> traverse (extractUnion interfaces) (Set.toList unions)

161+ <$> traverse (extractAlias types) (Set.toList aliases)

162+ <*> traverse (extractUnion types) (Set.toList unions)

111163

112164 oldDeps =

113165 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)

114166

115167 remainingResult =

116− extractTransitive interfaces oldDeps newDeps

168+ extractTransitive types oldDeps newDeps

117169 in

118170 mappend result remainingResult

119171

120172

121−extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias

122−extractAlias interfaces (Opt.Global home name) =

173+extractAlias :: Types -> Opt.Global -> Extractor T.Alias

174+extractAlias (Types dict) (Opt.Global home name) =

123175 let

124− (I.Interface _ _ aliases _) = interfaces ! home

125− (Can.Alias args aliasType) = I.toAliasInternals (aliases ! name)

176+ (Can.Alias args aliasType) = _alias_info (dict ! home) ! name

126177 in

127178 T.Alias (toPublicName home name) args <$> extract aliasType

128179

129180

130−extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union

131−extractUnion interfaces (Opt.Global home name) =

181+extractUnion :: Types -> Opt.Global -> Extractor T.Union

182+extractUnion (Types dict) (Opt.Global home name) =

132183 if name == Name.list && home == ModuleName.list

133184 then return $ T.Union (toPublicName home name) ["a"] []

134185 else

135186 let

136187 pname = toPublicName home name

137− unions = I._unions (interfaces ! home)

188+ (Can.Union vars ctors _ _) = _union_info (dict ! home) ! name

138189 in

139− case I.toUnionInternals (unions ! name) of

140− Can.Union vars ctors _ _ ->

141− T.Union pname vars <$> traverse extractCtor ctors

190+ T.Union pname vars <$> traverse extractCtor ctors

142191

143192

144193extractCtor :: Can.Ctor -> Extractor (Name.Name, [T.Type])

compiler/src/Elm/Constraint.hs+55−77

@@ -5,9 +5,6 @@ module Elm.Constraint

55 , exactly

66 , anything

77 , toChars

8− , toString

9− , Error(..)

10− , fromString

118 , satisfies

129 , check

1310 , intersect

@@ -16,6 +13,8 @@ module Elm.Constraint

1613 , untilNextMajor

1714 , untilNextMinor

1815 , expand

16+ --

17+ , Error(..)

1918 , decoder

2019 , encode

2120 )

@@ -24,11 +23,12 @@ module Elm.Constraint

2423

2524import Control.Monad (liftM4)

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

27−import qualified Data.Utf8 as Utf8

2826

2927import qualified Elm.Version as V

3028import qualified Json.Decode as D

3129import qualified Json.Encode as E

30+import qualified Parse.Primitives as P

31+import Parse.Primitives (Row, Col)

3232

3333

3434

@@ -61,78 +61,21 @@ anything =

6161

6262

6363

64−-- TO STRING

64+-- TO CHARS

6565

6666

67−toChars :: Constraint -> String

67+toChars :: Constraint -> [Char]

6868toChars constraint =

69− Utf8.toChars (toString constraint)

70−

71−

72−toString :: Constraint -> Utf8.String

73−toString constraint =

7469 case constraint of

7570 Range lower lowerOp upperOp upper ->

76− Utf8.join 0x20 {- -}

77− [ V.toString lower

78− , toStringHelp lowerOp

79− , "v"

80− , toStringHelp upperOp

81− , V.toString upper

82− ]

71+ V.toChars lower ++ opToChars lowerOp ++ "v" ++ opToChars upperOp ++ V.toChars upper

8372

8473

85−toStringHelp :: Op -> Utf8.String

86−toStringHelp op =

74+opToChars :: Op -> [Char]

75+opToChars op =

8776 case op of

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

77+ Less -> " < "

78+ LessOrEqual -> " <= "

13679

13780

13881

@@ -245,18 +188,12 @@ expand constraint@(Range lower lowerOp upperOp upper) version

245188

246189encode :: Constraint -> E.Value

247190encode constraint =

248− E.string (toString constraint)

191+ E.chars (toChars constraint)

249192

250193

251194decoder :: D.Decoder Error Constraint

252195decoder =

253− do str <- D.string

254− case fromString str of

255− Right constraint ->

256− return constraint

257−

258− Left err ->

259− D.failure err

196+ D.customString parser BadFormat

260197

261198

262199

@@ -279,4 +216,45 @@ instance Binary Op where

279216 case n of

280217 0 -> return Less

281218 1 -> return LessOrEqual

282− _ -> error "binary encoding of Op was corrupted"

219+ _ -> fail "binary encoding of Op was corrupted"

220+

221+

222+

223+-- PARSER

224+

225+

226+data Error

227+ = BadFormat Row Col

228+ | InvalidRange V.Version V.Version

229+

230+

231+parser :: P.Parser Error Constraint

232+parser =

233+ do lower <- parseVersion

234+ P.word1 0x20 {- -} BadFormat

235+ loOp <- parseOp

236+ P.word1 0x20 {- -} BadFormat

237+ P.word1 0x76 {-v-} BadFormat

238+ P.word1 0x20 {- -} BadFormat

239+ hiOp <- parseOp

240+ P.word1 0x20 {- -} BadFormat

241+ higher <- parseVersion

242+ P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->

243+ if lower < higher

244+ then eok (Range lower loOp hiOp higher) state

245+ else eerr row col (\_ _ -> InvalidRange lower higher)

246+

247+

248+parseVersion :: P.Parser Error V.Version

249+parseVersion =

250+ P.specialize (\(r,c) _ _ -> BadFormat r c) V.parser

251+

252+

253+parseOp :: P.Parser Error Op

254+parseOp =

255+ do P.word1 0x3C {-<-} BadFormat

256+ P.oneOfWithFallback

257+ [ do P.word1 0x3D {-=-} BadFormat

258+ return LessOrEqual

259+ ]

260+ Less

compiler/src/Elm/Docs.hs+218−158

@@ -1,8 +1,7 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE BangPatterns, MultiWayIf, OverloadedStrings, UnboxedTuples #-}

33module Elm.Docs

44 ( Documentation

5− , toDict

65 , Module(..)

76 , fromModule

87 , Union(..)

@@ -18,33 +17,35 @@ module Elm.Docs

1817 where

1918

2019

21−import qualified Data.ByteString as B

20+import qualified Data.Coerce as Coerce

2221import qualified Data.List as List

2322import Data.Map ((!))

2423import qualified Data.Map as Map

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

2525import qualified Data.Name as Name

26−import qualified Data.Text as Text

27−import qualified Data.Text.Encoding as Text

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)

2830

2931import qualified AST.Canonical as Can

32+import qualified AST.Source as Src

3033import qualified AST.Utils.Binop as Binop

31−import qualified Data.OneOrMore as OneOrMore

3234import qualified Elm.Compiler.Type as Type

3335import qualified Elm.Compiler.Type.Extract as Extract

3436import qualified Elm.ModuleName as ModuleName

3537import qualified Json.Decode as D

3638import qualified Json.Encode as E

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

3846import qualified Reporting.Annotation as A

39−import qualified Reporting.Error as Error

4047import qualified Reporting.Error.Docs as E

41−import qualified Reporting.Region as R

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

4849

4950

5051

@@ -55,21 +56,6 @@ type Documentation =

5556 Map.Map Name.Name Module

5657

5758

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−

7359data Module =

7460 Module

7561 { _name :: Name.Name

@@ -80,9 +66,7 @@ data Module =

8066 , _binops :: Map.Map Name.Name Binop

8167 }

8268

83−

84−type Comment = Text.Text

85−

69+type Comment = Json.String

8670

8771data Alias = Alias Comment [Name.Name] Type.Type

8872data Union = Union Comment [Name.Name] [(Name.Name, [Type.Type])]

@@ -91,14 +75,19 @@ data Binop = Binop Comment Type.Type Binop.Associativity Binop.Precedence

9175

9276

9377

94−-- JSON ENCODE / DECODE

78+-- JSON

79+

80+

81+encode :: Documentation -> E.Value

82+encode docs =

83+ E.list encodeModule (Map.elems docs)

9584

9685

97−encode :: Module -> E.Value

98−encode (Module name comment unions aliases values binops) =

86+encodeModule :: Module -> E.Value

87+encodeModule (Module name comment unions aliases values binops) =

9988 E.object $

10089 [ "name" ==> ModuleName.encode name

101− , "comment" ==> E.text comment

90+ , "comment" ==> E.string comment

10291 , "unions" ==> E.list encodeUnion (Map.toList unions)

10392 , "aliases" ==> E.list encodeAlias (Map.toList aliases)

10493 , "values" ==> E.list encodeValue (Map.toList values)

@@ -107,16 +96,31 @@ encode (Module name comment unions aliases values binops) =

10796

10897

10998data Error

110− = BadAssociativity Text.Text

111− | BadName

99+ = BadAssociativity

100+ | BadModuleName

112101 | BadType

113102

114103

115−decoder :: D.Decoder Error Module

104+decoder :: D.Decoder Error Documentation

116105decoder =

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 =

117121 Module

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

119− <*> D.field "comment" D.text

122+ <$> D.field "name" moduleNameDecoder

123+ <*> D.field "comment" D.string

120124 <*> D.field "unions" (dictDecoder union)

121125 <*> D.field "aliases" (dictDecoder alias)

122126 <*> D.field "values" (dictDecoder value)

@@ -131,13 +135,18 @@ dictDecoder entryDecoder =

131135named :: D.Decoder Error a -> D.Decoder Error (Name.Name, a)

132136named entryDecoder =

133137 (,)

134− <$> D.field "name" D.name

138+ <$> D.field "name" nameDecoder

135139 <*> entryDecoder

136140

137141

138−nameDecoder :: D.Decoder Error Name.Name

142+nameDecoder :: D.Decoder e Name.Name

139143nameDecoder =

140− D.mapError (const BadName) ModuleName.decoder

144+ fmap Coerce.coerce D.string

145+

146+

147+moduleNameDecoder :: D.Decoder Error ModuleName.Raw

148+moduleNameDecoder =

149+ D.mapError (const BadModuleName) ModuleName.decoder

141150

142151

143152typeDecoder :: D.Decoder Error Type.Type

@@ -153,7 +162,7 @@ encodeUnion :: (Name.Name, Union) -> E.Value

153162encodeUnion (name, Union comment args cases) =

154163 E.object

155164 [ "name" ==> E.name name

156− , "comment" ==> E.text comment

165+ , "comment" ==> E.string comment

157166 , "args" ==> E.list E.name args

158167 , "cases" ==> E.list encodeCase cases

159168 ]

@@ -162,8 +171,8 @@ encodeUnion (name, Union comment args cases) =

162171union :: D.Decoder Error Union

163172union =

164173 Union

165− <$> D.field "comment" D.text

166− <*> D.field "args" (D.list D.name)

174+ <$> D.field "comment" D.string

175+ <*> D.field "args" (D.list nameDecoder)

167176 <*> D.field "cases" (D.list caseDecoder)

168177

169178

@@ -174,7 +183,7 @@ encodeCase ( tag, args ) =

174183

175184caseDecoder :: D.Decoder Error ( Name.Name, [Type.Type] )

176185caseDecoder =

177− D.pair D.name (D.list typeDecoder)

186+ D.pair nameDecoder (D.list typeDecoder)

178187

179188

180189

@@ -185,7 +194,7 @@ encodeAlias :: (Name.Name, Alias) -> E.Value

185194encodeAlias ( name, Alias comment args tipe) =

186195 E.object

187196 [ "name" ==> E.name name

188− , "comment" ==> E.text comment

197+ , "comment" ==> E.string comment

189198 , "args" ==> E.list E.name args

190199 , "type" ==> Type.encode tipe

191200 ]

@@ -194,8 +203,8 @@ encodeAlias ( name, Alias comment args tipe) =

194203alias :: D.Decoder Error Alias

195204alias =

196205 Alias

197− <$> D.field "comment" D.text

198− <*> D.field "args" (D.list D.name)

206+ <$> D.field "comment" D.string

207+ <*> D.field "args" (D.list nameDecoder)

199208 <*> D.field "type" typeDecoder

200209

201210

@@ -207,7 +216,7 @@ encodeValue :: (Name.Name, Value) -> E.Value

207216encodeValue (name, Value comment tipe) =

208217 E.object

209218 [ "name" ==> E.name name

210− , "comment" ==> E.text comment

219+ , "comment" ==> E.string comment

211220 , "type" ==> Type.encode tipe

212221 ]

213222

@@ -215,7 +224,7 @@ encodeValue (name, Value comment tipe) =

215224value :: D.Decoder Error Value

216225value =

217226 Value

218− <$> D.field "comment" D.text

227+ <$> D.field "comment" D.string

219228 <*> D.field "type" typeDecoder

220229

221230

@@ -227,7 +236,7 @@ encodeBinop :: (Name.Name, Binop) -> E.Value

227236encodeBinop (name, Binop comment tipe assoc prec) =

228237 E.object

229238 [ "name" ==> E.name name

230− , "comment" ==> E.text comment

239+ , "comment" ==> E.string comment

231240 , "type" ==> Type.encode tipe

232241 , "associativity" ==> encodeAssoc assoc

233242 , "precedence" ==> encodePrec prec

@@ -237,7 +246,7 @@ encodeBinop (name, Binop comment tipe assoc prec) =

237246binop :: D.Decoder Error Binop

238247binop =

239248 Binop

240− <$> D.field "comment" D.text

249+ <$> D.field "comment" D.string

241250 <*> D.field "type" typeDecoder

242251 <*> D.field "associativity" assocDecoder

243252 <*> D.field "precedence" precDecoder

@@ -250,19 +259,23 @@ binop =

250259encodeAssoc :: Binop.Associativity -> E.Value

251260encodeAssoc assoc =

252261 case assoc of

253− Binop.Left -> E.text "left"

254− Binop.Non -> E.text "non"

255− Binop.Right -> E.text "right"

262+ Binop.Left -> E.chars "left"

263+ Binop.Non -> E.chars "non"

264+ Binop.Right -> E.chars "right"

256265

257266

258267assocDecoder :: D.Decoder Error Binop.Associativity

259268assocDecoder =

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)

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

266279

267280

268281

@@ -283,142 +296,190 @@ precDecoder =

283296-- FROM MODULE

284297

285298

286−fromModule :: Can.Module -> Result.Result i w Error.Error Module

287−fromModule (Can.Module name docs exports decls unions aliases binops effects) =

299+fromModule :: Can.Module -> Either E.Error Module

300+fromModule modul@(Can.Module _ exports docs _ _ _ _ _) =

288301 case exports of

289302 Can.ExportEverything region ->

290− Result.throw $ Error.Docs $ E.ImplicitExposing region

303+ Left (E.ImplicitExposing region)

291304

292305 Can.Export exportDict ->

293306 case docs of

294− Can.NoDocs region ->

295− Result.throw $ Error.Docs $ E.NoDocs region

307+ Src.NoDocs region ->

308+ Left (E.NoDocs region)

296309

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

310+ Src.YesDocs overview comments ->

311+ do names <- parseOverview overview

312+ checkNames exportDict names

313+ checkDefs exportDict overview (Map.fromList comments) modul

310314

311315

312316

313317-- PARSE OVERVIEW

314318

315319

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

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

319323 Left err ->

320− Result.throw (Error.Syntax err)

324+ Left (E.SyntaxProblem err)

321325

322326 Right names ->

323− Result.ok names

327+ Right names

328+

329+

330+type Parser a =

331+ P.Parser E.SyntaxProblem a

324332

325333

326334chompOverview :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

327335chompOverview names =

328− do isDocs <- W.chompUntilDocs

336+ do isDocs <- chompUntilDocs

329337 if isDocs

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

338+ then

339+ do Space.chomp E.Space

340+ chompOverview =<< chompDocs names

341+ else

342+ return names

341343

342344

343345chompDocs :: [A.Located Name.Name] -> Parser [A.Located Name.Name]

344346chompDocs names =

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

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

351362 chompDocs (name:names)

352− , return (name:names)

353363 ]

354−

355−

356−chompBinop :: Parser Name.Name

357−chompBinop =

358− do Symbol.leftParen

359− name <- Symbol.binop

360− Symbol.rightParen

361− return name

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)

362409

363410

364411

365412-- CHECK NAMES

366413

367414

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)

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

374426

375427

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

428+type DocNameRegions =

429+ Map.Map Name.Name (OneOrMore.OneOrMore A.Region)

386430

387431

388−addName :: Dups -> A.Located Name.Name -> Dups

432+addName :: DocNameRegions -> A.Located Name.Name -> DocNameRegions

389433addName dict (A.At region name) =

390434 Map.insertWith OneOrMore.more name (OneOrMore.one region) dict

391435

392436

393−isUnique :: Name.Name -> OneOrMore.OneOrMore R.Region -> Result i w R.Region

437+isUnique :: Name.Name -> OneOrMore.OneOrMore A.Region -> Result.Result i w E.NameProblem A.Region

394438isUnique name regions =

395439 case regions of

396440 OneOrMore.One region ->

397441 Result.ok region

398442

399− OneOrMore.More _ _ ->

400− let (r1:r2:_) = OneOrMore.toList regions in

401− Result.throw (E.Duplicate name r1 r2)

443+ OneOrMore.More left right ->

444+ let (r1, r2) = OneOrMore.getFirstTwo left right in

445+ Result.throw (E.NameDuplicate name r1 r2)

402446

403447

404−onlyInDocs :: Name.Name -> R.Region -> Result i w a

405−onlyInDocs name region =

406− Result.throw $ E.OnlyInDocs name region

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

407452

408453

409−onlyInExports :: Name.Name -> A.Located Can.Export -> Result i w a

454+onlyInExports :: Name.Name -> A.Located Can.Export -> Result.Result i w E.NameProblem a

410455onlyInExports name (A.At region _) =

411− Result.throw $ E.OnlyInExports name region

456+ Result.throw $ E.NameOnlyInExports name region

457+

458+

459+

460+-- CHECK DEFS

461+

412462

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

413472

414473

415−-- CHECK EXPORTS

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

416477

417478

418479data Info =

419480 Info

420− { _iComments :: Map.Map Name.Name Comment

421− , _iValues :: Types

481+ { _iComments :: Map.Map Name.Name Src.Comment

482+ , _iValues :: Map.Map Name.Name (Either A.Region Can.Type)

422483 , _iUnions :: Map.Map Name.Name Can.Union

423484 , _iAliases :: Map.Map Name.Name Can.Alias

424485 , _iBinops :: Map.Map Name.Name Can.Binop

@@ -426,7 +487,7 @@ data Info =

426487 }

427488

428489

429−checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result i w (Module -> Module)

490+checkExport :: Info -> Name.Name -> A.Located Can.Export -> Result.Result i w E.DefProblem (Module -> Module)

430491checkExport info name (A.At region export) =

431492 case export of

432493 Can.ExportValue ->

@@ -467,23 +528,23 @@ checkExport info name (A.At region export) =

467528 m { _values = Map.insert name (Value comment tipe) (_values m) }

468529

469530

470−getComment :: R.Region -> Name.Name -> Info -> Result i w Comment

531+getComment :: A.Region -> Name.Name -> Info -> Result.Result i w E.DefProblem Comment

471532getComment region name info =

472533 case Map.lookup name (_iComments info) of

473534 Nothing ->

474535 Result.throw (E.NoComment name region)

475536

476− Just comment ->

477− Result.ok comment

537+ Just (Src.Comment snippet) ->

538+ Result.ok (Json.fromComment snippet)

478539

479540

480−getType :: Name.Name -> Info -> Result i w Type.Type

541+getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type

481542getType name info =

482543 case _iValues info ! name of

483− A.At defRegion Nothing ->

484− Result.throw (E.NoAnnotation name defRegion)

544+ Left region ->

545+ Result.throw (E.NoAnnotation name region)

485546

486− A.At _ (Just tipe) ->

547+ Right tipe ->

487548 Result.ok (Extract.fromType tipe)

488549

489550

@@ -497,7 +558,7 @@ dector (Can.Ctor name _ _ args) =

497558

498559

499560type Types =

500− Map.Map Name.Name (A.Located (Maybe Can.Type))

561+ Map.Map Name.Name (Either A.Region Can.Type)

501562

502563

503564gatherTypes :: Can.Decls -> Types -> Types

@@ -506,8 +567,8 @@ gatherTypes decls types =

506567 Can.Declare def subDecls ->

507568 gatherTypes subDecls (addDef types def)

508569

509− Can.DeclareRec defs subDecls ->

510− gatherTypes subDecls (List.foldl' addDef types defs)

570+ Can.DeclareRec def defs subDecls ->

571+ gatherTypes subDecls (List.foldl' addDef (addDef types def) defs)

511572

512573 Can.SaveTheEnvironment ->

513574 types

@@ -517,11 +578,10 @@ addDef :: Types -> Can.Def -> Types

517578addDef types def =

518579 case def of

519580 Can.Def (A.At region name) _ _ ->

520− Map.insert name (A.At region Nothing) types

581+ Map.insert name (Left region) types

521582

522− Can.TypedDef (A.At region name) _ typedArgs _ resultType ->

583+ Can.TypedDef (A.At _ name) _ typedArgs _ resultType ->

523584 let

524− tipe =

525− foldr Can.TLambda resultType (map snd typedArgs)

585+ tipe = foldr Can.TLambda resultType (map snd typedArgs)

526586 in

527− Map.insert name (A.At region (Just tipe)) types

587+ Map.insert name (Right tipe) types

compiler/src/Elm/Float.hsnew file+51

@@ -0,0 +1,51 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE EmptyDataDecls, FlexibleInstances #-}

3+module Elm.Float

4+ ( Float

5+ , fromPtr

6+ , toBuilder

7+ )

8+ where

9+

10+

11+import Prelude hiding (Float)

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

13+import qualified Data.ByteString.Builder as B

14+import qualified Data.Utf8 as Utf8

15+import Data.Word (Word8)

16+import Foreign.Ptr (Ptr)

17+

18+

19+

20+-- FLOATS

21+

22+

23+type Float =

24+ Utf8.Utf8 ELM_FLOAT

25+

26+

27+data ELM_FLOAT

28+

29+

30+

31+-- HELPERS

32+

33+

34+fromPtr :: Ptr Word8 -> Ptr Word8 -> Float

35+fromPtr =

36+ Utf8.fromPtr

37+

38+

39+{-# INLINE toBuilder #-}

40+toBuilder :: Float -> B.Builder

41+toBuilder =

42+ Utf8.toBuilder

43+

44+

45+

46+-- BINARY

47+

48+

49+instance Binary (Utf8.Utf8 ELM_FLOAT) where

50+ get = Utf8.getUnder256

51+ put = Utf8.putUnder256

compiler/src/Elm/Interface.hs+17−14

@@ -11,11 +11,13 @@ module Elm.Interface

1111 , public

1212 , private

1313 , privatize

14+ , extractUnion

15+ , extractAlias

1416 )

1517 where

1618

1719

18−import Control.Monad (liftM, liftM2, liftM4, liftM5)

20+import Control.Monad (liftM, liftM3, liftM4, liftM5)

1921import Data.Binary

2022import Data.Map.Strict ((!))

2123import qualified Data.Map.Strict as Map

@@ -71,7 +73,7 @@ data Binop =

7173

7274

7375fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface

74−fromModule home (Can.Module _ exports _ unions aliases binops _) annotations =

76+fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =

7577 Interface

7678 { _home = home

7779 , _values = restrict exports annotations

@@ -153,7 +155,10 @@ toPublicAlias iAlias =

153155

154156data DependencyInterface

155157 = Public Interface

156− | Private (Map.Map Name.Name Can.Union) (Map.Map Name.Name Can.Alias)

158+ | Private

159+ Pkg.Name

160+ (Map.Map Name.Name Can.Union)

161+ (Map.Map Name.Name Can.Alias)

157162

158163

159164public :: Interface -> DependencyInterface

@@ -162,10 +167,8 @@ public =

162167

163168

164169private :: Interface -> DependencyInterface

165−private (Interface _ _ unions aliases _) =

166− Private

167− (Map.map extractUnion unions)

168− (Map.map extractAlias aliases)

170+private (Interface pkg _ unions aliases _) =

171+ Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases)

169172

170173

171174extractUnion :: Union -> Can.Union

@@ -187,7 +190,7 @@ privatize :: DependencyInterface -> DependencyInterface

187190privatize di =

188191 case di of

189192 Public i -> private i

190− Private _ _ -> di

193+ Private _ _ _ -> di

191194

192195

193196

@@ -212,7 +215,7 @@ instance Binary Union where

212215 0 -> liftM OpenUnion get

213216 1 -> liftM ClosedUnion get

214217 2 -> liftM PrivateUnion get

215− _ -> error "binary encoding of Union was corrupted"

218+ _ -> fail "binary encoding of Union was corrupted"

216219

217220

218221instance Binary Alias where

@@ -226,7 +229,7 @@ instance Binary Alias where

226229 case n of

227230 0 -> liftM PublicAlias get

228231 1 -> liftM PrivateAlias get

229− _ -> error "binary encoding of Alias was corrupted"

232+ _ -> fail "binary encoding of Alias was corrupted"

230233

231234

232235instance Binary Binop where

@@ -240,12 +243,12 @@ instance Binary Binop where

240243instance Binary DependencyInterface where

241244 put union =

242245 case union of

243− Public a -> putWord8 0 >> put a

244− Private a b -> putWord8 1 >> put a >> put b

246+ Public a -> putWord8 0 >> put a

247+ Private a b c -> putWord8 1 >> put a >> put b >> put c

245248

246249 get =

247250 do n <- getWord8

248251 case n of

249252 0 -> liftM Public get

250− 1 -> liftM2 Private get get

251− _ -> error "binary encoding of DependencyInterface was corrupted"

253+ 1 -> liftM3 Private get get get

254+ _ -> fail "binary encoding of DependencyInterface was corrupted"

compiler/src/Elm/Kernel.hs+132−127

@@ -3,55 +3,40 @@

33module Elm.Kernel

44 ( Content(..)

55 , Chunk(..)

6− , Dep(..)

7− , parser

6+ , fromByteString

7+ , countFields

88 )

99 where

1010

1111

1212import Control.Monad (liftM, liftM2)

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

14−import Data.Coerce (coerce)

14+import qualified Data.ByteString.Internal as B

1515import qualified Data.List as List

1616import qualified Data.Map as Map

1717import qualified Data.Name as Name

18−import qualified Data.Set as Set

19−import qualified Data.Utf8 as Utf8

20−import Data.Word (Word8, Word16)

21−import Foreign.Ptr (Ptr, plusPtr)

18+import Data.Word (Word8)

19+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

20+import Foreign.ForeignPtr (ForeignPtr)

21+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

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

2728import qualified Parse.Variable as Var

28−import Parse.Utils

29−import Parse.Primitives hiding (Parser, State)

29+import Parse.Primitives hiding (fromByteString)

3030import qualified Parse.Primitives as P

3131import qualified Reporting.Annotation as A

32−import qualified Reporting.Error.Syntax as E

3332

3433

3534

36−-- CONTENT

37−

38−

39−data Content =

40− Content [Chunk] (Set.Set Dep)

41−

42−

43−data Dep

44− = ElmDep ModuleName.Canonical Name.Name

45− | KernelDep Name.Name

46− deriving (Eq, Ord)

47−

48−

49−

50−-- CHUNKS

35+-- CHUNK

5136

5237

5338data Chunk

54− = JS (Utf8.VeryLong UNCHECKED)

39+ = JS B.ByteString

5540 | ElmVar ModuleName.Canonical Name.Name

5641 | JsVar Name.Name Name.Name

5742 | ElmField Name.Name

@@ -61,56 +46,93 @@ data Chunk

6146 | Prod

6247

6348

64−data UNCHECKED

6549

50+-- COUNT FIELDS

51+

52+

53+countFields :: [Chunk] -> Map.Map Name.Name Int

54+countFields chunks =

55+ foldr addField Map.empty chunks

6656

6757

68−-- PARSE

58+addField :: Chunk -> Map.Map Name.Name Int -> Map.Map Name.Name Int

59+addField chunk fields =

60+ case chunk of

61+ JS _ -> fields

62+ ElmVar _ _ -> fields

63+ JsVar _ _ -> fields

64+ ElmField f -> Map.insertWith (+) f 1 fields

65+ JsField _ -> fields

66+ JsEnum _ -> fields

67+ Debug -> fields

68+ Prod -> fields

6969

7070

71−type ImportDict =

72− Map.Map Name.Name [Pkg.Name]

7371

72+-- FROM FILE

73+

74+

75+data Content =

76+ Content [Src.Import] [Chunk]

7477

75−parser :: ImportDict -> Parser Content

76−parser importDict =

77− do word2 0x2F 0x2A {-/*-} E.XXX

78− Module.freshLine

79− imports <- Module.chompImports []

80− word2 0x2A 0x2F {-*/-} E.XXX

81− let (vtable, deps) = processImports importDict imports

82− chunks <- parseChunks vtable Map.empty Map.empty

83− return $ Content chunks deps

78+

79+type Foreigns =

80+ Map.Map ModuleName.Raw Pkg.Name

81+

82+

83+fromByteString :: Pkg.Name -> Foreigns -> B.ByteString -> Maybe Content

84+fromByteString pkg foreigns bytes =

85+ case P.fromByteString (parser pkg foreigns) toError bytes of

86+ Right content ->

87+ Just content

88+

89+ Left () ->

90+ Nothing

91+

92+

93+parser :: Pkg.Name -> Foreigns -> Parser () Content

94+parser pkg foreigns =

95+ do word2 0x2F 0x2A {-/*-} toError

96+ Space.chomp ignoreError

97+ Space.checkFreshLine toError

98+ imports <- specialize ignoreError (Module.chompImports [])

99+ word2 0x2A 0x2F {-*/-} toError

100+ chunks <- parseChunks (toVarTable pkg foreigns imports) Map.empty Map.empty

101+ return (Content imports chunks)

102+

103+

104+toError :: Row -> Col -> ()

105+toError _ _ =

106+ ()

107+

108+

109+ignoreError :: a -> Row -> Col -> ()

110+ignoreError _ _ _ =

111+ ()

84112

85113

86114

87115-- PARSE CHUNKS

88116

89117

90−parseChunks :: VarTable -> Enums -> Fields -> Parser [Chunk]

118+parseChunks :: VarTable -> Enums -> Fields -> Parser () [Chunk]

91119parseChunks vtable enums fields =

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

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

93121 let

94122 (# chunks, newPos, newRow, newCol #) =

95− chompChunks vtable enums fields pos end row col pos []

123+ chompChunks vtable enums fields src pos end row col pos []

96124 in

97125 if newPos == end then

98− cok chunks (P.State newPos end indent newRow newCol ctx)

126+ cok chunks (P.State src newPos end indent newRow newCol)

99127 else

100− cerr row col ctx E.XXX

101−

102−

103−addJS :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

104−addJS start end revChunks =

105− if start == end

106− then revChunks

107− else JS (Utf8.fromPtr start end) : revChunks

128+ cerr row col toError

108129

109130

110−chompChunks :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> Ptr Word8 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)

111−chompChunks vs es fs pos end row col lastPos revChunks =

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 =

112133 if pos >= end then

113− (# reverse (addJS lastPos end revChunks), pos, row, col #)

134+ let !js = toByteString src lastPos end in

135+ (# reverse (JS js : revChunks), pos, row, col #)

114136

115137 else

116138 let !word = unsafeIndex pos in

@@ -120,31 +142,45 @@ chompChunks vs es fs pos end row col lastPos revChunks =

120142 !pos3 = plusPtr pos 3

121143 in

122144 if pos3 <= end && unsafeIndex pos1 == 0x5F {-_-} then

123− chompTag vs es fs pos3 end row (col + 3) (addJS lastPos pos revChunks)

145+ let !js = toByteString src lastPos pos in

146+ chompTag vs es fs src pos3 end row (col + 3) (JS js : revChunks)

124147 else

125− chompChunks vs es fs pos1 end row (col + 1) lastPos revChunks

148+ chompChunks vs es fs src pos1 end row (col + 1) lastPos revChunks

126149

127150 else if word == 0x0A {-\n-} then

128− chompChunks vs es fs (plusPtr pos 1) end (row + 1) 1 lastPos revChunks

151+ chompChunks vs es fs src (plusPtr pos 1) end (row + 1) 1 lastPos revChunks

129152

130153 else

131154 let

132− !newPos = plusPtr pos (getCharWidth pos end word)

155+ !newPos = plusPtr pos (getCharWidth word)

133156 in

134− chompChunks vs es fs newPos end row (col + 1) lastPos revChunks

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+

135168

136169

137170-- relies on external checks in chompChunks

138−chompTag :: VarTable -> Enums -> Fields -> Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> [Chunk] -> (# [Chunk], Ptr Word8, Word16, Word16 #)

139−chompTag vs es fs pos end row col revChunks =

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 =

140173 let

141174 (# newPos, newCol #) = Var.chompInnerChars pos end col

142175 !tagPos = plusPtr pos (-1)

143176 !word = unsafeIndex tagPos

144177 in

145178 if word == 0x24 {-$-} then

146− chompChunks vs es fs newPos end row newCol newPos $

147− ElmField (Name.fromPtr pos newPos) : revChunks

179+ let

180+ !name = Name.fromPtr pos newPos

181+ in

182+ chompChunks vs es fs src newPos end row newCol newPos $

183+ ElmField name : revChunks

148184 else

149185 let

150186 !name = Name.fromPtr tagPos newPos

@@ -154,7 +190,7 @@ chompTag vs es fs pos end row col revChunks =

154190 (enum, newEnums) =

155191 lookupEnum (word - 0x30) name es

156192 in

157− chompChunks vs newEnums fs newPos end row newCol newPos $

193+ chompChunks vs newEnums fs src newPos end row newCol newPos $

158194 JsEnum enum : revChunks

159195

160196 else if 0x61 {-a-} <= word && word <= 0x7A {-z-} then

@@ -162,19 +198,19 @@ chompTag vs es fs pos end row col revChunks =

162198 (field, newFields) =

163199 lookupField name fs

164200 in

165− chompChunks vs es newFields newPos end row newCol newPos $

201+ chompChunks vs es newFields src newPos end row newCol newPos $

166202 JsField field : revChunks

167203

168204 else if name == "DEBUG" then

169− chompChunks vs es fs newPos end row newCol newPos (Debug : revChunks)

205+ chompChunks vs es fs src newPos end row newCol newPos (Debug : revChunks)

170206

171207 else if name == "PROD" then

172− chompChunks vs es fs newPos end row newCol newPos (Prod : revChunks)

208+ chompChunks vs es fs src newPos end row newCol newPos (Prod : revChunks)

173209

174210 else

175211 case Map.lookup name vs of

176212 Just chunk ->

177− chompChunks vs es fs newPos end row newCol newPos (chunk : revChunks)

213+ chompChunks vs es fs src newPos end row newCol newPos (chunk : revChunks)

178214

179215 Nothing ->

180216 (# revChunks, pos, row, col #)

@@ -230,60 +266,34 @@ type VarTable =

230266 Map.Map Name.Name Chunk

231267

232268

233−type State =

234− (VarTable, Set.Set Dep)

269+toVarTable :: Pkg.Name -> Foreigns -> [Src.Import] -> VarTable

270+toVarTable pkg foreigns imports =

271+ List.foldl' (addImport pkg foreigns) Map.empty imports

235272

236273

237−processImports :: ImportDict -> [Src.Import] -> State

238−processImports importDict imports =

239− List.foldl' (addImport importDict) (Map.empty, Set.empty) imports

240−

241−

242−addImport :: ImportDict -> State -> Src.Import -> State

243−addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =

244− if Name.isKernel home then

274+addImport :: Pkg.Name -> Foreigns -> VarTable -> Src.Import -> VarTable

275+addImport pkg foreigns vtable (Src.Import (A.At _ importName) maybeAlias exposing) =

276+ if Name.isKernel importName then

245277 case maybeAlias of

246278 Just _ ->

247− error ("Cannot use aliases on kernel import of: " ++ Name.toChars home)

279+ error ("cannot use `as` with kernel import of: " ++ Name.toChars importName)

248280

249281 Nothing ->

250− addKernelImport (Name.getKernel home) exposing state

251−

252− else

253− case Map.lookup home importDict of

254− Just [pkg] ->

255282 let

256− canonicalHome = ModuleName.Canonical pkg home

257− prefix = toPrefix home maybeAlias

283+ home = Name.getKernel importName

284+ add table name =

285+ Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table

258286 in

259− addNormalImport canonicalHome prefix exposing state

260−

261− _ ->

262− error ("Cannot find kernel import of: " ++ Name.toChars home)

263−

287+ List.foldl' add vtable (toNames exposing)

264288

265−-- INVARIANT: the `home` is the * in `Elm.Kernel.*`

266−--

267−addKernelImport :: Name.Name -> Src.Exposing -> State -> State

268−addKernelImport home exposing (vtable, deps) =

269− let

270− addVar table name =

271− Map.insert (Name.sepBy 0x5F {-_-} home name) (JsVar home name) table

272− in

273− ( List.foldl' addVar vtable (toNames exposing)

274− , Set.insert (KernelDep home) deps

275− )

276−

277−

278−addNormalImport :: ModuleName.Canonical -> Name.Name -> Src.Exposing -> State -> State

279−addNormalImport home prefix exposing state =

280− let

281− addVar (vtable, deps) name =

282− ( Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) vtable

283− , Set.insert (ElmDep home name) deps

284− )

285− in

286− List.foldl' addVar state (toNames exposing)

289+ else

290+ let

291+ home = ModuleName.Canonical (Map.findWithDefault pkg importName foreigns) importName

292+ prefix = toPrefix importName maybeAlias

293+ add table name =

294+ Map.insert (Name.sepBy 0x5F {-_-} prefix name) (ElmVar home name) table

295+ in

296+ List.foldl' add vtable (toNames exposing)

287297

288298

289299toPrefix :: Name.Name -> Maybe Name.Name -> Name.Name

@@ -303,25 +313,25 @@ toNames :: Src.Exposing -> [Name.Name]

303313toNames exposing =

304314 case exposing of

305315 Src.Open ->

306− error "Cannot have `exposing (..)` in kernel code."

316+ error "cannot have `exposing (..)` in kernel code."

307317

308318 Src.Explicit exposedList ->

309319 map toName exposedList

310320

311321

312−toName :: A.Located Src.Exposed -> Name.Name

313−toName (A.At _ exposed) =

322+toName :: Src.Exposed -> Name.Name

323+toName exposed =

314324 case exposed of

315− Src.Lower name ->

325+ Src.Lower (A.At _ name) ->

316326 name

317327

318− Src.Upper name Src.Private ->

328+ Src.Upper (A.At _ name) Src.Private ->

319329 name

320330

321− Src.Upper _ Src.Public ->

331+ Src.Upper _ (Src.Public _) ->

322332 error "cannot have Maybe(..) syntax in kernel code header"

323333

324− Src.Operator _ ->

334+ Src.Operator _ _ ->

325335 error "cannot use binops in kernel code"

326336

327337

@@ -332,7 +342,7 @@ toName (A.At _ exposed) =

332342instance Binary Chunk where

333343 put chunk =

334344 case chunk of

335− JS a -> putWord8 0 >> put (coerce a :: Utf8.String)

345+ JS a -> putWord8 0 >> put a

336346 ElmVar a b -> putWord8 1 >> put a >> put b

337347 JsVar a b -> putWord8 2 >> put a >> put b

338348 ElmField a -> putWord8 3 >> put a

@@ -344,7 +354,7 @@ instance Binary Chunk where

344354 get =

345355 do word <- getWord8

346356 case word of

347− 0 -> liftM toJS get

357+ 0 -> liftM JS get

348358 1 -> liftM2 ElmVar get get

349359 2 -> liftM2 JsVar get get

350360 3 -> liftM ElmField get

@@ -353,8 +363,3 @@ instance Binary Chunk where

353363 6 -> return Debug

354364 7 -> return Prod

355365 _ -> error "problem deserializing Elm.Kernel.Chunk"

356−

357−

358−toJS :: Utf8.String -> Chunk

359−toJS str =

360− JS (coerce str)

compiler/src/Elm/Licenses.hs+48−65

@@ -9,14 +9,12 @@ module Elm.Licenses

99 where

1010

1111

12−import Control.Monad (liftM2)

13−import Data.Binary (Binary, get, put)

14−import Data.Map ((!))

1512import qualified Data.Map as Map

1613import qualified Data.Utf8 as Utf8

1714

1815import qualified Json.Decode as D

1916import qualified Json.Encode as E

17+import qualified Json.String as Json

2018import qualified Reporting.Suggest as Suggest

2119

2220

@@ -24,25 +22,21 @@ import qualified Reporting.Suggest as Suggest

2422-- LICENCES

2523

2624

27−data License =

28− License

29− { _name :: Utf8.String

30− , _code :: Utf8.String

31− }

32− deriving (Eq, Ord)

25+newtype License =

26+ License Json.String

3327

3428

3529bsd3 :: License

3630bsd3 =

37− osiApprovedSpdxLicenses ! "BSD-3-Clause"

31+ License (Json.fromChars "BSD-3-Clause")

3832

3933

4034encode :: License -> E.Value

41−encode (License _ code) =

35+encode (License code) =

4236 E.string code

4337

4438

45−decoder :: (Utf8.String -> [Utf8.String] -> e) -> D.Decoder e License

39+decoder :: (Json.String -> [Json.String] -> e) -> D.Decoder e License

4640decoder toError =

4741 do str <- D.string

4842 case check str of

@@ -57,97 +51,93 @@ decoder toError =

5751-- CHECK

5852

5953

60−check :: Utf8.String -> Either [Utf8.String] License

61−check rawName =

62− case Map.lookup rawName osiApprovedSpdxLicenses of

63− Just license ->

64− Right license

54+check :: Json.String -> Either [Json.String] License

55+check givenCode =

56+ if Map.member givenCode osiApprovedSpdxLicenses then

57+ Right (License givenCode)

6558

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

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

7668

7769

7870

7971-- LIST OF LICENCES

8072

8173

82−(==>) :: Utf8.String -> Utf8.String -> (Utf8.String, License)

83−(==>) code name =

84− ( code, License name code )

74+(==>) :: [Char] -> [Char] -> (Json.String, [Char])

75+(==>) code fullName =

76+ ( Json.fromChars code, fullName )

8577

8678

8779--

8880-- OSI approved licenses in SPDX format.

8981-- <https://spdx.org/licenses/>

9082--

91−osiApprovedSpdxLicenses :: Map.Map Utf8.String License

83+osiApprovedSpdxLicenses :: Map.Map Json.String [Char]

9284osiApprovedSpdxLicenses =

9385 Map.fromList

94− [ "AFL-1.1" ==> "Academic Free License v1.1"

86+ [ "0BSD" ==> "BSD Zero Clause License"

87+ , "AAL" ==> "Attribution Assurance License"

88+ , "AFL-1.1" ==> "Academic Free License v1.1"

9589 , "AFL-1.2" ==> "Academic Free License v1.2"

9690 , "AFL-2.0" ==> "Academic Free License v2.0"

9791 , "AFL-2.1" ==> "Academic Free License v2.1"

9892 , "AFL-3.0" ==> "Academic Free License v3.0"

99− , "APL-1.0" ==> "Adaptive Public License 1.0"

93+ , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"

10094 , "Apache-1.1" ==> "Apache License 1.1"

10195 , "Apache-2.0" ==> "Apache License 2.0"

96+ , "APL-1.0" ==> "Adaptive Public License 1.0"

10297 , "APSL-1.0" ==> "Apple Public Source License 1.0"

10398 , "APSL-1.1" ==> "Apple Public Source License 1.1"

10499 , "APSL-1.2" ==> "Apple Public Source License 1.2"

105100 , "APSL-2.0" ==> "Apple Public Source License 2.0"

106101 , "Artistic-1.0" ==> "Artistic License 1.0"

107− , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"

108102 , "Artistic-1.0-cl8" ==> "Artistic License 1.0 w/clause 8"

103+ , "Artistic-1.0-Perl" ==> "Artistic License 1.0 (Perl)"

109104 , "Artistic-2.0" ==> "Artistic License 2.0"

110− , "AAL" ==> "Attribution Assurance License"

111− , "BSL-1.0" ==> "Boost Software License 1.0"

112105 , "BSD-2-Clause" ==> "BSD 2-clause \"Simplified\" License"

113106 , "BSD-3-Clause" ==> "BSD 3-clause \"New\" or \"Revised\" License"

114− , "0BSD" ==> "BSD Zero Clause 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"

115110 , "CECILL-2.1" ==> "CeCILL Free Software License Agreement v2.1"

116111 , "CNRI-Python" ==> "CNRI Python License"

117− , "CDDL-1.0" ==> "Common Development and Distribution License 1.0"

118112 , "CPAL-1.0" ==> "Common Public Attribution License 1.0"

119113 , "CPL-1.0" ==> "Common Public License 1.0"

120− , "CATOSL-1.1" ==> "Computer Associates Trusted Open Source License 1.1"

121114 , "CUA-OPL-1.0" ==> "CUA Office Public License v1.0"

122− , "EPL-1.0" ==> "Eclipse Public License 1.0"

123115 , "ECL-1.0" ==> "Educational Community License v1.0"

124116 , "ECL-2.0" ==> "Educational Community License v2.0"

125117 , "EFL-1.0" ==> "Eiffel Forum License v1.0"

126118 , "EFL-2.0" ==> "Eiffel Forum License v2.0"

127119 , "Entessa" ==> "Entessa Public License v1.0"

120+ , "EPL-1.0" ==> "Eclipse Public License 1.0"

128121 , "EUDatagrid" ==> "EU DataGrid Software License"

129122 , "EUPL-1.1" ==> "European Union Public License 1.1"

130123 , "Fair" ==> "Fair License"

131124 , "Frameworx-1.0" ==> "Frameworx Open License 1.0"

132− , "AGPL-3.0" ==> "GNU Affero General Public License v3.0"

133125 , "GPL-2.0" ==> "GNU General Public License v2.0 only"

134126 , "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"

138127 , "HPND" ==> "Historic Permission Notice and Disclaimer"

139− , "IPL-1.0" ==> "IBM Public License v1.0"

140128 , "Intel" ==> "Intel Open Source License"

141129 , "IPA" ==> "IPA Font License"

130+ , "IPL-1.0" ==> "IBM Public License v1.0"

142131 , "ISC" ==> "ISC License"

143− , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

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"

144135 , "LiLiQ-P-1.1" ==> "Licence Libre du Québec – Permissive version 1.1"

145− , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"

146136 , "LiLiQ-R-1.1" ==> "Licence Libre du Québec – Réciprocité version 1.1"

147− , "LPL-1.02" ==> "Lucent Public License v1.02"

137+ , "LiLiQ-Rplus-1.1" ==> "Licence Libre du Québec – Réciprocité forte version 1.1"

148138 , "LPL-1.0" ==> "Lucent Public License Version 1.0"

149− , "MS-PL" ==> "Microsoft Public License"

150− , "MS-RL" ==> "Microsoft Reciprocal License"

139+ , "LPL-1.02" ==> "Lucent Public License v1.02"

140+ , "LPPL-1.3c" ==> "LaTeX Project Public License v1.3c"

151141 , "MirOS" ==> "MirOS Licence"

152142 , "MIT" ==> "MIT License"

153143 , "Motosoto" ==> "Motosoto License"

@@ -155,48 +145,41 @@ osiApprovedSpdxLicenses =

155145 , "MPL-1.1" ==> "Mozilla Public License 1.1"

156146 , "MPL-2.0" ==> "Mozilla Public License 2.0"

157147 , "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"

158150 , "Multics" ==> "Multics License"

159151 , "NASA-1.3" ==> "NASA Open Source Agreement 1.3"

160152 , "Naumen" ==> "Naumen Public License"

153+ , "NCSA" ==> "University of Illinois/NCSA Open Source License"

161154 , "NGPL" ==> "Nethack General Public License"

162155 , "Nokia" ==> "Nokia Open Source License"

163156 , "NPOSL-3.0" ==> "Non-Profit Open Software License 3.0"

164157 , "NTP" ==> "NTP License"

165158 , "OCLC-2.0" ==> "OCLC Research Public License 2.0"

159+ , "OFL-1.1" ==> "SIL Open Font License 1.1"

166160 , "OGTSL" ==> "Open Group Test Suite License"

161+ , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

167162 , "OSL-1.0" ==> "Open Software License 1.0"

168163 , "OSL-2.0" ==> "Open Software License 2.0"

169164 , "OSL-2.1" ==> "Open Software License 2.1"

170165 , "OSL-3.0" ==> "Open Software License 3.0"

171− , "OSET-PL-2.1" ==> "OSET Public License version 2.1"

172166 , "PHP-3.0" ==> "PHP License v3.0"

173167 , "PostgreSQL" ==> "PostgreSQL License"

174168 , "Python-2.0" ==> "Python License 2.0"

175169 , "QPL-1.0" ==> "Q Public License 1.0"

176− , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

177170 , "RPL-1.1" ==> "Reciprocal Public License 1.1"

178171 , "RPL-1.5" ==> "Reciprocal Public License 1.5"

172+ , "RPSL-1.0" ==> "RealNetworks Public Source License v1.0"

179173 , "RSCPL" ==> "Ricoh Source Code Public License"

180− , "OFL-1.1" ==> "SIL Open Font License 1.1"

181174 , "SimPL-2.0" ==> "Simple Public License 2.0"

182− , "Sleepycat" ==> "Sleepycat License"

183175 , "SISSL" ==> "Sun Industry Standards Source License v1.1"

176+ , "Sleepycat" ==> "Sleepycat License"

184177 , "SPL-1.0" ==> "Sun Public License v1.0"

185− , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

186178 , "UPL-1.0" ==> "Universal Permissive License v1.0"

187− , "NCSA" ==> "University of Illinois/NCSA Open Source License"

188179 , "VSL-1.0" ==> "Vovida Software License v1.0"

189180 , "W3C" ==> "W3C Software Notice and License (2002-12-31)"

181+ , "Watcom-1.0" ==> "Sybase Open Watcom Public License 1.0"

190182 , "Xnet" ==> "X.Net License"

191183 , "Zlib" ==> "zlib License"

192184 , "ZPL-2.0" ==> "Zope Public License 2.0"

193185 ]

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+75−49

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

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE BangPatterns, OverloadedStrings, UnboxedTuples #-}

22module Elm.ModuleName

33 ( Raw

44 , toChars

5− , toString

6− , toSlashPath

5+ , toFilePath

76 , toHyphenPath

8− , fromHyphenPath

7+ --

98 , encode

109 , decoder

10+ , parser

11+ --

1112 , Canonical(..)

12− , canonicalIsKernel

1313 , basics, char, string

1414 , maybe, result, list, array, dict, tuple

1515 , platform, cmd, sub

16− , debug, bitwise

16+ , debug

1717 , virtualDom

1818 , jsonDecode, jsonEncode

1919 , webgl, texture, vector2, vector3, vector4, matrix4

@@ -23,15 +23,19 @@ module Elm.ModuleName

2323

2424import Control.Monad (liftM2)

2525import Data.Binary (Binary(..))

26−import qualified Data.Char as Char

2726import qualified Data.Name as Name

2827import qualified Data.Utf8 as Utf8

28+import Data.Word (Word8)

29+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

2930import Prelude hiding (maybe)

3031import qualified System.FilePath as FP

3132

3233import qualified Elm.Package as Pkg

33−import qualified Json.Decode as Decode

34−import qualified Json.Encode as Encode

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)

3539

3640

3741

@@ -46,13 +50,8 @@ toChars =

4650 Name.toChars

4751

4852

49−toString :: Raw -> Utf8.String

50−toString =

51− Name.toUtf8

52−

53−

54−toSlashPath :: Raw -> FilePath

55−toSlashPath name =

53+toFilePath :: Raw -> FilePath

54+toFilePath name =

5655 map (\c -> if c == '.' then FP.pathSeparator else c) (Name.toChars name)

5756

5857

@@ -61,38 +60,68 @@ toHyphenPath name =

6160 map (\c -> if c == '.' then '-' else c) (Name.toChars name)

6261

6362

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−

7563

7664-- JSON

7765

7866

79−encode :: Raw -> Encode.Value

67+encode :: Raw -> E.Value

8068encode =

81− Encode.name

69+ E.name

8270

8371

84−decoder :: Decode.Decoder Utf8.String Raw

72+decoder :: D.Decoder (Row, Col) Raw

8573decoder =

86− do str <- Decode.string

87− if all isGoodChunk (Utf8.split 0x2E {- . -} str)

88− then return (Name.fromUtf8 str)

89− else Decode.failure str

74+ D.customString parser (,)

9075

9176

92−isGoodChunk :: Utf8.String -> Bool

93−isGoodChunk chunk =

94− Utf8.startsWithChar Char.isUpper chunk

95− && Utf8.all (\c -> Char.isAlphaNum c || c == '_') chunk

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)

96125

97126

98127

@@ -104,12 +133,6 @@ data Canonical =

104133 { _package :: !Pkg.Name

105134 , _module :: !Name.Name

106135 }

107− deriving (Ord)

108−

109−

110−canonicalIsKernel :: Canonical -> Bool

111−canonicalIsKernel (Canonical _ name) =

112− Name.isKernel name

113136

114137

115138

@@ -121,6 +144,14 @@ instance Eq Canonical where

121144 name1 == name2 && pkg1 == pkg2

122145

123146

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+

124155instance Binary Canonical where

125156 put (Canonical a b) = put a >> put b

126157 get = liftM2 Canonical get get

@@ -195,11 +226,6 @@ debug :: Canonical

195226debug = Canonical Pkg.core Name.debug

196227

197228

198−{-# NOINLINE bitwise #-}

199−bitwise :: Canonical

200−bitwise = Canonical Pkg.core Name.bitwise

201−

202−

203229

204230-- HTML

205231

compiler/src/Elm/Package.hs+220−89

@@ -1,38 +1,52 @@

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, UnboxedTuples #-}

33module Elm.Package

44 ( Name(..)

5+ , Author

6+ , Project

57 , Canonical(..)

68 , isKernel

7− , toString

89 , toChars

910 , toUrl

1011 , toFilePath

11− , BadName(..)

12− , fromString

12+ , toJsonString

13+ --

1314 , dummyName, kernel, core

1415 , browser, virtualDom, html

1516 , json, http, url

1617 , webgl, linearAlgebra

18+ --

1719 , suggestions

20+ , nearbyNames

21+ --

1822 , decoder

1923 , encode

24+ , keyDecoder

25+ --

26+ , parser

2027 )

2128 where

2229

2330

2431import Control.Monad (liftM2)

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

26−import qualified Data.Char as Char

27−import qualified Data.Name as Name

33+import qualified Data.Coerce as Coerce

34+import qualified Data.List as List

2835import qualified Data.Map as Map

36+import qualified Data.Name as Name

2937import Data.Monoid ((<>))

3038import qualified Data.Utf8 as Utf8

39+import Data.Word (Word8)

40+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

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

3242

3343import qualified Elm.Version as V

34−import qualified Json.Decode as Decode

35−import qualified Json.Encode as Encode

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

3650

3751

3852

@@ -41,10 +55,17 @@ import qualified Json.Encode as Encode

4155

4256data Name =

4357 Name

44− { _author :: !Name.Name

45− , _project :: !Name.Name

58+ { _author :: !Author

59+ , _project :: !Project

4660 }

47− deriving (Eq, Ord)

61+ deriving (Ord)

62+

63+

64+type Author = Utf8.Utf8 AUTHOR

65+type Project = Utf8.Utf8 PROJECT

66+

67+data AUTHOR

68+data PROJECT

4869

4970

5071data Canonical =

@@ -52,7 +73,7 @@ data Canonical =

5273 { _name :: !Name

5374 , _version :: !V.Version

5475 }

55− deriving (Eq, Ord)

76+ deriving (Ord)

5677

5778

5879

@@ -61,127 +82,114 @@ data Canonical =

6182

6283isKernel :: Name -> Bool

6384isKernel (Name author _) =

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 ]

85+ author == elm || author == elm_explorations

7086

7187

7288toChars :: Name -> String

7389toChars (Name author project) =

74− Name.toChars author <> "/" <> Name.toChars project

90+ Utf8.toChars author <> "/" <> Utf8.toChars project

7591

7692

7793toUrl :: Name -> String

7894toUrl (Name author project) =

79− Name.toChars author ++ "/" ++ Name.toChars project

95+ Utf8.toChars author ++ "/" ++ Utf8.toChars project

8096

8197

8298toFilePath :: Name -> FilePath

8399toFilePath (Name author project) =

84− Name.toChars author </> Name.toChars project

100+ Utf8.toChars author </> Utf8.toChars project

85101

86102

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

103+toJsonString :: Name -> Json.String

104+toJsonString (Name author project) =

105+ Utf8.join 0x2F {-/-} [ Coerce.coerce author, Coerce.coerce project ]

101106

102− _ ->

103− Left BadStructure

104107

105108

106−data BadName

107− = BadStructure

108− | TooLong

109− | HasDoubleDash

110− | HasUnderscore

111− | HasDot

112− | HasUppercase

113− | HasDashEnd

114− | HasNonLowercaseStart

115−

109+-- COMMON PACKAGE NAMES

116110

117111

118−-- COMMON PACKAGE NAMES

112+toName :: Author -> [Char] -> Name

113+toName author project =

114+ Name author (Utf8.fromChars project)

119115

120116

121117{-# NOINLINE dummyName #-}

122118dummyName :: Name

123119dummyName =

124− Name "author" "project"

120+ toName (Utf8.fromChars "author") "project"

125121

126122

127123{-# NOINLINE kernel #-}

128124kernel :: Name

129125kernel =

130− Name "elm" "kernel"

126+ toName elm "kernel"

131127

132128

133129{-# NOINLINE core #-}

134130core :: Name

135131core =

136− Name "elm" "core"

132+ toName elm "core"

137133

138134

139135{-# NOINLINE browser #-}

140136browser :: Name

141137browser =

142− Name "elm" "browser"

138+ toName elm "browser"

143139

144140

145141{-# NOINLINE virtualDom #-}

146142virtualDom :: Name

147143virtualDom =

148− Name "elm" "virtual-dom"

144+ toName elm "virtual-dom"

149145

150146

151147{-# NOINLINE html #-}

152148html :: Name

153149html =

154− Name "elm" "html"

150+ toName elm "html"

155151

156152

157153{-# NOINLINE json #-}

158154json :: Name

159155json =

160− Name "elm" "json"

156+ toName elm "json"

161157

162158

163159{-# NOINLINE http #-}

164160http :: Name

165161http =

166− Name "elm" "http"

162+ toName elm "http"

167163

168164

169165{-# NOINLINE url #-}

170166url :: Name

171167url =

172− Name "elm" "url"

168+ toName elm "url"

173169

174170

175171{-# NOINLINE webgl #-}

176172webgl :: Name

177173webgl =

178− Name "elm-explorations" "webgl"

174+ toName elm_explorations "webgl"

179175

180176

181177{-# NOINLINE linearAlgebra #-}

182178linearAlgebra :: Name

183179linearAlgebra =

184− Name "elm-explorations" "linear-algebra"

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"

185193

186194

187195

@@ -190,54 +198,177 @@ linearAlgebra =

190198

191199suggestions :: Map.Map Name.Name Name

192200suggestions =

201+ let

202+ random = toName elm "random"

203+ time = toName elm "time"

204+ file = toName elm "file"

205+ in

193206 Map.fromList

194− [ ("Browser", browser)

195− , ("Html", html)

196− , ("Http", http)

197− , ("Json.Decode", json)

198− , ("Json.Encode", json)

199− , ("Url.Parser", url)

200− , ("Url", url)

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

201221 ]

202222

203223

224+(==>) :: [Char] -> Name -> (Name.Name, Name)

225+(==>) moduleName package =

226+ ( Utf8.fromChars moduleName, package )

204227

205−-- BINARY

206228

207229

208−instance Binary Name where

209− get =

210− liftM2 Name get get

230+-- NEARBY NAMES

211231

212− put (Name author project) =

213− do put author

214− put project

215232

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)

216238

217−instance Binary Canonical where

218− get =

219− liftM2 Canonical get get

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

220250

221− put (Canonical name version) =

222− do put name

223− put version

251+

252+projectDistance :: [Char] -> Project -> Int

253+projectDistance given possibility =

254+ abs (Suggest.distance given (Utf8.toChars possibility))

255+

256+

257+

258+-- INSTANCES

259+

260+

261+instance Eq Name where

262+ (==) (Name author1 project1) (Name author2 project2) =

263+ project1 == project2 && author1 == author2

264+

265+

266+instance Eq Canonical where

267+ (==) (Canonical package1 version1) (Canonical package2 version2) =

268+ version1 == version2 && package1 == package2

269+

270+

271+

272+-- BINARY

273+

274+

275+instance Binary Name where -- PERF try storing as a Word16

276+ get = liftM2 Name Utf8.getUnder256 Utf8.getUnder256

277+ put (Name a b) = Utf8.putUnder256 a >> Utf8.putUnder256 b

278+

279+

280+instance Binary Canonical where

281+ get = liftM2 Canonical get get

282+ put (Canonical a b) = put a >> put b

224283

225284

226285

227286-- JSON

228287

229288

230−decoder :: Decode.Decoder BadName Name

289+decoder :: D.Decoder (Row, Col) Name

231290decoder =

232− do str <- Decode.string

233− case fromString str of

234− Right name ->

235− return name

236−

237− Left err ->

238− Decode.failure err

291+ D.customString parser (,)

239292

240293

241−encode :: Name -> Encode.Value

294+encode :: Name -> E.Value

242295encode name =

243− Encode.string (toString name)

296+ E.chars (toChars name)

297+

298+

299+keyDecoder :: (Row -> Col -> x) -> D.KeyDecoder x Name

300+keyDecoder toError =

301+ let

302+ keyParser =

303+ P.specialize (\(r,c) _ _ -> toError r c) parser

304+ in

305+ D.KeyDecoder keyParser toError

306+

307+

308+

309+-- PARSER

310+

311+

312+parser :: P.Parser (Row, Col) Name

313+parser =

314+ do author <- parseName isAlphaOrDigit isAlphaOrDigit

315+ P.word1 0x2F {-/-} (,)

316+ project <- parseName isLower isLowerOrDigit

317+ return (Name author project)

318+

319+

320+parseName :: (Word8 -> Bool) -> (Word8 -> Bool) -> P.Parser (Row, Col) (Utf8.Utf8 t)

321+parseName isGoodStart isGoodInner =

322+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

323+ if pos >= end then

324+ eerr row col (,)

325+ else

326+ let !word = P.unsafeIndex pos in

327+ if not (isGoodStart word) then

328+ eerr row col (,)

329+ else

330+ let

331+ (# isGood, newPos #) = chompName isGoodInner (plusPtr pos 1) end False

332+ !len = fromIntegral (minusPtr newPos pos)

333+ !newCol = col + len

334+ in

335+ if isGood && len < 256 then

336+ let !newState = P.State src newPos end indent row newCol in

337+ cok (Utf8.fromPtr pos newPos) newState

338+ else

339+ cerr row newCol (,)

340+

341+

342+isLower :: Word8 -> Bool

343+isLower word =

344+ 0x61 {-a-} <= word && word <= 0x7A {-z-}

345+

346+

347+isLowerOrDigit :: Word8 -> Bool

348+isLowerOrDigit word =

349+ 0x61 {-a-} <= word && word <= 0x7A {-z-}

350+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}

351+

352+

353+isAlphaOrDigit :: Word8 -> Bool

354+isAlphaOrDigit word =

355+ 0x61 {-a-} <= word && word <= 0x7A {-z-}

356+ || 0x41 {-A-} <= word && word <= 0x5A {-Z-}

357+ || 0x30 {-0-} <= word && word <= 0x39 {-9-}

358+

359+

360+chompName :: (Word8 -> Bool) -> Ptr Word8 -> Ptr Word8 -> Bool -> (# Bool, Ptr Word8 #)

361+chompName isGoodChar pos end prevWasDash =

362+ if pos >= end then

363+ (# not prevWasDash, pos #)

364+ else

365+ let !word = P.unsafeIndex pos in

366+ if isGoodChar word then

367+ chompName isGoodChar (plusPtr pos 1) end False

368+ else if word == 0x2D {---} then

369+ if prevWasDash then

370+ (# False, pos #)

371+ else

372+ chompName isGoodChar (plusPtr pos 1) end True

373+ else

374+ (# True, pos #)

compiler/src/Elm/String.hsnew file+133

@@ -0,0 +1,133 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances #-}

3+module Elm.String

4+ ( String

5+ , toChars

6+ , toBuilder

7+ , Chunk(..)

8+ , fromChunks

9+ )

10+ where

11+

12+

13+import Prelude hiding (String)

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

15+import Data.Bits ((.&.), shiftR)

16+import qualified Data.ByteString.Builder as B

17+import qualified Data.Utf8 as Utf8

18+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

19+import GHC.Exts (RealWorld, Ptr)

20+import GHC.IO (stToIO, unsafeDupablePerformIO)

21+import GHC.ST (ST)

22+import GHC.Word (Word8)

23+

24+

25+

26+-- STRINGS

27+

28+

29+type String =

30+ Utf8.Utf8 ELM_STRING

31+

32+

33+data ELM_STRING

34+

35+

36+

37+-- HELPERS

38+

39+

40+toChars :: String -> [Char]

41+toChars =

42+ Utf8.toChars

43+

44+

45+{-# INLINE toBuilder #-}

46+toBuilder :: String -> B.Builder

47+toBuilder =

48+ Utf8.toBuilder

49+

50+

51+

52+-- FROM CHUNKS

53+

54+

55+data Chunk

56+ = Slice (Ptr Word8) Int

57+ | Escape Word8

58+ | CodePoint Int

59+

60+

61+fromChunks :: [Chunk] -> String

62+fromChunks chunks =

63+ unsafeDupablePerformIO (stToIO (

64+ do let !len = sum (map chunkToWidth chunks)

65+ mba <- newByteArray len

66+ writeChunks mba 0 chunks

67+ freeze mba

68+ ))

69+

70+

71+chunkToWidth :: Chunk -> Int

72+chunkToWidth chunk =

73+ case chunk of

74+ Slice _ len -> len

75+ Escape _ -> 2

76+ CodePoint c -> if c < 0xFFFF then 6 else 12

77+

78+

79+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

80+writeChunks mba offset chunks =

81+ case chunks of

82+ [] ->

83+ return ()

84+

85+ chunk : chunks ->

86+ case chunk of

87+ Slice ptr len ->

88+ do copyFromPtr ptr mba offset len

89+ let !newOffset = offset + len

90+ writeChunks mba newOffset chunks

91+

92+ Escape word ->

93+ do writeWord8 mba offset 0x5C {- \ -}

94+ writeWord8 mba (offset + 1) word

95+ let !newOffset = offset + 2

96+ writeChunks mba newOffset chunks

97+

98+ CodePoint code ->

99+ if code < 0xFFFF then

100+ do writeCode mba offset code

101+ let !newOffset = offset + 6

102+ writeChunks mba newOffset chunks

103+ else

104+ do let (hi,lo) = divMod (code - 0x10000) 0x400

105+ writeCode mba (offset ) (hi + 0xD800)

106+ writeCode mba (offset + 6) (lo + 0xDC00)

107+ let !newOffset = offset + 12

108+ writeChunks mba newOffset chunks

109+

110+

111+writeCode :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

112+writeCode mba offset code =

113+ do writeWord8 mba offset 0x5C {- \ -}

114+ writeWord8 mba (offset + 1) 0x75 {- u -}

115+ writeHex mba (offset + 2) (shiftR code 12)

116+ writeHex mba (offset + 3) (shiftR code 8)

117+ writeHex mba (offset + 4) (shiftR code 4)

118+ writeHex mba (offset + 5) code

119+

120+

121+writeHex :: MBA RealWorld -> Int -> Int -> ST RealWorld ()

122+writeHex mba !offset !bits =

123+ do let !n = fromIntegral bits .&. 0x0F

124+ writeWord8 mba offset (if n < 10 then 0x30 + n else 0x37 + n)

125+

126+

127+

128+-- BINARY

129+

130+

131+instance Binary (Utf8.Utf8 ELM_STRING) where

132+ get = Utf8.getVeryLong

133+ put = Utf8.putVeryLong

compiler/src/Elm/Version.hs+79−50

@@ -1,3 +1,5 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns, UnboxedTuples #-}

13module Elm.Version

24 ( Version(..)

35 , one

@@ -7,24 +9,27 @@ module Elm.Version

79 , bumpMinor

810 , bumpMajor

911 , toChars

10− , toString

11− , fromString

12+ --

1213 , decoder

1314 , encode

15+ --

16+ , parser

1417 )

1518 where

1619

1720

1821import Prelude hiding (max)

19−import Control.Monad (liftM, liftM3)

22+import Control.Monad (liftM3)

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

21−import qualified Data.Utf8 as Utf8

2224import qualified Data.Version as Version

23−import Data.Word (Word16)

25+import Data.Word (Word8, Word16)

26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

2427import qualified Paths_elm

2528

2629import qualified Json.Decode as D

2730import qualified Json.Encode as E

31+import qualified Parse.Primitives as P

32+import Parse.Primitives (Row, Col)

2833

2934

3035

@@ -86,58 +91,26 @@ bumpMajor (Version major _minor _patch) =

8691

8792

8893

89−-- TO STRING

94+-- TO CHARS

9095

9196

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

97+toChars :: Version -> [Char]

98+toChars (Version major minor patch) =

99+ show major ++ '.' : show minor ++ '.' : show patch

121100

122101

123102

124103-- JSON

125104

126105

127−decoder :: D.Decoder Utf8.String Version

106+decoder :: D.Decoder (Row, Col) Version

128107decoder =

129− do str <- D.string

130− case fromString str of

131− Just version ->

132− return version

133−

134− Nothing ->

135− D.failure str

108+ D.customString parser (,)

136109

137110

138111encode :: Version -> E.Value

139112encode version =

140− E.string (toString version)

113+ E.chars (toChars version)

141114

142115

143116

@@ -147,21 +120,77 @@ encode version =

147120instance Binary Version where

148121 get =

149122 do word <- getWord8

150− if word == 0

123+ if word == 255

151124 then liftM3 Version get get get

152125 else

153− do minor <- liftM fromIntegral getWord8

154− patch <- liftM fromIntegral getWord8

155− return (Version (fromIntegral word) minor patch)

126+ do minor <- getWord8

127+ patch <- getWord8

128+ return (Version (fromIntegral word) (fromIntegral minor) (fromIntegral patch))

156129

157130 put (Version major minor patch) =

158− if major < 256 && minor < 256 && patch < 256 then

131+ if major < 255 && minor < 256 && patch < 256 then

159132 do putWord8 (fromIntegral major)

160133 putWord8 (fromIntegral minor)

161134 putWord8 (fromIntegral patch)

162135 else

163− do putWord8 0

136+ do putWord8 255

164137 put major

165138 put minor

166139 put patch

167140

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+17−4

@@ -24,18 +24,31 @@ sandwich moduleName javascript =

2424<head>

2525 <meta charset="UTF-8">

2626 <title>|] <> name <> [r|</title>

27+ <style>body { padding: 0; margin: 0; }</style>

2728</head>

2829

2930<body>

30−<div id="elm-df98db9626"></div>

31+

32+<pre id="elm"></pre>

33+

3134<script>

35+try {

3236|] <> javascript <> [r|

3337

34−var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm-df98db9626") });

35−if (document.getElementById("elm-df98db9626"))

38+ var app = Elm.|] <> name <> [r|.init({ node: document.getElementById("elm") });

39+}

40+catch (e)

3641{

37− document.getElementById("elm-df98db9626").innerText = 'This is a headless program, meaning there is nothing to show here.\n\nI started the program anyway though, and you can access it as `app` in the developer console.';

42+ // display initialization errors (e.g. bad flags, infinite recursion)

43+ var header = document.createElement("h1");

44+ header.style.fontFamily = "monospace";

45+ header.innerText = "Initialization Error";

46+ var pre = document.getElementById("elm");

47+ document.body.insertBefore(header, pre);

48+ pre.innerText = e;

49+ throw e;

3850}

3951</script>

52+

4053</body>

4154</html>|]

compiler/src/Generate/JavaScript.hs+97−87

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

11{-# LANGUAGE OverloadedStrings #-}

22module Generate.JavaScript

3− ( Output(..)

4− , generate

3+ ( generate

54 , generateForRepl

5+ , generateForReplEndpoint

66 )

77 where

88

@@ -20,11 +20,11 @@ import qualified Data.Utf8 as Utf8

2020import qualified AST.Canonical as Can

2121import qualified AST.Optimized as Opt

2222import qualified Data.Index as Index

23−import qualified Elm.Interface as I

2423import qualified Elm.Kernel as K

2524import qualified Elm.ModuleName as ModuleName

2625import qualified Generate.JavaScript.Builder as JS

2726import qualified Generate.JavaScript.Expression as Expr

27+import qualified Generate.JavaScript.Functions as Functions

2828import qualified Generate.JavaScript.Name as JsName

2929import qualified Generate.Mode as Mode

3030import qualified Reporting.Doc as D

@@ -33,33 +33,27 @@ import qualified Reporting.Render.Type.Localizer as L

3333

3434

3535

36−-- GENERATE MAINS

36+-- GENERATE

3737

3838

39−data Output

40− = None

41− | Some Name.Name [Name.Name] B.Builder

39+type Graph = Map.Map Opt.Global Opt.Node

40+type Mains = Map.Map ModuleName.Canonical Opt.Main

4241

4342

44−generate :: Mode.Mode -> Opt.Graph -> [ModuleName.Canonical] -> Output

45−generate mode (Opt.Graph mains graph _) roots =

43+generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder

44+generate mode (Opt.GlobalGraph graph _) mains =

4645 let

47− rootSet = Set.fromList roots

48− rootMap = Map.restrictKeys mains rootSet

46+ state = Map.foldrWithKey (addMain mode graph) emptyState mains

4947 in

50− case map ModuleName._module (Map.keys rootMap) of

51− [] ->

52− None

53−

54− name:names ->

55− let

56− state = Map.foldrWithKey (addMain mode graph) emptyState rootMap

57− builder = perfNote mode <> stateToBuilder state <> toMainExports mode rootMap

58− in

59− Some name names builder

48+ "(function(scope){\n'use strict';"

49+ <> Functions.functions

50+ <> perfNote mode

51+ <> stateToBuilder state

52+ <> toMainExports mode mains

53+ <> "}(this));"

6054

6155

62−addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State

56+addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State

6357addMain mode graph home _ state =

6458 addGlobal mode graph state (Opt.Global home "main")

6559

@@ -85,34 +79,68 @@ perfNote mode =

8579-- GENERATE FOR REPL

8680

8781

88−generateForRepl :: Bool -> L.Localizer -> Opt.Graph -> I.Interface -> ModuleName.Canonical -> Name.Name -> B.Builder

89−generateForRepl ansi localizer (Opt.Graph _ graph _) iface home name =

82+generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder

83+generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) =

9084 let

9185 mode = Mode.Dev Nothing

9286 debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")

9387 evalState = addGlobal mode graph debugState (Opt.Global home name)

9488 in

95− stateToBuilder evalState

96− <>

97− print ansi localizer home name (I._values iface ! name)

89+ "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });"

90+ <> Functions.functions

91+ <> stateToBuilder evalState

92+ <> print ansi localizer home name tipe

9893

9994

100−print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder

101−print ansi localizer home name (Can.Forall _ tipe) =

95+print :: Bool -> L.Localizer -> ModuleName.Canonical -> Name.Name -> Can.Type -> B.Builder

96+print ansi localizer home name tipe =

10297 let

10398 value = JsName.toBuilder (JsName.fromGlobal home name)

10499 toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")

105100 tipeDoc = RT.canToDoc localizer RT.None tipe

106101 bool = if ansi then "true" else "false"

107102 in

108− "var _value = " <> toString <> "(" <> bool <> ", " <> value <> ");\n\

109− \var _type = " <> B.stringUtf8 (show (D.toString tipeDoc)) <> ";\n\

110− \function _print(t) { console.log(_value + (" <> bool <> " ? '\x1b[90m' + t + '\x1b[0m' : t)); }\n\

111− \if (_value.length + 3 + _type.length >= 80 || _type.indexOf('\\n') >= 0) {\n\

112− \ _print('\\n : ' + _type.split('\\n').join('\\n '));\n\

113− \} else {\n\

114− \ _print(' : ' + _type);\n\

115− \}\n"

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"

116144

117145

118146

@@ -146,9 +174,6 @@ prependBuilders revBuilders monolith =

146174-- ADD DEPENDENCIES

147175

148176

149−type Graph = Map.Map Opt.Global Opt.Node

150−

151−

152177addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State

153178addGlobal mode graph state@(State revKernels builders seen) global =

154179 if Set.member global seen then

@@ -236,7 +261,7 @@ addKernel (State revKernels revBuilders seen) kernel =

236261

237262var :: Opt.Global -> Expr.Code -> JS.Stmt

238263var (Opt.Global home name) code =

239− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr code)) ]

264+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code)

240265

241266

242267isDebugger :: Opt.Global -> Bool

@@ -267,7 +292,7 @@ generateCycle mode (Opt.Global home _) names values functions =

267292 "Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"

268293 <> drawCycle names

269294 <> "\\n\\nThese errors are very tricky, so read "

270− <> B.stringUtf8 (D.makeNakedLink "halting-problem")

295+ <> B.stringUtf8 (D.makeNakedLink "bad-recursion")

271296 <> " to learn how to fix it!"

272297 ]

273298

@@ -276,10 +301,10 @@ generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt

276301generateCycleFunc mode home def =

277302 case def of

278303 Opt.Def name expr ->

279− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generate mode expr))) ]

304+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr))

280305

281306 Opt.TailDef name args expr ->

282− JS.Var [ (JsName.fromGlobal home name, Just (Expr.codeToExpr (Expr.generateTailDef mode name args expr))) ]

307+ JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr))

283308

284309

285310generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt

@@ -295,9 +320,9 @@ generateRealCycle home (name, _) =

295320 realName = JsName.fromGlobal home name

296321 in

297322 JS.Block

298− [ JS.Var [ ( realName, Just (JS.Call (JS.Ref safeName) []) ) ]

323+ [ JS.Var realName (JS.Call (JS.Ref safeName) [])

299324 , JS.ExprStmt $ JS.Assign (JS.LRef safeName) $

300− JS.Function Nothing [] [ JS.Return (Just (JS.Ref realName)) ]

325+ JS.Function Nothing [] [ JS.Return (JS.Ref realName) ]

301326 ]

302327

303328

@@ -325,7 +350,7 @@ addChunk :: Mode.Mode -> K.Chunk -> B.Builder -> B.Builder

325350addChunk mode chunk builder =

326351 case chunk of

327352 K.JS javascript ->

328− Utf8.toBuilder javascript <> builder

353+ B.byteString javascript <> builder

329354

330355 K.ElmVar home name ->

331356 JsName.toBuilder (JsName.fromGlobal home name) <> builder

@@ -365,16 +390,13 @@ addChunk mode chunk builder =

365390

366391generateEnum :: Mode.Mode -> Opt.Global -> Index.ZeroBased -> JS.Stmt

367392generateEnum mode global@(Opt.Global home name) index =

368− let

369− definition =

370− case mode of

371− Mode.Dev _ ->

372− Expr.codeToExpr (Expr.generateCtor mode global index 0)

393+ JS.Var (JsName.fromGlobal home name) $

394+ case mode of

395+ Mode.Dev _ ->

396+ Expr.codeToExpr (Expr.generateCtor mode global index 0)

373397

374− Mode.Prod _ ->

375− JS.Int (Index.toMachine index)

376− in

377− JS.Var [ (JsName.fromGlobal home name, Just definition) ]

398+ Mode.Prod _ ->

399+ JS.Int (Index.toMachine index)

378400

379401

380402

@@ -383,16 +405,13 @@ generateEnum mode global@(Opt.Global home name) index =

383405

384406generateBox :: Mode.Mode -> Opt.Global -> JS.Stmt

385407generateBox mode global@(Opt.Global home name) =

386− let

387− definition =

388− case mode of

389− Mode.Dev _ ->

390− Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

408+ JS.Var (JsName.fromGlobal home name) $

409+ case mode of

410+ Mode.Dev _ ->

411+ Expr.codeToExpr (Expr.generateCtor mode global Index.first 1)

391412

392− Mode.Prod _ ->

393− JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

394− in

395− JS.Var [ (JsName.fromGlobal home name, Just definition) ]

413+ Mode.Prod _ ->

414+ JS.Ref (JsName.fromGlobal ModuleName.basics Name.identity)

396415

397416

398417{-# NOINLINE identity #-}

@@ -407,14 +426,11 @@ identity =

407426

408427generatePort :: Mode.Mode -> Opt.Global -> Name.Name -> Opt.Expr -> JS.Stmt

409428generatePort mode (Opt.Global home name) makePort converter =

410− let

411− definition =

412− JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort))

413− [ JS.String (Name.toBuilder name)

414− , Expr.codeToExpr (Expr.generate mode converter)

415− ]

416− in

417− JS.Var [ (JsName.fromGlobal home name, Just definition) ]

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

418434

419435

420436

@@ -442,11 +458,9 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName)

442458

443459generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt

444460generateLeaf home@(ModuleName.Canonical _ moduleName) name =

445− let

446− definition =

447− JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

448− in

449− JS.Var [ (JsName.fromGlobal home name, Just definition) ]

461+ JS.Var (JsName.fromGlobal home name) $

462+ JS.Call leaf [ JS.String (Name.toBuilder moduleName) ]

463+

450464

451465

452466{-# NOINLINE leaf #-}

@@ -487,7 +501,7 @@ generateManagerHelp home effectsType =

487501-- MAIN EXPORTS

488502

489503

490−toMainExports :: Mode.Mode -> Map.Map ModuleName.Canonical Opt.Main -> B.Builder

504+toMainExports :: Mode.Mode -> Mains -> B.Builder

491505toMainExports mode mains =

492506 let

493507 export = JsName.fromKernel Name.platform "export"

@@ -520,7 +534,7 @@ generateExports mode (Trie maybeMain subs) =

520534 <> List.foldl' (addSubTrie mode) "}" otherSubTries

521535

522536

523−addSubTrie :: Mode.Mode -> B.Builder -> (Utf8.String, Trie) -> B.Builder

537+addSubTrie :: Mode.Mode -> B.Builder -> (Name.Name, Trie) -> B.Builder

524538addSubTrie mode end (name, trie) =

525539 ",'" <> Utf8.toBuilder name <> "':" <> generateExports mode trie <> end

526540

@@ -532,7 +546,7 @@ addSubTrie mode end (name, trie) =

532546data Trie =

533547 Trie

534548 { _main :: Maybe (ModuleName.Canonical, Opt.Main)

535− , _subs :: Map.Map Utf8.String Trie

549+ , _subs :: Map.Map Name.Name Trie

536550 }

537551

538552

@@ -543,14 +557,10 @@ emptyTrie =

543557

544558addToTrie :: ModuleName.Canonical -> Opt.Main -> Trie -> Trie

545559addToTrie home@(ModuleName.Canonical _ moduleName) main trie =

546− let

547− segments =

548− Utf8.split 0x2E {-.-} (Name.toUtf8 moduleName)

549− in

550− merge trie $ segmentsToTrie home segments main

560+ merge trie $ segmentsToTrie home (Name.splitDots moduleName) main

551561

552562

553−segmentsToTrie :: ModuleName.Canonical -> [Utf8.String] -> Opt.Main -> Trie

563+segmentsToTrie :: ModuleName.Canonical -> [Name.Name] -> Opt.Main -> Trie

554564segmentsToTrie home segments main =

555565 case segments of

556566 [] ->

compiler/src/Generate/JavaScript/Builder.hs+207−217

@@ -16,6 +16,7 @@ module Generate.JavaScript.Builder

1616

1717import Prelude hiding (lines)

1818import qualified Data.List as List

19+import qualified Data.ByteString as BS

1920import Data.ByteString.Builder as B

2021import Data.Monoid ((<>))

2122import qualified Generate.JavaScript.Name as Name

@@ -27,6 +28,19 @@ import qualified Json.Encode as Json

2728-- EXPRESSIONS

2829

2930

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

3044data Expr

3145 = String Builder

3246 | Float Builder

@@ -37,13 +51,13 @@ data Expr

3751 | Array [Expr]

3852 | Object [(Name, Expr)]

3953 | Ref Name

40− | Access Expr Name -- ^ @foo.bar@, spec 11.2.1

41− | Index Expr Expr -- ^ @foo[bar]@, spec 11.2.1

54+ | Access Expr Name -- foo.bar

55+ | Index Expr Expr -- foo[bar]

4256 | Prefix PrefixOp Expr

4357 | Infix InfixOp Expr Expr

4458 | If Expr Expr Expr

4559 | Assign LValue Expr

46− | Call Expr [Expr] -- ^ @f(x,y,z)@, spec 11.2.3

60+ | Call Expr [Expr]

4761 | Function (Maybe Name) [Name] [Stmt]

4862

4963

@@ -58,20 +72,21 @@ data LValue

5872

5973

6074data 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) {...}

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]

7590

7691

7792data Case

@@ -84,37 +99,31 @@ data Case

8499

85100

86101data InfixOp

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

102+ = OpAdd -- +

103+ | OpSub -- -

99104 | OpMul -- *

100105 | OpDiv -- /

101106 | OpMod -- %

102− | OpSub -- -

103− | OpLShift -- <<

104− | OpSpRShift -- >>

105− | OpZfRShift -- >>>

106− | OpBAnd -- &

107− | OpBXor -- ^

108− | OpBOr -- |

109− | OpAdd -- +

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

110121

111122

112123data PrefixOp

113− = PrefixLNot -- !

114− | PrefixBNot -- ~

115− | PrefixPlus -- +

116− | PrefixMinus -- -

117− | PrefixTypeof -- typeof

124+ = PrefixNot -- !

125+ | PrefixNegate -- -

126+ | PrefixComplement -- ~

118127

119128

120129

@@ -123,21 +132,40 @@ data PrefixOp

123132

124133stmtToBuilder :: Stmt -> Builder

125134stmtToBuilder stmts =

126− fromStmt "" stmts

135+ fromStmt levelZero stmts

127136

128137

129138exprToBuilder :: Expr -> Builder

130139exprToBuilder expr =

131− snd $ fromExpr "" Whatever expr

140+ snd $ fromExpr levelZero Whatever expr

132141

133142

134143

135−-- HELPERS

144+-- INDENT LEVEL

145+

146+

147+data Level =

148+ Level Builder Level

149+

150+

151+levelZero :: Level

152+levelZero =

153+ Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))

154+

155+

156+makeLevel :: Int -> BS.ByteString -> Level

157+makeLevel level oldTabs =

158+ let

159+ tabs =

160+ if level <= BS.length oldTabs

161+ then oldTabs

162+ else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}

163+ in

164+ Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)

165+

136166

137167

138−deeper :: Builder -> Builder

139−deeper indent =

140− "\t" <> indent

168+-- HELPERS

141169

142170

143171commaSep :: [Builder] -> Builder

@@ -145,52 +173,52 @@ commaSep builders =

145173 mconcat (List.intersperse ", " builders)

146174

147175

148−commaNewlineSep :: Builder -> [Builder] -> Builder

149−commaNewlineSep indent builders =

150− mconcat (List.intersperse (",\n" <> deeper indent) builders)

176+commaNewlineSep :: Level -> [Builder] -> Builder

177+commaNewlineSep (Level _ (Level deeperIndent _)) builders =

178+ mconcat (List.intersperse (",\n" <> deeperIndent) builders)

151179

152180

153181

154182-- STATEMENTS

155183

156184

157−fromStmtBlock :: Builder -> [Stmt] -> Builder

158−fromStmtBlock indent stmts =

159− mconcat (map (fromStmt indent) stmts)

185+fromStmtBlock :: Level -> [Stmt] -> Builder

186+fromStmtBlock level stmts =

187+ mconcat (map (fromStmt level) stmts)

160188

161189

162−fromStmt :: Builder -> Stmt -> Builder

163−fromStmt indent statement =

190+fromStmt :: Level -> Stmt -> Builder

191+fromStmt level@(Level indent nextLevel) statement =

164192 case statement of

165193 Block stmts ->

166− fromStmtBlock indent stmts

194+ fromStmtBlock level stmts

167195

168196 EmptyStmt ->

169197 mempty

170198

171199 ExprStmt expr ->

172− indent <> snd (fromExpr indent Whatever expr) <> ";\n"

200+ indent <> snd (fromExpr level Whatever expr) <> ";\n"

173201

174202 IfStmt condition thenStmt elseStmt ->

175203 mconcat

176− [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"

177− , fromStmt (deeper indent) thenStmt

204+ [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"

205+ , fromStmt nextLevel thenStmt

178206 , indent, "} else {\n"

179− , fromStmt (deeper indent) elseStmt

207+ , fromStmt nextLevel elseStmt

180208 , indent, "}\n"

181209 ]

182210

183211 Switch expr clauses ->

184212 mconcat

185− [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"

186− , mconcat (map (fromClause (deeper indent)) clauses)

213+ [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"

214+ , mconcat (map (fromClause nextLevel) clauses)

187215 , indent, "}\n"

188216 ]

189217

190218 While expr stmt ->

191219 mconcat

192− [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"

193− , fromStmt (deeper indent) stmt

220+ [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"

221+ , fromStmt nextLevel stmt

194222 , indent, "}\n"

195223 ]

196224

@@ -209,37 +237,37 @@ fromStmt indent statement =

209237 Labelled label stmt ->

210238 mconcat

211239 [ indent, Name.toBuilder label, ":\n"

212− , fromStmt indent stmt

240+ , fromStmt level stmt

213241 ]

214242

215243 Try tryStmt errorName catchStmt ->

216244 mconcat

217245 [ indent, "try {\n"

218− , fromStmt (deeper indent) tryStmt

246+ , fromStmt nextLevel tryStmt

219247 , indent, "} catch (", Name.toBuilder errorName, ") {\n"

220− , fromStmt (deeper indent) catchStmt

248+ , fromStmt nextLevel catchStmt

221249 , indent, "}\n"

222250 ]

223251

224252 Throw expr ->

225− "throw " <> snd (fromExpr indent Whatever expr) <> ";"

253+ indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"

226254

227− Return Nothing ->

228− indent <> "return;\n"

255+ Return expr ->

256+ indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"

229257

230− Return (Just expr) ->

231− indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"

258+ Var name expr ->

259+ indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"

232260

233− Var [] ->

261+ Vars [] ->

234262 mempty

235263

236− Var vars ->

237− indent <> "var " <> commaNewlineSep indent (map (varToBuilder indent) vars) <> ";\n"

264+ Vars vars ->

265+ indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"

238266

239267 FunctionStmt name args stmts ->

240268 indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

241269 <>

242− fromStmtBlock (deeper indent) stmts

270+ fromStmtBlock nextLevel stmts

243271 <>

244272 indent <> "}\n"

245273

@@ -248,30 +276,25 @@ fromStmt indent statement =

248276-- SWITCH CLAUSES

249277

250278

251−fromClause :: Builder -> Case -> Builder

252−fromClause indent clause =

279+fromClause :: Level -> Case -> Builder

280+fromClause level@(Level indent nextLevel) clause =

253281 case clause of

254282 Case expr stmts ->

255− indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"

256− <> fromStmtBlock (deeper indent) stmts

283+ indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"

284+ <> fromStmtBlock nextLevel stmts

257285

258286 Default stmts ->

259287 indent <> "default:\n"

260− <> fromStmtBlock (deeper indent) stmts

288+ <> fromStmtBlock nextLevel stmts

261289

262290

263291

264292-- VAR DECLS

265293

266294

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)

295+varToBuilder :: Level -> (Name, Expr) -> Builder

296+varToBuilder level (name, expr) =

297+ Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)

275298

276299

277300

@@ -289,12 +312,11 @@ merge a b =

289312linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])

290313linesMap func xs =

291314 let

292− pairs =

293− map func xs

315+ pairs = map func xs

294316 in

295− ( any ((==) Many . fst) pairs

296− , map snd pairs

297− )

317+ ( any ((==) Many . fst) pairs

318+ , map snd pairs

319+ )

298320

299321

300322data Grouping = Atomic | Whatever

@@ -310,23 +332,23 @@ parensFor grouping builder =

310332 builder

311333

312334

313−fromExpr :: Builder -> Grouping -> Expr -> (Lines, Builder)

314−fromExpr indent grouping expression =

335+fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)

336+fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =

315337 case expression of

316338 String string ->

317− (One, "'" <> string <> "'")

339+ ( One, "'" <> string <> "'" )

318340

319341 Float float ->

320− (One, float)

342+ ( One, float )

321343

322344 Int n ->

323− (One, B.intDec n)

345+ ( One, B.intDec n )

324346

325347 Bool bool ->

326− (One, if bool then "true" else "false")

348+ ( One, if bool then "true" else "false" )

327349

328350 Null ->

329− (One, "null")

351+ ( One, "null" )

330352

331353 Json json ->

332354 ( One, Json.encodeUgly json )

@@ -334,111 +356,90 @@ fromExpr indent grouping expression =

334356 Array exprs ->

335357 (,) Many $

336358 let

337− (anyMany, builders) =

338− linesMap (fromExpr indent Whatever) exprs

359+ (anyMany, builders) = linesMap (fromExpr level Whatever) exprs

339360 in

340− if anyMany then

341− "[\n"

342− <> deeper indent

343− <> commaNewlineSep indent builders

344− <> "\n" <> indent <> "]"

345−

346− else

347− "[" <> commaSep builders <> "]"

361+ if anyMany then

362+ "[\n"

363+ <> deeperIndent

364+ <> commaNewlineSep level builders

365+ <> "\n" <> indent <> "]"

366+ else

367+ "[" <> commaSep builders <> "]"

348368

349369 Object fields ->

350370 (,) Many $

351371 let

352− deeperIndent =

353− deeper indent

354−

355− (anyMany, builders) =

356− linesMap (fromField deeperIndent) fields

372+ (anyMany, builders) = linesMap (fromField nextLevel) fields

357373 in

358− if anyMany then

359− "{\n"

360− <> deeperIndent

361− <> commaNewlineSep indent builders

362− <> "\n" <> indent <> "}"

363−

364− else

365− "{" <> commaSep builders <> "}"

374+ if anyMany then

375+ "{\n"

376+ <> deeperIndent

377+ <> commaNewlineSep level builders

378+ <> "\n" <> indent <> "}"

379+ else

380+ "{" <> commaSep builders <> "}"

366381

367382 Ref name ->

368− (One, Name.toBuilder name)

383+ ( One, Name.toBuilder name )

369384

370385 Access expr field ->

371− makeDot indent expr field

386+ makeDot level expr field

372387

373388 Index expr bracketedExpr ->

374− makeBracketed indent expr bracketedExpr

389+ makeBracketed level expr bracketedExpr

375390

376391 Prefix op expr ->

377392 let

378− (lines, builder) =

379− fromExpr indent Atomic expr

393+ (lines, builder) = fromExpr level Atomic expr

380394 in

381− ( lines

382− , parensFor grouping (fromPrefix op <> builder)

383− )

395+ ( lines

396+ , parensFor grouping (fromPrefix op <> builder)

397+ )

384398

385399 Infix op leftExpr rightExpr ->

386400 let

387− (leftLines, left) =

388− fromExpr indent Atomic leftExpr

389−

390− (rightLines, right) =

391− fromExpr indent Atomic rightExpr

401+ (leftLines , left ) = fromExpr level Atomic leftExpr

402+ (rightLines, right) = fromExpr level Atomic rightExpr

392403 in

393− ( merge leftLines rightLines

394− , parensFor grouping (left <> fromInfix op <> right)

395− )

404+ ( merge leftLines rightLines

405+ , parensFor grouping (left <> fromInfix op <> right)

406+ )

396407

397408 If condExpr thenExpr elseExpr ->

398409 let

399− condB = snd (fromExpr indent Atomic condExpr)

400− thenB = snd (fromExpr indent Atomic thenExpr)

401− elseB = snd (fromExpr indent Atomic elseExpr)

410+ condB = snd (fromExpr level Atomic condExpr)

411+ thenB = snd (fromExpr level Atomic thenExpr)

412+ elseB = snd (fromExpr level Atomic elseExpr)

402413 in

403− ( Many

404− , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

405− )

414+ ( Many

415+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

416+ )

406417

407418 Assign lValue expr ->

408419 let

409− (leftLines, left) =

410− fromLValue indent lValue

411−

412− (rightLines, right) =

413− fromExpr indent Whatever expr

420+ (leftLines , left ) = fromLValue level lValue

421+ (rightLines, right) = fromExpr level Whatever expr

414422 in

415− ( merge leftLines rightLines

416− , parensFor grouping (left <> " = " <> right)

417− )

423+ ( merge leftLines rightLines

424+ , parensFor grouping (left <> " = " <> right)

425+ )

418426

419427 Call function args ->

420428 (,) Many $

421429 let

422− deeperIndent =

423− deeper indent

424−

425− funcB =

426− snd (fromExpr indent Atomic function)

427−

428− (anyMany, argsB) =

429− linesMap (fromExpr deeperIndent Whatever) args

430+ (_ , funcB) = fromExpr level Atomic function

431+ (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args

430432 in

431− if anyMany then

432− funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"

433−

434− else

435− funcB <> "(" <> commaSep argsB <> ")"

433+ if anyMany then

434+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"

435+ else

436+ funcB <> "(" <> commaSep argsB <> ")"

436437

437438 Function maybeName args stmts ->

438439 (,) Many $

439440 "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"

440441 <>

441− fromStmtBlock (deeper indent) stmts

442+ fromStmtBlock nextLevel stmts

442443 <>

443444 indent <> "}"

444445

@@ -447,55 +448,50 @@ fromExpr indent grouping expression =

447448-- FIELDS

448449

449450

450−fromField :: Builder -> (Name, Expr) -> (Lines, Builder)

451−fromField indent (field, expr) =

451+fromField :: Level -> (Name, Expr) -> (Lines, Builder)

452+fromField level (field, expr) =

452453 let

453− (lines, builder) =

454− fromExpr indent Whatever expr

454+ (lines, builder) = fromExpr level 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 :: Builder -> LValue -> (Lines, Builder)

466−fromLValue indent lValue =

465+fromLValue :: Level -> LValue -> (Lines, Builder)

466+fromLValue level lValue =

467467 case lValue of

468468 LRef name ->

469469 (One, Name.toBuilder name)

470470

471471 LDot expr field ->

472− makeDot indent expr field

472+ makeDot level expr field

473473

474474 LBracket expr bracketedExpr ->

475− makeBracketed indent expr bracketedExpr

475+ makeBracketed level expr bracketedExpr

476476

477477

478−makeDot :: Builder -> Expr -> Name -> (Lines, Builder)

479−makeDot indent expr field =

478+makeDot :: Level -> Expr -> Name -> (Lines, Builder)

479+makeDot level expr field =

480480 let

481− (lines, builder) =

482− fromExpr indent Atomic expr

481+ (lines, builder) = fromExpr level Atomic expr

483482 in

484− (lines, builder <> "." <> Name.toBuilder field)

483+ (lines, builder <> "." <> Name.toBuilder field)

485484

486485

487−makeBracketed :: Builder -> Expr -> Expr -> (Lines, Builder)

488−makeBracketed indent expr bracketedExpr =

486+makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)

487+makeBracketed level expr bracketedExpr =

489488 let

490− (lines, builder) =

491− fromExpr indent Atomic expr

492−

493− (bracketedLines, bracketedBuilder) =

494− fromExpr indent Whatever bracketedExpr

489+ (lines , builder ) = fromExpr level Atomic expr

490+ (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr

495491 in

496− ( merge lines bracketedLines

497− , builder <> "[" <> bracketedBuilder <> "]"

498− )

492+ ( merge lines bracketedLines

493+ , builder <> "[" <> bracketedBuilder <> "]"

494+ )

499495

500496

501497

@@ -505,36 +501,30 @@ makeBracketed indent expr bracketedExpr =

505501fromPrefix :: PrefixOp -> Builder

506502fromPrefix op =

507503 case op of

508− PrefixLNot -> "!"

509− PrefixBNot -> "~"

510− PrefixPlus -> "+"

511− PrefixMinus -> "-"

512− PrefixTypeof -> "typeof "

504+ PrefixNot -> "!"

505+ PrefixNegate -> "-"

506+ PrefixComplement -> "~"

513507

514508

515509fromInfix :: InfixOp -> Builder

516510fromInfix op =

517511 case op of

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

512+ OpAdd -> " + "

513+ OpSub -> " - "

530514 OpMul -> " * "

531515 OpDiv -> " / "

532516 OpMod -> " % "

533− OpSub -> " - "

517+ OpEq -> " === "

518+ OpNe -> " !== "

519+ OpLt -> " < "

520+ OpLe -> " <= "

521+ OpGt -> " > "

522+ OpGe -> " >= "

523+ OpAnd -> " && "

524+ OpOr -> " || "

525+ OpBitwiseAnd -> " & "

526+ OpBitwiseXor -> " ^ "

527+ OpBitwiseOr -> " | "

534528 OpLShift -> " << "

535529 OpSpRShift -> " >> "

536530 OpZfRShift -> " >>> "

537− OpBAnd -> " & "

538− OpBXor -> " ^ "

539− OpBOr -> " | "

540− OpAdd -> " + "

compiler/src/Generate/JavaScript/Expression.hs+46−45

@@ -22,6 +22,7 @@ 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

2526import qualified Data.Index as Index

2627import qualified Elm.Compiler.Type as Type

2728import qualified Elm.Compiler.Type.Extract as Extract

@@ -32,6 +33,7 @@ import qualified Generate.JavaScript.Builder as JS

3233import qualified Generate.JavaScript.Name as JsName

3334import qualified Generate.Mode as Mode

3435import qualified Json.Encode as Encode

36+import Json.Encode ((==>))

3537import qualified Optimize.DecisionTree as DT

3638import qualified Reporting.Annotation as A

3739

@@ -128,8 +130,7 @@ generate mode expression =

128130

129131 Opt.Destruct (Opt.Destructor name path) body ->

130132 let

131− pathExpr = generatePath mode path

132− pathDef = JS.Var [ (JsName.fromLocal name, Just pathExpr) ]

133+ pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path)

133134 in

134135 JsBlock $ pathDef : codeToStmtList (generate mode body)

135136

@@ -138,7 +139,7 @@ generate mode expression =

138139

139140 Opt.Accessor field ->

140141 JsExpr $ JS.Function Nothing [JsName.dollar]

141− [ JS.Return $ Just $

142+ [ JS.Return $

142143 JS.Access (JS.Ref JsName.dollar) (generateField mode field)

143144 ]

144145

@@ -190,7 +191,7 @@ generate mode expression =

190191 JS.Object (map toTranlation (Set.toList fields))

191192 in

192193 JsExpr $ JS.Object $

193− [ ( JsName.fromLocal "src", JS.String (Utf8.toBuilder src) )

194+ [ ( JsName.fromLocal "src", JS.String (Shader.toJsStringBuilder src) )

194195 , ( JsName.fromLocal "attributes", toTranslationObject attributes )

195196 , ( JsName.fromLocal "uniforms", toTranslationObject uniforms )

196197 ]

@@ -211,7 +212,7 @@ codeToExpr code =

211212 JsExpr expr ->

212213 expr

213214

214− JsBlock [ JS.Return (Just expr) ] ->

215+ JsBlock [ JS.Return expr ] ->

215216 expr

216217

217218 JsBlock stmts ->

@@ -225,7 +226,7 @@ codeToStmtList code =

225226 stmts

226227

227228 JsExpr expr ->

228− [ JS.Return (Just expr) ]

229+ [ JS.Return expr ]

229230

230231 JsBlock stmts ->

231232 stmts

@@ -238,7 +239,7 @@ codeToStmt code =

238239 JS.Block stmts

239240

240241 JsExpr expr ->

241− JS.Return (Just expr)

242+ JS.Return expr

242243

243244 JsBlock [stmt] ->

244245 stmt

@@ -482,17 +483,17 @@ generateBitwiseCall home name args =

482483 case args of

483484 [arg] ->

484485 case name of

485− "complement" -> JS.Prefix JS.PrefixBNot arg

486+ "complement" -> JS.Prefix JS.PrefixComplement arg

486487 _ -> generateGlobalCall home name args

487488

488489 [left,right] ->

489490 case name of

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

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

496497 _ -> generateGlobalCall home name args

497498

498499 _ ->

@@ -505,10 +506,10 @@ generateBasicsCall mode home name args =

505506 [elmArg] ->

506507 let arg = generateJsExpr mode elmArg in

507508 case name of

508− "not" -> JS.Prefix JS.PrefixLNot arg

509− "negate" -> JS.Prefix JS.PrefixMinus arg

509+ "not" -> JS.Prefix JS.PrefixNot arg

510+ "negate" -> JS.Prefix JS.PrefixNegate arg

510511 "toFloat" -> arg

511− "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)

512+ "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0)

512513 _ -> generateGlobalCall home name [arg]

513514

514515 [elmLeft, elmRight] ->

@@ -528,16 +529,16 @@ generateBasicsCall mode home name args =

528529 "sub" -> JS.Infix JS.OpSub left right

529530 "mul" -> JS.Infix JS.OpMul left right

530531 "fdiv" -> JS.Infix JS.OpDiv left right

531− "idiv" -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

532+ "idiv" -> JS.Infix JS.OpBitwiseOr (JS.Infix JS.OpDiv left right) (JS.Int 0)

532533 "eq" -> equal left right

533534 "neq" -> notEqual 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

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

541542 "remainderBy" -> JS.Infix JS.OpMod right left

542543 _ -> generateGlobalCall home name [left, right]

543544

@@ -558,7 +559,7 @@ notEqual left right =

558559 if isLiteral left || isLiteral right then

559560 strictNEq left right

560561 else

561− JS.Prefix JS.PrefixLNot $

562+ JS.Prefix JS.PrefixNot $

562563 JS.Call (JS.Ref (JsName.fromKernel Name.utils "eq")) [left, right]

563564

564565

@@ -647,42 +648,42 @@ strictEq :: JS.Expr -> JS.Expr -> JS.Expr

647648strictEq left right =

648649 case left of

649650 JS.Int 0 ->

650− JS.Prefix JS.PrefixLNot right

651+ JS.Prefix JS.PrefixNot right

651652

652653 JS.Bool bool ->

653− if bool then right else JS.Prefix JS.PrefixLNot right

654+ if bool then right else JS.Prefix JS.PrefixNot right

654655

655656 _ ->

656657 case right of

657658 JS.Int 0 ->

658− JS.Prefix JS.PrefixLNot left

659+ JS.Prefix JS.PrefixNot left

659660

660661 JS.Bool bool ->

661− if bool then left else JS.Prefix JS.PrefixLNot left

662+ if bool then left else JS.Prefix JS.PrefixNot left

662663

663664 _ ->

664− JS.Infix JS.OpStrictEq left right

665+ JS.Infix JS.OpEq left right

665666

666667

667668strictNEq :: JS.Expr -> JS.Expr -> JS.Expr

668669strictNEq left right =

669670 case left of

670671 JS.Int 0 ->

671− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot right)

672+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot right)

672673

673674 JS.Bool bool ->

674− if bool then JS.Prefix JS.PrefixLNot right else right

675+ if bool then JS.Prefix JS.PrefixNot right else right

675676

676677 _ ->

677678 case right of

678679 JS.Int 0 ->

679− JS.Prefix JS.PrefixLNot (JS.Prefix JS.PrefixLNot left)

680+ JS.Prefix JS.PrefixNot (JS.Prefix JS.PrefixNot left)

680681

681682 JS.Bool bool ->

682− if bool then JS.Prefix JS.PrefixLNot left else left

683+ if bool then JS.Prefix JS.PrefixNot left else left

683684

684685 _ ->

685− JS.Infix JS.OpStrictNEq left right

686+ JS.Infix JS.OpNe left right

686687

687688

688689

@@ -695,13 +696,13 @@ generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stm

695696generateTailCall mode name args =

696697 let

697698 toTempVars (argName, arg) =

698− ( JsName.makeTemp argName, Just (generateJsExpr mode arg) )

699+ ( JsName.makeTemp argName, generateJsExpr mode arg )

699700

700701 toRealVars (argName, _) =

701702 JS.ExprStmt $

702703 JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))

703704 in

704− JS.Var (map toTempVars args)

705+ JS.Vars (map toTempVars args)

705706 : map toRealVars args

706707 ++ [ JS.Continue (Just (JsName.fromLocal name)) ]

707708

@@ -714,10 +715,10 @@ generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt

714715generateDef mode def =

715716 case def of

716717 Opt.Def name body ->

717− JS.Var [ (JsName.fromLocal name, Just (generateJsExpr mode body)) ]

718+ JS.Var (JsName.fromLocal name) (generateJsExpr mode body)

718719

719720 Opt.TailDef name argNames body ->

720− JS.Var [ (JsName.fromLocal name, Just (codeToExpr (generateTailDef mode name argNames body))) ]

721+ JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body))

721722

722723

723724generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code

@@ -850,7 +851,7 @@ generateDecider mode label root decisionTree =

850851

851852 Opt.Chain testChain success failure ->

852853 [ JS.IfStmt

853− (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))

854+ (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain))

854855 (JS.Block $ generateDecider mode label root success)

855856 (JS.Block $ generateDecider mode label root failure)

856857 ]

@@ -892,7 +893,7 @@ generateIfTest mode root (path, test) =

892893 value

893894

894895 DT.IsBool False ->

895− JS.Prefix JS.PrefixLNot value

896+ JS.Prefix JS.PrefixNot value

896897

897898 DT.IsInt int ->

898899 strictEq value (JS.Int int)

@@ -910,7 +911,7 @@ generateIfTest mode root (path, test) =

910911 JS.Access value (JsName.fromLocal "b")

911912

912913 DT.IsNil ->

913− JS.Prefix JS.PrefixLNot $

914+ JS.Prefix JS.PrefixNot $

914915 JS.Access value (JsName.fromLocal "b")

915916

916917 DT.IsTuple ->

@@ -1064,6 +1065,6 @@ toDebugMetadata mode msgType =

10641065

10651066 Mode.Dev (Just interfaces) ->

10661067 JS.Json $ Encode.object $

1067− [ ("versions", Encode.object [ ("elm", V.encode V.compiler) ])

1068− , ("types", Type.encodeMetadata (Extract.fromMsg interfaces msgType))

1068+ [ "versions" ==> Encode.object [ "elm" ==> V.encode V.compiler ]

1069+ , "types" ==> Type.encodeMetadata (Extract.fromMsg interfaces msgType)

10691070 ]

compiler/src/Generate/JavaScript/Functions.hs+2−3

@@ -1,6 +1,5 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−module Generate.Functions

1+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}

2+module Generate.JavaScript.Functions

43 ( functions

54 )

65 where

compiler/src/Generate/JavaScript/Name.hs+22−12

@@ -62,19 +62,13 @@ fromLocal name =

6262

6363

6464fromGlobal :: ModuleName.Canonical -> Name.Name -> 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

65+fromGlobal home name =

66+ Name $ homeToBuilder home <> usd <> Name.toBuilder name

7067

7168

7269fromCycle :: ModuleName.Canonical -> Name.Name -> 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

70+fromCycle home name =

71+ Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name

7872

7973

8074fromKernel :: Name.Name -> Name.Name -> Name

@@ -82,6 +76,17 @@ fromKernel home name =

8276 Name ("_" <> Name.toBuilder home <> "_" <> Name.toBuilder name)

8377

8478

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+

8590

8691-- TEMPORARY NAMES

8792

@@ -98,7 +103,7 @@ makeA n =

98103

99104makeLabel :: Name.Name -> Int -> Name

100105makeLabel name index =

101− Name (Name.toBuilder name <> "$" <> B.intDec index)

106+ Name (Name.toBuilder name <> usd <> B.intDec index)

102107

103108

104109makeTemp :: Name.Name -> Name

@@ -108,7 +113,12 @@ makeTemp name =

108113

109114dollar :: Name

110115dollar =

111− Name (Name.toBuilder Name.dollar)

116+ Name usd

117+

118+

119+usd :: B.Builder

120+usd =

121+ Name.toBuilder Name.dollar

112122

113123

114124

compiler/src/Generate/Mode.hs+2−3

@@ -41,15 +41,14 @@ type ShortFieldNames =

4141 Map.Map Name.Name JsName.Name

4242

4343

44−shortenFieldNames :: Opt.Graph -> ShortFieldNames

45−shortenFieldNames (Opt.Graph _ _ frequencies) =

44+shortenFieldNames :: Opt.GlobalGraph -> ShortFieldNames

45+shortenFieldNames (Opt.GlobalGraph _ frequencies) =

4646 Map.foldr addToShortNames Map.empty $

4747 Map.foldrWithKey addToBuckets Map.empty frequencies

4848

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

5352 Map.insertWith (++) frequency [field] buckets

5453

5554

compiler/src/Json/Decode.hs+333−180

@@ -2,69 +2,112 @@

22{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, UnboxedTuples #-}

33module Json.Decode

44 ( fromByteString

5− , fromFile

65 , Decoder

76 , string

7+ , customString

88 , bool

99 , int

10− , list, pair

11− , dict, pairs, field

10+ , list

11+ , nonEmptyList

12+ , pair

13+ --

14+ , KeyDecoder(..)

15+ , dict

16+ , pairs

17+ , field

18+ --

1219 , oneOf

1320 , failure

1421 , mapError

22+ --

23+ , Error(..)

24+ , Problem(..)

25+ , DecodeExpectation(..)

26+ , ParseError(..)

27+ , StringProblem(..)

1528 )

1629 where

1730

1831

19−import qualified Data.ByteString as B

20−import qualified Data.List as List

32+import qualified Data.ByteString.Internal as B

2133import qualified Data.Map as Map

22−import qualified Data.Utf8 as Utf8

23−import Data.Word (Word8, Word16)

34+import qualified Data.NonEmptyList as NE

35+import Data.Word (Word8)

2436import Foreign.Ptr (Ptr, plusPtr, minusPtr)

37+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

2538

39+import qualified Json.String as Json

2640import qualified Parse.Keyword as K

2741import qualified Parse.Primitives as P

28−import qualified Reporting.Error.Json as E

42+import Parse.Primitives (Row, Col)

43+import qualified Reporting.Annotation as A

2944

3045

3146

3247-- RUNNERS

3348

3449

35−fromByteString :: Decoder e a -> B.ByteString -> Either (E.Error e) a

36−fromByteString decoder src =

37− fromAST decoder (P.fromByteString pFile src)

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)

3855

56+ Left problem ->

57+ Left (ParseProblem src problem)

3958

40−fromFile :: Decoder e a -> FilePath -> IO (Either (E.Error e) a)

41−fromFile decoder path =

42− fromAST decoder <$> P.fromFile pFile path

4359

4460

45−fromAST :: Decoder e a -> P.Result E.Context E.ParseExpectation AST -> Either (E.Error e) a

46−fromAST (Decoder decode) parserResult =

47− case parserResult of

48− P.Ok ast _ ->

49− decode ast Right (Left . E.DecodeProblem)

61+-- DECODERS

5062

51− P.Err row col ctx expectation ->

52− Left (E.ParseProblem row col ctx expectation)

5363

64+newtype Decoder x a =

65+ Decoder

66+ (

67+ forall b.

68+ AST

69+ -> (a -> b)

70+ -> (Problem x -> b)

71+ -> b

72+ )

5473

5574

56−-- DECODERS

75+

76+-- ERRORS

77+

78+

79+data Error x

80+ = DecodeProblem B.ByteString (Problem x)

81+ | ParseProblem B.ByteString ParseError

82+

83+

84+

85+-- DECODE PROBLEMS

5786

5887

59−newtype Decoder e a =

60− Decoder (forall b. AST -> (a -> b) -> (E.Problem e -> b) -> b)

88+data Problem x

89+ = Field B.ByteString (Problem x)

90+ | Index Int (Problem x)

91+ | OneOf (Problem x) [Problem x]

92+ | Failure A.Region x

93+ | Expecting A.Region DecodeExpectation

94+

95+

96+data DecodeExpectation

97+ = TObject

98+ | TArray

99+ | TString

100+ | TBool

101+ | TInt

102+ | TObjectWith B.ByteString

103+ | TArrayPair Int

61104

62105

63106

64107-- INSTANCES

65108

66109

67−instance Functor (Decoder e) where

110+instance Functor (Decoder x) where

68111 {-# INLINE fmap #-}

69112 fmap func (Decoder decodeA) =

70113 Decoder $ \ast ok err ->

@@ -74,7 +117,7 @@ instance Functor (Decoder e) where

74117 decodeA ast ok' err

75118

76119

77−instance Applicative (Decoder e) where

120+instance Applicative (Decoder x) where

78121 {-# INLINE pure #-}

79122 pure = return

80123

@@ -91,7 +134,7 @@ instance Applicative (Decoder e) where

91134 decodeFunc ast okF err

92135

93136

94−instance Monad (Decoder e) where

137+instance Monad (Decoder x) where

95138 {-# INLINE return #-}

96139 return a =

97140 Decoder $ \_ ok _ ->

@@ -112,24 +155,37 @@ instance Monad (Decoder e) where

112155-- STRINGS

113156

114157

115−string :: Decoder e Utf8.String

158+string :: Decoder x Json.String

116159string =

117− Decoder $ \ast ok err ->

160+ Decoder $ \(A.At region ast) ok err ->

118161 case ast of

119− String bits ->

120− ok bits

162+ String snippet ->

163+ ok (Json.fromSnippet snippet)

121164

122165 _ ->

123− err (E.Expecting E.TString)

166+ err (Expecting region TString)

167+

168+

169+customString :: P.Parser x a -> (Row -> Col -> x) -> Decoder x a

170+customString parser toBadEnd =

171+ Decoder $ \(A.At region ast) ok err ->

172+ case ast of

173+ String snippet ->

174+ case P.fromSnippet parser toBadEnd snippet of

175+ Right a -> ok a

176+ Left x -> err (Failure region x)

177+

178+ _ ->

179+ err (Expecting region TString)

124180

125181

126182

127183-- BOOL

128184

129185

130−bool :: Decoder e Bool

186+bool :: Decoder x Bool

131187bool =

132− Decoder $ \ast ok err ->

188+ Decoder $ \(A.At region ast) ok err ->

133189 case ast of

134190 TRUE ->

135191 ok True

@@ -138,40 +194,40 @@ bool =

138194 ok False

139195

140196 _ ->

141− err (E.Expecting E.TBool)

197+ err (Expecting region TBool)

142198

143199

144200

145201-- INT

146202

147203

148−int :: Decoder e Int

204+int :: Decoder x Int

149205int =

150− Decoder $ \ast ok err ->

206+ Decoder $ \(A.At region ast) ok err ->

151207 case ast of

152208 Int n ->

153209 ok n

154210

155211 _ ->

156− err (E.Expecting E.TInt)

212+ err (Expecting region TInt)

157213

158214

159215

160−-- ARRAYS

216+-- LISTS

161217

162218

163−list :: Decoder e a -> Decoder e [a]

219+list :: Decoder x a -> Decoder x [a]

164220list decoder =

165− Decoder $ \ast ok err ->

221+ Decoder $ \(A.At region ast) ok err ->

166222 case ast of

167223 Array asts ->

168224 listHelp decoder ok err 0 asts []

169225

170226 _ ->

171− err (E.Expecting E.TArray)

227+ err (Expecting region TArray)

172228

173229

174−listHelp :: Decoder e a -> ([a] -> b) -> (E.Problem e -> b) -> Int -> [AST] -> [a] -> b

230+listHelp :: Decoder x a -> ([a] -> b) -> (Problem x -> b) -> Int -> [AST] -> [a] -> b

175231listHelp decoder@(Decoder decodeA) ok err !i asts revs =

176232 case asts of

177233 [] ->

@@ -179,24 +235,40 @@ listHelp decoder@(Decoder decodeA) ok err !i asts revs =

179235

180236 ast:asts ->

181237 let

182− ok' a = listHelp decoder ok err (i+1) asts (a:revs)

183− err' e = err (E.Index i e)

238+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)

239+ err' prob = err (Index i prob)

184240 in

185241 decodeA ast ok' err'

186242

187243

188−pair :: Decoder e a -> Decoder e b -> Decoder e (a,b)

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)

189261pair (Decoder decodeA) (Decoder decodeB) =

190− Decoder $ \ast ok err ->

262+ Decoder $ \(A.At region ast) ok err ->

191263 case ast of

192264 Array vs ->

193265 case vs of

194266 [astA,astB] ->

195267 let

196− err0 e = err (E.Index 0 e)

268+ err0 e = err (Index 0 e)

197269 ok0 a =

198270 let

199− err1 e = err (E.Index 1 e)

271+ err1 e = err (Index 1 e)

200272 ok1 b = ok (a,b)

201273 in

202274 decodeB astB ok1 err1

@@ -204,70 +276,103 @@ pair (Decoder decodeA) (Decoder decodeB) =

204276 decodeA astA ok0 err0

205277

206278 _ ->

207− err (E.Expecting (E.TArrayPair (length vs)))

279+ err (Expecting region (TArrayPair (length vs)))

208280

209281 _ ->

210− err (E.Expecting E.TArray)

282+ err (Expecting region TArray)

211283

212284

213285

214−-- OBJECT

286+-- OBJECTS

215287

216288

217−dict :: Decoder e a -> Decoder e (Map.Map Utf8.String a)

218−dict decoder =

219− Map.fromList <$> pairs decoder

289+data KeyDecoder x a =

290+ KeyDecoder (P.Parser x a) (Row -> Col -> x)

220291

221292

222−pairs :: Decoder e a -> Decoder e [(Utf8.String, a)]

223−pairs decoder =

224− Decoder $ \ast ok err ->

293+dict :: (Ord k) => KeyDecoder x k -> Decoder x a -> Decoder x (Map.Map k a)

294+dict keyDecoder valueDecoder =

295+ Map.fromList <$> pairs keyDecoder valueDecoder

296+

297+

298+pairs :: KeyDecoder x k -> Decoder x a -> Decoder x [(k, a)]

299+pairs keyDecoder valueDecoder =

300+ Decoder $ \(A.At region ast) ok err ->

225301 case ast of

226302 Object kvs ->

227− pairsHelp decoder ok err kvs []

303+ pairsHelp keyDecoder valueDecoder ok err kvs []

228304

229305 _ ->

230− err (E.Expecting E.TObject)

306+ err (Expecting region TObject)

231307

232308

233−pairsHelp :: Decoder e a -> ([(Utf8.String, a)] -> b) -> (E.Problem e -> b) -> [(Utf8.String, AST)] -> [(Utf8.String, a)] -> b

234−pairsHelp decoder@(Decoder decodeA) ok err kvs revs =

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 =

235311 case kvs of

236312 [] ->

237313 ok (reverse revs)

238314

239− (key, ast) : kvs ->

240− let

241− ok' a = pairsHelp decoder ok err kvs ((key,a):revs)

242− err' e = err (E.Field key e)

243− in

244− decodeA ast ok' err'

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+

245334

246335

247−field :: Utf8.String -> Decoder e a -> Decoder e a

336+-- FIELDS

337+

338+

339+field :: B.ByteString -> Decoder x a -> Decoder x a

248340field key (Decoder decodeA) =

249− Decoder $ \ast ok err ->

341+ Decoder $ \(A.At region ast) ok err ->

250342 case ast of

251343 Object kvs ->

252− case List.lookup key kvs of

253− Just v ->

344+ case findField key kvs of

345+ Just value ->

254346 let

255− err' e = err (E.Field key e)

347+ err' prob =

348+ err (Field key prob)

256349 in

257− decodeA v ok err'

350+ decodeA value ok err'

258351

259352 Nothing ->

260− err (E.Expecting (E.TObjectWith key))

353+ err (Expecting region (TObjectWith key))

261354

262355 _ ->

263− err (E.Expecting E.TObject)

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

264369

265370

266371

267372-- ONE OF

268373

269374

270−oneOf :: [Decoder e a] -> Decoder e a

375+oneOf :: [Decoder x a] -> Decoder x a

271376oneOf decoders =

272377 Decoder $ \ast ok err ->

273378 case decoders of

@@ -282,71 +387,75 @@ oneOf decoders =

282387 error "Ran into (Json.Decode.oneOf [])"

283388

284389

285−oneOfHelp :: AST -> (a -> b) -> (E.Problem e -> b) -> [Decoder e a] -> E.Problem e -> [E.Problem e] -> b

286−oneOfHelp ast ok err decoders e es =

390+oneOfHelp :: AST -> (a -> b) -> (Problem x -> b) -> [Decoder x a] -> Problem x -> [Problem x] -> b

391+oneOfHelp ast ok err decoders p ps =

287392 case decoders of

288393 Decoder decodeA : decoders ->

289394 let

290− err' e' =

291− oneOfHelp ast ok err decoders e' (e:es)

395+ err' p' =

396+ oneOfHelp ast ok err decoders p' (p:ps)

292397 in

293398 decodeA ast ok err'

294399

295400 [] ->

296− err (oneOfError [] e es)

401+ err (oneOfError [] p ps)

297402

298403

299−oneOfError :: [E.Problem e] -> E.Problem e -> [E.Problem e] -> E.Problem e

300−oneOfError errors err es =

301− case es of

404+oneOfError :: [Problem x] -> Problem x -> [Problem x] -> Problem x

405+oneOfError problems prob ps =

406+ case ps of

302407 [] ->

303− E.OneOf err errors

408+ OneOf prob problems

304409

305− e:es ->

306− oneOfError (err:errors) e es

410+ p:ps ->

411+ oneOfError (prob:problems) p ps

307412

308413

309414

310415-- FAILURE

311416

312417

313−failure :: e -> Decoder e a

314−failure e =

315− Decoder $ \_ _ err ->

316− err (E.Failure e)

418+failure :: x -> Decoder x a

419+failure x =

420+ Decoder $ \(A.At region _) _ err ->

421+ err (Failure region x)

317422

318423

319424

320425-- ERRORS

321426

322427

323−mapError :: (e -> e') -> Decoder e a -> Decoder e' a

428+mapError :: (x -> y) -> Decoder x a -> Decoder y a

324429mapError func (Decoder decodeA) =

325430 Decoder $ \ast ok err ->

326431 let

327− err' e = err (mapErrorHelp func e)

432+ err' prob = err (mapErrorHelp func prob)

328433 in

329434 decodeA ast ok err'

330435

331436

332−mapErrorHelp :: (e -> e') -> E.Problem e -> E.Problem e'

333−mapErrorHelp func err =

334− case err of

335− E.Field k e -> E.Field k (mapErrorHelp func e)

336− E.Index i e -> E.Index i (mapErrorHelp func e)

337− E.OneOf e es -> E.OneOf (mapErrorHelp func e) (map (mapErrorHelp func) es)

338− E.Failure e -> E.Failure (func e)

339− E.Expecting e -> E.Expecting e

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

340445

341446

342447

343448-- AST

344449

345450

346−data AST

451+type AST =

452+ A.Located AST_

453+

454+

455+data AST_

347456 = Array [AST]

348− | Object [(Utf8.String, AST)]

349− | String Utf8.String

457+ | Object [(P.Snippet, AST)]

458+ | String P.Snippet

350459 | Int Int

351460 | TRUE

352461 | FALSE

@@ -358,7 +467,33 @@ data AST

358467

359468

360469type Parser a =

361− P.Parser E.Context E.ParseExpectation 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

362497

363498

364499pFile :: Parser AST

@@ -366,69 +501,60 @@ pFile =

366501 do spaces

367502 value <- pValue

368503 spaces

369− endOfFile

370504 return value

371505

372506

373507pValue :: Parser AST

374508pValue =

375− P.oneOf E.Value

376− [ fmap String pString

509+ P.addLocation $

510+ P.oneOf Start

511+ [ String <$> pString Start

377512 , pObject

378513 , pArray

379514 , pInt

380− , K.k4 0x74 0x72 0x75 0x65 E.Bool >> return TRUE

381− , K.k5 0x66 0x61 0x6C 0x73 0x65 E.Bool >> return FALSE

382− , K.k4 0x6E 0x75 0x6C 0x6C E.Null >> return NULL

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

383518 ]

384519

385520

386−endOfFile :: Parser ()

387−endOfFile =

388− P.Parser $ \state@(P.State pos end _ row col ctx) _ eok _ eerr ->

389− if pos < end then

390− eerr row col ctx E.EndOfFile

391− else

392− eok () state

393−

394−

395521

396522-- OBJECT

397523

398524

399−pObject :: Parser AST

525+pObject :: Parser AST_

400526pObject =

401− do P.word1 0x7B {- { -} E.ObjectStart

527+ do P.word1 0x7B {- { -} Start

402528 spaces

403− P.oneOf E.ObjectMore

529+ P.oneOf ObjectField

404530 [ do entry <- pField

405531 spaces

406532 pObjectHelp [entry]

407− , do P.word1 0x7D {-}-} E.ObjectEnd

533+ , do P.word1 0x7D {-}-} ObjectEnd

408534 return (Object [])

409535 ]

410536

411537

412−pObjectHelp :: [(Utf8.String, AST)] -> Parser AST

538+pObjectHelp :: [(P.Snippet, AST)] -> Parser AST_

413539pObjectHelp revEntries =

414− P.oneOf E.ObjectMore

540+ P.oneOf ObjectEnd

415541 [

416− do P.word1 0x2C {-,-} E.ObjectMore

542+ do P.word1 0x2C {-,-} ObjectEnd

417543 spaces

418544 entry <- pField

419545 spaces

420546 pObjectHelp (entry:revEntries)

421547 ,

422− do P.word1 0x7D {-}-} E.ObjectEnd

548+ do P.word1 0x7D {-}-} ObjectEnd

423549 return (Object (reverse revEntries))

424550 ]

425551

426552

427−pField :: Parser (Utf8.String, AST)

553+pField :: Parser (P.Snippet, AST)

428554pField =

429− do key <- pString

555+ do key <- pString ObjectField

430556 spaces

431− P.word1 0x3A {-:-} E.Colon

557+ P.word1 0x3A {-:-} ObjectColon

432558 spaces

433559 value <- pValue

434560 return (key, value)

@@ -438,30 +564,30 @@ pField =

438564-- ARRAY

439565

440566

441−pArray :: Parser AST

567+pArray :: Parser AST_

442568pArray =

443− do P.word1 0x5B {-[-} E.ArrayStart

569+ do P.word1 0x5B {-[-} Start

444570 spaces

445− P.oneOf E.ArrayMore

571+ P.oneOf Start

446572 [ do entry <- pValue

447573 spaces

448574 pArrayHelp 1 [entry]

449− , do P.word1 0x5D {-]-} E.ArrayEnd

575+ , do P.word1 0x5D {-]-} ArrayEnd

450576 return (Array [])

451577 ]

452578

453579

454−pArrayHelp :: Int -> [AST] -> Parser AST

580+pArrayHelp :: Int -> [AST] -> Parser AST_

455581pArrayHelp !len revEntries =

456− P.oneOf E.ArrayMore

582+ P.oneOf ArrayEnd

457583 [

458− do P.word1 0x2C {-,-} E.ArrayMore

584+ do P.word1 0x2C {-,-} ArrayEnd

459585 spaces

460586 entry <- pValue

461587 spaces

462588 pArrayHelp (len + 1) (entry:revEntries)

463589 ,

464− do P.word1 0x5D {-]-} E.ArrayEnd

590+ do P.word1 0x5D {-]-} ArrayEnd

465591 return (Array (reverse revEntries))

466592 ]

467593

@@ -470,41 +596,44 @@ pArrayHelp !len revEntries =

470596-- STRING

471597

472598

473−pString :: Parser Utf8.String

474−pString =

475− P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

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

476602 if pos < end && P.unsafeIndex pos == 0x22 {-"-} then

477603

478604 let

479605 !pos1 = plusPtr pos 1

606+ !col1 = col + 1

480607

481608 (# status, newPos, newRow, newCol #) =

482− pStringHelp pos1 end row (col + 1)

609+ pStringHelp pos1 end row col1

483610 in

484611 case status of

485612 GoodString ->

486613 let

487− !newState = P.State newPos end indent newRow newCol ctx

488− !content = Utf8.fromPtr pos1 (plusPtr newPos (-1))

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

489618 in

490− cok content newState

619+ cok snp newState

491620

492− BadStringEnd ->

493− cerr newRow newCol ctx E.StringEnd

621+ BadString problem ->

622+ cerr newRow newCol (StringProblem problem)

494623

495624 else

496− eerr row col ctx E.StringStart

625+ eerr row col start

497626

498627

499628data StringStatus

500629 = GoodString

501− | BadStringEnd

630+ | BadString StringProblem

502631

503632

504−pStringHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# StringStatus, Ptr Word8, Word16, Word16 #)

633+pStringHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# StringStatus, Ptr Word8, Row, Col #)

505634pStringHelp pos end row col =

506635 if pos >= end then

507− (# BadStringEnd, pos, row, col #)

636+ (# BadString BadStringEnd, pos, row, col #)

508637

509638 else

510639 case P.unsafeIndex pos of

@@ -512,26 +641,50 @@ pStringHelp pos end row col =

512641 (# GoodString, plusPtr pos 1, row, col + 1 #)

513642

514643 0x0A {-\n-} ->

515− (# BadStringEnd, pos, row, col #)

644+ (# BadString BadStringEnd, pos, row, col #)

516645

517646 0x5C {-\-} ->

518− let

519− !pos1 = plusPtr pos 1

520− in

521− if pos1 < end then

522−

523− let

524− !word = P.unsafeIndex pos1

525− !newPos = plusPtr pos1 (P.getCharWidth pos1 end word)

526− in

527− pStringHelp newPos end row (col + 2)

528−

647+ let !pos1 = plusPtr pos 1 in

648+ if pos1 >= end then

649+ (# BadString BadStringEnd, pos1, row + 1, col #)

529650 else

530− (# BadStringEnd, pos1, row + 1, col #)

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

531674

532675 word ->

533− let !newPos = plusPtr pos (P.getCharWidth pos end word) in

534− pStringHelp newPos end row (col + 1)

676+ if word < 0x20 then

677+ (# BadString BadStringControlChar, pos, row, col #)

678+ else

679+ let !newPos = plusPtr pos (P.getCharWidth word) in

680+ pStringHelp newPos end row (col + 1)

681+

682+

683+isHex :: Word8 -> Bool

684+isHex word =

685+ 0x30 {-0-} <= word && word <= 0x39 {-9-}

686+ || 0x61 {-a-} <= word && word <= 0x66 {-f-}

687+ || 0x41 {-A-} <= word && word <= 0x46 {-F-}

535688

536689

537690

@@ -540,7 +693,7 @@ pStringHelp pos end row col =

540693

541694spaces :: Parser ()

542695spaces =

543− P.Parser $ \state@(P.State pos end indent row col ctx) cok eok _ _ ->

696+ P.Parser $ \state@(P.State src pos end indent row col) cok eok _ _ ->

544697 let

545698 (# newPos, newRow, newCol #) =

546699 eatSpaces pos end row col

@@ -550,12 +703,12 @@ spaces =

550703 else

551704 let

552705 !newState =

553− P.State newPos end indent newRow newCol ctx

706+ P.State src newPos end indent newRow newCol

554707 in

555708 cok () newState

556709

557710

558−eatSpaces :: Ptr Word8 -> Ptr Word8 -> Word16 -> Word16 -> (# Ptr Word8, Word16, Word16 #)

711+eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Ptr Word8, Row, Col #)

559712eatSpaces pos end row col =

560713 if pos >= end then

561714 (# pos, row, col #)

@@ -574,29 +727,29 @@ eatSpaces pos end row col =

574727-- INTS

575728

576729

577−pInt :: Parser AST

730+pInt :: Parser AST_

578731pInt =

579− P.Parser $ \(P.State pos end indent row col ctx) cok _ cerr eerr ->

732+ P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->

580733 if pos >= end then

581− eerr row col ctx E.IntStart

734+ eerr row col Start

582735

583736 else

584737 let !word = P.unsafeIndex pos in

585738 if not (isDecimalDigit word) then

586− eerr row col ctx E.IntStart

739+ eerr row col Start

587740

588741 else if word == 0x30 {-0-} then

589742

590743 let

591744 !pos1 = plusPtr pos 1

592− !newState = P.State pos1 end indent row (col + 1) ctx

745+ !newState = P.State src pos1 end indent row (col + 1)

593746 in

594747 if pos1 < end then

595748 let !word1 = P.unsafeIndex pos1 in

596749 if isDecimalDigit word1 then

597− cerr row (col + 1) ctx E.NoLeadingZeros

750+ cerr row (col + 1) NoLeadingZeros

598751 else if word1 == 0x2E {-.-} then

599− cerr row (col + 1) ctx E.NoFloats

752+ cerr row (col + 1) NoFloats

600753 else

601754 cok (Int 0) newState

602755 else

@@ -613,12 +766,12 @@ pInt =

613766 GoodInt ->

614767 let

615768 !newState =

616− P.State newPos end indent row (col + len) ctx

769+ P.State src newPos end indent row (col + len)

617770 in

618771 cok (Int n) newState

619772

620773 BadIntEnd ->

621− cerr row (col + len) ctx E.NoFloats

774+ cerr row (col + len) NoFloats

622775

623776

624777data IntStatus = GoodInt | BadIntEnd

compiler/src/Json/Encode.hs+41−26

@@ -10,6 +10,7 @@ module Json.Encode

1010 , object

1111 , string

1212 , name

13+ , chars

1314 , bool

1415 , int

1516 , number

@@ -30,7 +31,9 @@ import qualified Data.Scientific as Sci

3031import Data.Monoid ((<>))

3132import qualified Data.Name as Name

3233import qualified Data.Utf8 as Utf8

33−import System.IO (IOMode(WriteMode), withBinaryFile)

34+

35+import qualified File

36+import qualified Json.String as Json

3437

3538

3639

@@ -39,7 +42,7 @@ import System.IO (IOMode(WriteMode), withBinaryFile)

3942

4043data Value

4144 = Array [Value]

42− | Object [(Utf8.String, Value)]

45+ | Object [(Json.String, Value)]

4346 | String B.Builder

4447 | Boolean Bool

4548 | Integer Int

@@ -52,14 +55,14 @@ array =

5255 Array

5356

5457

55−object :: [(Utf8.String,Value)] -> Value

58+object :: [(Json.String, Value)] -> Value

5659object =

5760 Object

5861

5962

60−string :: Utf8.String -> Value

63+string :: Json.String -> Value

6164string str =

62− String (encodeUtf8 str)

65+ String (B.char7 '"' <> Json.toBuilder str <> B.char7 '"')

6366

6467

6568name :: Name.Name -> Value

@@ -87,7 +90,7 @@ null =

8790 Null

8891

8992

90−dict :: (k -> Utf8.String) -> (v -> Value) -> Map.Map k v -> Value

93+dict :: (k -> Json.String) -> (v -> Value) -> Map.Map k v -> Value

9194dict encodeKey encodeValue pairs =

9295 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)

9396

@@ -98,12 +101,35 @@ list encodeEntry entries =

98101

99102

100103

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+

101127-- HELPERS

102128

103129

104−(==>) :: a -> b -> (a, b)

105−(==>) a b =

106− (a, b)

130+(==>) :: [Char] -> value -> (Json.String, value)

131+(==>) key value =

132+ (Json.fromChars key, value)

107133

108134

109135

@@ -112,14 +138,12 @@ list encodeEntry entries =

112138

113139write :: FilePath -> Value -> IO ()

114140write path value =

115− withBinaryFile path WriteMode $ \handle ->

116− B.hPutBuilder handle (encode value <> "\n")

141+ File.writeBuilder path (encode value <> "\n")

117142

118143

119144writeUgly :: FilePath -> Value -> IO ()

120145writeUgly path value =

121− withBinaryFile path WriteMode $ \handle ->

122− B.hPutBuilder handle (encodeUgly value)

146+ File.writeBuilder path (encodeUgly value)

123147

124148

125149

@@ -145,7 +169,7 @@ encodeUgly value =

145169 Object (first : rest) ->

146170 let

147171 encodeEntry char (key, entry) =

148− B.char7 char <> encodeUtf8 key <> B.char7 ':' <> encodeUgly entry

172+ B.char7 char <> B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\":" <> encodeUgly entry

149173 in

150174 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'

151175

@@ -206,15 +230,6 @@ encodeHelp indent value =

206230

207231

208232

209−-- ENCODE UTF-8

210−

211−

212−encodeUtf8 :: Utf8.String -> B.Builder

213−encodeUtf8 str =

214− B.char7 '"' <> Utf8.toBuilder str <> B.char7 '"'

215−

216−

217−

218233-- ENCODE ARRAY

219234

220235

@@ -237,7 +252,7 @@ arrayClose =

237252-- ENCODE OBJECT

238253

239254

240−encodeObject :: BSC.ByteString -> (Utf8.String, Value) -> [(Utf8.String, Value)] -> B.Builder

255+encodeObject :: BSC.ByteString -> (Json.String, Value) -> [(Json.String, Value)] -> B.Builder

241256encodeObject =

242257 encodeSequence objectOpen objectClose encodeField

243258

@@ -252,9 +267,9 @@ objectClose =

252267 B.char7 '}'

253268

254269

255−encodeField :: BSC.ByteString -> (Utf8.String, Value) -> B.Builder

270+encodeField :: BSC.ByteString -> (Json.String, Value) -> B.Builder

256271encodeField indent (key, value) =

257− encodeUtf8 key <> B.string7 ": " <> encodeHelp indent value

272+ B.char7 '"' <> Utf8.toBuilder key <> B.string7 "\": " <> encodeHelp indent value

258273

259274

260275

compiler/src/Json/String.hsnew file+192

@@ -0,0 +1,192 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls #-}

3+module Json.String

4+ ( String

5+ , isEmpty

6+ --

7+ , fromPtr

8+ , fromName

9+ , fromChars

10+ , fromSnippet

11+ , fromComment

12+ --

13+ , toChars

14+ , toBuilder

15+ )

16+ where

17+

18+

19+import Prelude hiding (String)

20+import qualified Data.ByteString.Builder as B

21+import qualified Data.Coerce as Coerce

22+import qualified Data.Name as Name

23+import qualified Data.Utf8 as Utf8

24+import Data.Utf8 (MBA, newByteArray, copyFromPtr, freeze, writeWord8)

25+import Data.Word (Word8)

26+import Foreign.Ptr (Ptr, plusPtr, minusPtr)

27+import Foreign.ForeignPtr (withForeignPtr)

28+import GHC.Exts (RealWorld)

29+import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)

30+import GHC.ST (ST)

31+

32+import qualified Parse.Primitives as P

33+

34+

35+

36+-- JSON STRINGS

37+

38+

39+-- INVARIANT: any Json.String is appropriately escaped already

40+-- PERF: is this the right representation for Json.String? Maybe ByteString instead?

41+--

42+type String =

43+ Utf8.Utf8 JSON_STRING

44+

45+

46+data JSON_STRING

47+

48+

49+isEmpty :: String -> Bool

50+isEmpty =

51+ Utf8.isEmpty

52+

53+

54+

55+-- FROM

56+

57+

58+fromPtr :: Ptr Word8 -> Ptr Word8 -> String

59+fromPtr =

60+ Utf8.fromPtr

61+

62+

63+fromChars :: [Char] -> String

64+fromChars =

65+ Utf8.fromChars

66+

67+

68+fromSnippet :: P.Snippet -> String

69+fromSnippet =

70+ Utf8.fromSnippet

71+

72+

73+fromName :: Name.Name -> String

74+fromName =

75+ Coerce.coerce

76+

77+

78+

79+-- TO

80+

81+

82+toChars :: String -> [Char]

83+toChars =

84+ Utf8.toChars

85+

86+

87+{-# INLINE toBuilder #-}

88+toBuilder :: String -> B.Builder

89+toBuilder =

90+ Utf8.toBuilder

91+

92+

93+

94+-- FROM COMMENT

95+

96+

97+fromComment :: P.Snippet -> String

98+fromComment (P.Snippet fptr off len _ _) =

99+ unsafePerformIO $ withForeignPtr fptr $ \ptr ->

100+ let

101+ !pos = plusPtr ptr off

102+ !end = plusPtr pos len

103+ !str = fromChunks (chompChunks pos end pos [])

104+ in

105+ return str

106+

107+

108+chompChunks :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

109+chompChunks pos end start revChunks =

110+ if pos >= end then

111+ reverse (addSlice start end revChunks)

112+ else

113+ let

114+ !word = P.unsafeIndex pos

115+ in

116+ case word of

117+ 0x0A {-\n-} -> chompEscape 0x6E {-n-} pos end start revChunks

118+ 0x22 {-"-} -> chompEscape 0x22 {-"-} pos end start revChunks

119+ 0x5C {-\-} -> chompEscape 0x5C {-\-} pos end start revChunks

120+ 0x0D {-\r-} ->

121+ let

122+ !newPos = plusPtr pos 1

123+ in

124+ chompChunks newPos end newPos (addSlice start pos revChunks)

125+

126+ _ ->

127+ let

128+ !width = P.getCharWidth word

129+ !newPos = plusPtr pos width

130+ in

131+ chompChunks newPos end start revChunks

132+

133+

134+chompEscape :: Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

135+chompEscape escape pos end start revChunks =

136+ let

137+ !pos1 = plusPtr pos 1

138+ in

139+ chompChunks pos1 end pos1 (Escape escape : addSlice start pos revChunks)

140+

141+

142+addSlice :: Ptr Word8 -> Ptr Word8 -> [Chunk] -> [Chunk]

143+addSlice start end revChunks =

144+ if start == end

145+ then revChunks

146+ else Slice start (minusPtr end start) : revChunks

147+

148+

149+

150+-- FROM CHUNKS

151+

152+

153+data Chunk

154+ = Slice (Ptr Word8) Int

155+ | Escape Word8

156+

157+

158+fromChunks :: [Chunk] -> String

159+fromChunks chunks =

160+ unsafeDupablePerformIO (stToIO (

161+ do let !len = sum (map chunkToWidth chunks)

162+ mba <- newByteArray len

163+ writeChunks mba 0 chunks

164+ freeze mba

165+ ))

166+

167+

168+chunkToWidth :: Chunk -> Int

169+chunkToWidth chunk =

170+ case chunk of

171+ Slice _ len -> len

172+ Escape _ -> 2

173+

174+

175+writeChunks :: MBA RealWorld -> Int -> [Chunk] -> ST RealWorld ()

176+writeChunks mba offset chunks =

177+ case chunks of

178+ [] ->

179+ return ()

180+

181+ chunk : chunks ->

182+ case chunk of

183+ Slice ptr len ->

184+ do copyFromPtr ptr mba offset len

185+ let !newOffset = offset + len

186+ writeChunks mba newOffset chunks

187+

188+ Escape word ->

189+ do writeWord8 mba offset 0x5C {- \ -}

190+ writeWord8 mba (offset + 1) word

191+ let !newOffset = offset + 2

192+ writeChunks mba newOffset chunks

compiler/src/Nitpick/Debug.hs+6−18

@@ -1,33 +1,21 @@

11module Nitpick.Debug

2− ( findDebugUses

2+ ( hasDebugUses

33 )

44 where

55

66

7−import qualified Data.Map as Map

8−import qualified Data.Name as Name

9−import qualified Data.Set as Set

7+import qualified Data.Map.Utils as Map

108

119import qualified AST.Optimized as Opt

12−import qualified Elm.ModuleName as ModuleName

13−import qualified Elm.Package as Pkg

1410

1511

1612

17−-- FIND DEBUG USES

13+-- HAS DEBUG USES

1814

1915

20−findDebugUses :: Pkg.Name -> Opt.Graph -> [Name.Name]

21−findDebugUses pkg (Opt.Graph _ graph _) =

22− Set.toList $ Map.foldrWithKey (addDebugUses pkg) Set.empty graph

23−

24−

25−addDebugUses :: Pkg.Name -> Opt.Global -> Opt.Node -> Set.Set Name.Name -> Set.Set Name.Name

26−addDebugUses here (Opt.Global (ModuleName.Canonical pkg home) _) node uses =

27− if pkg == here && nodeHasDebug node then

28− Set.insert home uses

29− else

30− uses

16+hasDebugUses :: Opt.LocalGraph -> Bool

17+hasDebugUses (Opt.LocalGraph _ graph _) =

18+ Map.any nodeHasDebug graph

3119

3220

3321nodeHasDebug :: Opt.Node -> Bool

compiler/src/Nitpick/PatternMatches.hs+10−9

@@ -21,11 +21,12 @@ 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.Utf8 as Utf8

24+import qualified Data.NonEmptyList as NE

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

2930import qualified Reporting.Annotation as A

3031

3132

@@ -40,8 +41,8 @@ data Pattern

4041

4142

4243data Literal

43− = Chr Utf8.String

44− | Str Utf8.String

44+ = Chr ES.String

45+ | Str ES.String

4546 | Int Int

4647 deriving (Eq)

4748

@@ -202,14 +203,14 @@ data Context

202203-- CHECK

203204

204205

205−check :: Can.Module -> Either [Error] ()

206−check (Can.Module _ _ decls _ _ _ _) =

206+check :: Can.Module -> Either (NE.List Error) ()

207+check (Can.Module _ _ _ decls _ _ _ _) =

207208 case checkDecls decls [] of

208209 [] ->

209210 Right ()

210211

211− errors ->

212− Left errors

212+ e:es ->

213+ Left (NE.List e es)

213214

214215

215216

@@ -222,8 +223,8 @@ checkDecls decls errors =

222223 Can.Declare def subDecls ->

223224 checkDef def $ checkDecls subDecls errors

224225

225− Can.DeclareRec defs subDecls ->

226− foldr checkDef (checkDecls subDecls errors) defs

226+ Can.DeclareRec def defs subDecls ->

227+ checkDef def (foldr checkDef (checkDecls subDecls errors) defs)

227228

228229 Can.SaveTheEnvironment ->

229230 errors

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

3130

3231import qualified AST.Canonical as Can

3332import qualified Data.Index as Index

3433import 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 Utf8.String

81− | IsStr Utf8.String

80+ | IsChr ES.String

81+ | IsStr ES.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− _ -> error "problem getting DecisionTree.Test binary"

621+ _ -> fail "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− _ -> error "problem getting DecisionTree.Path binary"

637+ _ -> fail "problem getting DecisionTree.Path binary"

compiler/src/Optimize/Module.hs+35−38

@@ -40,13 +40,13 @@ type Annotations =

4040 Map.Map Name.Name Can.Annotation

4141

4242

43−optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.Graph

44−optimize annotations (Can.Module home _ decls unions aliases _ effects) =

43+optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph

44+optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =

4545 addDecls home annotations decls $

4646 addEffects home effects $

4747 addUnions home unions $

4848 addAliases home aliases $

49− Opt.Graph Map.empty Map.empty Map.empty

49+ Opt.LocalGraph Nothing Map.empty Map.empty

5050

5151

5252

@@ -57,9 +57,9 @@ type Nodes =

5757 Map.Map Opt.Global Opt.Node

5858

5959

60−addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.Graph -> Opt.Graph

61−addUnions home unions (Opt.Graph mains nodes fields) =

62− Opt.Graph mains (Map.foldr (addUnion home) nodes unions) fields

60+addUnions :: ModuleName.Canonical -> Map.Map Name.Name Can.Union -> Opt.LocalGraph -> Opt.LocalGraph

61+addUnions home unions (Opt.LocalGraph main nodes fields) =

62+ Opt.LocalGraph main (Map.foldr (addUnion home) nodes unions) fields

6363

6464

6565addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes

@@ -83,13 +83,13 @@ addCtorNode home opts nodes (Can.Ctor name index numArgs _) =

8383-- ALIAS

8484

8585

86−addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.Graph -> Opt.Graph

86+addAliases :: ModuleName.Canonical -> Map.Map Name.Name Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph

8787addAliases home aliases graph =

8888 Map.foldrWithKey (addAlias home) graph aliases

8989

9090

91−addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.Graph -> Opt.Graph

92−addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts) =

91+addAlias :: ModuleName.Canonical -> Name.Name -> Can.Alias -> Opt.LocalGraph -> Opt.LocalGraph

92+addAlias home name (Can.Alias _ tipe) graph@(Opt.LocalGraph main nodes fieldCounts) =

9393 case tipe of

9494 Can.TRecord fields Nothing ->

9595 let

@@ -100,8 +100,8 @@ addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts)

100100 node =

101101 Opt.Define function Set.empty

102102 in

103− Opt.Graph

104− mains

103+ Opt.LocalGraph

104+ main

105105 (Map.insert (Opt.Global home name) node nodes)

106106 (Map.foldrWithKey addRecordCtorField fieldCounts fields)

107107

@@ -118,8 +118,8 @@ addRecordCtorField name _ fields =

118118-- ADD EFFECTS

119119

120120

121−addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph

122−addEffects home effects graph@(Opt.Graph mains nodes fields) =

121+addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.LocalGraph -> Opt.LocalGraph

122+addEffects home effects graph@(Opt.LocalGraph main nodes fields) =

123123 case effects of

124124 Can.NoEffects ->

125125 graph

@@ -148,10 +148,10 @@ addEffects home effects graph@(Opt.Graph mains nodes fields) =

148148 Map.insert sub link $

149149 Map.insert fx (Opt.Manager Opt.Fx) nodes

150150 in

151− Opt.Graph mains newNodes fields

151+ Opt.LocalGraph main newNodes fields

152152

153153

154−addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.Graph -> Opt.Graph

154+addPort :: ModuleName.Canonical -> Name.Name -> Can.Port -> Opt.LocalGraph -> Opt.LocalGraph

155155addPort home name port_ graph =

156156 case port_ of

157157 Can.Incoming _ payloadType _ ->

@@ -173,10 +173,10 @@ addPort home name port_ graph =

173173-- HELPER

174174

175175

176−addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.Graph -> Opt.Graph

177−addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =

178− Opt.Graph

179− mains

176+addToGraph :: Opt.Global -> Opt.Node -> Map.Map Name.Name Int -> Opt.LocalGraph -> Opt.LocalGraph

177+addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =

178+ Opt.LocalGraph

179+ main

180180 (Map.insert name node nodes)

181181 (Map.unionWith (+) fields fieldCounts)

182182

@@ -185,19 +185,20 @@ addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =

185185-- ADD DECLS

186186

187187

188−addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph

188+addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph

189189addDecls home annotations decls graph =

190190 case decls of

191191 Can.Declare def subDecls ->

192192 addDecls home annotations subDecls =<< addDef home annotations def graph

193193

194− Can.DeclareRec defs subDecls ->

194+ Can.DeclareRec d ds subDecls ->

195+ let defs = d:ds in

195196 case findMain defs of

196197 Nothing ->

197198 addDecls home annotations subDecls (addRecDefs home defs graph)

198199

199200 Just region ->

200− Result.throw $ E.BadCycle region (map defToName defs)

201+ Result.throw $ E.BadCycle region (defToName d) (map defToName ds)

201202

202203 Can.SaveTheEnvironment ->

203204 Result.ok graph

@@ -212,10 +213,10 @@ findMain defs =

212213 def:rest ->

213214 case def of

214215 Can.Def (A.At region name) _ _ ->

215− if name == Name.main then Just region else findMain rest

216+ if name == Name._main then Just region else findMain rest

216217

217218 Can.TypedDef (A.At region name) _ _ _ _ ->

218− if name == Name.main then Just region else findMain rest

219+ if name == Name._main then Just region else findMain rest

219220

220221

221222defToName :: Can.Def -> Name.Name

@@ -229,7 +230,7 @@ defToName def =

229230-- ADD DEFS

230231

231232

232−addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph

233+addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph

233234addDef home annotations def graph =

234235 case def of

235236 Can.Def (A.At region name) args body ->

@@ -241,21 +242,17 @@ addDef home annotations def graph =

241242 addDefHelp region annotations home name (map fst typedArgs) body graph

242243

243244

244−addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph

245−addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =

246− if name /= Name.main then

245+addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph

246+addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =

247+ if name /= Name._main then

247248 Result.ok (addDefNode home name args body Set.empty graph)

248249 else

249250 let

250251 (Can.Forall _ tipe) = annotations ! name

251252

252253 addMain (deps, fields, main) =

253− let

254− newMains = Map.insert home main mains

255− newFields = Map.unionWith (+) fields fieldCounts

256− in

257254 addDefNode home name args body deps $

258− Opt.Graph newMains nodes newFields

255+ Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)

259256 in

260257 case Type.deepDealias tipe of

261258 Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == Name.node ->

@@ -275,7 +272,7 @@ addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes f

275272 Result.throw (E.BadType region tipe)

276273

277274

278−addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph

275+addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph

279276addDefNode home name args body mainDeps graph =

280277 let

281278 (deps, fields, def) =

@@ -304,8 +301,8 @@ data State =

304301 }

305302

306303

307−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph

308−addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =

304+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.LocalGraph -> Opt.LocalGraph

305+addRecDefs home defs (Opt.LocalGraph main nodes fieldCounts) =

309306 let

310307 names = reverse (map toName defs)

311308 cycleName = Opt.Global home (Name.fromManyNames names)

@@ -316,8 +313,8 @@ addRecDefs home defs (Opt.Graph mains nodes fieldCounts) =

316313 Names.run $

317314 foldM (addRecDef cycle) (State [] []) defs

318315 in

319− Opt.Graph

320− mains

316+ Opt.LocalGraph

317+ main

321318 (Map.insert cycleName (Opt.Cycle names values funcs deps) (Map.union links nodes))

322319 (Map.unionWith (+) fields fieldCounts)

323320

compiler/src/Optimize/Names.hs+1−7

@@ -24,7 +24,6 @@ import qualified AST.Canonical as Can

2424import qualified AST.Optimized as Opt

2525import qualified Data.Index as Index

2626import qualified Elm.ModuleName as ModuleName

27−import qualified Elm.Package as Pkg

2827import qualified Reporting.Annotation as A

2928

3029

@@ -58,12 +57,7 @@ generate =

5857registerKernel :: Name.Name -> a -> Tracker a

5958registerKernel home value =

6059 Tracker $ \uid deps fields ok ->

61− ok uid (Set.insert (toKernelGlobal home) deps) fields value

62−

63−

64−toKernelGlobal :: Name.Name -> Opt.Global

65−toKernelGlobal home =

66− Opt.Global (ModuleName.Canonical Pkg.kernel home) Name.dollar

60+ ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value

6761

6862

6963registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr

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 union type"

61+ error "toEncoder: bad custom 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.toUtf8 name)) value Nothing

71+ return $ Opt.Tuple (Opt.Str (Name.toElmString 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.toUtf8 key), typeDecoder ]

312+ , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]

313313 ]

314314

315315

compiler/src/Parse/Declaration.hs+180−131

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

1920import qualified Parse.Symbol as Symbol

2021import qualified Parse.Type as Type

2122import qualified Parse.Variable as Var

22−import Parse.Utils

23−import Parse.Primitives hiding (Parser, State)

23+import Parse.Primitives hiding (State)

2424import qualified Parse.Primitives as P

2525import qualified Reporting.Annotation as A

2626import qualified Reporting.Error.Syntax as E

@@ -31,141 +31,182 @@ import qualified Reporting.Error.Syntax as E

3131

3232

3333data Decl

34− = Value (A.Located Src.Value)

35− | Union (A.Located Src.Union)

36− | Alias (A.Located Src.Alias)

37− | Port Src.Port

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

3838

3939

40−declaration :: SParser Decl

40+declaration :: Space.Parser E.Decl Decl

4141declaration =

42− do start <- getPosition

43− oneOf E.XXX

44− [ typeDecl start

45− , portDecl

46− , valueDecl start

42+ do maybeDocs <- chompDocComment

43+ start <- getPosition

44+ oneOf E.DeclStart

45+ [ typeDecl maybeDocs start

46+ , portDecl maybeDocs

47+ , valueDecl maybeDocs start

4748 ]

4849

4950

5051

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+

5168-- DEFINITION and ANNOTATION

5269

5370

5471{-# INLINE valueDecl #-}

55−valueDecl :: A.Position -> SParser Decl

56−valueDecl start =

57− do name <- Var.lower

72+valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl

73+valueDecl maybeDocs start =

74+ do name <- Var.lower E.DeclStart

5875 end <- getPosition

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 )

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)

92104 ]

93105

94106

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

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

99113 let

100− cokL name newState@(P.State _ _ _ er ec _) =

114+ cokL name newState@(P.State _ _ _ _ er ec) =

101115 if expectedName == name

102116 then cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

103− else cerr sr sc ctx (E.MatchingName expectedName)

117+ else cerr sr sc (E.DeclDefNameMatch name)

104118

105− eokL name newState@(P.State _ _ _ er ec _) =

119+ eokL name newState@(P.State _ _ _ _ er ec) =

106120 if expectedName == name

107121 then eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) name) newState

108− else eerr sr sc ctx (E.MatchingName expectedName)

122+ else eerr sr sc (E.DeclDefNameMatch name)

109123 in

110124 parserL state cokL eokL cerr eerr

111125

112126

113127

114−-- TYPE ALIAS and UNION TYPES

128+-- TYPE DECLARATIONS

115129

116130

117131{-# INLINE typeDecl #-}

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

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

138175

139176

140−nameArgsEquals :: Parser (A.Located Name.Name, [A.Located Name.Name])

141−nameArgsEquals =

142− do name <- addLocation Var.upper

143− spaces

144− nameArgsEqualsHelp name []

145177

178+-- CUSTOM TYPES

146179

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

180+

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

186+

187+

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

155196 return ( name, reverse args )

156197 ]

157198

158199

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 )

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

168208 ]

209+ (reverse variants, end)

169210

170211

171212

@@ -173,16 +214,19 @@ chompConstructors ctors end pos =

173214

174215

175216{-# INLINE portDecl #-}

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 )

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

186230

187231

188232

@@ -191,27 +235,32 @@ portDecl =

191235

192236-- INVARIANT: always chomps to a freshline

193237--

194−infix_ :: Parser (A.Located Src.Binop)

238+infix_ :: Parser E.Module (A.Located Src.Infix)

195239infix_ =

240+ let

241+ err = E.Infix

242+ _err = \_ -> E.Infix

243+ in

196244 do start <- getPosition

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

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

compiler/src/Parse/Docs.hsdeleted−275

This diff is too big to show here.

compiler/src/Parse/Expression.hs+330−341

This diff is too big to show here.

compiler/src/Parse/Keyword.hs+83−84

This diff is too big to show here.

compiler/src/Parse/Module.hs+330−259

This diff is too big to show here.

compiler/src/Parse/Number.hs+37−34

This diff is too big to show here.

compiler/src/Parse/Pattern.hs+138−130

This diff is too big to show here.

compiler/src/Parse/Primitives.hs+199−123

This diff is too big to show here.

compiler/src/Parse/Repl.hsdeleted−117

This diff is too big to show here.

compiler/src/Parse/Shader.hs+25−24

This diff is too big to show here.

compiler/src/Parse/Space.hsnew file+273

This diff is too big to show here.

compiler/src/Parse/Utf8.hs → compiler/src/Parse/String.hsrenamed+104−94

This diff is too big to show here.

compiler/src/Parse/Symbol.hs+22−37

This diff is too big to show here.

compiler/src/Parse/Type.hs+101−103

This diff is too big to show here.

compiler/src/Parse/Utils.hsdeleted−259

This diff is too big to show here.

compiler/src/Parse/Variable.hs+54−49

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+96−54

This diff is too big to show here.

compiler/src/Reporting/Error.hs+175−22

This diff is too big to show here.

compiler/src/Reporting/Error/Canonicalize.hs+115−127

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hs+132−23

This diff is too big to show here.

compiler/src/Reporting/Error/Import.hsnew file+162

This diff is too big to show here.

compiler/src/Reporting/Error/Json.hs+280−270

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hs+6−6

This diff is too big to show here.

compiler/src/Reporting/Error/Pattern.hs+9−8

This diff is too big to show here.

compiler/src/Reporting/Error/Syntax.hs+5688−627

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hs+53−32

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+154−10

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+7−27

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+12−2

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

This diff is too big to show here.

compiler/src/Type/Error.hs+14−123

This diff is too big to show here.

compiler/src/Type/Solve.hs+11−3

This diff is too big to show here.

compiler/src/Type/Unify.hs+12−10

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.

upgrade-docs/0.16.md → docs/upgrade-instructions/0.16.mdrenamed

The content is the same.

upgrade-docs/0.17.md → docs/upgrade-instructions/0.17.mdrenamed

The content is the same.

upgrade-docs/0.18.md → docs/upgrade-instructions/0.18.mdrenamed

The content is the same.

upgrade-docs/0.19.md → docs/upgrade-instructions/0.19.0.mdrenamed

The content is the same.

docs/upgrade-instructions/0.19.1.mdnew file+60

This diff is too big to show here.

upgrade-docs/earlier.md → docs/upgrade-instructions/earlier.mdrenamed

The content is the same.

elm.cabal+69−98

This diff is too big to show here.

hints/bad-recursion.mdnew file+133

This diff is too big to show here.

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

This diff is too big to show here.

hints/comparing-records.mdnew file+85

This diff is too big to show here.

hints/implicit-casts.mdnew file+50

This diff is too big to show here.

hints/import-cycles.mdnew file+184

This diff is too big to show here.

hints/imports.mdnew file+126

This diff is too big to show here.

hints/infinite-type.mdnew file+42

This diff is too big to show here.

hints/init.mdnew file+55

This diff is too big to show here.

hints/missing-patterns.mdnew file+139

This diff is too big to show here.

hints/optimize.mdnew file+59

This diff is too big to show here.

hints/port-modules.mdnew file+32

This diff is too big to show here.

hints/recursive-alias.mdnew file+162

This diff is too big to show here.

hints/repl.mdnew file+73

This diff is too big to show here.

hints/shadowing.mdnew file+70

This diff is too big to show here.

hints/tuples.mdnew file+19

This diff is too big to show here.

hints/type-annotations.mdnew file+60

This diff is too big to show here.

installers/README.mdnew file+32

This diff is too big to show here.

installers/linux/Dockerfilenew file+39

This diff is too big to show here.

installers/linux/README.mdnew file+93

This diff is too big to show here.

installers/mac/Distribution.xml+5−3

This diff is too big to show here.

installers/mac/README.mdnew file+93

This diff is too big to show here.

installers/mac/Resources/en.lproj/background.pngdeleted

Binary file not shown.

installers/mac/Resources/en.lproj/conclusion.rtf+13−6

This diff is too big to show here.

installers/mac/Resources/en.lproj/welcome.rtf+9−4

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+30−3

This diff is too big to show here.

installers/npm/PUBLISHING.md+29−141

This diff is too big to show here.

installers/npm/README.md+30−23

This diff is too big to show here.

installers/npm/bin/elmmode 100644 → 100755+47−41

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/index.jsdeleted−21

This diff is too big to show here.

installers/npm/install.jsnew file+4

This diff is too big to show here.

installers/npm/package.json+13−15

This diff is too big to show here.

installers/npm/troubleshooting.mdnew file+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+18−3

This diff is too big to show here.

installers/win/file.icodeleted

Binary file not shown.

installers/win/inst.dat+1−2

This diff is too big to show here.

installers/win/logo.ico

Binary file not shown.

installers/win/uninst.dat+1−2

This diff is too big to show here.

installers/win/welcome.bmp

Binary file not shown.

reactor/assets/waiting.gifdeleted

Binary file not shown.

reactor/elm.json+2−2

This diff is too big to show here.

reactor/src/Index.elm+20−15

This diff is too big to show here.

reactor/src/Index/Navigator.elm+1−1

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

terminal/src/Terminal/Args.hs → terminal/impl/Terminal.hsrenamed+33−27

This diff is too big to show here.

terminal/src/Terminal/Args/Chomp.hs → terminal/impl/Terminal/Chomp.hsrenamed+4−5

This diff is too big to show here.

terminal/src/Terminal/Args/Error.hs → terminal/impl/Terminal/Error.hsrenamed+28−18

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsnew file+148

This diff is too big to show here.

terminal/src/Terminal/Args/Internal.hs → terminal/impl/Terminal/Internal.hsrenamed+8−8

This diff is too big to show here.

terminal/src/Bump.hs+158−8

This diff is too big to show here.

terminal/src/Develop.hs+70−77

This diff is too big to show here.

terminal/src/Develop/Generate/Index.hs+149−74

This diff is too big to show here.

terminal/src/Develop/StaticFiles.hs+1−7

This diff is too big to show here.

terminal/src/Develop/StaticFiles/Build.hs+46−29

This diff is too big to show here.

terminal/src/Diff.hs+348−6

This diff is too big to show here.

terminal/src/Init.hs+40−36

This diff is too big to show here.

terminal/src/Install.hs+401−14

This diff is too big to show here.

terminal/src/Main.hs+32−36

This diff is too big to show here.

terminal/src/Make.hs+257−32

This diff is too big to show here.

terminal/src/Publish.hs+529−8

This diff is too big to show here.

terminal/src/Repl.hs+522−197

This diff is too big to show here.

terminal/src/Terminal/Args/Helpers.hsdeleted−125

This diff is too big to show here.

worker/elm.cabalnew file+210

This diff is too big to show here.

worker/elm.jsonnew file+26

This diff is too big to show here.

worker/nginx.confnew file+22

This diff is too big to show here.

worker/outlines/compile/elm.jsonnew file+32

This diff is too big to show here.

worker/outlines/repl/elm.jsonnew file+19

This diff is too big to show here.

worker/src/Artifacts.hsnew file+155

This diff is too big to show here.

worker/src/Cors.hsnew file+48

This diff is too big to show here.

worker/src/Endpoint/Compile.hsnew file+323

This diff is too big to show here.

worker/src/Endpoint/Quotes.hsnew file+114

This diff is too big to show here.

worker/src/Endpoint/Repl.hsnew file+244

This diff is too big to show here.

worker/src/Errors.elmnew file+217

This diff is too big to show here.

worker/src/Main.hsnew file+73

This diff is too big to show here.