2861e0e...master · elk

.github/CONTRIBUTING.md+18−20

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

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

55possible.

66

7−## Licensing

87

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

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

8+## Expectations

9+

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

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

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

13+

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

15+

1116

1217## Style Guide

1318

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

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

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

1924

20−## Branches

2125

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

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

24− should target this branch!

26+## Branches

2527

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

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

28− release from source.

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

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

30+should target this branch!

2931

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

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

3233

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

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

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

36−features.

3734

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

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

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

41−your changes maintain this compatibility.

35+## Licensing

36+

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

38+

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

40+

4241

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

.github/ISSUE_TEMPLATE.md+14−9

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

1−BEFORE DELETING THIS:

21

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

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

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

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

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

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

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

93

104

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

5+## SSCCE

126

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

7+```elm

8+

9+```

10+

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

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

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

14+

15+

16+## Additional Details

17+

18+???

.github/PULL_REQUEST_TEMPLATE.mdnew file+18

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

1+

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

3+

4+

5+## SSCCE

6+

7+```elm

8+

9+```

10+

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

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

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

14+

15+

16+## Additional Details

17+

18+???

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

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

1+name: Set Issue Expectations

2+on:

3+ issues:

4+ types: [opened]

5+jobs:

6+ comment-on-issue:

7+ name: Comment On Issue

8+ runs-on: ubuntu-latest

9+ steps:

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

11+ env:

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

13+ with:

14+ args: |

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

16+

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

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

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

20+

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

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

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

1+on:

2+ pull_request_target:

3+ types: [opened]

4+

5+jobs:

6+ comment-on-pull:

7+ name: Comment On Pull

8+ runs-on: ubuntu-latest

9+ steps:

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

11+ with:

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

13+ script: |

14+ github.issues.createComment({

15+ issue_number: context.issue.number,

16+ owner: context.repo.owner,

17+ repo: context.repo.repo,

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

19+ })

.gitignore+1

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

55cabal.sandbox.config

66.DS_Store

77*~

8+travis.log

.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+80−60

@@ -4,11 +4,10 @@ module Deps.Diff

44 , PackageChanges(..)

55 , ModuleChanges(..)

66 , Changes(..)

7− , Magnitude(..)

87 , moduleChangeMagnitude

9− , magnitudeToString

108 , toMagnitude

119 , bump

10+ , getDocs

1211 )

1312 where

1413

@@ -17,14 +16,23 @@ import Control.Monad (zipWithM)

1716import Data.Function (on)

1817import qualified Data.List as List

1918import qualified Data.Map as Map

19+import qualified Data.Name as Name

2020import qualified Data.Set as Set

21−import qualified Data.Text as Text

21+import qualified System.Directory as Dir

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

2223

23−import qualified Elm.Compiler.Module as Module

24+import qualified Deps.Website as Website

2425import qualified Elm.Compiler.Type as Type

2526import qualified Elm.Docs as Docs

26−import qualified Elm.Name as N

27+import qualified Elm.Magnitude as M

28+import qualified Elm.ModuleName as ModuleName

2729import qualified Elm.Package as Pkg

30+import qualified Elm.Version as V

31+import qualified File

32+import qualified Http

33+import qualified Json.Decode as D

34+import qualified Reporting.Exit as Exit

35+import qualified Stuff

2836

2937

3038

@@ -33,18 +41,18 @@ import qualified Elm.Package as Pkg

3341

3442data PackageChanges =

3543 PackageChanges

36− { _modules_added :: [Module.Raw]

37− , _modules_changed :: Map.Map Module.Raw ModuleChanges

38− , _modules_removed :: [Module.Raw]

44+ { _modules_added :: [ModuleName.Raw]

45+ , _modules_changed :: Map.Map ModuleName.Raw ModuleChanges

46+ , _modules_removed :: [ModuleName.Raw]

3947 }

4048

4149

4250data ModuleChanges =

4351 ModuleChanges

44− { _unions :: Changes N.Name Docs.Union

45− , _aliases :: Changes N.Name Docs.Alias

46− , _values :: Changes N.Name Docs.Value

47− , _binops :: Changes N.Name Docs.Binop

52+ { _unions :: Changes Name.Name Docs.Union

53+ , _aliases :: Changes Name.Name Docs.Alias

54+ , _values :: Changes Name.Name Docs.Value

55+ , _binops :: Changes Name.Name Docs.Binop

4856 }

4957

5058

@@ -73,7 +81,7 @@ diff :: Docs.Documentation -> Docs.Documentation -> PackageChanges

7381diff oldDocs newDocs =

7482 let

7583 filterOutPatches chngs =

76− Map.filter (\chng -> moduleChangeMagnitude chng /= PATCH) chngs

84+ Map.filter (\chng -> moduleChangeMagnitude chng /= M.PATCH) chngs

7785

7886 (Changes added changed removed) =

7987 getChanges (\_ _ -> False) oldDocs newDocs

@@ -144,7 +152,7 @@ isEquivalentBinop (Docs.Binop c1 t1 a1 p1) (Docs.Binop c2 t2 a2 p2) =

144152-- DIFF TYPES

145153

146154

147−diffType :: Type.Type -> Type.Type -> Maybe [(N.Name,N.Name)]

155+diffType :: Type.Type -> Type.Type -> Maybe [(Name.Name,Name.Name)]

148156diffType oldType newType =

149157 case (oldType, newType) of

150158 (Type.Var oldName, Type.Var newName) ->

@@ -192,11 +200,11 @@ diffType oldType newType =

192200

193201

194202-- handle very old docs that do not use qualified names

195−isSameName :: N.Name -> N.Name -> Bool

203+isSameName :: Name.Name -> Name.Name -> Bool

196204isSameName oldFullName newFullName =

197205 let

198206 dedot name =

199− reverse (Text.splitOn "." (N.toText name))

207+ reverse (Name.splitDots name)

200208 in

201209 case ( dedot oldFullName, dedot newFullName ) of

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

@@ -209,7 +217,7 @@ isSameName oldFullName newFullName =

209217 oldFullName == newFullName

210218

211219

212−diffFields :: [(N.Name, Type.Type)] -> [(N.Name, Type.Type)] -> Maybe [(N.Name,N.Name)]

220+diffFields :: [(Name.Name, Type.Type)] -> [(Name.Name, Type.Type)] -> Maybe [(Name.Name,Name.Name)]

213221diffFields oldRawFields newRawFields =

214222 let

215223 sort = List.sortBy (compare `on` fst)

@@ -230,7 +238,7 @@ diffFields oldRawFields newRawFields =

230238-- TYPE VARIABLES

231239

232240

233−isEquivalentRenaming :: [(N.Name,N.Name)] -> Bool

241+isEquivalentRenaming :: [(Name.Name,Name.Name)] -> Bool

234242isEquivalentRenaming varPairs =

235243 let

236244 renamings =

@@ -263,7 +271,7 @@ isEquivalentRenaming varPairs =

263271 allUnique (map snd verifiedRenamings)

264272

265273

266−compatibleVars :: (N.Name, N.Name) -> Bool

274+compatibleVars :: (Name.Name, Name.Name) -> Bool

267275compatibleVars (old, new) =

268276 case (categorizeVar old, categorizeVar new) of

269277 (CompAppend, CompAppend) -> True

@@ -285,63 +293,43 @@ data TypeVarCategory

285293 | Var

286294

287295

288−categorizeVar :: N.Name -> TypeVarCategory

296+categorizeVar :: Name.Name -> TypeVarCategory

289297categorizeVar name

290− | N.startsWith "compappend" name = CompAppend

291− | N.startsWith "comparable" name = Comparable

292− | N.startsWith "appendable" name = Appendable

293− | N.startsWith "number" name = Number

294− | otherwise = Var

298+ | Name.isCompappendType name = CompAppend

299+ | Name.isComparableType name = Comparable

300+ | Name.isAppendableType name = Appendable

301+ | Name.isNumberType name = Number

302+ | otherwise = Var

295303

296304

297305

298306-- MAGNITUDE

299307

300308

301−data Magnitude

302− = PATCH

303− | MINOR

304− | MAJOR

305− deriving (Eq, Ord)

306−

307−

308−magnitudeToString :: Magnitude -> String

309−magnitudeToString magnitude =

310− case magnitude of

311− PATCH ->

312− "PATCH"

313−

314− MINOR ->

315− "MINOR"

316−

317− MAJOR ->

318− "MAJOR"

319−

320−

321−bump :: PackageChanges -> Pkg.Version -> Pkg.Version

309+bump :: PackageChanges -> V.Version -> V.Version

322310bump changes version =

323311 case toMagnitude changes of

324− PATCH ->

325− Pkg.bumpPatch version

312+ M.PATCH ->

313+ V.bumpPatch version

326314

327− MINOR ->

328− Pkg.bumpMinor version

315+ M.MINOR ->

316+ V.bumpMinor version

329317

330− MAJOR ->

331− Pkg.bumpMajor version

318+ M.MAJOR ->

319+ V.bumpMajor version

332320

333321

334−toMagnitude :: PackageChanges -> Magnitude

322+toMagnitude :: PackageChanges -> M.Magnitude

335323toMagnitude (PackageChanges added changed removed) =

336324 let

337− addMag = if null added then PATCH else MINOR

338− removeMag = if null removed then PATCH else MAJOR

325+ addMag = if null added then M.PATCH else M.MINOR

326+ removeMag = if null removed then M.PATCH else M.MAJOR

339327 changeMags = map moduleChangeMagnitude (Map.elems changed)

340328 in

341329 maximum (addMag : removeMag : changeMags)

342330

343331

344−moduleChangeMagnitude :: ModuleChanges -> Magnitude

332+moduleChangeMagnitude :: ModuleChanges -> M.Magnitude

345333moduleChangeMagnitude (ModuleChanges unions aliases values binops) =

346334 maximum

347335 [ changeMagnitude unions

@@ -351,13 +339,45 @@ moduleChangeMagnitude (ModuleChanges unions aliases values binops) =

351339 ]

352340

353341

354−changeMagnitude :: Changes k v -> Magnitude

342+changeMagnitude :: Changes k v -> M.Magnitude

355343changeMagnitude (Changes added changed removed) =

356344 if Map.size removed > 0 || Map.size changed > 0 then

357− MAJOR

345+ M.MAJOR

358346

359347 else if Map.size added > 0 then

360− MINOR

348+ M.MINOR

361349

362350 else

363− PATCH

351+ M.PATCH

352+

353+

354+

355+-- GET DOCS

356+

357+

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

359+getDocs cache manager name version =

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

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

362+ exists <- File.exists path

363+ if exists

364+ then

365+ do bytes <- File.readUtf8 path

366+ case D.fromByteString Docs.decoder bytes of

367+ Right docs ->

368+ return $ Right docs

369+

370+ Left _ ->

371+ do File.remove path

372+ return $ Left Exit.DP_Cache

373+ else

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

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

376+ case D.fromByteString Docs.decoder body of

377+ Right docs ->

378+ do Dir.createDirectoryIfMissing True home

379+ File.writeUtf8 path body

380+ return $ Right docs

381+

382+ Left _ ->

383+ return $ Left $ Exit.DP_Data url body

builder/src/Deps/Explorer.hsdeleted−116

@@ -1,116 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Deps.Explorer

3− ( Explorer

4− , Metadata

5− , Info(..)

6− , run

7− , exists

8− , getVersions

9− , getConstraints

10− )

11− where

12−

13−{-| It is expensive to load ALL package metadata. You would need to:

14−

15− 1. Know all the packages and all their versions.

16− 2. Download or read the elm.json file for each version.

17−

18−The goal of this module is to only pay for (1) and pay for (2) as needed.

19−-}

20−

21−

22−import Control.Monad.Except (lift, throwError)

23−import Control.Monad.State (StateT, evalStateT, gets, modify)

24−import Data.Map (Map)

25−import qualified Data.Map as Map

26−

27−import Elm.Package (Name, Version)

28−

29−import qualified Deps.Get as Get

30−import qualified Elm.Project.Json as Project

31−import Elm.Project.Constraint (Constraint)

32−import qualified Reporting.Exit as Exit

33−import qualified Reporting.Exit.Deps as E

34−import qualified Reporting.Task as Task

35−

36−

37−

38−-- EXPLORER

39−

40−

41−type Explorer =

42− StateT Metadata Task.Task

43−

44−

45−data Metadata =

46− Metadata

47− { _vsns :: Get.AllPackages

48− , _info :: Map (Name, Version) Info

49− }

50−

51−

52−data Info =

53− Info

54− { _elm :: Constraint

55− , _pkgs :: Map Name Constraint

56− }

57−

58−

59−run :: Explorer a -> Task.Task a

60−run explorer =

61− do versions <- Get.all Get.AllowOffline

62− evalStateT explorer (Metadata versions Map.empty)

63−

64−

65−

66−-- EXISTS

67−

68−

69−exists :: Name -> Explorer ()

70−exists name =

71− do pkgs <- gets _vsns

72− case Get.versions name pkgs of

73− Right _ ->

74− return ()

75−

76− Left suggestions ->

77− throwError (Exit.Deps (E.PackageNotFound name suggestions))

78−

79−

80−

81−-- VERSIONS

82−

83−

84−getVersions :: Name -> Explorer [Version]

85−getVersions name =

86− do pkgs <- gets _vsns

87− case Get.versions name pkgs of

88− Right versions ->

89− return versions

90−

91− Left _suggestions ->

92− throwError (Exit.Deps (E.CorruptVersionCache name))

93−

94−

95−

96−-- CONSTRAINTS

97−

98−

99−getConstraints :: Name -> Version -> Explorer Info

100−getConstraints name version =

101− do allInfo <- gets _info

102− case Map.lookup (name, version) allInfo of

103− Just info ->

104− return info

105−

106− Nothing ->

107− do pkgInfo <- lift $ Get.info name version

108−

109− let elm = Project._pkg_elm_version pkgInfo

110− let pkgs = Project._pkg_deps pkgInfo

111− let info = Info elm pkgs

112−

113− modify $ \(Metadata vsns infos) ->

114− Metadata vsns $ Map.insert (name, version) info infos

115−

116− return info

builder/src/Deps/Get.hsdeleted−211

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

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Deps.Get

4− ( all

5− , AllPackages

6− , Mode(..)

7− , versions

8− , info

9− , docs

10− )

11− where

12−

13−

14−import Prelude hiding (all)

15−import Control.Monad.Except (catchError, liftIO)

16−import qualified Data.ByteString as BS

17−import Data.Function (on)

18−import qualified Data.List as List

19−import qualified Data.Map as Map

20−import Data.Map (Map)

21−import qualified Data.Text as Text

22−import qualified System.Directory as Dir

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

24−

25−import qualified Elm.Docs as Docs

26−import qualified Elm.Package as Pkg

27−

28−import qualified Deps.Website as Website

29−import qualified Elm.Project.Json as Project

30−import qualified File.IO as IO

31−import qualified Json.Decode as Decode

32−import qualified Reporting.Doc as D

33−import qualified Reporting.Exit as Exit

34−import qualified Reporting.Exit.Assets as E

35−import qualified Reporting.Progress as Progress

36−import qualified Reporting.Suggest as Suggest

37−import qualified Reporting.Task as Task

38−

39−

40−

41−-- ALL VERSIONS

42−

43−

44−data Mode = RequireLatest | AllowOffline

45−

46−

47−newtype AllPackages = AllPackages (Map Pkg.Name [Pkg.Version])

48−

49−

50−all :: Mode -> Task.Task AllPackages

51−all mode =

52− do dir <- Task.getPackageCacheDir

53− let versionsFile = dir </> "versions.dat"

54− exists <- liftIO $ Dir.doesFileExist versionsFile

55− if exists

56− then fetchNew versionsFile mode

57− else fetchAll versionsFile

58−

59−

60−fetchAll :: FilePath -> Task.Task AllPackages

61−fetchAll versionsFile =

62− do packages <- Website.getAllPackages

63− let size = Map.foldr ((+) . length) 0 packages

64− IO.writeBinary versionsFile (size, packages)

65− return (AllPackages packages)

66−

67−

68−fetchNew :: FilePath -> Mode -> Task.Task AllPackages

69−fetchNew versionsFile mode =

70− do (size, packages) <- IO.readBinary versionsFile

71−

72− news <-

73− case mode of

74− RequireLatest ->

75− Website.getNewPackages size

76−

77− AllowOffline ->

78− Website.getNewPackages size `catchError` \_ ->

79− do Task.report Progress.UnableToLoadLatestPackages

80− return []

81−

82− if null news

83− then return (AllPackages packages)

84− else

85− do let newAllPkgs = List.foldl' addNew packages news

86− IO.writeBinary versionsFile (size + length news, newAllPkgs)

87− return (AllPackages newAllPkgs)

88−

89−

90−addNew :: Map Pkg.Name [Pkg.Version] -> (Pkg.Name, Pkg.Version) -> Map Pkg.Name [Pkg.Version]

91−addNew packages (name, version) =

92− Map.insertWith (++) name [version] packages

93−

94−

95−

96−-- VERSIONS

97−

98−

99−versions :: Pkg.Name -> AllPackages -> Either [Pkg.Name] [Pkg.Version]

100−versions name (AllPackages pkgs) =

101− case Map.lookup name pkgs of

102− Just vsns ->

103− Right vsns

104−

105− Nothing ->

106− Left (nearbyNames name (Map.keys pkgs))

107−

108−

109−nearbyNames :: Pkg.Name -> [Pkg.Name] -> [Pkg.Name]

110−nearbyNames (Pkg.Name author1 project1) possibleNames =

111− let

112− authorDist = authorDistance (Text.unpack author1)

113− projectDist = projectDistance (Text.unpack project1)

114−

115− addDistance name@(Pkg.Name author2 project2) =

116− ( authorDist author2 + projectDist project2, name )

117− in

118− map snd $ take 4 $

119− List.sortBy (compare `on` fst) $

120− map addDistance possibleNames

121−

122−

123−authorDistance :: String -> Text.Text -> Int

124−authorDistance bad possibility =

125− abs (Suggest.distance bad (Text.unpack possibility))

126−

127−

128−projectDistance :: String -> Text.Text -> Int

129−projectDistance bad possibility =

130− if possibility == "elm-lang" || possibility == "elm-explorations" then

131− 0

132− else

133− abs (Suggest.distance bad (Text.unpack possibility))

134−

135−

136−

137−-- PACKAGE INFO

138−

139−

140−info :: Pkg.Name -> Pkg.Version -> Task.Task Project.PkgInfo

141−info name version =

142− do dir <- Task.getPackageCacheDirFor name version

143− let elmJson = dir </> "elm.json"

144−

145− exists <- liftIO $ Dir.doesFileExist elmJson

146−

147− json <-

148− if exists

149− then liftIO (BS.readFile elmJson)

150− else

151− do bits <- Website.getElmJson name version

152− liftIO (BS.writeFile elmJson bits)

153− return bits

154−

155− case Decode.parse "project" E.badContentToDocs Project.pkgDecoder json of

156− Right pkgInfo ->

157− return pkgInfo

158−

159− Left _ ->

160− do IO.remove elmJson

161− Task.throw $ Exit.Assets $ E.CorruptElmJson name version

162−

163−

164−

165−-- DOCS

166−

167−

168−docs :: Pkg.Name -> Pkg.Version -> Task.Task Docs.Documentation

169−docs name version =

170− do dir <- Task.getPackageCacheDirFor name version

171− let docsJson = dir </> "docs.json"

172−

173− exists <- liftIO $ Dir.doesFileExist docsJson

174−

175− json <-

176− if exists

177− then liftIO (BS.readFile docsJson)

178− else

179− do bits <- Website.getDocs name version

180− liftIO (BS.writeFile docsJson bits)

181− return bits

182−

183− case Decode.parse "docs" errorToDocs (Docs.toDict <$> Decode.list Docs.decoder) json of

184− Right pkgInfo ->

185− return pkgInfo

186−

187− Left _ ->

188− do IO.remove docsJson

189− Task.throw $ Exit.Assets $ E.CorruptDocumentation name version

190−

191−

192−errorToDocs :: Docs.Error -> [D.Doc]

193−errorToDocs err =

194− let

195− details =

196− case err of

197− Docs.BadAssociativity txt ->

198− ["Binary","operators","cannot","have",D.red (D.fromString (show txt)),"as","their","associativity."]

199−

200− Docs.BadName ->

201− ["It","is","not","a","valid","module","name."]

202−

203− Docs.BadType ->

204− ["It","is","not","a","valid","Elm","type."]

205− in

206− details

207− ++

208− ["This","should","not","happen","in","general,","so","please","report","this","at"

209− ,"<https://github.com/elm-lang/package.elm-lang.org/issues>"

210− ,"if","you","think","it","is","on","the","Elm","side!"

211− ]

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.hsnew file+213

@@ -0,0 +1,213 @@

1+{-# OPTIONS_GHC -Wall #-}

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

3+module Deps.Registry

4+ ( Registry(..)

5+ , KnownVersions(..)

6+ , read

7+ , fetch

8+ , update

9+ , latest

10+ , getVersions

11+ , getVersions'

12+ )

13+ where

14+

15+

16+import Prelude hiding (read)

17+import Control.Monad (liftM2)

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

19+import qualified Data.List as List

20+import qualified Data.Map.Strict as Map

21+

22+import qualified Deps.Website as Website

23+import qualified Elm.Package as Pkg

24+import qualified Elm.Version as V

25+import qualified File

26+import qualified Http

27+import qualified Json.Decode as D

28+import qualified Parse.Primitives as P

29+import qualified Reporting.Exit as Exit

30+import qualified Stuff

31+

32+

33+

34+-- REGISTRY

35+

36+

37+data Registry =

38+ Registry

39+ { _count :: !Int

40+ , _versions :: !(Map.Map Pkg.Name KnownVersions)

41+ }

42+

43+

44+data KnownVersions =

45+ KnownVersions

46+ { _newest :: V.Version

47+ , _previous :: ![V.Version]

48+ }

49+

50+

51+

52+-- READ

53+

54+

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

56+read cache =

57+ File.readBinary (Stuff.registry cache)

58+

59+

60+

61+-- FETCH

62+

63+

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

65+fetch manager cache =

66+ post manager "/all-packages" allPkgsDecoder $

67+ \versions ->

68+ do let size = Map.foldr' addEntry 0 versions

69+ let registry = Registry size versions

70+ let path = Stuff.registry cache

71+ File.writeBinary path registry

72+ return registry

73+

74+

75+addEntry :: KnownVersions -> Int -> Int

76+addEntry (KnownVersions _ vs) count =

77+ count + 1 + length vs

78+

79+

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

81+allPkgsDecoder =

82+ let

83+ keyDecoder =

84+ Pkg.keyDecoder bail

85+

86+ versionsDecoder =

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

88+

89+ toKnownVersions versions =

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

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

92+ [] -> D.failure ()

93+ in

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

95+

96+

97+

98+-- UPDATE

99+

100+

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

102+update manager cache oldRegistry@(Registry size packages) =

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

104+ \news ->

105+ case news of

106+ [] ->

107+ return oldRegistry

108+

109+ _:_ ->

110+ let

111+ newSize = size + length news

112+ newPkgs = foldr addNew packages news

113+ newRegistry = Registry newSize newPkgs

114+ in

115+ do File.writeBinary (Stuff.registry cache) newRegistry

116+ return newRegistry

117+

118+

119+addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions

120+addNew (name, version) versions =

121+ let

122+ add maybeKnowns =

123+ case maybeKnowns of

124+ Just (KnownVersions v vs) ->

125+ KnownVersions version (v:vs)

126+

127+ Nothing ->

128+ KnownVersions version []

129+ in

130+ Map.alter (Just . add) name versions

131+

132+

133+

134+-- NEW PACKAGE DECODER

135+

136+

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

138+newPkgDecoder =

139+ D.customString newPkgParser bail

140+

141+

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

143+newPkgParser =

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

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

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

147+ return (pkg, vsn)

148+

149+

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

151+bail _ _ =

152+ ()

153+

154+

155+

156+-- LATEST

157+

158+

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

160+latest manager cache =

161+ do maybeOldRegistry <- read cache

162+ case maybeOldRegistry of

163+ Just oldRegistry ->

164+ update manager cache oldRegistry

165+

166+ Nothing ->

167+ fetch manager cache

168+

169+

170+

171+-- GET VERSIONS

172+

173+

174+getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions

175+getVersions name (Registry _ versions) =

176+ Map.lookup name versions

177+

178+

179+getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions

180+getVersions' name (Registry _ versions) =

181+ case Map.lookup name versions of

182+ Just kvs -> Right kvs

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

184+

185+

186+

187+-- POST

188+

189+

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

191+post manager path decoder callback =

192+ let

193+ url = Website.route path []

194+ in

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

196+ \body ->

197+ case D.fromByteString decoder body of

198+ Right a -> Right <$> callback a

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

200+

201+

202+

203+-- BINARY

204+

205+

206+instance Binary Registry where

207+ get = liftM2 Registry get get

208+ put (Registry a b) = put a >> put b

209+

210+

211+instance Binary KnownVersions where

212+ get = liftM2 KnownVersions get get

213+ put (KnownVersions a b) = put a >> put b

builder/src/Deps/Solver.hs+399−58

@@ -1,89 +1,243 @@

1+{-# LANGUAGE OverloadedStrings, Rank2Types #-}

12module Deps.Solver

23 ( Solver

3− , run

4− , solve

4+ , Result(..)

5+ , Connection(..)

6+ --

7+ , Details(..)

8+ , verify

9+ --

10+ , AppSolution(..)

11+ , addToApp

12+ --

13+ , Env(..)

14+ , initEnv

515 )

616 where

717

818

9−import Control.Monad (foldM, guard, mzero, msum)

10−import Control.Monad.Logic (LogicT, runLogicT, lift)

11−import qualified Data.List as List

19+import Control.Monad (foldM)

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

1221import qualified Data.Map as Map

13−import Data.Map (Map)

22+import Data.Map ((!))

23+import qualified System.Directory as Dir

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

1425

15−import Elm.Package (Name, Version)

26+import qualified Deps.Registry as Registry

27+import qualified Deps.Website as Website

28+import qualified Elm.Constraint as C

29+import qualified Elm.Package as Pkg

30+import qualified Elm.Outline as Outline

31+import qualified Elm.Version as V

32+import qualified File

33+import qualified Http

34+import qualified Json.Decode as D

35+import qualified Reporting.Exit as Exit

36+import qualified Stuff

1637

17−import Deps.Explorer (Explorer)

18−import qualified Deps.Explorer as Explorer

19−import Elm.Project.Constraint (Constraint)

20−import qualified Elm.Project.Constraint as Con

2138

2239

40+-- SOLVER

41+

42+

43+newtype Solver a =

44+ Solver

45+ (

46+ forall b.

47+ State

48+ -> (State -> a -> (State -> IO b) -> IO b)

49+ -> (State -> IO b)

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

51+ -> IO b

52+ )

53+

2354

24−-- SOLVE

55+data State =

56+ State

57+ { _cache :: Stuff.PackageCache

58+ , _connection :: Connection

59+ , _registry :: Registry.Registry

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

61+ }

2562

2663

27−solve :: Map Name Constraint -> Solver (Map Name Version)

28−solve cons =

29− mkSolver (State Map.empty cons)

64+data Constraints =

65+ Constraints

66+ { _elm :: C.Constraint

67+ , _deps :: Map.Map Pkg.Name C.Constraint

68+ }

3069

3170

32−type Solver a =

33− LogicT Explorer a

71+data Connection

72+ = Online Http.Manager

73+ | Offline

3474

3575

36−run :: Solver a -> Explorer (Maybe a)

37−run solver =

38− runLogicT solver (const . return . Just) (return Nothing)

3976

77+-- RESULT

4078

4179

42−-- SOLVER

80+data Result a

81+ = Ok a

82+ | NoSolution

83+ | NoOfflineSolution

84+ | Err Exit.Solver

4385

4486

45−data State =

46− State

47− { _solution :: Map Name Version

48− , _unsolved :: Map Name Constraint

87+

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

89+

90+

91+data Details =

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

93+

94+

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

96+verify cache connection registry constraints =

97+ Stuff.withRegistryLock cache $

98+ case try constraints of

99+ Solver solver ->

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

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

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

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

104+

105+

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

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

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

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

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

111+

112+

113+noSolution :: Connection -> Result a

114+noSolution connection =

115+ case connection of

116+ Online _ -> NoSolution

117+ Offline -> NoOfflineSolution

118+

119+

120+

121+-- ADD TO APP - used in Install

122+

123+

124+data AppSolution =

125+ AppSolution

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

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

128+ , _app :: Outline.AppOutline

49129 }

50130

51131

52−mkSolver :: State -> Solver (Map Name Version)

53−mkSolver (State solution unsolved) =

54− case Map.minViewWithKey unsolved of

55− Nothing ->

56− return solution

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

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

134+ Stuff.withRegistryLock cache $

135+ let

136+ allIndirects = Map.union indirect testIndirect

137+ allDirects = Map.union direct testDirect

138+ allDeps = Map.union allDirects allIndirects

139+

140+ attempt toConstraint deps =

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

142+ in

143+ case

144+ oneOf

145+ ( attempt C.exactly allDeps )

146+ [ attempt C.exactly allDirects

147+ , attempt C.untilNextMinor allDirects

148+ , attempt C.untilNextMajor allDirects

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

150+ ]

151+ of

152+ Solver solver ->

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

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

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

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

157+

158+

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

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

161+ let

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

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

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

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

166+ in

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

168+

169+

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

171+getTransitive constraints solution unvisited visited =

172+ case unvisited of

173+ [] ->

174+ visited

175+

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

177+ if Map.member pkg visited

178+ then getTransitive constraints solution infos visited

179+ else

180+ let

181+ newDeps = _deps (constraints ! info)

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

183+ newVisited = Map.insert pkg vsn visited

184+ in

185+ getTransitive constraints solution infos $

186+ getTransitive constraints solution newUnvisited newVisited

187+

188+

57189

58− Just ((name, constraint), otherUnsolved) ->

59− do allVersions <- lift $ Explorer.getVersions name

60− let versions =

61− reverse $ List.sort $

62− filter (Con.satisfies constraint) allVersions

190+-- TRY

63191

64− let state1 = State solution otherUnsolved

65− state2 <- msum (map (addVersion state1 name) versions)

66− mkSolver state2

67192

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

194+try constraints =

195+ exploreGoals (Goals constraints Map.empty)

68196

69−addVersion :: State -> Name -> Version -> Solver State

70−addVersion (State solution unsolved) name version =

71− do (Explorer.Info elm cons) <-

72− lift $ Explorer.getConstraints name version

73197

74− guard (Con.goodElm elm)

75− newUnsolved <- foldM (addConstraint solution) unsolved (Map.toList cons)

76− return (State (Map.insert name version solution) newUnsolved)

77198

199+-- EXPLORE GOALS

78200

79−addConstraint :: Map Name Version -> Map Name Constraint -> (Name, Constraint) -> Solver (Map Name Constraint)

80−addConstraint solution unsolved (name, newConstraint) =

81− case Map.lookup name solution of

201+

202+data Goals =

203+ Goals

204+ { _pending :: Map.Map Pkg.Name C.Constraint

205+ , _solved :: Map.Map Pkg.Name V.Version

206+ }

207+

208+

209+exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)

210+exploreGoals (Goals pending solved) =

211+ case Map.minViewWithKey pending of

212+ Nothing ->

213+ return solved

214+

215+ Just ((name, constraint), otherPending) ->

216+ do let goals1 = Goals otherPending solved

217+ let addVsn = addVersion goals1 name

218+ (v,vs) <- getRelevantVersions name constraint

219+ goals2 <- oneOf (addVsn v) (map addVsn vs)

220+ exploreGoals goals2

221+

222+

223+addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals

224+addVersion (Goals pending solved) name version =

225+ do (Constraints elm deps) <- getConstraints name version

226+ if C.goodElm elm

227+ then

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

229+ return (Goals newPending (Map.insert name version solved))

230+ else

231+ backtrack

232+

233+

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

235+addConstraint solved unsolved (name, newConstraint) =

236+ case Map.lookup name solved of

82237 Just version ->

83− if Con.satisfies newConstraint version then

84− return unsolved

85− else

86− mzero

238+ if C.satisfies newConstraint version

239+ then return unsolved

240+ else backtrack

87241

88242 Nothing ->

89243 case Map.lookup name unsolved of

@@ -91,13 +245,200 @@ addConstraint solution unsolved (name, newConstraint) =

91245 return $ Map.insert name newConstraint unsolved

92246

93247 Just oldConstraint ->

94− case Con.intersect oldConstraint newConstraint of

248+ case C.intersect oldConstraint newConstraint of

95249 Nothing ->

96− mzero

250+ backtrack

97251

98252 Just mergedConstraint ->

99− if oldConstraint == mergedConstraint then

100− return unsolved

101− else

102− return (Map.insert name mergedConstraint unsolved)

253+ if oldConstraint == mergedConstraint

254+ then return unsolved

255+ else return (Map.insert name mergedConstraint unsolved)

256+

257+

258+

259+-- GET RELEVANT VERSIONS

260+

261+

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

263+getRelevantVersions name constraint =

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

265+ case Registry.getVersions name registry of

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

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

268+ [] -> back state

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

270+

271+ Nothing ->

272+ back state

273+

274+

275+

276+-- GET CONSTRAINTS

277+

278+

279+getConstraints :: Pkg.Name -> V.Version -> Solver Constraints

280+getConstraints pkg vsn =

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

282+ do let key = (pkg, vsn)

283+ case Map.lookup key cDict of

284+ Just cs ->

285+ ok state cs back

286+

287+ Nothing ->

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

289+ let home = Stuff.package cache pkg vsn

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

291+ outlineExists <- File.exists path

292+ if outlineExists

293+ then

294+ do bytes <- File.readUtf8 path

295+ case D.fromByteString constraintsDecoder bytes of

296+ Right cs ->

297+ case connection of

298+ Online _ ->

299+ ok (toNewState cs) cs back

300+

301+ Offline ->

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

303+ if srcExists

304+ then ok (toNewState cs) cs back

305+ else back state

306+

307+ Left _ ->

308+ do File.remove path

309+ err (Exit.SolverBadCacheData pkg vsn)

310+ else

311+ case connection of

312+ Offline ->

313+ back state

314+

315+ Online manager ->

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

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

318+ case result of

319+ Left httpProblem ->

320+ err (Exit.SolverBadHttp pkg vsn httpProblem)

321+

322+ Right body ->

323+ case D.fromByteString constraintsDecoder body of

324+ Right cs ->

325+ do Dir.createDirectoryIfMissing True home

326+ File.writeUtf8 path body

327+ ok (toNewState cs) cs back

328+

329+ Left _ ->

330+ err (Exit.SolverBadHttpData pkg vsn url)

331+

332+

333+constraintsDecoder :: D.Decoder () Constraints

334+constraintsDecoder =

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

336+ case outline of

337+ Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ elmConstraint) ->

338+ return (Constraints elmConstraint deps)

339+

340+ Outline.App _ ->

341+ D.failure ()

342+

343+

344+

345+-- ENVIRONMENT

346+

347+

348+data Env =

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

350+

351+

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

353+initEnv =

354+ do mvar <- newEmptyMVar

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

356+ cache <- Stuff.getPackageCache

357+ Stuff.withRegistryLock cache $

358+ do maybeRegistry <- Registry.read cache

359+ manager <- readMVar mvar

360+

361+ case maybeRegistry of

362+ Nothing ->

363+ do eitherRegistry <- Registry.fetch manager cache

364+ case eitherRegistry of

365+ Right latestRegistry ->

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

367+

368+ Left problem ->

369+ return $ Left $ problem

370+

371+ Just cachedRegistry ->

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

373+ case eitherRegistry of

374+ Right latestRegistry ->

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

376+

377+ Left _ ->

378+ return $ Right $ Env cache manager Offline cachedRegistry

379+

380+

381+

382+-- INSTANCES

383+

384+

385+instance Functor Solver where

386+ fmap func (Solver solver) =

387+ Solver $ \state ok back err ->

388+ let

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

390+ in

391+ solver state okA back err

392+

393+

394+instance Applicative Solver where

395+ pure a =

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

397+

398+ (<*>) (Solver solverFunc) (Solver solverArg) =

399+ Solver $ \state ok back err ->

400+ let

401+ okF stateF func backF =

402+ let

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

404+ in

405+ solverArg stateF okA backF err

406+ in

407+ solverFunc state okF back err

408+

409+

410+instance Monad Solver where

411+ return a =

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

413+

414+ (>>=) (Solver solverA) callback =

415+ Solver $ \state ok back err ->

416+ let

417+ okA stateA a backA =

418+ case callback a of

419+ Solver solverB -> solverB stateA ok backA err

420+ in

421+ solverA state okA back err

422+

423+

424+oneOf :: Solver a -> [Solver a] -> Solver a

425+oneOf solver@(Solver solverHead) solvers =

426+ case solvers of

427+ [] ->

428+ solver

429+

430+ s:ss ->

431+ Solver $ \state0 ok back err ->

432+ let

433+ tryTail state1 =

434+ let

435+ (Solver solverTail) = oneOf s ss

436+ in

437+ solverTail state1 ok back err

438+ in

439+ solverHead state0 ok tryTail err

440+

103441

442+backtrack :: Solver a

443+backtrack =

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

builder/src/Deps/Verify.hsdeleted−363

@@ -1,363 +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.Set as Set

13−import Data.Map (Map)

14−import Data.Set (Set)

15−import System.Directory (doesDirectoryExist)

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

17−

18−import qualified Elm.Compiler.Module as Module

19−import qualified Elm.Compiler.Objects as Obj

20−import qualified Elm.Docs as Docs

21−import Elm.Package (Name, Version)

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

23−import qualified Json.Encode as Encode

24−

25−import qualified Deps.Explorer as Explorer

26−import qualified Deps.Get as Get

27−import qualified Deps.Solver as Solver

28−import qualified Deps.Website as Website

29−import qualified Elm.Compiler as Compiler

30−import qualified Elm.Project.Json as Project

31−import qualified Elm.Project.Constraint as Con

32−import qualified Elm.Project.Summary as Summary

33−import qualified File.Args as Args

34−import qualified File.Artifacts as Artifacts

35−import qualified File.Compile as Compile

36−import qualified File.Crawl as Crawl

37−import qualified File.IO as IO

38−import qualified File.Plan as Plan

39−import qualified Reporting.Exit as Exit

40−import qualified Reporting.Exit.Deps as E

41−import qualified Reporting.Progress as Progress

42−import qualified Reporting.Task as Task

43−import qualified Stuff.Paths as Paths

44−

45−

46−

47−-- VERIFY

48−

49−

50−verify :: FilePath -> Project -> Task.Task (Map Name Version, Summary.Summary)

51−verify root project =

52− do solution <- Project.get verifyApp verifyPkg project

53− (RawInfo infos ifaces) <- verifyArtifacts solution

54− let summary = Summary.init root project infos ifaces

55− return (solution, summary)

56−

57−

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

59−throw exit =

60− Task.throw (Exit.Deps exit)

61−

62−

63−

64−-- VERIFY SOLUTION

65−

66−

67−verifyApp :: AppInfo -> Task.Task (Map Name Version)

68−verifyApp info =

69− if _app_elm_version info /= Compiler.version then

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

71−

72− else

73− do let oldSolution = Project.appSolution info

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

75− maybeSolution <- Explorer.run (Solver.run solver)

76− case maybeSolution of

77− Nothing ->

78− throw E.BadDeps

79−

80− Just solution ->

81− return solution

82−

83−

84−verifyPkg :: PkgInfo -> Task.Task (Map Name Version)

85−verifyPkg info =

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

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

88−

89− else

90− do let deps = Map.union (_pkg_deps info) (_pkg_test_deps info)

91− let solver = Solver.solve deps

92− maybeSolution <- Explorer.run (Solver.run solver)

93− case maybeSolution of

94− Nothing ->

95− throw E.BadDeps

96−

97− Just solution ->

98− return solution

99−

100−

101−

102−-- VERIFY ARTIFACTS

103−

104−

105−verifyArtifacts :: Map Name Version -> Task.Task RawInfo

106−verifyArtifacts solution =

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

108− verifyBuildArtifacts solution

109−

110−

111−noSrc :: (Name, Version) -> Task.Task Bool

112−noSrc (name, version) =

113− do root <- Task.getPackageCacheDirFor name version

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

115−

116−

117−

118−-- VERIFY BUILD ARTIFACTS

119−

120−

121−verifyBuildArtifacts :: Map Name Version -> Task.Task RawInfo

122−verifyBuildArtifacts solution =

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

124− startMVar <- liftIO newEmptyMVar

125− ifacesMVar <- liftIO $ newMVar Map.empty

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

127− liftIO $ putMVar startMVar pkgInfoMVars

128− answers <- liftIO $ traverse readMVar pkgInfoMVars

129− Task.report Progress.BuildDepsEnd

130− RawInfo

131− <$> Map.traverseMaybeWithKey toInfo answers

132− <*> liftIO (readMVar ifacesMVar)

133−

134−

135−data RawInfo =

136− RawInfo (Map Name PkgInfo) Module.Interfaces

137−

138−

139−verifyBuild

140− :: MVar (Map Name (MVar Answer))

141− -> MVar Module.Interfaces

142− -> Name

143− -> Version

144− -> Task.Task (MVar Answer)

145−verifyBuild pkgInfoMVar ifacesMVar name version =

146− do mvar <- liftIO newEmptyMVar

147− info <- Get.info name version

148− report <- Task.getReporter

149− runner <- Task.getSilentRunner

150−

151− liftIO $ void $ forkIO $

152− do allMVars <- readMVar pkgInfoMVar

153− let deps = Project._pkg_deps info

154− let depsMVars = Map.intersection allMVars deps

155− depAnswers <- traverse readMVar depsMVars

156−

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

158− do ifacesBefore <- readMVar ifacesMVar

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

160− case result of

161− Right ifaces ->

162− do ifacesNow <- takeMVar ifacesMVar

163− putMVar ifacesMVar (Map.union ifacesNow ifaces)

164− return (Ok info)

165−

166− Left _ ->

167− return (Err name version)

168−

169− report Progress.BuildDepsProgress

170− putMVar mvar answer

171−

172− return mvar

173−

174−

175−

176−-- ANSWERS

177−

178−

179−data Answer

180− = Ok PkgInfo

181− | Blocked

182− | Err Name Version

183−

184−

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

186−toInfo _ answer =

187− case answer of

188− Ok info ->

189− return (Just info)

190−

191− Blocked ->

192− return Nothing

193−

194− Err name version ->

195− throw (E.BuildFailure name version)

196−

197−

198−ifNotBlocked :: Map Name Answer -> (Map Name PkgInfo -> IO Answer) -> IO Answer

199−ifNotBlocked answers callback =

200− case traverse isOk answers of

201− Nothing ->

202− return Blocked

203−

204− Just infos ->

205− callback infos

206−

207−

208−isOk :: Answer -> Maybe PkgInfo

209−isOk answer =

210− case answer of

211− Ok info -> Just info

212− Blocked -> Nothing

213− Err _ _ -> Nothing

214−

215−

216−

217−-- GET INTERFACE

218−

219−

220−getIface

221− :: Name

222− -> Version

223− -> PkgInfo

224− -> Map Name PkgInfo

225− -> Module.Interfaces

226− -> Task.Task Module.Interfaces

227−getIface name version info infos depIfaces =

228− do root <- Task.getPackageCacheDirFor name version

229− let solution = Map.map _pkg_version infos

230−

231− cached <- isCached root solution

232−

233− if cached

234− then IO.readBinary (root </> "ifaces.dat")

235− else

236− do Paths.removeStuff root

237− let docsPath = root </> "docs.json"

238−

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

240− args <- Args.fromSummary summary

241− graph <- Crawl.crawl summary args

242− (dirty, cachedIfaces) <- Plan.plan (Just docsPath) summary graph

243− answers <- Compile.compile (Pkg info) (Just docsPath) cachedIfaces dirty

244− results <- Artifacts.ignore answers

245− _ <- Artifacts.writeDocs results docsPath

246−

247− Paths.removeStuff root

248−

249− updateCache root name info solution graph results

250−

251−

252−

253−-- IS CACHED?

254−

255−

256−isCached :: FilePath -> Map Name Version -> Task.Task Bool

257−isCached root solution =

258− IO.andM

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

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

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

262− , IO.exists (root </> "documentation.json")

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

264− ]

265−

266−

267−isCachedHelp :: Map Name Version -> Map Name (Set Version) -> Bool

268−isCachedHelp solution cachedDeps =

269− let

270− matches =

271− Map.intersectionWith Set.member solution cachedDeps

272− in

273− Map.size solution == Map.size matches

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

275−

276−

277−

278−-- UPDATE CACHE

279−

280−

281−updateCache

282− :: FilePath

283− -> Name

284− -> PkgInfo

285− -> Map Name Version

286− -> Crawl.Result

287− -> Map Module.Raw Compiler.Artifacts

288− -> Task.Task Module.Interfaces

289−updateCache root name info solution graph results =

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

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

292− let elmi = crush name info results

293−

294− exists <- IO.exists path

295−

296− if exists

297− then

298− do oldDeps <- IO.readBinary path

299− IO.writeBinary path (Map.unionWith Set.union deps oldDeps)

300− else

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

302−

303− IO.writeBinary path deps

304−

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

306− Map.foldr addGraph (objGraphFromKernels graph) results

307−

308− liftIO $ Encode.write (root </> "documentation.json") $

309− Encode.list Docs.encode $

310− Map.foldr addDocs [] results

311−

312− return elmi

313−

314−

315−

316−-- CRUSH INTERFACES

317−

318−

319−crush :: Name -> PkgInfo -> Map Module.Raw Compiler.Artifacts -> Module.Interfaces

320−crush pkg info results =

321− let

322− exposed =

323− Set.fromList (Project.getExposed info)

324− in

325− Map.mapKeys (Module.Canonical pkg) $

326− Map.mapMaybeWithKey (crushHelp exposed) results

327−

328−

329−crushHelp :: Set Module.Raw -> Module.Raw -> Compiler.Artifacts -> Maybe Module.Interface

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

331− if Set.member name exposed then

332− Just elmi

333−

334− else

335− Nothing

336−

337−

338−

339−-- DOCUMENTATION

340−

341−

342−addDocs :: Compiler.Artifacts -> [Docs.Module] -> [Docs.Module]

343−addDocs (Compiler.Artifacts _ _ maybeDocs) docsList =

344− case maybeDocs of

345− Nothing ->

346− docsList

347−

348− Just docs ->

349− docs : docsList

350−

351−

352−

353−-- OBJECT GRAPH

354−

355−

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

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

358− Obj.union elmo graph

359−

360−

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

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

363− Obj.fromKernels kernels

builder/src/Deps/Website.hs+14−333

@@ -1,345 +1,26 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

31module Deps.Website

4− ( getElmJson

5− , getDocs

6− , getNewPackages

7− , getAllPackages

8− , download

9− , githubCommit

10− , githubDownload

11− , Sha

12− , register

2+ ( domain

3+ , route

4+ , metadata

135 )

146 where

157

168

17−import Prelude hiding (zip)

18−import qualified Codec.Archive.Zip as Zip

19−import Control.Monad (void)

20−import qualified Data.Binary as Binary

21−import qualified Data.Binary.Get as Binary

22−import qualified Data.ByteString.Char8 as BS

23−import qualified Data.ByteString.Lazy as LBS

24−import qualified Data.Digest.Pure.SHA as SHA

25−import qualified Data.HashMap.Lazy as HashMap

26−import qualified Data.Map as Map

27−import qualified Data.Text as Text

28−import qualified Network.HTTP.Client as Client

29−import qualified Network.HTTP.Client.MultipartFormData as Multi

30−import qualified Network.HTTP.Types as Http

31−import qualified System.Directory as Dir

32−import System.FilePath ((</>), splitFileName)

33−

34−import Elm.Package (Name, Version)

359import qualified Elm.Package as Pkg

36−import qualified Json.Decode as D

37−

38−import qualified Reporting.Doc as D

39−import qualified Reporting.Exit.Http as E

40−import qualified Reporting.Progress as Progress

41−import qualified Reporting.Task as Task

42−import qualified Reporting.Task.Http as Http

43−import qualified Stuff.Paths as Path

44−

45−

46−

47−-- GET PACKAGE INFO

48−

49−

50−getElmJson :: Name -> Version -> Task.Task BS.ByteString

51−getElmJson name version =

52− Http.run $ fetchByteString $

53− "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/elm.json"

54−

55−

56−getDocs :: Name -> Version -> Task.Task BS.ByteString

57−getDocs name version =

58− Http.run $ fetchByteString $

59− "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/docs.json"

60−

61−

62−

63−-- NEW PACKAGES

64−

65−

66−getNewPackages :: Int -> Task.Task [(Name, Version)]

67−getNewPackages index =

68− Http.run $ fetchJson "packages" E.badJsonToDocs (D.list newPkgDecoder) ("all-packages/since/" ++ show index)

69−

70−

71−newPkgDecoder :: D.Decoder E.BadJson ( Name, Version )

72−newPkgDecoder =

73− do txt <- D.text

74− case Text.splitOn "@" txt of

75− [key, value] ->

76− case Pkg.fromText key of

77− Right pkg ->

78− case Pkg.versionFromText value of

79− Just vsn ->

80− D.succeed (pkg, vsn)

81−

82− Nothing ->

83− D.fail (E.BadNewPkg txt)

84−

85− Left _ ->

86− D.fail (E.BadNewPkg txt)

87−

88− _ ->

89− D.fail (E.BadNewPkg txt)

90−

91−

92−

93−-- ALL PACKAGES

94−

95−

96−getAllPackages :: Task.Task (Map.Map Name [Version])

97−getAllPackages =

98− Http.run $ fetchJson "packages" E.badJsonToDocs allPkgsDecoder "all-packages"

99−

100−

101−allPkgsDecoder :: D.Decoder E.BadJson (Map.Map Name [Version])

102−allPkgsDecoder =

103− let

104− checkKeys pairs pkgs =

105− case pairs of

106− [] ->

107− D.succeed pkgs

108−

109− (key, versions) : rest ->

110− case Pkg.fromText key of

111− Left (msg, _) ->

112− D.fail (E.BadAllPkg key msg)

113−

114− Right pkg ->

115− checkKeys rest (Map.insert pkg versions pkgs)

116− in

117− do dict <- D.dict (D.list (D.mapError E.BadAllVsn Pkg.versionDecoder))

118− checkKeys (HashMap.toList dict) Map.empty

119−

120−

121−

122−-- HELPERS

123−

124−

125−fetchByteString :: String -> Http.Fetch BS.ByteString

126−fetchByteString path =

127− Http.package path [] $ \request manager ->

128− do response <- Client.httpLbs request manager

129− return $ Right $ LBS.toStrict $ Client.responseBody response

130−

131−

132−fetchJson :: String -> (e -> [D.Doc]) -> D.Decoder e a -> String -> Http.Fetch a

133−fetchJson rootName errorToDocs decoder path =

134− Http.package path [] $ \request manager ->

135− do response <- Client.httpLbs request manager

136− let bytes = LBS.toStrict (Client.responseBody response)

137− case D.parse rootName errorToDocs decoder bytes of

138− Right value ->

139− return $ Right value

140−

141− Left jsonProblem ->

142− return $ Left $ E.BadJson path jsonProblem

143−

144−

145−

146−-- DOWNLOAD

147−

148−

149−download :: [(Name, Version)] -> Task.Task ()

150−download packages =

151− case packages of

152− [] ->

153− Task.report Progress.DownloadSkip

154−

155− _ ->

156− do cache <- Task.getPackageCacheDir

157−

158− let start = Progress.DownloadStart packages

159− let toEnd = Progress.DownloadEnd

160−

161− void $ Http.run $ Http.report start toEnd $

162− Http.parallel $ map (downloadHelp cache) packages

163−

164−

165−downloadHelp :: FilePath -> (Name, Version) -> Http.Fetch ()

166−downloadHelp cache (name, version) =

167− let

168− endpointUrl =

169− "packages/" ++ Pkg.toUrl name ++ "/" ++ Pkg.versionToString version ++ "/endpoint.json"

170− in

171− Http.andThen (fetchJson "version" id endpointDecoder endpointUrl) $ \(endpoint, hash) ->

172− let

173− start = Progress.DownloadPkgStart name version

174− toEnd = Progress.DownloadPkgEnd name version

175− in

176− Http.report start toEnd $

177− Http.anything endpoint $ \request manager ->

178− Client.withResponse request manager (downloadArchive cache name version hash)

179−

180−

181−endpointDecoder :: D.Decoder e (String, String)

182−endpointDecoder =

183− D.map2 (,)

184− (D.field "url" D.string)

185− (D.field "hash" D.string)

186−

187−

188−

189−-- DOWNLOAD ZIP ARCHIVE

190−

191−

192−downloadArchive :: FilePath -> Name -> Version -> String -> Client.Response Client.BodyReader -> IO (Either E.Exit ())

193−downloadArchive cache name version expectedHash response =

194− do result <- readArchive (Client.responseBody response) initialArchiveState

195− case result of

196− Left msg ->

197− return (Left msg)

198−

199− Right (sha, archive) ->

200− if expectedHash == SHA.showDigest sha then

201− Right <$> writeArchive archive (cache </> Pkg.toFilePath name) (Pkg.versionToString version)

202− else

203− return $ Left $ E.BadZipSha expectedHash (SHA.showDigest sha)

204−

205−

206−

207−-- READ ARCHIVE

208−

209−

210−data ArchiveState =

211− AS

212− { _len :: !Int

213− , _sha :: !(Binary.Decoder SHA.SHA1State)

214− , _zip :: !(Binary.Decoder Zip.Archive)

215− }

216−

217−

218−initialArchiveState :: ArchiveState

219−initialArchiveState =

220− AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)

221−

222−

223−type Sha = SHA.Digest SHA.SHA1State

224−

225−

226−readArchive :: Client.BodyReader -> ArchiveState -> IO (Either E.Exit (Sha, Zip.Archive))

227−readArchive body (AS len sha zip) =

228− case zip of

229− Binary.Fail _ _ _ ->

230− return $ Left E.BadZipData

231−

232− Binary.Partial k ->

233− do chunk <- Client.brRead body

234− readArchive body $ AS

235− { _len = len + BS.length chunk

236− , _sha = Binary.pushChunk sha chunk

237− , _zip = k (if BS.null chunk then Nothing else Just chunk)

238− }

239−

240− Binary.Done _ _ archive ->

241− return $ Right ( SHA.completeSha1Incremental sha len, archive )

242−

243−

244−

245−-- WRITE ARCHIVE

246−

247−

248−writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()

249−writeArchive archive destination newRoot =

250− do Dir.createDirectoryIfMissing True destination

251− let opts = [Zip.OptDestination destination]

252− mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)

253−

254−

255−replaceRoot :: String -> Zip.Entry -> Zip.Entry

256−replaceRoot root entry =

257− let

258− rootless =

259− dropWhile (/='/') (Zip.eRelativePath entry)

260− in

261− entry { Zip.eRelativePath = root ++ rootless }

262−

263−

264−

265−-- FIND TAGGED COMMIT ON GITHUB

266−

267−

268−githubCommit :: Name -> Version -> Task.Task String

269−githubCommit name version =

270− let

271− endpoint =

272− "https://api.github.com/repos/" ++ Pkg.toUrl name ++ "/git/refs/tags/alpha-" ++ Pkg.versionToString version

273−

274− headers =

275− [ ( Http.hUserAgent, "elm-cli" )

276− , ( Http.hAccept, "application/json" )

277− ]

278−

279− decoder =

280− D.at ["object","sha"] D.string

281− in

282− Http.run $ Http.anything endpoint $ \request manager ->

283− do response <- Client.httpLbs (request { Client.requestHeaders = headers }) manager

284− let bytes = LBS.toStrict (Client.responseBody response)

285− case D.parse "github" id decoder bytes of

286− Right value ->

287− return $ Right value

288−

289− Left jsonProblem ->

290− return $ Left $ E.BadJson "github.json" jsonProblem

291−

292−

293−

294−-- DOWNLOAD FROM GITHUB

295−

296−

297−githubDownload :: Name -> Version -> FilePath -> Task.Task Sha

298−githubDownload name version dir =

299− let

300− endpoint =

301− "https://github.com/" ++ Pkg.toUrl name ++ "/zipball/alpha-" ++ Pkg.versionToString version ++ "/"

302− in

303− Http.run $ Http.anything endpoint $ \request manager ->

304− Client.withResponse request manager (githubDownloadHelp dir)

305−

306−

307−githubDownloadHelp :: FilePath -> Client.Response Client.BodyReader -> IO (Either E.Exit Sha)

308−githubDownloadHelp targetDir response =

309− do result <- readArchive (Client.responseBody response) initialArchiveState

310− case result of

311− Left msg ->

312− return (Left msg)

313−

314− Right (sha, archive) ->

315− do let (dir, root) = splitFileName targetDir

316− writeArchive archive dir root

317− return $ Right sha

10+import qualified Elm.Version as V

11+import qualified Http

31812

31913

14+domain :: String

15+domain =

16+ "https://package.elm-lang.org"

32017

321−-- REGISTER PACKAGES

32218

19+route :: String -> [(String,String)] -> String

20+route path params =

21+ Http.toUrl (domain ++ path) params

32322

324−register :: Name -> Version -> String -> Sha -> Task.Task ()

325−register name version commitHash digest =

326− let

327− params =

328− [ ("name", Pkg.toString name)

329− , ("version", Pkg.versionToString version)

330− , ("commit-hash", commitHash)

331− ]

33223

333− files =

334− [ Multi.partFileSource "elm.json" "elm.json"

335− , Multi.partFileSource "docs.json" Path.docs

336− , Multi.partFileSource "README.md" "README.md"

337− , Multi.partFileRequestBody "github-hash" "github-hash" $

338− Client.RequestBodyBS (BS.pack (SHA.showDigest digest))

339− ]

340− in

341− Http.run $ Http.package "register" params $ \rawRequest manager ->

342− do requestWithBody <- Multi.formDataBody files rawRequest

343− let request = requestWithBody { Client.responseTimeout = Client.responseTimeoutNone }

344− void $ Client.httpLbs request manager

345− return $ Right ()

24+metadata :: Pkg.Name -> V.Version -> String -> String

25+metadata name version file =

26+ domain ++ "/packages/" ++ Pkg.toUrl name ++ "/" ++ V.toChars version ++ "/" ++ file

builder/src/Elm/Bump.hsdeleted−139

@@ -1,139 +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.Diff as Diff

13−import qualified Deps.Get as Get

14−import qualified Elm.Package as Pkg

15−import qualified Elm.Project as Project

16−import qualified Elm.Project.Json as Project

17−import qualified Elm.Project.Summary as Summary

18−import Reporting.Doc ((<>), (<+>))

19−import qualified Reporting.Doc as D

20−import qualified Reporting.Exit as Exit

21−import qualified Reporting.Exit.Bump as E

22−import qualified Reporting.Exit.Help as Help

23−import qualified Reporting.Progress.Terminal as Terminal

24−import qualified Reporting.Task as Task

25−

26−

27−

28−-- BUMP

29−

30−

31−bump :: Summary.Summary -> Task.Task ()

32−bump summary@(Summary.Summary root project _ _ _) =

33− case project of

34− Project.App _ ->

35− Task.throw (Exit.Bump E.Application)

36−

37− Project.Pkg info@(Project.PkgInfo name _ _ version _ _ _ _) ->

38− do pkgs <- Get.all Get.RequireLatest

39− case Get.versions name pkgs of

40− Left _suggestions ->

41− checkNewPackage root info

42−

43− Right publishedVersions ->

44− let

45− bumpableVersions =

46− map (\(old, _, _) -> old) (toPossibleBumps publishedVersions)

47− in

48− if elem version bumpableVersions then

49− suggestVersion summary info

50− else

51− Task.throw $ Exit.Bump $ E.Unbumpable version $

52− map head (List.group (List.sort bumpableVersions))

53−

54−

55−

56−-- VALID BUMPS

57−

58−

59−toPossibleBumps :: [Pkg.Version] -> [(Pkg.Version, Pkg.Version, Diff.Magnitude)]

60−toPossibleBumps publishedVersions =

61− case publishedVersions of

62− [] ->

63− []

64−

65− _ ->

66− let

67− patchPoints =

68− Pkg.filterLatest Pkg.majorAndMinor publishedVersions

69−

70− minorPoints =

71− Pkg.filterLatest Pkg._major publishedVersions

72−

73− majorPoint =

74− maximum publishedVersions

75− in

76− (majorPoint, Pkg.bumpMajor majorPoint, Diff.MAJOR)

77− : map (\v -> (v, Pkg.bumpMinor v, Diff.MINOR)) minorPoints

78− ++ map (\v -> (v, Pkg.bumpPatch v, Diff.PATCH)) patchPoints

79−

80−

81−

82−-- CHECK NEW PACKAGE

83−

84−

85−checkNewPackage :: FilePath -> Project.PkgInfo -> Task.Task ()

86−checkNewPackage root info@(Project.PkgInfo _ _ _ version _ _ _ _) =

87− do liftIO $ putStrLn Terminal.newPackageOverview

88− if version == Pkg.initialVersion

89− then

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

91− else

92− changeVersion root info Pkg.initialVersion $

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

94− \Would you like me to change it back to "

95− <> D.fromText (Pkg.versionToText Pkg.initialVersion) <> "? [Y/n] "

96−

97−

98−

99−-- SUGGEST VERSION

100−

101−

102−suggestVersion :: Summary.Summary -> Project.PkgInfo -> Task.Task ()

103−suggestVersion summary@(Summary.Summary root _ _ _ _) info@(Project.PkgInfo name _ _ version _ _ _ _) =

104− do oldDocs <- Get.docs name version

105− newDocs <- Task.silently (Project.generateDocs summary)

106− let changes = Diff.diff oldDocs newDocs

107− let newVersion = Diff.bump changes version

108− changeVersion root info newVersion $

109− let

110− old = D.fromText $ Pkg.versionToText version

111− new = D.fromText $ Pkg.versionToText newVersion

112− mag = D.fromString $ Diff.magnitudeToString (Diff.toMagnitude changes)

113− in

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

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

116− <> "\n"

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

118−

119−

120−

121−-- CHANGE VERSION

122−

123−

124−changeVersion :: FilePath -> Project.PkgInfo -> Pkg.Version -> D.Doc -> Task.Task ()

125−changeVersion root info targetVersion explanation =

126− do liftIO $ Help.toStdout explanation

127− approved <- Task.getApproval

128− if not approved

129− then

130− liftIO $ putStrLn "Okay, no changes were made."

131−

132− else

133− do liftIO $ Project.write root $ Project.Pkg $

134− info { Project._pkg_version = targetVersion }

135−

136− liftIO $ Help.toStdout $

137− "Version changed to "

138− <> D.green (D.fromText (Pkg.versionToText targetVersion))

139− <> "!\n"

builder/src/Elm/Details.hsnew file+833

@@ -0,0 +1,833 @@

1+{-# OPTIONS_GHC -Wall #-}

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

3+module Elm.Details

4+ ( Details(..)

5+ , BuildID

6+ , ValidOutline(..)

7+ , Local(..)

8+ , Foreign(..)

9+ , load

10+ , loadObjects

11+ , loadInterfaces

12+ , verifyInstall

13+ )

14+ where

15+

16+

17+import Control.Concurrent (forkIO)

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

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

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

21+import qualified Data.Either as Either

22+import qualified Data.Map as Map

23+import qualified Data.Map.Utils as Map

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

25+import qualified Data.Maybe as Maybe

26+import qualified Data.Name as Name

27+import qualified Data.NonEmptyList as NE

28+import qualified Data.OneOrMore as OneOrMore

29+import qualified Data.Set as Set

30+import qualified Data.Utf8 as Utf8

31+import Data.Word (Word64)

32+import qualified System.Directory as Dir

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

34+

35+import qualified AST.Canonical as Can

36+import qualified AST.Source as Src

37+import qualified AST.Optimized as Opt

38+import qualified BackgroundWriter as BW

39+import qualified Compile

40+import qualified Deps.Registry as Registry

41+import qualified Deps.Solver as Solver

42+import qualified Deps.Website as Website

43+import qualified Elm.Constraint as Con

44+import qualified Elm.Docs as Docs

45+import qualified Elm.Interface as I

46+import qualified Elm.Kernel as Kernel

47+import qualified Elm.ModuleName as ModuleName

48+import qualified Elm.Outline as Outline

49+import qualified Elm.Package as Pkg

50+import qualified Elm.Version as V

51+import qualified File

52+import qualified Http

53+import qualified Json.Decode as D

54+import qualified Json.Encode as E

55+import qualified Parse.Module as Parse

56+import qualified Reporting

57+import qualified Reporting.Annotation as A

58+import qualified Reporting.Exit as Exit

59+import qualified Reporting.Task as Task

60+import qualified Stuff

61+

62+

63+

64+-- DETAILS

65+

66+

67+data Details =

68+ Details

69+ { _outlineTime :: File.Time

70+ , _outline :: ValidOutline

71+ , _buildID :: BuildID

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

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

74+ , _extras :: Extras

75+ }

76+

77+

78+type BuildID = Word64

79+

80+

81+data ValidOutline

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

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

84+

85+

86+-- NOTE: we need two ways to detect if a file must be recompiled:

87+--

88+-- (1) _time is the modification time from the last time we compiled the file.

89+-- By checking EQUALITY with the current modification time, we can detect file

90+-- saves and `git checkout` of previous versions. Both need a recompile.

91+--

92+-- (2) _lastChange is the BuildID from the last time a new interface file was

93+-- generated, and _lastCompile is the BuildID from the last time the file was

94+-- compiled. These may be different if a file is recompiled but the interface

95+-- stayed the same. When the _lastCompile is LESS THAN the _lastChange of any

96+-- imports, we need to recompile. This can happen when a project has multiple

97+-- entrypoints and some modules are compiled less often than their imports.

98+--

99+data Local =

100+ Local

101+ { _path :: FilePath

102+ , _time :: File.Time

103+ , _deps :: [ModuleName.Raw]

104+ , _main :: Bool

105+ , _lastChange :: BuildID

106+ , _lastCompile :: BuildID

107+ }

108+

109+

110+data Foreign =

111+ Foreign Pkg.Name [Pkg.Name]

112+

113+

114+data Extras

115+ = ArtifactsCached

116+ | ArtifactsFresh Interfaces Opt.GlobalGraph

117+

118+

119+type Interfaces =

120+ Map.Map ModuleName.Canonical I.DependencyInterface

121+

122+

123+

124+-- LOAD ARTIFACTS

125+

126+

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

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

129+ case extras of

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

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

132+

133+

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

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

136+ case extras of

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

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

139+

140+

141+

142+-- VERIFY INSTALL -- used by Install

143+

144+

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

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

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

148+ let key = Reporting.ignorer

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

150+ case outline of

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

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

153+

154+

155+

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

157+

158+

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

160+load style scope root =

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

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

163+ case maybeDetails of

164+ Nothing ->

165+ generate style scope root newTime

166+

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

168+ if oldTime == newTime

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

170+ else generate style scope root newTime

171+

172+

173+

174+-- GENERATE

175+

176+

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

178+generate style scope root time =

179+ Reporting.trackDetails style $ \key ->

180+ do result <- initEnv key scope root

181+ case result of

182+ Left exit ->

183+ return (Left exit)

184+

185+ Right (env, outline) ->

186+ case outline of

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

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

189+

190+

191+

192+-- ENV

193+

194+

195+data Env =

196+ Env

197+ { _key :: Reporting.DKey

198+ , _scope :: BW.Scope

199+ , _root :: FilePath

200+ , _cache :: Stuff.PackageCache

201+ , _manager :: Http.Manager

202+ , _connection :: Solver.Connection

203+ , _registry :: Registry.Registry

204+ }

205+

206+

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

208+initEnv key scope root =

209+ do mvar <- fork Solver.initEnv

210+ eitherOutline <- Outline.read root

211+ case eitherOutline of

212+ Left problem ->

213+ return $ Left $ Exit.DetailsBadOutline problem

214+

215+ Right outline ->

216+ do maybeEnv <- readMVar mvar

217+ case maybeEnv of

218+ Left problem ->

219+ return $ Left $ Exit.DetailsCannotGetRegistry problem

220+

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

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

223+

224+

225+

226+-- VERIFY PROJECT

227+

228+

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

230+

231+

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

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

234+ if Con.goodElm elm

235+ then

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

237+ let exposedList = Outline.flattenExposed exposed

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

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

240+ else

241+ Task.throw $ Exit.DetailsBadElmInPkg elm

242+

243+

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

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

246+ if elmVersion == V.compiler

247+ then

248+ do stated <- checkAppDeps outline

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

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

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

252+ else Task.throw $ Exit.DetailsHandEditedDependencies

253+ else

254+ Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion

255+

256+

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

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

259+ do x <- union allowEqualDups indirect testDirect

260+ y <- union noDups direct testIndirect

261+ union noDups x y

262+

263+

264+

265+-- VERIFY CONSTRAINTS

266+

267+

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

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

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

271+ case result of

272+ Solver.Ok details -> return details

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

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

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

276+

277+

278+

279+-- UNION

280+

281+

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

283+union tieBreaker deps1 deps2 =

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

285+

286+

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

288+noDups _ _ _ =

289+ Task.throw Exit.DetailsHandEditedDependencies

290+

291+

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

293+allowEqualDups _ v1 v2 =

294+ if v1 == v2

295+ then return v1

296+ else Task.throw Exit.DetailsHandEditedDependencies

297+

298+

299+

300+-- FORK

301+

302+

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

304+fork work =

305+ do mvar <- newEmptyMVar

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

307+ return mvar

308+

309+

310+

311+-- VERIFY DEPENDENCIES

312+

313+

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

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

316+ Task.eio id $

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

318+ mvar <- newEmptyMVar

319+ mvars <- Stuff.withRegistryLock cache $

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

321+ putMVar mvar mvars

322+ deps <- traverse readMVar mvars

323+ case sequence deps of

324+ Left _ ->

325+ do home <- Stuff.getElmHome

326+ return $ Left $ Exit.DetailsBadDeps home $

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

328+

329+ Right artifacts ->

330+ let

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

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

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

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

335+ in

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

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

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

339+ return (Right details)

340+

341+

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

343+addObjects (Artifacts _ objs) graph =

344+ Opt.addGlobalGraph objs graph

345+

346+

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

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

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

350+ if Map.member pkg directDeps

351+ then ifaces

352+ else Map.map I.privatize ifaces

353+

354+

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

356+gatherForeigns pkg (Artifacts ifaces _) foreigns =

357+ let

358+ isPublic di =

359+ case di of

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

361+ I.Private _ _ _ -> Nothing

362+ in

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

364+

365+

366+

367+-- VERIFY DEPENDENCY

368+

369+

370+data Artifacts =

371+ Artifacts

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

373+ , _objects :: Opt.GlobalGraph

374+ }

375+

376+

377+type Dep =

378+ Either (Maybe Exit.DetailsBadDep) Artifacts

379+

380+

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

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

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

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

385+ if exists

386+ then

387+ do Reporting.report key Reporting.DCached

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

389+ case maybeCache of

390+ Nothing ->

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

392+

393+ Just (ArtifactCache fingerprints artifacts) ->

394+ if Set.member fingerprint fingerprints

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

396+ else build key cache depsMVar pkg details fingerprint fingerprints

397+ else

398+ do Reporting.report key Reporting.DRequested

399+ result <- downloadPackage cache manager pkg vsn

400+ case result of

401+ Left problem ->

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

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

404+

405+ Right () ->

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

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

408+

409+

410+

411+-- ARTIFACT CACHE

412+

413+

414+data ArtifactCache =

415+ ArtifactCache

416+ { _fingerprints :: Set.Set Fingerprint

417+ , _artifacts :: Artifacts

418+ }

419+

420+

421+type Fingerprint =

422+ Map.Map Pkg.Name V.Version

423+

424+

425+

426+-- BUILD

427+

428+

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

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

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

432+ case eitherOutline of

433+ Left _ ->

434+ do Reporting.report key Reporting.DBroken

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

436+

437+ Right (Outline.App _) ->

438+ do Reporting.report key Reporting.DBroken

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

440+

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

442+ do allDeps <- readMVar depsMVar

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

444+ case sequence directDeps of

445+ Left _ ->

446+ do Reporting.report key Reporting.DBroken

447+ return $ Left $ Nothing

448+

449+ Right directArtifacts ->

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

451+ let foreignDeps = gatherForeignInterfaces directArtifacts

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

453+ docsStatus <- getDocsStatus cache pkg vsn

454+ mvar <- newEmptyMVar

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

456+ putMVar mvar mvars

457+ mapM_ readMVar mvars

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

459+ case sequence maybeStatuses of

460+ Nothing ->

461+ do Reporting.report key Reporting.DBroken

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

463+

464+ Just statuses ->

465+ do rmvar <- newEmptyMVar

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

467+ putMVar rmvar rmvars

468+ maybeResults <- traverse readMVar rmvars

469+ case sequence maybeResults of

470+ Nothing ->

471+ do Reporting.report key Reporting.DBroken

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

473+

474+ Just results ->

475+ let

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

477+ ifaces = gatherInterfaces exposedDict results

478+ objects = gatherObjects results

479+ artifacts = Artifacts ifaces objects

480+ fingerprints = Set.insert f fs

481+ in

482+ do writeDocs cache pkg vsn docsStatus results

483+ File.writeBinary path (ArtifactCache fingerprints artifacts)

484+ Reporting.report key Reporting.DBuilt

485+ return (Right artifacts)

486+

487+

488+

489+-- GATHER

490+

491+

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

493+gatherObjects results =

494+ Map.foldrWithKey addLocalGraph Opt.empty results

495+

496+

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

498+addLocalGraph name status graph =

499+ case status of

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

501+ RForeign _ -> graph

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

503+ RKernelForeign -> graph

504+

505+

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

507+gatherInterfaces exposed artifacts =

508+ let

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

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

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

512+ in

513+ Map.merge onLeft onRight onBoth exposed artifacts

514+

515+

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

517+toLocalInterface func result =

518+ case result of

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

520+ RForeign _ -> Nothing

521+ RKernelLocal _ -> Nothing

522+ RKernelForeign -> Nothing

523+

524+

525+

526+-- GATHER FOREIGN INTERFACES

527+

528+

529+data ForeignInterface

530+ = ForeignAmbiguous

531+ | ForeignSpecific I.Interface

532+

533+

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

535+gatherForeignInterfaces directArtifacts =

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

537+ Map.foldrWithKey gather Map.empty directArtifacts

538+ where

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

540+ finalize i is =

541+ case is of

542+ [] -> ForeignSpecific i

543+ _:_ -> ForeignAmbiguous

544+

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

546+ gather _ (Artifacts ifaces _) buckets =

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

548+

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

550+ isPublic di =

551+ case di of

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

553+ I.Private _ _ _ -> Nothing

554+

555+

556+

557+-- CRAWL

558+

559+

560+type StatusDict =

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

562+

563+

564+data Status

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

566+ | SForeign I.Interface

567+ | SKernelLocal [Kernel.Chunk]

568+ | SKernelForeign

569+

570+

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

572+crawlModule foreignDeps mvar pkg src docsStatus name =

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

574+ exists <- File.exists path

575+ case Map.lookup name foreignDeps of

576+ Just ForeignAmbiguous ->

577+ return Nothing

578+

579+ Just (ForeignSpecific iface) ->

580+ if exists

581+ then return Nothing

582+ else return (Just (SForeign iface))

583+

584+ Nothing ->

585+ if exists then

586+ crawlFile foreignDeps mvar pkg src docsStatus name path

587+

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

589+ crawlKernel foreignDeps mvar pkg src name

590+

591+ else

592+ return Nothing

593+

594+

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

596+crawlFile foreignDeps mvar pkg src docsStatus expectedName path =

597+ do bytes <- File.readUtf8 path

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

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

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

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

602+

603+ _ ->

604+ return Nothing

605+

606+

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

608+crawlImports foreignDeps mvar pkg src imports =

609+ do statusDict <- takeMVar mvar

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

611+ let news = Map.difference deps statusDict

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

613+ putMVar mvar (Map.union mvars statusDict)

614+ mapM_ readMVar mvars

615+ return deps

616+

617+

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

619+crawlKernel foreignDeps mvar pkg src name =

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

621+ exists <- File.exists path

622+ if exists

623+ then

624+ do bytes <- File.readUtf8 path

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

626+ Nothing ->

627+ return Nothing

628+

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

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

631+ return (Just (SKernelLocal chunks))

632+ else

633+ return (Just SKernelForeign)

634+

635+

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

637+getDepHome fi =

638+ case fi of

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

640+ ForeignAmbiguous -> Nothing

641+

642+

643+

644+-- COMPILE

645+

646+

647+data Result

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

649+ | RForeign I.Interface

650+ | RKernelLocal [Kernel.Chunk]

651+ | RKernelForeign

652+

653+

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

655+compile pkg mvar status =

656+ case status of

657+ SLocal docsStatus deps modul ->

658+ do resultsDict <- readMVar mvar

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

660+ case sequence maybeResults of

661+ Nothing ->

662+ return Nothing

663+

664+ Just results ->

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

666+ Left _ ->

667+ return Nothing

668+

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

670+ let

671+ ifaces = I.fromModule pkg canonical annotations

672+ docs = makeDocs docsStatus canonical

673+ in

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

675+

676+ SForeign iface ->

677+ return (Just (RForeign iface))

678+

679+ SKernelLocal chunks ->

680+ return (Just (RKernelLocal chunks))

681+

682+ SKernelForeign ->

683+ return (Just RKernelForeign)

684+

685+

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

687+getInterface result =

688+ case result of

689+ RLocal iface _ _ -> Just iface

690+ RForeign iface -> Just iface

691+ RKernelLocal _ -> Nothing

692+ RKernelForeign -> Nothing

693+

694+

695+

696+-- MAKE DOCS

697+

698+

699+data DocsStatus

700+ = DocsNeeded

701+ | DocsNotNeeded

702+

703+

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

705+getDocsStatus cache pkg vsn =

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

707+ if exists

708+ then return DocsNotNeeded

709+ else return DocsNeeded

710+

711+

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

713+makeDocs status modul =

714+ case status of

715+ DocsNeeded ->

716+ case Docs.fromModule modul of

717+ Right docs -> Just docs

718+ Left _ -> Nothing

719+

720+ DocsNotNeeded ->

721+ Nothing

722+

723+

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

725+writeDocs cache pkg vsn status results =

726+ case status of

727+ DocsNeeded ->

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

729+ Docs.encode $ Map.mapMaybe toDocs results

730+

731+ DocsNotNeeded ->

732+ return ()

733+

734+

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

736+toDocs result =

737+ case result of

738+ RLocal _ _ docs -> docs

739+ RForeign _ -> Nothing

740+ RKernelLocal _ -> Nothing

741+ RKernelForeign -> Nothing

742+

743+

744+

745+-- DOWNLOAD PACKAGE

746+

747+

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

749+downloadPackage cache manager pkg vsn =

750+ let

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

752+ in

753+ do eitherByteString <-

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

755+

756+ case eitherByteString of

757+ Left err ->

758+ return $ Left $ Exit.PP_BadEndpointRequest err

759+

760+ Right byteString ->

761+ case D.fromByteString endpointDecoder byteString of

762+ Left _ ->

763+ return $ Left $ Exit.PP_BadEndpointContent url

764+

765+ Right (endpoint, expectedHash) ->

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

767+ \(sha, archive) ->

768+ if expectedHash == Http.shaToChars sha

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

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

771+

772+

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

774+endpointDecoder =

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

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

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

778+

779+

780+

781+-- BINARY

782+

783+

784+instance Binary Details where

785+ put (Details a b c d e _) = put a >> put b >> put c >> put d >> put e

786+ get =

787+ do a <- get

788+ b <- get

789+ c <- get

790+ d <- get

791+ e <- get

792+ return (Details a b c d e ArtifactsCached)

793+

794+

795+instance Binary ValidOutline where

796+ put outline =

797+ case outline of

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

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

800+

801+ get =

802+ do n <- getWord8

803+ case n of

804+ 0 -> liftM ValidApp get

805+ 1 -> liftM3 ValidPkg get get get

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

807+

808+

809+instance Binary Local where

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

811+ get =

812+ do a <- get

813+ b <- get

814+ c <- get

815+ d <- get

816+ e <- get

817+ f <- get

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

819+

820+

821+instance Binary Foreign where

822+ get = liftM2 Foreign get get

823+ put (Foreign a b) = put a >> put b

824+

825+

826+instance Binary Artifacts where

827+ get = liftM2 Artifacts get get

828+ put (Artifacts a b) = put a >> put b

829+

830+

831+instance Binary ArtifactCache where

832+ get = liftM2 ArtifactCache get get

833+ put (ArtifactCache a b) = put a >> put b

builder/src/Elm/Diff.hsdeleted−279

@@ -1,279 +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−

15−import Deps.Diff (PackageChanges(..), ModuleChanges(..), Changes(..), Magnitude(..))

16−import qualified Deps.Diff as Diff

17−import qualified Deps.Get as Get

18−import qualified Elm.Compiler.Module as Module

19−import qualified Elm.Compiler.Type as Type

20−import qualified Elm.Docs as Docs

21−import qualified Elm.Name as N

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 Reporting.Doc ((<>), (<+>))

27−import qualified Reporting.Doc as D

28−import qualified Reporting.Exit as Exit

29−import qualified Reporting.Exit.Diff as E

30−import qualified Reporting.Exit.Help as Help

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

32−import qualified Reporting.Task as Task

33−

34−

35−

36−-- DIFF

37−

38−

39−data Args

40− = CodeVsLatest

41− | CodeVsExactly Pkg.Version

42− | LocalInquiry Pkg.Version Pkg.Version

43− | GlobalInquiry Pkg.Name Pkg.Version Pkg.Version

44−

45−

46−diff :: Args -> Task.Task ()

47−diff args =

48− case args of

49− GlobalInquiry name v1 v2 ->

50− do pkgs <- Get.all Get.RequireLatest

51− case Get.versions name pkgs of

52− Left suggestions ->

53− throw $ E.UnknownPackage name suggestions

54−

55− Right vsns ->

56− do oldDocs <- getDocs name vsns (min v1 v2)

57− newDocs <- getDocs name vsns (max v1 v2)

58− writeDiff oldDocs newDocs

59−

60− LocalInquiry v1 v2 ->

61− do (_, name, vsns) <- getPackageInfo

62− oldDocs <- getDocs name vsns (min v1 v2)

63− newDocs <- getDocs name vsns (max v1 v2)

64− writeDiff oldDocs newDocs

65−

66− CodeVsLatest ->

67− do (summary, name, vsns) <- getPackageInfo

68− oldDocs <- getDocs name vsns (maximum vsns)

69− newDocs <- Task.silently (Project.generateDocs summary)

70− writeDiff oldDocs newDocs

71−

72− CodeVsExactly version ->

73− do (summary, name, vsns) <- getPackageInfo

74− oldDocs <- getDocs name vsns version

75− newDocs <- Task.silently (Project.generateDocs summary)

76− writeDiff oldDocs newDocs

77−

78−

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

80−throw exit =

81− Task.throw $ Exit.Diff exit

82−

83−

84−

85−-- DIFF HELPERS

86−

87−

88−getDocs :: Pkg.Name -> [Pkg.Version] -> Pkg.Version -> Task.Task Docs.Documentation

89−getDocs name allVersions version =

90− if elem version allVersions then

91− Get.docs name version

92− else

93− throw $ E.UnknownVersion name version allVersions

94−

95−

96−getPackageInfo :: Task.Task (Summary.Summary, Pkg.Name, [Pkg.Version])

97−getPackageInfo =

98− do summary <- Project.getRoot

99− case Summary._project summary of

100− Project.App _ ->

101− throw $ E.Application

102−

103− Project.Pkg (Project.PkgInfo name _ _ _ _ _ _ _) ->

104− do pkgs <- Get.all Get.RequireLatest

105− let vsns = either (const []) id (Get.versions name pkgs)

106− return ( summary, name, vsns )

107−

108−

109−

110−-- WRITE DOC

111−

112−

113−writeDiff :: Docs.Documentation -> Docs.Documentation -> Task.Task ()

114−writeDiff oldDocs newDocs =

115− let

116− changes = Diff.diff oldDocs newDocs

117− localizer = L.fromNames (Map.union oldDocs newDocs)

118− in

119− liftIO $ Help.toStdout (toDoc localizer changes <> "\n")

120−

121−

122−

123−-- TO DOC

124−

125−

126−toDoc :: L.Localizer -> PackageChanges -> D.Doc

127−toDoc localizer changes@(PackageChanges added changed removed) =

128− if null added && Map.null changed && null removed then

129− "No API changes detected, so this is a" <+> D.green "PATCH" <+> "change."

130− else

131− let

132− magDoc =

133− D.fromString (Diff.magnitudeToString (Diff.toMagnitude changes))

134−

135− header =

136− "This is a" <+> D.green magDoc <+> "change."

137−

138− addedChunk =

139− if null added then [] else

140− [ Chunk "ADDED MODULES" MINOR $

141− D.vcat $ map (D.fromString . Module.nameToString) added

142− ]

143−

144− removedChunk =

145− if null removed then [] else

146− [ Chunk "REMOVED MODULES" MAJOR $

147− D.vcat $ map (D.fromString . Module.nameToString) removed

148− ]

149−

150− chunks =

151− addedChunk ++ removedChunk ++ map (changesToChunk localizer) (Map.toList changed)

152− in

153− D.vcat (header : "" : map chunkToDoc chunks)

154−

155−

156−data Chunk =

157− Chunk

158− { _title :: String

159− , _magnitude :: Magnitude

160− , _details :: D.Doc

161− }

162−

163−

164−chunkToDoc :: Chunk -> D.Doc

165−chunkToDoc (Chunk title magnitude details) =

166− let

167− magDoc =

168− Diff.magnitudeToString magnitude

169−

170− header =

171− "----" <+> D.fromString title <+> "-" <+> D.fromString magDoc <+> "----"

172− in

173− D.vcat

174− [ D.dullcyan header

175− , ""

176− , D.indent 4 details

177− , ""

178− , ""

179− ]

180−

181−

182−changesToChunk :: L.Localizer -> (N.Name, ModuleChanges) -> Chunk

183−changesToChunk localizer (name, changes@(ModuleChanges unions aliases values binops)) =

184− let

185− magnitude =

186− Diff.moduleChangeMagnitude changes

187−

188− (unionAdd, unionChange, unionRemove) =

189− changesToDocTriple (unionToDoc localizer) unions

190−

191− (aliasAdd, aliasChange, aliasRemove) =

192− changesToDocTriple (aliasToDoc localizer) aliases

193−

194− (valueAdd, valueChange, valueRemove) =

195− changesToDocTriple (valueToDoc localizer) values

196−

197− (binopAdd, binopChange, binopRemove) =

198− changesToDocTriple (binopToDoc localizer) binops

199− in

200− Chunk (N.toString name) magnitude $

201− D.vcat $ List.intersperse "" $ Maybe.catMaybes $

202− [ changesToDoc "Added" unionAdd aliasAdd valueAdd binopAdd

203− , changesToDoc "Removed" unionRemove aliasRemove valueRemove binopRemove

204− , changesToDoc "Changed" unionChange aliasChange valueChange binopChange

205− ]

206−

207−

208−changesToDocTriple :: (k -> v -> D.Doc) -> Changes k v -> ([D.Doc], [D.Doc], [D.Doc])

209−changesToDocTriple entryToDoc (Changes added changed removed) =

210− let

211− indented (name, value) =

212− D.indent 4 (entryToDoc name value)

213−

214− diffed (name, (oldValue, newValue)) =

215− D.vcat

216− [ " - " <> entryToDoc name oldValue

217− , " + " <> entryToDoc name newValue

218− , ""

219− ]

220− in

221− ( map indented (Map.toList added)

222− , map diffed (Map.toList changed)

223− , map indented (Map.toList removed)

224− )

225−

226−

227−changesToDoc :: String -> [D.Doc] -> [D.Doc] -> [D.Doc] -> [D.Doc] -> Maybe D.Doc

228−changesToDoc categoryName unions aliases values binops =

229− if null unions && null aliases && null values && null binops then

230− Nothing

231−

232− else

233− Just $ D.vcat $

234− D.fromString categoryName <> ":" : unions ++ aliases ++ binops ++ values

235−

236−

237−unionToDoc :: L.Localizer -> N.Name -> Docs.Union -> D.Doc

238−unionToDoc localizer name (Docs.Union _ tvars ctors) =

239− let

240− setup =

241− "type" <+> D.fromName name <+> D.hsep (map D.fromName tvars)

242−

243− ctorDoc (ctor, tipes) =

244− typeDoc localizer (Type.Type ctor tipes)

245− in

246− D.hang 4 (D.sep (setup : zipWith (<+>) ("=" : repeat "|") (map ctorDoc ctors)))

247−

248−

249−aliasToDoc :: L.Localizer -> N.Name -> Docs.Alias -> D.Doc

250−aliasToDoc localizer name (Docs.Alias _ tvars tipe) =

251− let

252− declaration =

253− "type" <+> "alias" <+> D.hsep (map D.fromName (name:tvars)) <+> "="

254− in

255− D.hang 4 (D.sep [ declaration, typeDoc localizer tipe ])

256−

257−

258−valueToDoc :: L.Localizer -> N.Name -> Docs.Value -> D.Doc

259−valueToDoc localizer name (Docs.Value _ tipe) =

260− D.hang 4 $ D.sep [ D.fromName name <+> ":", typeDoc localizer tipe ]

261−

262−

263−binopToDoc :: L.Localizer -> N.Name -> Docs.Binop -> D.Doc

264−binopToDoc localizer name (Docs.Binop _ tipe associativity (Docs.Precedence n)) =

265− "(" <> D.fromName name <> ")" <+> ":" <+> typeDoc localizer tipe <> D.black details

266− where

267− details =

268− " (" <> D.fromName assoc <> "/" <> D.fromInt n <> ")"

269−

270− assoc =

271− case associativity of

272− Docs.Left -> "left"

273− Docs.Non -> "non"

274− Docs.Right -> "right"

275−

276−

277−typeDoc :: L.Localizer -> Type.Type -> D.Doc

278−typeDoc localizer tipe =

279− Type.toDoc localizer Type.None tipe

builder/src/Elm/Install.hsdeleted−356

@@ -1,356 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Elm.Install

3− ( install

4− )

5− where

6−

7−

8−import Control.Monad (filterM, forM, msum, void)

9−import Control.Monad.Except (catchError, lift, liftIO)

10−import Data.Map (Map, (!))

11−import qualified Data.Map as Map

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

13−import System.IO (stdout)

14−

15−import qualified Elm.Package as Pkg

16−import Elm.Package (Name, Version)

17−

18−import Deps.Explorer (Explorer)

19−import qualified Deps.Explorer as Explorer

20−import qualified Deps.Verify as Verify

21−import qualified Deps.Solver as Solver

22−import Elm.Project.Constraint (Constraint)

23−import qualified Elm.Project.Constraint as Con

24−import qualified Elm.Project.Json as Project

25−import qualified Elm.Project.Root as Root

26−import Reporting.Doc ((<>), (<+>))

27−import qualified Reporting.Doc as D

28−import qualified Reporting.Exit as Exit

29−import qualified Reporting.Task as Task

30−

31−

32−

33−-- INSTALL

34−

35−

36−install :: Name -> Task.Task ()

37−install pkg =

38− do (root, oldProject) <- Root.unsafeGet

39− makePlan pkg oldProject $ \newProject ->

40− let

41− upgrade =

42− do liftIO $ Project.write root newProject

43− void $ Verify.verify root newProject

44−

45− revert err =

46− do liftIO $ Project.write root oldProject

47− Task.throw err

48− in

49− upgrade `catchError` revert

50−

51−

52−

53−-- MAKE PLAN

54−

55−

56−makePlan :: Name -> Project.Project -> (Project.Project -> Task.Task ()) -> Task.Task ()

57−makePlan pkg project attemptInstall =

58− case project of

59− Project.App info@(Project.AppInfo elm srcDirs deps test trans) ->

60− do changes <- addToApp pkg info

61−

62− let news = Map.mapMaybe keepNew changes

63− let newDeps = addNews (Just pkg) news deps

64− let newTest = addNews Nothing news test

65− let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans

66− let newInfo = Project.AppInfo elm srcDirs newDeps newTest newTrans

67− let newProject = Project.App newInfo

68−

69− withApproval Pkg.versionToString changes (attemptInstall newProject)

70−

71− Project.Pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) ->

72− do changes <- addToPkg pkg info

73−

74− let news = Map.mapMaybe keepNew changes

75− let newProject = Project.Pkg $

76− info

77− { Project._pkg_deps = addNews (Just pkg) news deps

78− , Project._pkg_test_deps = addNews Nothing news test

79− }

80−

81− withApproval (show . Con.toString) changes (attemptInstall newProject)

82−

83−

84−addNews :: Maybe Name -> Map Name a -> Map Name a -> Map Name a

85−addNews pkg new old =

86− Map.merge

87− Map.preserveMissing

88− (Map.mapMaybeMissing (\k v -> if Just k == pkg then Just v else Nothing))

89− (Map.zipWithMatched (\_ _ n -> n))

90− old

91− new

92−

93−

94−

95−-- CHANGES

96−

97−

98−data Change a

99− = Insert a

100− | Change a a

101− | Remove a

102−

103−

104−detectChanges :: (Eq a) => Map Name a -> Map Name a -> Map Name (Change a)

105−detectChanges old new =

106− Map.merge

107− (Map.mapMissing (\_ v -> Remove v))

108− (Map.mapMissing (\_ v -> Insert v))

109− (Map.zipWithMaybeMatched keepChange)

110− old

111− new

112−

113−

114−keepChange :: (Eq v) => k -> v -> v -> Maybe (Change v)

115−keepChange _ old new =

116− if old == new then

117− Nothing

118− else

119− Just (Change old new)

120−

121−

122−keepNew :: Change a -> Maybe a

123−keepNew change =

124− case change of

125− Insert a ->

126− Just a

127−

128− Change _ a ->

129− Just a

130−

131− Remove _ ->

132− Nothing

133−

134−

135−

136−-- ADD TO APP

137−

138−

139−addToApp :: Name -> Project.AppInfo -> Task.Task (Map Name (Change Version))

140−addToApp pkg info@(Project.AppInfo _ _ deps tests trans) =

141− Explorer.run $

142− do Explorer.exists pkg

143− let old = Map.unions [ deps, tests, trans ]

144− result <- Solver.run (addToAppHelp pkg info)

145− case result of

146− Just new ->

147− return $ detectChanges old new

148−

149− Nothing ->

150− do badNames <- filterM isBadElm (pkg : Map.keys old)

151− lift $ Task.throw (Exit.NoSolution badNames)

152−

153−

154−addToAppHelp :: Name -> Project.AppInfo -> Solver.Solver (Map Name Version)

155−addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =

156− let

157− directs =

158− Map.union deps tests

159−

160− everything =

161− Map.union directs trans

162−

163− try constraints =

164− Solver.solve $ Map.insert pkg Con.anything constraints

165− in

166− msum $ map try $

167− [ Map.map Con.exactly everything

168− , Map.map Con.exactly directs

169− , Map.map Con.untilNextMinor directs

170− , Map.map Con.untilNextMajor directs

171− , Map.map (\_ -> Con.anything) directs

172− ]

173−

174−

175−

176−-- ADD TO PKG

177−

178−

179−addToPkg :: Name -> Project.PkgInfo -> Task.Task (Map Name (Change Constraint))

180−addToPkg pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =

181− Explorer.run $

182− do Explorer.exists pkg

183− let old = Map.union deps tests

184− result <- Solver.run (addToPkgHelp pkg info)

185− case result of

186− Just new ->

187− return $ detectChanges old new

188−

189− Nothing ->

190− do let pkgs = Map.keys deps ++ Map.keys tests

191− badNames <- filterM isBadElm (pkg : pkgs)

192− lift $ Task.throw (Exit.NoSolution badNames)

193−

194−

195−addToPkgHelp :: Name -> Project.PkgInfo -> Solver.Solver (Map Name Constraint)

196−addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =

197− do let directs = Map.union deps tests

198− let newCons = Map.insert pkg Con.anything directs

199− solution <- Solver.solve newCons

200− let con = Con.untilNextMajor (solution ! pkg)

201− return $ Map.insert pkg con directs

202−

203−

204−

205−-- FAILURE HINTS

206−

207−

208−isBadElm :: Name -> Explorer Bool

209−isBadElm name =

210− do versions <- Explorer.getVersions name

211−

212− elmVersions <- forM versions $ \vsn ->

213− Explorer._elm <$> Explorer.getConstraints name vsn

214−

215− return (not (any Con.goodElm elmVersions))

216−

217−

218−

219−-- VIEW

220−

221−

222−withApproval :: (a -> String) -> Map Name (Change a) -> Task.Task () -> Task.Task ()

223−withApproval toString changes attemptInstall =

224− let

225− widths =

226− Map.foldrWithKey (widen toString) (Widths 0 0 0) changes

227−

228− changeDocs =

229− Map.foldrWithKey (addChange toString widths) (Docs [] [] []) changes

230− in

231− case changeDocs of

232− Docs [] [] [] ->

233− do liftIO $ putStrLn "Already installed. No changes necessary!"

234−

235− Docs inserts [] [] ->

236− do liftIO $ putStrLn "Adding the following dependencies:\n"

237− liftIO $ D.toAnsi stdout $ D.indent 2 (D.vcat (reverse inserts))

238− liftIO $ putStrLn "\n"

239− attemptInstall

240−

241− Docs _ _ _ ->

242− do liftIO $ putStrLn "Here is my plan:"

243− liftIO $ D.toAnsi stdout $ viewChangeDocs changeDocs

244− liftIO $ putStrLn "\nDo you approve? [Y/n]: "

245− Task.withApproval attemptInstall

246−

247−

248−

249−-- VIEW CHANGE DOCS

250−

251−

252−data ChangeDocs =

253− Docs

254− { _doc_inserts :: [D.Doc]

255− , _doc_changes :: [D.Doc]

256− , _doc_removes :: [D.Doc]

257− }

258−

259−

260−viewChangeDocs :: ChangeDocs -> D.Doc

261−viewChangeDocs (Docs inserts changes removes) =

262− D.indent 2 $ D.vcat $ concat $

263− [ viewNonZero "Add:" inserts

264− , viewNonZero "Change:" changes

265− , viewNonZero "Remove:" removes

266− ]

267−

268−

269−viewNonZero :: String -> [D.Doc] -> [D.Doc]

270−viewNonZero title entries =

271− if null entries then

272− []

273− else

274− [ ""

275− , D.fromString title

276− , D.indent 2 (D.vcat (reverse entries))

277− ]

278−

279−

280−

281−-- VIEW CHANGE

282−

283−

284−addChange :: (a -> String) -> Widths -> Name -> Change a -> ChangeDocs -> ChangeDocs

285−addChange toString widths name change (Docs inserts changes removes) =

286− case change of

287− Insert new ->

288− Docs (viewInsert toString widths name new : inserts) changes removes

289−

290− Change old new ->

291− Docs inserts (viewChange toString widths name old new : changes) removes

292−

293− Remove old ->

294− Docs inserts changes (viewRemove toString widths name old : removes)

295−

296−

297−viewInsert :: (a -> String) -> Widths -> Name -> a -> D.Doc

298−viewInsert toString (Widths nameWidth leftWidth _) name new =

299− viewName nameWidth name <+> pad leftWidth (toString new)

300−

301−

302−viewChange :: (a -> String) -> Widths -> Name -> a -> a -> D.Doc

303−viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =

304− D.hsep

305− [ viewName nameWidth name

306− , pad leftWidth (toString old)

307− , "=>"

308− , pad rightWidth (toString new)

309− ]

310−

311−

312−viewRemove :: (a -> String) -> Widths -> Name -> a -> D.Doc

313−viewRemove toString (Widths nameWidth leftWidth _) name old =

314− viewName nameWidth name <+> pad leftWidth (toString old)

315−

316−

317−viewName :: Int -> Name -> D.Doc

318−viewName width name =

319− D.fill (width + 3) (D.fromText (Pkg.toText name))

320−

321−

322−pad :: Int -> String -> D.Doc

323−pad width string =

324− D.fromString (replicate (width - length string) ' ') <> D.fromString string

325−

326−

327−

328−-- WIDTHS

329−

330−

331−data Widths =

332− Widths

333− { _name :: !Int

334− , _left :: !Int

335− , _right :: !Int

336− }

337−

338−

339−widen :: (a -> String) -> Name -> Change a -> Widths -> Widths

340−widen toString pkg change (Widths name left right) =

341− let

342− toLength a =

343− length (toString a)

344−

345− newName =

346− max name (length (Pkg.toString pkg))

347− in

348− case change of

349− Insert new ->

350− Widths newName (max left (toLength new)) right

351−

352− Change old new ->

353− Widths newName (max left (toLength old)) (max right (toLength new))

354−

355− Remove old ->

356− Widths newName (max left (toLength old)) right

builder/src/Elm/Outline.hsnew file+407

@@ -0,0 +1,407 @@

1+{-# OPTIONS_GHC -Wall #-}

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

3+module Elm.Outline

4+ ( Outline(..)

5+ , AppOutline(..)

6+ , PkgOutline(..)

7+ , Exposed(..)

8+ , SrcDir(..)

9+ , read

10+ , write

11+ , encode

12+ , decoder

13+ , defaultSummary

14+ , flattenExposed

15+ )

16+ where

17+

18+

19+import Prelude hiding (read)

20+import Control.Monad (filterM, liftM)

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

22+import qualified Data.Map as Map

23+import qualified Data.NonEmptyList as NE

24+import qualified Data.OneOrMore as OneOrMore

25+import Foreign.Ptr (minusPtr)

26+import qualified System.Directory as Dir

27+import qualified System.FilePath as FP

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

29+

30+import qualified Elm.Constraint as Con

31+import qualified Elm.Licenses as Licenses

32+import qualified Elm.ModuleName as ModuleName

33+import qualified Elm.Package as Pkg

34+import qualified Elm.Version as V

35+import qualified File

36+import qualified Json.Decode as D

37+import qualified Json.Encode as E

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

39+import qualified Json.String as Json

40+import qualified Parse.Primitives as P

41+import qualified Reporting.Exit as Exit

42+

43+

44+

45+-- OUTLINE

46+

47+

48+data Outline

49+ = App AppOutline

50+ | Pkg PkgOutline

51+

52+

53+data AppOutline =

54+ AppOutline

55+ { _app_elm_version :: V.Version

56+ , _app_source_dirs :: NE.List SrcDir

57+ , _app_deps_direct :: Map.Map Pkg.Name V.Version

58+ , _app_deps_indirect :: Map.Map Pkg.Name V.Version

59+ , _app_test_direct :: Map.Map Pkg.Name V.Version

60+ , _app_test_indirect :: Map.Map Pkg.Name V.Version

61+ }

62+

63+

64+data PkgOutline =

65+ PkgOutline

66+ { _pkg_name :: Pkg.Name

67+ , _pkg_summary :: Json.String

68+ , _pkg_license :: Licenses.License

69+ , _pkg_version :: V.Version

70+ , _pkg_exposed :: Exposed

71+ , _pkg_deps :: Map.Map Pkg.Name Con.Constraint

72+ , _pkg_test_deps :: Map.Map Pkg.Name Con.Constraint

73+ , _pkg_elm_version :: Con.Constraint

74+ }

75+

76+

77+data Exposed

78+ = ExposedList [ModuleName.Raw]

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

80+

81+

82+data SrcDir

83+ = AbsoluteSrcDir FilePath

84+ | RelativeSrcDir FilePath

85+

86+

87+

88+-- DEFAULTS

89+

90+

91+defaultSummary :: Json.String

92+defaultSummary =

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

94+

95+

96+

97+-- HELPERS

98+

99+

100+flattenExposed :: Exposed -> [ModuleName.Raw]

101+flattenExposed exposed =

102+ case exposed of

103+ ExposedList names ->

104+ names

105+

106+ ExposedDict sections ->

107+ concatMap snd sections

108+

109+

110+

111+-- WRITE

112+

113+

114+write :: FilePath -> Outline -> IO ()

115+write root outline =

116+ E.write (root </> "elm.json") (encode outline)

117+

118+

119+

120+-- JSON ENCODE

121+

122+

123+encode :: Outline -> E.Value

124+encode outline =

125+ case outline of

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

127+ E.object

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

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

130+ , "elm-version" ==> V.encode elm

131+ , "dependencies" ==>

132+ E.object

133+ [ "direct" ==> encodeDeps V.encode depsDirect

134+ , "indirect" ==> encodeDeps V.encode depsTrans

135+ ]

136+ , "test-dependencies" ==>

137+ E.object

138+ [ "direct" ==> encodeDeps V.encode testDirect

139+ , "indirect" ==> encodeDeps V.encode testTrans

140+ ]

141+ ]

142+

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

144+ E.object

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

146+ , "name" ==> Pkg.encode name

147+ , "summary" ==> E.string summary

148+ , "license" ==> Licenses.encode license

149+ , "version" ==> V.encode version

150+ , "exposed-modules" ==> encodeExposed exposed

151+ , "elm-version" ==> Con.encode elm

152+ , "dependencies" ==> encodeDeps Con.encode deps

153+ , "test-dependencies" ==> encodeDeps Con.encode tests

154+ ]

155+

156+

157+encodeExposed :: Exposed -> E.Value

158+encodeExposed exposed =

159+ case exposed of

160+ ExposedList modules ->

161+ E.list encodeModule modules

162+

163+ ExposedDict chunks ->

164+ E.object (map (fmap (E.list encodeModule)) chunks)

165+

166+

167+encodeModule :: ModuleName.Raw -> E.Value

168+encodeModule name =

169+ E.name name

170+

171+

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

173+encodeDeps encodeValue deps =

174+ E.dict Pkg.toJsonString encodeValue deps

175+

176+

177+encodeSrcDir :: SrcDir -> E.Value

178+encodeSrcDir srcDir =

179+ case srcDir of

180+ AbsoluteSrcDir dir -> E.chars dir

181+ RelativeSrcDir dir -> E.chars dir

182+

183+

184+

185+-- PARSE AND VERIFY

186+

187+

188+read :: FilePath -> IO (Either Exit.Outline Outline)

189+read root =

190+ do bytes <- File.readUtf8 (root </> "elm.json")

191+ case D.fromByteString decoder bytes of

192+ Left err ->

193+ return $ Left (Exit.OutlineHasBadStructure err)

194+

195+ Right outline ->

196+ case outline of

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

198+ return $

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

200+ then Left Exit.OutlineNoPkgCore

201+ else Right outline

202+

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

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

205+ return $ Left Exit.OutlineNoAppCore

206+

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

208+ return $ Left Exit.OutlineNoAppJson

209+

210+ | otherwise ->

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

212+ case map toGiven badDirs of

213+ d:ds ->

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

215+

216+ [] ->

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

218+ case maybeDups of

219+ Nothing ->

220+ return $ Right outline

221+

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

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

224+

225+

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

227+isSrcDirMissing root srcDir =

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

229+

230+

231+toGiven :: SrcDir -> FilePath

232+toGiven srcDir =

233+ case srcDir of

234+ AbsoluteSrcDir dir -> dir

235+ RelativeSrcDir dir -> dir

236+

237+

238+toAbsolute :: FilePath -> SrcDir -> FilePath

239+toAbsolute root srcDir =

240+ case srcDir of

241+ AbsoluteSrcDir dir -> dir

242+ RelativeSrcDir dir -> root </> dir

243+

244+

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

246+detectDuplicates root srcDirs =

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

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

249+ Map.fromListWith OneOrMore.more pairs

250+

251+

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

253+toPair root srcDir =

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

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

256+

257+

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

259+isDup paths =

260+ case paths of

261+ OneOrMore.One _ -> Nothing

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

263+

264+

265+

266+-- JSON DECODE

267+

268+

269+type Decoder a =

270+ D.Decoder Exit.OutlineProblem a

271+

272+

273+decoder :: Decoder Outline

274+decoder =

275+ let

276+ application = Json.fromChars "application"

277+ package = Json.fromChars "package"

278+ in

279+ do tipe <- D.field "type" D.string

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

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

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

283+

284+

285+appDecoder :: Decoder AppOutline

286+appDecoder =

287+ AppOutline

288+ <$> D.field "elm-version" versionDecoder

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

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

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

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

293+ <*> D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder))

294+

295+

296+pkgDecoder :: Decoder PkgOutline

297+pkgDecoder =

298+ PkgOutline

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

300+ <*> D.field "summary" summaryDecoder

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

302+ <*> D.field "version" versionDecoder

303+ <*> D.field "exposed-modules" exposedDecoder

304+ <*> D.field "dependencies" (depsDecoder constraintDecoder)

305+ <*> D.field "test-dependencies" (depsDecoder constraintDecoder)

306+ <*> D.field "elm-version" constraintDecoder

307+

308+

309+

310+-- JSON DECODE HELPERS

311+

312+

313+nameDecoder :: Decoder Pkg.Name

314+nameDecoder =

315+ D.mapError (uncurry Exit.OP_BadPkgName) Pkg.decoder

316+

317+

318+summaryDecoder :: Decoder Json.String

319+summaryDecoder =

320+ D.customString

321+ (boundParser 80 Exit.OP_BadSummaryTooLong)

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

323+

324+

325+versionDecoder :: Decoder V.Version

326+versionDecoder =

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

328+

329+

330+constraintDecoder :: Decoder Con.Constraint

331+constraintDecoder =

332+ D.mapError Exit.OP_BadConstraint Con.decoder

333+

334+

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

336+depsDecoder valueDecoder =

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

338+

339+

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

341+dirsDecoder =

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

343+

344+

345+toSrcDir :: FilePath -> SrcDir

346+toSrcDir path =

347+ if FP.isRelative path

348+ then RelativeSrcDir path

349+ else AbsoluteSrcDir path

350+

351+

352+

353+-- EXPOSED MODULES DECODER

354+

355+

356+exposedDecoder :: Decoder Exposed

357+exposedDecoder =

358+ D.oneOf

359+ [ ExposedList <$> D.list moduleDecoder

360+ , ExposedDict <$> D.pairs headerKeyDecoder (D.list moduleDecoder)

361+ ]

362+

363+

364+moduleDecoder :: Decoder ModuleName.Raw

365+moduleDecoder =

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

367+

368+

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

370+headerKeyDecoder =

371+ D.KeyDecoder

372+ (boundParser 20 Exit.OP_BadModuleHeaderTooLong)

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

374+

375+

376+

377+-- BOUND PARSER

378+

379+

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

381+boundParser bound tooLong =

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

383+ let

384+ len = minusPtr end pos

385+ newCol = col + fromIntegral len

386+ in

387+ if len < bound

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

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

390+

391+

392+

393+-- BINARY

394+

395+

396+instance Binary SrcDir where

397+ put outline =

398+ case outline of

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

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

401+

402+ get =

403+ do n <- getWord8

404+ case n of

405+ 0 -> liftM AbsoluteSrcDir get

406+ 1 -> liftM RelativeSrcDir get

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

builder/src/Elm/PerUserCache.hsdeleted−41

@@ -1,41 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Elm.PerUserCache

3− ( getPackageRoot

4− , getReplRoot

5− )

6− where

7−

8−import qualified System.Directory as Dir

9−import qualified System.Environment as Env

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

11−

12−import qualified Elm.Compiler as Compiler

13−import qualified Elm.Package as Pkg

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 maybeHome <- Env.lookupEnv "ELM_HOME"

33− home <- maybe (Dir.getAppUserDataDirectory "elm") return maybeHome

34− let root = home </> version </> projectName

35− Dir.createDirectoryIfMissing True root

36− return root

37−

38−

39−version :: FilePath

40−version =

41− Pkg.versionToString Compiler.version

builder/src/Elm/Project.hsdeleted−98

@@ -1,98 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Elm.Project

4− ( getRoot

5− , getRootWithReplFallback

6− , compile

7− , compileForRepl

8− , generateDocs

9− )

10− where

11−

12−

13−import qualified Data.ByteString as BS

14−import Data.Map ((!))

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

16−

17−import qualified Elm.Compiler as Compiler

18−import qualified Elm.Docs as Docs

19−import qualified Elm.Name as N

20−import qualified Elm.Project.Root as Root

21−import qualified Elm.Project.Summary as Summary

22−import Elm.Project.Summary (Summary)

23−import qualified File.Args as Args

24−import qualified File.Artifacts as Artifacts

25−import qualified File.Compile as Compile

26−import qualified File.Crawl as Crawl

27−import qualified File.Plan as Plan

28−import qualified Generate.Output as Output

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

30−import qualified Reporting.Task as Task

31−import qualified Stuff.Paths as Path

32−

33−

34−

35−-- GET ROOT

36−

37−

38−getRoot :: Task.Task Summary

39−getRoot =

40− Root.get

41−

42−

43−getRootWithReplFallback :: IO FilePath

44−getRootWithReplFallback =

45− Root.getWithReplFallback

46−

47−

48−

49−-- COMPILE

50−

51−

52−compile

53− :: Output.Mode

54− -> Output.Target

55− -> Maybe Output.Output

56− -> Maybe FilePath

57− -> Summary

58− -> [FilePath]

59− -> Task.Task ()

60−compile mode target maybeOutput docs summary@(Summary.Summary root project _ _ _) paths =

61− do args <- Args.fromPaths summary paths

62− graph <- Crawl.crawl summary args

63− (dirty, ifaces) <- Plan.plan docs summary graph

64− answers <- Compile.compile project docs ifaces dirty

65− results <- Artifacts.write root answers

66− _ <- traverse (Artifacts.writeDocs results) docs

67− Output.generate mode target maybeOutput summary graph results

68−

69−

70−

71−-- COMPILE FOR REPL

72−

73−

74−compileForRepl :: L.Localizer -> BS.ByteString -> Maybe N.Name -> Task.Task (Maybe FilePath)

75−compileForRepl localizer source maybeName =

76− do summary@(Summary.Summary root project _ _ _) <- getRoot

77− graph <- Crawl.crawlFromSource summary source

78− (dirty, ifaces) <- Plan.plan Nothing summary graph

79− answers <- Compile.compile project Nothing ifaces dirty

80− results <- Artifacts.write root answers

81− let (Compiler.Artifacts elmi _ _) = results ! N.replModule

82− traverse (Output.generateReplFile localizer summary graph elmi) maybeName

83−

84−

85−

86−-- GENERATE DOCS

87−

88−

89−generateDocs :: Summary.Summary -> Task.Task Docs.Documentation

90−generateDocs summary@(Summary.Summary root project _ _ _) =

91− do let docsPath = root </> Path.docs

92− args <- Args.fromSummary summary

93− graph <- Crawl.crawl summary args

94− (dirty, ifaces) <- Plan.plan (Just docsPath) summary graph

95− answers <- Compile.compile project (Just docsPath) ifaces dirty

96− results <- Artifacts.write root answers

97− Output.noDebugUsesInPackage summary graph

98− Artifacts.writeDocs results docsPath

builder/src/Elm/Project/Constraint.hsdeleted−234

@@ -1,234 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Elm.Project.Constraint

4− ( Constraint

5− , exactly

6− , anything

7− , fromText

8− , toString

9− , toText

10− , satisfies

11− , check

12− , intersect

13− , goodElm

14− , defaultElm

15− , untilNextMajor

16− , untilNextMinor

17− , expand

18− )

19− where

20−

21−import qualified Data.Text as Text

22−import Data.Text (Text)

23−

24−import qualified Elm.Compiler as Compiler

25−import qualified Elm.Package as Pkg

26−import Elm.Package (Version(..))

27−

28−

29−

30−-- CONSTRAINTS

31−

32−

33−data Constraint

34− = Range Version Op Op Version

35− deriving (Eq)

36−

37−

38−data Op

39− = Less

40− | LessOrEqual

41− deriving (Eq)

42−

43−

44−

45−-- COMMON CONSTRAINTS

46−

47−

48−exactly :: Version -> Constraint

49−exactly version =

50− Range version LessOrEqual LessOrEqual version

51−

52−

53−anything :: Constraint

54−anything =

55− Range (Version 1 0 0) LessOrEqual LessOrEqual (Version 30000 0 0)

56−

57−

58−

59−-- TEXT CONVERSION

60−

61−

62−toString :: Constraint -> String

63−toString constraint =

64− Text.unpack (toText constraint)

65−

66−

67−toText :: Constraint -> Text

68−toText constraint =

69− case constraint of

70− Range lower lowerOp upperOp upper ->

71− Text.intercalate " "

72− [ Pkg.versionToText lower

73− , opToText lowerOp

74− , "v"

75− , opToText upperOp

76− , Pkg.versionToText upper

77− ]

78−

79−

80−opToText :: Op -> Text

81−opToText op =

82− case op of

83− Less ->

84− "<"

85−

86− LessOrEqual ->

87− "<="

88−

89−

90−fromText :: Text -> Either String Constraint

91−fromText text =

92− case Text.splitOn " " text of

93− [lower, lowerOp, "v", upperOp, upper] ->

94− do lo <- versionFromText "lower" lower

95− lop <- opFromText lowerOp

96− hop <- opFromText upperOp

97− hi <- versionFromText "upper" upper

98− if lo < hi

99− then Right (Range lo lop hop hi)

100− else

101− Left $

102− "The lower bound (" ++ Text.unpack lower

103− ++ ") must be less than the upper bound ("

104− ++ Text.unpack upper ++ ")"

105−

106− _ ->

107− Left "The standard format is \"1.0.0 <= v < 2.0.0\""

108−

109−

110−versionFromText :: String -> Text -> Either String Version

111−versionFromText lowerOrUpper text =

112− case Pkg.versionFromText text of

113− Just vsn ->

114− Right vsn

115−

116− Nothing ->

117− Left $ "The " ++ lowerOrUpper ++ " bound (" ++ Text.unpack text ++ ") is not a valid version number."

118−

119−

120−opFromText :: Text -> Either String Op

121−opFromText text =

122− case text of

123− "<=" ->

124− Right LessOrEqual

125−

126− "<" ->

127− Right Less

128−

129− _ ->

130− Left $ "The operator (" ++ Text.unpack text ++ ") is not valid. Must be (<=) or (<)."

131−

132−

133−

134−-- IS SATISFIED

135−

136−

137−satisfies :: Constraint -> Version -> Bool

138−satisfies constraint version =

139− case constraint of

140− Range lower lowerOp upperOp upper ->

141− isLess lowerOp lower version

142− &&

143− isLess upperOp version upper

144−

145−

146−isLess :: (Ord a) => Op -> (a -> a -> Bool)

147−isLess op =

148− case op of

149− Less ->

150− (<)

151−

152− LessOrEqual ->

153− (<=)

154−

155−

156−check :: Constraint -> Version -> Ordering

157−check constraint version =

158− case constraint of

159− Range lower lowerOp upperOp upper ->

160− if not (isLess lowerOp lower version) then

161− LT

162−

163− else if not (isLess upperOp version upper) then

164− GT

165−

166− else

167− EQ

168−

169−

170−

171−-- INTERSECT

172−

173−

174−intersect :: Constraint -> Constraint -> Maybe Constraint

175−intersect (Range lo lop hop hi) (Range lo_ lop_ hop_ hi_) =

176− let

177− (newLo, newLop) =

178− case compare lo lo_ of

179− LT -> (lo_, lop_)

180− EQ -> (lo, if elem Less [lop,lop_] then Less else LessOrEqual)

181− GT -> (lo, lop)

182−

183− (newHi, newHop) =

184− case compare hi hi_ of

185− LT -> (hi, hop)

186− EQ -> (hi, if elem Less [hop, hop_] then Less else LessOrEqual)

187− GT -> (hi_, hop_)

188− in

189− if newLo <= newHi then

190− Just (Range newLo newLop newHop newHi)

191− else

192− Nothing

193−

194−

195−

196−-- ELM CONSTRAINT

197−

198−

199−goodElm :: Constraint -> Bool

200−goodElm constraint =

201− satisfies constraint Compiler.version

202−

203−

204−defaultElm :: Constraint

205−defaultElm =

206− if Pkg._major Compiler.version > 0

207− then untilNextMajor Compiler.version

208− else untilNextMinor Compiler.version

209−

210−

211−

212−-- CREATE CONSTRAINTS

213−

214−

215−untilNextMajor :: Version -> Constraint

216−untilNextMajor version =

217− Range version LessOrEqual Less (Pkg.bumpMajor version)

218−

219−

220−untilNextMinor :: Version -> Constraint

221−untilNextMinor version =

222− Range version LessOrEqual Less (Pkg.bumpMinor version)

223−

224−

225−expand :: Constraint -> Version -> Constraint

226−expand constraint@(Range lower lowerOp upperOp upper) version

227− | version < lower =

228− Range version LessOrEqual upperOp upper

229−

230− | version > upper =

231− Range lower lowerOp Less (Pkg.bumpMajor version)

232−

233− | otherwise =

234− constraint

builder/src/Elm/Project/Json.hsdeleted−423

@@ -1,423 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Elm.Project.Json

4− ( Project(..)

5− , AppInfo(..)

6− , PkgInfo(..)

7− , Exposed(..)

8− , defaultSummary

9− -- json

10− , write

11− , encode

12− , read

13− , pkgDecoder

14− -- queries

15− , appSolution

16− , isPlatformPackage

17− , get

18− , getName

19− , getExposed

20− )

21− where

22−

23−

24−import Prelude hiding (read)

25−import Control.Monad.Trans (liftIO)

26−import qualified Data.ByteString as BS

27−import Data.Foldable (traverse_)

28−import Data.Map (Map)

29−import Data.Text (Text)

30−import qualified Data.Map as Map

31−import qualified Data.Text as Text

32−import qualified System.Directory as Dir

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

34−

35−import qualified Elm.Compiler.Module as Module

36−import qualified Elm.Package as Pkg

37−import Elm.Package (Name, Version)

38−

39−import qualified Elm.Project.Constraint as Con

40−import qualified Elm.Project.Licenses as Licenses

41−import qualified Json.Decode as D

42−import qualified Json.Encode as E

43−import qualified Reporting.Exit as Exit

44−import qualified Reporting.Exit.Assets as E

45−import qualified Reporting.Task as Task

46−

47−

48−

49−-- PROJECT

50−

51−

52−data Project

53− = App AppInfo

54− | Pkg PkgInfo

55−

56−

57−

58−-- APPLICATION

59−

60−

61−data AppInfo =

62− AppInfo

63− { _app_elm_version :: Version

64− , _app_source_dirs :: [FilePath]

65− , _app_deps :: Map Name Version

66− , _app_test_deps :: Map Name Version

67− , _app_trans_deps :: Map Name Version

68− }

69−

70−

71−

72−-- PACKAGE

73−

74−

75−data PkgInfo =

76− PkgInfo

77− { _pkg_name :: Name

78− , _pkg_summary :: Text

79− , _pkg_license :: Licenses.License

80− , _pkg_version :: Version

81− , _pkg_exposed :: Exposed

82− , _pkg_deps :: Map Name Con.Constraint

83− , _pkg_test_deps :: Map Name Con.Constraint

84− , _pkg_elm_version :: Con.Constraint

85− }

86−

87−

88−data Exposed

89− = ExposedList [Module.Raw]

90− | ExposedDict [(Text, [Module.Raw])]

91−

92−

93−

94−-- DEFAULTS

95−

96−

97−defaultSummary :: Text

98−defaultSummary =

99− "helpful summary of your project, less than 80 characters"

100−

101−

102−

103−-- QUERIES

104−

105−

106−appSolution :: AppInfo -> Map Name Version

107−appSolution info =

108− Map.unions

109− [ _app_deps info

110− , _app_test_deps info

111− , _app_trans_deps info

112− ]

113−

114−

115−isPlatformPackage :: Project -> Bool

116−isPlatformPackage project =

117− case project of

118− App _ ->

119− False

120−

121− Pkg info ->

122− let

123− (Pkg.Name user _) =

124− _pkg_name info

125− in

126− user == "elm-lang" || user == "elm-explorations"

127−

128−

129−get :: (AppInfo -> a) -> (PkgInfo -> a) -> Project -> a

130−get appFunc pkgFunc project =

131− case project of

132− App info ->

133− appFunc info

134−

135− Pkg info ->

136− pkgFunc info

137−

138−

139−getName :: Project -> Name

140−getName project =

141− get (\_ -> Pkg.dummyName) _pkg_name project

142−

143−

144−getExposed :: PkgInfo -> [Module.Raw]

145−getExposed info =

146− case _pkg_exposed info of

147− ExposedList modules ->

148− modules

149−

150− ExposedDict chunks ->

151− concatMap snd chunks

152−

153−

154−

155−-- WRITE

156−

157−

158−write :: FilePath -> Project -> IO ()

159−write root project =

160− E.write (root </> "elm.json") (encode project)

161−

162−

163−

164−-- JSON ENCODE

165−

166−

167−encode :: Project -> E.Value

168−encode project =

169− case project of

170− App (AppInfo elm srcDirs deps tests trans) ->

171− E.object

172− [ "type" ==> E.text "application"

173− , "source-directories" ==> E.list (E.text . Text.pack) srcDirs

174− , "elm-version" ==> encodeVersion elm

175− , "dependencies" ==> encodeDeps encodeVersion deps

176− , "test-dependencies" ==> encodeDeps encodeVersion tests

177− , "do-not-edit-this-by-hand" ==>

178− E.object [ "transitive-dependencies" ==> encodeDeps encodeVersion trans ]

179− ]

180−

181− Pkg (PkgInfo name summary license version exposed deps tests elm) ->

182− E.object

183− [ "type" ==> E.text "package"

184− , "name" ==> E.text (Pkg.toText name)

185− , "summary" ==> E.text summary

186− , "license" ==> Licenses.encode license

187− , "version" ==> E.text (Pkg.versionToText version)

188− , "exposed-modules" ==> encodeExposed exposed

189− , "elm-version" ==> encodeConstraint elm

190− , "dependencies" ==> encodeDeps encodeConstraint deps

191− , "test-dependencies" ==> encodeDeps encodeConstraint tests

192− ]

193−

194−

195−(==>) :: a -> b -> (a, b)

196−(==>) a b =

197− (a, b)

198−

199−

200−encodeExposed :: Exposed -> E.Value

201−encodeExposed exposed =

202− case exposed of

203− ExposedList modules ->

204− E.list encodeModule modules

205−

206− ExposedDict chunks ->

207− E.object (map (fmap (E.list encodeModule)) chunks)

208−

209−

210−encodeModule :: Module.Raw -> E.Value

211−encodeModule name =

212− E.name name

213−

214−

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

216−encodeDeps encodeValue deps =

217− E.dict Pkg.toText encodeValue deps

218−

219−

220−encodeConstraint :: Con.Constraint -> E.Value

221−encodeConstraint constraint =

222− E.text (Con.toText constraint)

223−

224−

225−encodeVersion :: Pkg.Version -> E.Value

226−encodeVersion version =

227− E.text (Pkg.versionToText version)

228−

229−

230−

231−-- PARSE AND VERIFY

232−

233−

234−read :: FilePath -> Task.Task Project

235−read path =

236− do bytes <- liftIO $ BS.readFile path

237− case D.parse "project" E.badContentToDocs decoder bytes of

238− Left err ->

239− throwBadJson (E.BadJson err)

240−

241− Right project@(Pkg (PkgInfo _ _ _ _ _ deps tests _)) ->

242− do checkOverlap "dependencies" "test-dependencies" deps tests

243− return project

244−

245− Right project@(App (AppInfo _ srcDirs deps tests trans)) ->

246− do checkOverlap "dependencies" "test-dependencies" deps tests

247− checkOverlap "dependencies" "transitive-dependencies" deps trans

248− checkOverlap "test-dependencies" "transitive-dependencies" tests trans

249− mapM_ doesDirectoryExist srcDirs

250− return project

251−

252−

253−throwBadJson :: E.ElmJsonProblem -> Task.Task a

254−throwBadJson problem =

255− Task.throw (Exit.Assets (E.BadElmJson problem))

256−

257−

258−checkOverlap :: String -> String -> Map Name a -> Map Name a -> Task.Task ()

259−checkOverlap field1 field2 deps1 deps2 =

260− case Map.keys (Map.intersection deps1 deps2) of

261− [] ->

262− return ()

263−

264− dup : dups ->

265− throwBadJson (E.BadDepDup field1 field2 dup dups)

266−

267−

268−doesDirectoryExist :: FilePath -> Task.Task ()

269−doesDirectoryExist dir =

270− do exists <- liftIO $ Dir.doesDirectoryExist dir

271− if exists

272− then return ()

273− else throwBadJson (E.BadSrcDir dir)

274−

275−

276−

277−-- JSON DECODE

278−

279−

280−type Decoder a =

281− D.Decoder E.BadElmJsonContent a

282−

283−

284−decoder :: Decoder Project

285−decoder =

286− do tipe <- D.field "type" D.text

287− case tipe of

288− "application" ->

289− D.map App appDecoder

290−

291− "package" ->

292− D.map Pkg pkgDecoder

293−

294− other ->

295− D.fail (E.BadType other)

296−

297−

298−appDecoder :: Decoder AppInfo

299−appDecoder =

300− AppInfo

301− <$> D.field "elm-version" versionDecoder

302− <*> D.field "source-directories" (D.list dirDecoder)

303− <*> D.field "dependencies" (depsDecoder versionDecoder)

304− <*> D.field "test-dependencies" (depsDecoder versionDecoder)

305− <*> D.at ["do-not-edit-this-by-hand", "transitive-dependencies"] (depsDecoder versionDecoder)

306−

307−

308−pkgDecoder :: Decoder PkgInfo

309−pkgDecoder =

310− PkgInfo

311− <$> D.field "name" pkgNameDecoder

312− <*> D.field "summary" summaryDecoder

313− <*> D.field "license" licenseDecoder

314− <*> D.field "version" versionDecoder

315− <*> D.field "exposed-modules" exposedDecoder

316− <*> D.field "dependencies" (depsDecoder constraintDecoder)

317− <*> D.field "test-dependencies" (depsDecoder constraintDecoder)

318− <*> D.field "elm-version" constraintDecoder

319−

320−

321−

322−-- JSON DECODE HELPERS

323−

324−

325−pkgNameDecoder :: Decoder Pkg.Name

326−pkgNameDecoder =

327− D.mapError E.BadPkgName Pkg.decoder

328−

329−

330−summaryDecoder :: Decoder Text

331−summaryDecoder =

332− do summary <- D.text

333− if Text.length summary < 80

334− then D.succeed summary

335− else D.fail E.BadSummaryTooLong

336−

337−

338−licenseDecoder :: Decoder Licenses.License

339−licenseDecoder =

340− do txt <- D.text

341− case Licenses.check txt of

342− Left suggestions ->

343− D.fail (E.BadLicense txt suggestions)

344−

345− Right license ->

346− D.succeed license

347−

348−

349−versionDecoder :: Decoder Version

350−versionDecoder =

351− do txt <- D.text

352− case Pkg.versionFromText txt of

353− Just version ->

354− D.succeed version

355−

356− Nothing ->

357− D.fail (E.BadVersion txt)

358−

359−

360−constraintDecoder :: Decoder Con.Constraint

361−constraintDecoder =

362− do txt <- D.text

363− case Con.fromText txt of

364− Right constraint ->

365− D.succeed constraint

366−

367− Left msg ->

368− D.fail (E.BadConstraint msg)

369−

370−

371−depsDecoder :: Decoder a -> Decoder (Map Name a)

372−depsDecoder valueDecoder =

373− Map.fromList <$> (

374− traverse validateKey =<< D.pairs valueDecoder

375− )

376−

377−

378−validateKey :: (Text, a) -> Decoder (Name, a)

379−validateKey (key, value) =

380− case Pkg.fromText key of

381− Right name ->

382− D.succeed (name, value)

383−

384− Left _ ->

385− D.fail (E.BadDependencyName key)

386−

387−

388−dirDecoder :: Decoder FilePath

389−dirDecoder =

390− do maybeText <- D.maybe D.text

391− case maybeText of

392− Nothing ->

393− D.fail E.BadDirectoryNotString

394−

395− Just txt ->

396− D.succeed (Text.unpack txt)

397−

398−

399−

400−-- EXPOSED MODULES DECODER

401−

402−

403−exposedDecoder :: Decoder Exposed

404−exposedDecoder =

405− D.oneOf

406− [ ExposedList <$> D.list moduleDecoder

407− , do pairs <- D.pairs (D.list moduleDecoder)

408− traverse_ (checkHeader . fst) pairs

409− return (ExposedDict pairs)

410− ]

411−

412−

413−moduleDecoder :: Decoder Module.Raw

414−moduleDecoder =

415− D.mapError E.BadModuleName Module.decoder

416−

417−

418−checkHeader :: Text -> Decoder ()

419−checkHeader header =

420− if Text.length header < 20 then

421− D.succeed ()

422− else

423− D.fail (E.BadModuleHeaderTooLong header)

builder/src/Elm/Project/Root.hsdeleted−94

@@ -1,94 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Elm.Project.Root

3− ( get

4− , unsafeGet

5− , getWithReplFallback

6− )

7− where

8−

9−import Control.Monad.Trans (liftIO)

10−import qualified Data.Map as Map

11−import qualified System.Directory as Dir

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

13−

14−import qualified Elm.Package as Pkg

15−import qualified Elm.Project.Constraint as Con

16−import qualified Elm.Project.Json as Project

17−import qualified Elm.Project.Licenses as Licenses

18−import Elm.Project.Json (Project(..), PkgInfo(..))

19−import Elm.Project.Summary (Summary)

20−import qualified Elm.PerUserCache as PerUserCache

21−import qualified File.IO as IO

22−import qualified Reporting.Exit as Exit

23−import qualified Reporting.Task as Task

24−import qualified Stuff.Verify as Verify

25−import qualified Json.Encode as Encode

26−

27−

28−

29−-- GET

30−

31−

32−get :: Task.Task Summary

33−get =

34− do root <- moveToRoot

35− project <- Project.read "elm.json"

36− Verify.verify root project

37−

38−

39−unsafeGet :: Task.Task (FilePath, Project)

40−unsafeGet =

41− (,) <$> moveToRoot <*> Project.read "elm.json"

42−

43−

44−

45−-- MOVE TO ROOT

46−

47−

48−moveToRoot :: Task.Task FilePath

49−moveToRoot =

50− do maybeRoot <- liftIO $ IO.find "elm.json"

51− case maybeRoot of

52− Just root ->

53− do liftIO $ Dir.setCurrentDirectory root

54− return root

55−

56− Nothing ->

57− Task.throw Exit.NoElmJson

58−

59−

60−

61−-- GET WITH FALLBACK

62−

63−

64−getWithReplFallback :: IO FilePath

65−getWithReplFallback =

66− do maybeRoot <- IO.find "elm.json"

67−

68− case maybeRoot of

69− Just root ->

70− do Dir.setCurrentDirectory root

71− return root

72−

73− Nothing ->

74− do cache <- PerUserCache.getReplRoot

75− let root = cache </> "tmp"

76− Dir.createDirectoryIfMissing True root

77− Dir.setCurrentDirectory root

78− IO.removeDir "elm-stuff"

79− Encode.write "elm.json" (Project.encode (Pkg replInfo))

80− return root

81−

82−

83−replInfo :: PkgInfo

84−replInfo =

85− PkgInfo

86− { _pkg_name = Pkg.dummyName

87− , _pkg_summary = "dummy code for the REPL"

88− , _pkg_license = Licenses.bsd3

89− , _pkg_version = Pkg.dummyVersion

90− , _pkg_exposed = Project.ExposedList []

91− , _pkg_deps = Map.singleton Pkg.core Con.anything

92− , _pkg_test_deps = Map.empty

93− , _pkg_elm_version = Con.defaultElm

94− }

builder/src/Elm/Project/Summary.hsdeleted−105

@@ -1,105 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Elm.Project.Summary

3− ( Summary(..)

4− , ExposedModules

5− , DepsGraph

6− , init

7− , cheapInit

8− )

9− where

10−

11−

12−import Prelude hiding (init)

13−import qualified Data.List as List

14−import qualified Data.Map as Map

15−import Data.Map (Map)

16−

17−import qualified Elm.Compiler.Module as Module

18−import Elm.Package (Package(..), Name, Version)

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

20−import qualified Elm.Project.Json as Project

21−

22−

23−

24−-- SUMMARY

25−

26−

27−data Summary =

28− Summary

29− { _root :: FilePath

30− , _project :: Project

31− , _exposed :: ExposedModules

32− , _ifaces :: Module.Interfaces

33− , _depsGraph :: DepsGraph

34− }

35−

36−

37−type ExposedModules =

38− Map.Map Module.Raw [Package]

39−

40−

41−type DepsGraph =

42− Map.Map Name ( Version, [Name] )

43−

44−

45−

46−-- MAKE SUMMARY

47−

48−

49−init :: FilePath -> Project -> Map Name PkgInfo -> Module.Interfaces -> Summary

50−init root project deps ifaces =

51− let

52− exposed =

53− Project.get

54− (getExposed deps . _app_deps)

55− (getExposed deps . _pkg_deps)

56− project

57−

58− privatizedInterfaces =

59− Map.mapMaybeWithKey (privatize exposed) ifaces

60−

61− depsGraph =

62− Map.foldr toNode Map.empty deps

63− in

64− Summary root project exposed privatizedInterfaces depsGraph

65−

66−

67−privatize :: ExposedModules -> Module.Canonical -> Module.Interface -> Maybe Module.Interface

68−privatize exposed (Module.Canonical _ name) iface =

69− case Map.lookup name exposed of

70− Just [_] ->

71− Just iface

72−

73− _ ->

74− Nothing

75−

76−

77−toNode :: PkgInfo -> DepsGraph -> DepsGraph

78−toNode (PkgInfo name _ _ version _ deps _ _) graph =

79− Map.insert name (version, Map.keys deps) graph

80−

81−

82−

83−-- MAKE CHEAP SUMMARY

84−

85−

86−cheapInit :: FilePath -> PkgInfo -> Map Name PkgInfo -> Module.Interfaces -> Summary

87−cheapInit root info deps ifaces =

88− Summary root (Pkg info) (getExposed deps (_pkg_deps info)) ifaces Map.empty

89−

90−

91−getExposed :: Map Name PkgInfo -> Map Name a -> ExposedModules

92−getExposed deps directs =

93− Map.foldl insertExposed Map.empty (Map.intersection deps directs)

94−

95−

96−insertExposed :: ExposedModules -> PkgInfo -> ExposedModules

97−insertExposed exposed info =

98− let

99− home =

100− Package (_pkg_name info) (_pkg_version info)

101−

102− insertModule dict modul =

103− Map.insertWith (++) modul [home] dict

104− in

105− List.foldl' insertModule exposed (Project.getExposed info)

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.Text as Text

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.Diff as Diff

17−import qualified Deps.Get as Get

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

23−import qualified Elm.Project.Json as Project

24−import qualified Elm.Project.Summary as Summary

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− pkgs <- Get.all Get.RequireLatest

45− let maybePublishedVersions = either (const Nothing) Just (Get.versions name pkgs)

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 (Project.generateDocs 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 :: Text.Text -> Bool

75−badSummary summary =

76− Text.null 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 -> Pkg.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 -> Pkg.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 -> Pkg.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 $ 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 -> Pkg.Version -> Docs.Documentation -> Maybe [Pkg.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 == Pkg.initialVersion 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 -> Pkg.Version -> Docs.Documentation -> [Pkg.Version] -> Task.Task (Pkg.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 <- Get.docs 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.hsnew file+231

@@ -0,0 +1,231 @@

1+module File

2+ ( Time

3+ , getTime

4+ , zeroTime

5+ , writeBinary

6+ , readBinary

7+ , writeUtf8

8+ , readUtf8

9+ , writeBuilder

10+ , writePackage

11+ , exists

12+ , remove

13+ , removeDir

14+ )

15+ where

16+

17+

18+import qualified Codec.Archive.Zip as Zip

19+import Control.Exception (catch)

20+import qualified Data.Binary as Binary

21+import qualified Data.ByteString as BS

22+import qualified Data.ByteString.Internal as BS

23+import qualified Data.ByteString.Builder as B

24+import qualified Data.ByteString.Lazy as LBS

25+import qualified Data.Fixed as Fixed

26+import qualified Data.List as List

27+import qualified Data.Time.Clock as Time

28+import qualified Data.Time.Clock.POSIX as Time

29+import qualified Foreign.ForeignPtr as FPtr

30+import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))

31+import qualified System.Directory as Dir

32+import qualified System.FilePath as FP

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

34+import qualified System.IO as IO

35+import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)

36+

37+

38+

39+-- TIME

40+

41+

42+newtype Time = Time Fixed.Pico

43+ deriving (Eq, Ord)

44+

45+

46+getTime :: FilePath -> IO Time

47+getTime path =

48+ fmap

49+ (Time . Time.nominalDiffTimeToSeconds . Time.utcTimeToPOSIXSeconds)

50+ (Dir.getModificationTime path)

51+

52+

53+zeroTime :: Time

54+zeroTime =

55+ Time 0

56+

57+

58+instance Binary.Binary Time where

59+ put (Time time) = Binary.put time

60+ get = Time <$> Binary.get

61+

62+

63+

64+-- BINARY

65+

66+

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

68+writeBinary path value =

69+ do let dir = FP.dropFileName path

70+ Dir.createDirectoryIfMissing True dir

71+ Binary.encodeFile path value

72+

73+

74+readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)

75+readBinary path =

76+ do pathExists <- Dir.doesFileExist path

77+ if pathExists

78+ then

79+ do result <- Binary.decodeFileOrFail path

80+ case result of

81+ Right a ->

82+ return (Just a)

83+

84+ Left (offset, message) ->

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

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

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

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

89+ , "| Message: " ++ message

90+ , "|"

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

92+ , "| Trying to continue anyway."

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

94+ ]

95+ return Nothing

96+ else

97+ return Nothing

98+

99+

100+

101+-- WRITE UTF-8

102+

103+

104+writeUtf8 :: FilePath -> BS.ByteString -> IO ()

105+writeUtf8 path content =

106+ withUtf8 path IO.WriteMode $ \handle ->

107+ BS.hPut handle content

108+

109+

110+withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a

111+withUtf8 path mode callback =

112+ IO.withFile path mode $ \handle ->

113+ do IO.hSetEncoding handle IO.utf8

114+ callback handle

115+

116+

117+

118+-- READ UTF-8

119+

120+

121+readUtf8 :: FilePath -> IO BS.ByteString

122+readUtf8 path =

123+ withUtf8 path IO.ReadMode $ \handle ->

124+ modifyIOError (encodingError path) $

125+ do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile

126+ let readSize = max 0 (fromIntegral fileSize) + 1

127+ hGetContentsSizeHint handle readSize (max 255 readSize)

128+

129+

130+useZeroIfNotRegularFile :: IOException -> IO Integer

131+useZeroIfNotRegularFile _ =

132+ return 0

133+

134+

135+hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString

136+hGetContentsSizeHint handle =

137+ readChunks []

138+ where

139+ readChunks chunks readSize incrementSize =

140+ do fp <- BS.mallocByteString readSize

141+ readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize

142+ let chunk = BS.PS fp 0 readCount

143+ if readCount < readSize && readSize > 0

144+ then return $! BS.concat (reverse (chunk:chunks))

145+ else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))

146+

147+

148+encodingError :: FilePath -> IOError -> IOError

149+encodingError path ioErr =

150+ case ioeGetErrorType ioErr of

151+ InvalidArgument ->

152+ annotateIOError

153+ (userError "Bad encoding; the file must be valid UTF-8")

154+ ""

155+ Nothing

156+ (Just path)

157+

158+ _ ->

159+ ioErr

160+

161+

162+

163+-- WRITE BUILDER

164+

165+

166+writeBuilder :: FilePath -> B.Builder -> IO ()

167+writeBuilder path builder =

168+ IO.withBinaryFile path IO.WriteMode $ \handle ->

169+ do IO.hSetBuffering handle (IO.BlockBuffering Nothing)

170+ B.hPutBuilder handle builder

171+

172+

173+

174+-- WRITE PACKAGE

175+

176+

177+writePackage :: FilePath -> Zip.Archive -> IO ()

178+writePackage destination archive =

179+ case Zip.zEntries archive of

180+ [] ->

181+ return ()

182+

183+ entry:entries ->

184+ do let root = length (Zip.eRelativePath entry)

185+ mapM_ (writeEntry destination root) entries

186+

187+

188+writeEntry :: FilePath -> Int -> Zip.Entry -> IO ()

189+writeEntry destination root entry =

190+ let

191+ path = drop root (Zip.eRelativePath entry)

192+ in

193+ if List.isPrefixOf "src/" path

194+ || path == "LICENSE"

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

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

197+ then

198+ if not (null path) && last path == '/'

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

200+ else LBS.writeFile (destination </> path) (Zip.fromEntry entry)

201+ else

202+ return ()

203+

204+

205+

206+-- EXISTS

207+

208+

209+exists :: FilePath -> IO Bool

210+exists path =

211+ Dir.doesFileExist path

212+

213+

214+

215+-- REMOVE FILES

216+

217+

218+remove :: FilePath -> IO ()

219+remove path =

220+ do exists_ <- Dir.doesFileExist path

221+ if exists_

222+ then Dir.removeFile path

223+ else return ()

224+

225+

226+removeDir :: FilePath -> IO ()

227+removeDir path =

228+ do exists_ <- Dir.doesDirectoryExist path

229+ if exists_

230+ then Dir.removeDirectoryRecursive path

231+ else return ()

builder/src/File/Args.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module File.Args

3− ( Args(..)

4− , fromPaths

5− , fromSummary

6− )

7− where

8−

9−

10−import qualified Elm.Compiler.Module as Module

11−import qualified Elm.Project.Json as Project

12−import qualified Elm.Project.Summary as Summary

13−import qualified Reporting.Exit as Exit

14−import qualified Reporting.Exit.Make as E

15−import qualified Reporting.Task as Task

16−

17−

18−data Args root

19− = Pkg [Module.Raw]

20− | Roots root [root]

21−

22−

23−fromPaths :: Summary.Summary -> [FilePath] -> Task.Task (Args FilePath)

24−fromPaths summary paths =

25− case paths of

26− [] ->

27− fromSummary summary

28−

29− first : rest ->

30− return $ Roots first rest

31−

32−

33−fromSummary :: Summary.Summary -> Task.Task (Args a)

34−fromSummary (Summary.Summary _ project _ _ _) =

35− case project of

36− Project.Pkg info ->

37− return $ Pkg (Project.getExposed info)

38−

39− Project.App _ ->

40− Task.throw (Exit.Make E.CannotMakeNothing)

builder/src/File/Artifacts.hsdeleted−138

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

1−module File.Artifacts

2− ( ignore

3− , write

4− , writeDocs

5− )

6− where

7−

8−

9−import Control.Concurrent (forkIO)

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

11−import Control.Monad (foldM, void)

12−import Control.Monad.Except (liftIO)

13−import qualified Data.Binary as Binary

14−import Data.Map (Map)

15−import qualified Data.Map as Map

16−import qualified Data.Maybe as Maybe

17−import qualified Data.Text.Encoding as Text

18−

19−import qualified Elm.Compiler as Compiler

20−import qualified Elm.Compiler.Module as Module

21−import qualified Elm.Docs as Docs

22−import qualified Json.Encode as Encode

23−

24−import File.Compile (Answer(..))

25−import qualified Reporting.Exit.Compile as E

26−import qualified Reporting.Exit as Exit

27−import qualified Reporting.Task as Task

28−import qualified Stuff.Paths as Path

29−

30−

31−

32−-- IGNORE

33−

34−

35−ignore :: Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts)

36−ignore answers =

37− let

38− ignorer _name result =

39− return result

40− in

41− gather ignorer answers

42−

43−

44−

45−-- WRITE

46−

47−

48−write :: FilePath -> Map Module.Raw Answer -> Task.Task (Map Module.Raw Compiler.Artifacts)

49−write root answers =

50− let

51− writer name result@(Compiler.Artifacts elmi elmo _) =

52− do mvar <- newEmptyMVar

53− void $ forkIO $

54− do Binary.encodeFile (Path.elmi root name) elmi

55− Binary.encodeFile (Path.elmo root name) elmo

56− putMVar mvar result

57− return mvar

58− in

59− do mvars <- gather writer answers

60− liftIO $ traverse readMVar mvars

61−

62−

63−writeDocs :: Map Module.Raw Compiler.Artifacts -> FilePath -> Task.Task Docs.Documentation

64−writeDocs results path =

65− let

66− getDocs (Compiler.Artifacts _ _ docs) =

67− docs

68− in

69− case Maybe.mapMaybe getDocs (Map.elems results) of

70− [] ->

71− return Map.empty

72−

73− docs ->

74− do liftIO $ Encode.writeUgly path $ Encode.list Docs.encode docs

75− return $ Docs.toDict docs

76−

77−

78−

79−-- GATHER

80−

81−

82−gather :: OnGood a -> Map Module.Raw Answer -> Task.Task (Map Module.Raw a)

83−gather onGood answers =

84− do summary <- liftIO $

85− foldM (gatherHelp onGood) (Right Map.empty) (Map.toList answers)

86−

87− case summary of

88− Left (err, errors) ->

89− Task.throw (Exit.Compile err errors)

90−

91− Right results ->

92− return results

93−

94−

95−type OnGood a = Module.Raw -> Compiler.Artifacts -> IO a

96−

97−

98−gatherHelp :: OnGood a -> Summary a -> (Module.Raw, Answer) -> IO (Summary a)

99−gatherHelp onGood summary (name, answer) =

100− case answer of

101− Blocked ->

102− return summary

103−

104− Bad path time src errors ->

105− do let err = E.Exit name path time (Text.decodeUtf8 src) errors

106− return (addErr err summary)

107−

108− Good result ->

109− do value <- onGood name result

110− return (addOk name value summary)

111−

112−

113−

114−-- DICT RESULT

115−

116−

117−type Summary a =

118− Either (E.Exit, [E.Exit]) (Map Module.Raw a)

119−

120−

121−addOk :: Module.Raw -> a -> Summary a -> Summary a

122−addOk name result acc =

123− case acc of

124− Left _ ->

125− acc

126−

127− Right results ->

128− Right (Map.insert name result results)

129−

130−

131−addErr :: E.Exit -> Summary a -> Summary a

132−addErr err acc =

133− case acc of

134− Left (e, es) ->

135− Left (err, e:es)

136−

137− Right _ ->

138− Left (err, [])

builder/src/File/Compile.hsdeleted−192

@@ -1,192 +0,0 @@

1−module File.Compile

2− ( compile

3− , Answer(..)

4− )

5− where

6−

7−import Control.Concurrent (forkIO)

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

9−import Control.Monad (void)

10−import Control.Monad.Except (liftIO)

11−import qualified Data.ByteString as BS

12−import qualified Data.Map as Map

13−import qualified Data.Time.Clock as Time

14−

15−import qualified Elm.Compiler as Compiler

16−import qualified Elm.Compiler.Module as Module

17−

18−import Elm.Project.Json (Project)

19−import qualified Elm.Project.Json as Project

20−import qualified File.Plan as Plan

21−import qualified Reporting.Progress as Progress

22−import qualified Reporting.Task as Task

23−

24−

25−

26−-- COMPILE

27−

28−

29−compile :: Project -> Maybe FilePath -> Module.Interfaces -> Dict Plan.Info -> Task.Task (Dict Answer)

30−compile project maybeDocsPath ifaces modules =

31− do Task.report (Progress.CompileStart (Map.size modules))

32−

33− tell <- Task.getReporter

34−

35− answers <- liftIO $

36− do mvar <- newEmptyMVar

37− iMVar <- newMVar ifaces

38− answerMVars <- Map.traverseWithKey (compileModule tell project maybeDocsPath mvar iMVar) modules

39− putMVar mvar answerMVars

40− traverse readMVar answerMVars

41−

42− Task.report Progress.CompileEnd

43−

44− return answers

45−

46−

47−

48−-- ANSWERS

49−

50−

51−data Answer

52− = Blocked

53− | Bad FilePath Time.UTCTime BS.ByteString [Compiler.Error]

54− | Good Compiler.Artifacts

55−

56−

57−type Dict a = Map.Map Module.Raw a

58−

59−

60−

61−-- COMPILE MODULE

62−

63−

64−compileModule

65− :: (Progress.Progress -> IO ())

66− -> Project

67− -> Maybe FilePath

68− -> MVar (Dict (MVar Answer))

69− -> MVar Module.Interfaces

70− -> Module.Raw

71− -> Plan.Info

72− -> IO (MVar Answer)

73−compileModule tell project maybeDocsPath answersMVar ifacesMVar name info =

74− do mvar <- newEmptyMVar

75−

76− void $ forkIO $

77− do answers <- readMVar answersMVar

78− blocked <- isBlocked answers info

79− if blocked

80− then putMVar mvar Blocked

81− else

82− do tell (Progress.CompileFileStart name)

83− let pkg = Project.getName project

84− let docs = toDocsFlag name project maybeDocsPath

85− let imports = makeImports project info

86− ifaces <- readMVar ifacesMVar

87− let context = Compiler.Context pkg docs imports ifaces

88− let source = Plan._src info

89− case Compiler.compile context source of

90− (_warnings, Left errors) ->

91− do tell (Progress.CompileFileEnd name Progress.Bad)

92− let path = Plan._path info

93− let time = Plan._time info

94− putMVar mvar (Bad path time source errors)

95−

96− (_warnings, Right result@(Compiler.Artifacts elmi _ _)) ->

97− do tell (Progress.CompileFileEnd name Progress.Good)

98− let canonicalName = Module.Canonical pkg name

99− lock <- takeMVar ifacesMVar

100− putMVar ifacesMVar (Map.insert canonicalName elmi lock)

101− putMVar mvar (Good result)

102−

103− return mvar

104−

105−

106−

107−-- TO DOCS FLAG

108−

109−

110−toDocsFlag :: Module.Raw -> Project -> Maybe FilePath -> Compiler.DocsFlag

111−toDocsFlag name project maybeDocsPath =

112− case maybeDocsPath of

113− Nothing ->

114− Compiler.NoDocs

115−

116− Just _ ->

117− case project of

118− Project.App _ ->

119− Compiler.NoDocs

120−

121− Project.Pkg info ->

122− if isExposed name (Project._pkg_exposed info) then

123− Compiler.YesDocs

124− else

125− Compiler.NoDocs

126−

127−

128−isExposed :: Module.Raw -> Project.Exposed -> Bool

129−isExposed name exposed =

130− case exposed of

131− Project.ExposedList modules ->

132− elem name modules

133−

134− Project.ExposedDict chunks ->

135− elem name (concatMap snd chunks)

136−

137−

138−

139−-- IMPORTS

140−

141−

142−makeImports :: Project -> Plan.Info -> Dict Module.Canonical

143−makeImports project (Plan.Info _ _ _ clean dirty foreign) =

144− let

145− pkgName =

146− Project.getName project

147−

148− mkLocal name =

149− ( name, Module.Canonical pkgName name )

150−

151− mkForeign canonicalName@(Module.Canonical _ name) =

152− ( name, canonicalName )

153− in

154− Map.fromList $

155− map mkLocal clean

156− ++ map mkLocal dirty

157− ++ map mkForeign foreign

158−

159−

160−

161−-- INTERFACES

162−

163−

164−isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool

165−isBlocked answers info =

166− anyBlock <$> traverse (get answers) (Plan._dirty info)

167−

168−

169−get :: Dict (MVar Answer) -> Module.Raw -> IO Answer

170−get names name =

171− case Map.lookup name names of

172− Nothing ->

173− error "bug manifesting in File.Complie.get, please report at <TODO>!"

174−

175− Just mvar ->

176− readMVar mvar

177−

178−

179−anyBlock :: [Answer] -> Bool

180−anyBlock answers =

181− case answers of

182− [] ->

183− False

184−

185− Blocked : _ ->

186− True

187−

188− Bad _ _ _ _ : _ ->

189− True

190−

191− Good _ : otherAnswers ->

192− anyBlock otherAnswers

builder/src/File/Crawl.hsdeleted−297

@@ -1,297 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module File.Crawl

4− ( Result

5− , Graph(..)

6− , crawl

7− , crawlFromSource

8− )

9− where

10−

11−import Control.Concurrent.Chan (Chan, newChan, readChan)

12−import Control.Monad (foldM)

13−import Control.Monad.Except (liftIO)

14−import qualified Data.ByteString as BS

15−import qualified Data.Graph as Graph

16−import qualified Data.Map as Map

17−import qualified Data.Set as Set

18−

19−import qualified Elm.Compiler.Module as Module

20−import qualified Elm.Compiler.Objects as Obj

21−import qualified Elm.Kernel as Kernel

22−import qualified Elm.Package as Pkg

23−

24−import qualified Elm.Project.Json as Project

25−import Elm.Project.Summary (Summary(..))

26−import qualified File.Args as Args

27−import qualified File.Find as Find

28−import qualified File.Header as Header

29−import qualified File.IO as IO

30−import qualified Reporting.Exit as Exit

31−import qualified Reporting.Exit.Crawl as E

32−import qualified Reporting.Task as Task

33−

34−

35−

36−-- GRAPH

37−

38−

39−data Graph kernel problems =

40− Graph

41− { _args :: Args.Args Module.Raw

42− , _locals :: Map.Map Module.Raw Header.Info

43− , _kernels :: Map.Map Module.Raw kernel

44− , _foreigns :: Map.Map Module.Raw Pkg.Package

45− , _problems :: problems

46− }

47−

48−

49−type Result =

50− Graph Obj.Kernel ()

51−

52−

53−type WorkGraph =

54− Graph (FilePath, Maybe FilePath) [E.Problem]

55−

56−

57−initWorkGraph :: Args.Args Module.Raw -> Map.Map Module.Raw Header.Info -> WorkGraph

58−initWorkGraph args locals =

59− Graph args locals Map.empty Map.empty []

60−

61−

62−

63−-- CRAWL

64−

65−

66−crawl :: Summary -> Args.Args FilePath -> Task.Task Result

67−crawl summary args =

68− case args of

69− Args.Pkg names ->

70− do let roots = map (Unvisited E.ElmJson) names

71− let graph = initWorkGraph (Args.Pkg names) Map.empty

72− depthFirstSearch summary roots graph

73−

74− Args.Roots path [] ->

75− crawlHelp summary =<< Header.readOneFile summary path

76−

77− Args.Roots p ps ->

78− do (h,hs) <- Header.readManyFiles summary p ps

79− let unvisited = concatMap toUnvisited (h:hs)

80− let graph = initWorkGraph (Args.Roots (fst h) (map fst hs)) (Map.fromList (h:hs))

81− depthFirstSearch summary unvisited graph

82− where

83− toUnvisited (name, Header.Info path _ _ deps) =

84− map (Unvisited (E.Module path name)) deps

85−

86−

87−crawlFromSource :: Summary -> BS.ByteString -> Task.Task Result

88−crawlFromSource summary@(Summary _ project _ _ _) source =

89− crawlHelp summary =<<

90− Header.readSource project source

91−

92−

93−crawlHelp :: Summary -> ( Maybe Module.Raw, Header.Info ) -> Task.Task Result

94−crawlHelp summary ( maybeName, info@(Header.Info path _ _ deps) ) =

95− do let name = maybe "Main" id maybeName

96− let toUnvisited dep = Unvisited (maybe (E.File path) (E.Module path) maybeName) dep

97− let roots = map toUnvisited deps

98− let graph = initWorkGraph (Args.Roots name []) (Map.singleton name info)

99− depthFirstSearch summary roots graph

100−

101−

102−

103−-- DEPTH FIRST SEARCH

104−

105−

106−depthFirstSearch :: Summary -> [Unvisited] -> WorkGraph -> Task.Task Result

107−depthFirstSearch summary unvisited startGraph =

108− do chan <- liftIO newChan

109−

110− (Graph args locals kernelPaths foreigns problems) <-

111− dfs summary chan 0 Set.empty unvisited startGraph

112−

113− case problems of

114− [] ->

115− do checkForCycles locals

116− kernels <- visitKernels summary locals kernelPaths

117− return $ Graph args locals kernels foreigns ()

118−

119− problem : otherProblems ->

120− Task.throw (Exit.Crawl (E.DependencyProblems problem otherProblems))

121−

122−

123−

124−-- CHECK FOR CYCLES

125−

126−

127−checkForCycles :: Map.Map Module.Raw Header.Info -> Task.Task ()

128−checkForCycles locals =

129− let

130− toNode (name, Header.Info _ _ _ imports) =

131− (name, name, imports)

132−

133− components =

134− Graph.stronglyConnComp (map toNode (Map.toList locals))

135− in

136− mapM_ checkComponent components

137−

138−

139−checkComponent :: Graph.SCC Module.Raw -> Task.Task ()

140−checkComponent scc =

141− case scc of

142− Graph.AcyclicSCC _ ->

143− return ()

144−

145− Graph.CyclicSCC names ->

146− Task.throw (Exit.Cycle names)

147−

148−

149−

150−-- CONCURRENT DEPTH FIRST SEARCH

151−

152−

153−dfs

154− :: Summary

155− -> Chan (Either E.Problem Asset)

156− -> Int

157− -> Set.Set Module.Raw

158− -> [Unvisited]

159− -> WorkGraph

160− -> Task.Task WorkGraph

161−dfs summary chan oldPending oldSeen unvisited graph =

162− do (seen, pending) <-

163− foldM (spawnVisitor summary chan) (oldSeen, oldPending) unvisited

164−

165− if pending == 0

166− then return graph

167− else

168− do asset <- liftIO $ readChan chan

169− case asset of

170− Right (Local name info@(Header.Info path _ _ imports)) ->

171− do let newGraph = graph { _locals = Map.insert name info (_locals graph) }

172− let deps = map (Unvisited (E.Module path name)) imports

173− dfs summary chan (pending - 1) seen deps newGraph

174−

175− Right (Kernel name info) ->

176− do let kernels = Map.insert name info (_kernels graph)

177− let newGraph = graph { _kernels = kernels }

178− dfs summary chan (pending - 1) seen [] newGraph

179−

180− Right (Foreign name pkg) ->

181− do let foreigns = Map.insert name pkg (_foreigns graph)

182− let newGraph = graph { _foreigns = foreigns }

183− dfs summary chan (pending - 1) seen [] newGraph

184−

185− Right ForeignKernel ->

186− dfs summary chan (pending - 1) seen [] graph

187−

188− Left problem ->

189− do let problems = problem : _problems graph

190− let newGraph = graph { _problems = problems }

191− dfs summary chan (pending - 1) seen [] newGraph

192−

193−

194−spawnVisitor

195− :: Summary

196− -> Chan (Either E.Problem Asset)

197− -> (Set.Set Module.Raw, Int)

198− -> Unvisited

199− -> Task.Task (Set.Set Module.Raw, Int)

200−spawnVisitor summary chan (seen, n) unvisited@(Unvisited _ name) =

201− if Set.member name seen then

202− return (seen, n)

203− else

204− do Task.workerChan chan (toVisitor summary unvisited)

205− return (Set.insert name seen, n + 1)

206−

207−

208−

209−-- VISITOR

210−

211−

212−data Unvisited =

213− Unvisited

214− { _origin :: E.Origin

215− , _name :: Module.Raw

216− }

217−

218−

219−data Asset

220− = Local Module.Raw Header.Info

221− | Kernel Module.Raw (FilePath, Maybe FilePath)

222− | Foreign Module.Raw Pkg.Package

223− | ForeignKernel

224−

225−

226−toVisitor :: Summary -> Unvisited -> Task.Task_ E.Problem Asset

227−toVisitor summary (Unvisited origin name) =

228− do asset <- Find.find summary origin name

229− case asset of

230− Find.Local path ->

231− uncurry Local <$> Header.readModule summary name path

232−

233− Find.Foreign pkg ->

234− return $ Foreign name pkg

235−

236− Find.Kernel clientPath maybeServerPath ->

237− return $ Kernel name (clientPath, maybeServerPath)

238−

239− Find.ForeignKernel ->

240− return ForeignKernel

241−

242−

243−

244−-- VISIT KERNELS

245−

246−

247−visitKernels

248− :: Summary

249− -> Map.Map Module.Raw Header.Info

250− -> Map.Map Module.Raw (FilePath, Maybe FilePath)

251− -> Task.Task (Map.Map Module.Raw Obj.Kernel)

252−visitKernels summary locals kernelPaths =

253− if Map.null kernelPaths then

254− return Map.empty

255− else

256− -- TODO do this concurrently?

257− -- Need better concurrency primitives in Task

258− traverse (readKernel (toImportDict summary locals)) kernelPaths

259−

260−

261−readKernel :: ImportDict -> (FilePath, Maybe FilePath) -> Task.Task Obj.Kernel

262−readKernel importDict (clientPath, maybeServerPath) =

263− Obj.Kernel

264− <$> readKContent importDict clientPath

265− <*> traverse (readKContent importDict) maybeServerPath

266−

267−

268−readKContent :: ImportDict -> FilePath -> Task.Task Kernel.KContent

269−readKContent importDict path =

270− do source <- liftIO $ IO.readUtf8 path

271− case Kernel.parse importDict source of

272− Right content ->

273− return content

274−

275− Left _ ->

276− Task.throw (Exit.Crawl (E.BadKernelHeader path))

277−

278−

279−

280−-- IMPORT DICT

281−

282−

283−type ImportDict =

284− Map.Map Module.Raw [Pkg.Name]

285−

286−

287−toImportDict :: Summary -> Map.Map Module.Raw info -> ImportDict

288−toImportDict (Summary _ project exposed _ _) locals =

289− let

290− localPkg =

291− [Project.getName project]

292−

293− addLocal name _ dict =

294− Map.insertWith (++) name localPkg dict

295− in

296− Map.foldrWithKey addLocal (Map.map (map Pkg._name) exposed) locals

297−

builder/src/File/Find.hsdeleted−109

@@ -1,109 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module File.Find

4− ( Asset(..)

5− , find

6− )

7− where

8−

9−import Control.Monad.Except (liftIO)

10−import qualified Data.Map as Map

11−import qualified Data.Maybe as Maybe

12−import qualified System.FilePath as FP

13−import qualified System.Directory as Dir

14−import System.FilePath ((</>), (<.>))

15−

16−import qualified Elm.Compiler.Module as Module

17−import qualified Elm.Name as N

18−import qualified Elm.Package as Pkg

19−

20−import qualified Elm.Project.Json as Project

21−import qualified Elm.Project.Summary as Summary

22−import qualified Reporting.Exit.Crawl as E

23−import qualified Reporting.Task as Task

24−

25−

26−

27−-- ASSET

28−

29−

30−data Asset

31− = Local FilePath

32− | Kernel FilePath (Maybe FilePath)

33− | Foreign Pkg.Package

34− | ForeignKernel

35−

36−

37−

38−-- FIND

39−

40−

41−find :: Summary.Summary -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset

42−find (Summary.Summary root project exposed _ _) origin name =

43− do here <- liftIO Dir.getCurrentDirectory

44− let toRoot dir = FP.makeRelative here (root </> dir)

45− case project of

46− Project.App info ->

47− do let srcDirs = map toRoot (Project._app_source_dirs info)

48− findElm srcDirs exposed origin name

49−

50− Project.Pkg _ ->

51− if N.startsWith "Elm.Kernel." name then

52− if Project.isPlatformPackage project then

53− findKernel (toRoot "src") exposed origin name

54− else

55− Task.throw $ E.ModuleNameReservedForKernel origin name

56−

57− else

58− findElm [ toRoot "src" ] exposed origin name

59−

60−

61−

62−-- FIND ELM

63−

64−

65−findElm :: [FilePath] -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset

66−findElm srcDirs exposed origin name =

67− do

68− paths <- liftIO $ Maybe.catMaybes <$> mapM (elmExists name) srcDirs

69−

70− case (paths, Map.lookup name exposed) of

71− ([path], Nothing) ->

72− return (Local path)

73−

74− ([], Just [pkg]) ->

75− return (Foreign pkg)

76−

77− ([], Nothing) ->

78− Task.throw $ E.ModuleNotFound origin name srcDirs

79−

80− (_, maybePkgs) ->

81− Task.throw $ E.ModuleAmbiguous origin name paths (maybe [] id maybePkgs)

82−

83−

84−elmExists :: Module.Raw -> FilePath -> IO (Maybe FilePath)

85−elmExists name srcDir =

86− do let path = srcDir </> Module.nameToSlashPath name <.> "elm"

87− exists <- Dir.doesFileExist path

88− return $ if exists then Just path else Nothing

89−

90−

91−

92−-- FIND KERNEL

93−

94−

95−findKernel :: FilePath -> Summary.ExposedModules -> E.Origin -> Module.Raw -> Task.Task_ E.Problem Asset

96−findKernel srcDir exposed origin name =

97− do let clientPath = srcDir </> Module.nameToSlashPath name <.> "js"

98− let serverPath = srcDir </> Module.nameToSlashPath name <.> "server.js"

99− client <- liftIO $ Dir.doesFileExist clientPath

100− server <- liftIO $ Dir.doesFileExist serverPath

101− if client

102− then return $ Kernel clientPath (if server then Just serverPath else Nothing)

103− else

104− case Map.lookup (N.drop 11 name) exposed of

105− Just [Pkg.Package pkg _vsn] | pkg == Pkg.core || pkg == Pkg.virtualDom ->

106− return ForeignKernel

107−

108− _ ->

109− Task.throw $ E.ModuleNotFound origin name [srcDir]

builder/src/File/Hash.hsdeleted−110

@@ -1,110 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module File.Hash

3− ( Hasher

4− , put

5− , Digest

6− , toString

7− , putByteString

8− , putBuilder

9− , putFile

10− )

11− where

12−

13−

14−import Prelude hiding (appendFile)

15−import Control.Monad (foldM)

16−import qualified Control.Monad.State as State

17−import qualified Data.Binary.Get as Binary

18−import qualified Data.ByteString as BS

19−import qualified Data.ByteString.Builder as BS

20−import qualified Data.ByteString.Builder.Extra as BS (defaultChunkSize)

21−import qualified Data.ByteString.Lazy as LBS

22−import qualified Data.Digest.Pure.SHA as SHA

23−import qualified System.IO as IO

24−

25−

26−

27−-- HASHER

28−

29−

30−type Hasher = State.StateT State IO ()

31−

32−

33−type Digest = SHA.Digest SHA.SHA1State

34−

35−

36−put :: FilePath -> Hasher -> IO Digest

37−put path hasher =

38− IO.withBinaryFile path IO.WriteMode $ \handle ->

39− do let state = State handle 0 SHA.sha1Incremental

40− (State _ len decoder) <- State.execStateT hasher state

41− return (SHA.completeSha1Incremental decoder len)

42−

43−

44−toString :: Digest -> String

45−toString =

46− SHA.showDigest

47−

48−

49−

50−-- HASH STATE

51−

52−

53−data State =

54− State

55− { _handle :: !IO.Handle

56− , _length :: !Int

57− , _decoder :: !(Binary.Decoder SHA.SHA1State)

58− }

59−

60−

61−

62−-- PUBLIC API

63−

64−

65−putByteString :: BS.ByteString -> Hasher

66−putByteString chunk =

67− do state <- State.get

68− State.put =<< State.liftIO (appendByteString state chunk)

69−

70−

71−putBuilder :: BS.Builder -> Hasher

72−putBuilder builder =

73− do state <- State.get

74− State.put =<< State.liftIO (appendBuilder builder state)

75−

76−

77−putFile :: FilePath -> Hasher

78−putFile path =

79− do state <- State.get

80− State.put =<< State.liftIO (appendFile path state)

81−

82−

83−

84−-- PRIMITIVES

85−

86−

87−appendByteString :: State -> BS.ByteString -> IO State

88−appendByteString (State handle len decoder) chunk =

89− do BS.hPut handle chunk

90− return $ State handle (len + BS.length chunk) (Binary.pushChunk decoder chunk)

91−

92−

93−appendBuilder :: BS.Builder -> State -> IO State

94−appendBuilder builder state =

95− foldM appendByteString state $

96− LBS.toChunks (BS.toLazyByteString builder)

97−

98−

99−appendFile :: FilePath -> State -> IO State

100−appendFile path state =

101− IO.withBinaryFile path IO.ReadMode $ \handle ->

102− appendHelp handle state

103−

104−

105−appendHelp :: IO.Handle -> State -> IO State

106−appendHelp handle state =

107− do chunk <- BS.hGet handle BS.defaultChunkSize

108− if BS.null chunk

109− then return state

110− else appendHelp handle =<< appendByteString state chunk

builder/src/File/Header.hsdeleted−191

@@ -1,191 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module File.Header

4− ( Info(..)

5− , readModule

6− , readOneFile

7− , readManyFiles

8− , readSource

9− )

10− where

11−

12−import Control.Monad.Except (liftIO)

13−import qualified Data.ByteString as BS

14−import qualified Data.Map as Map

15−import qualified Data.Time.Calendar as Day

16−import qualified Data.Time.Clock as Time

17−import qualified System.Directory as Dir

18−

19−import qualified Elm.Compiler.Module as Module

20−import qualified Elm.Header as Header

21−

22−import qualified Elm.Project.Json as Project

23−import Elm.Project.Json (Project)

24−import Elm.Project.Summary (Summary(..))

25−import qualified File.IO as IO

26−import qualified Reporting.Exit as Exit

27−import qualified Reporting.Exit.Crawl as E

28−import qualified Reporting.Task as Task

29−

30−

31−

32−-- INFO

33−

34−

35−data Info =

36− Info

37− { _path :: FilePath

38− , _time :: Time.UTCTime

39− , _source :: BS.ByteString

40− , _imports :: [Module.Raw]

41− }

42−

43−

44−atRoot :: Task.Task_ E.Problem a -> Task.Task_ E.Exit a

45−atRoot task =

46− Task.mapError (\problem -> E.DependencyProblems problem []) task

47−

48−

49−-- READ MODULE

50−

51−

52−readModule :: Summary -> Module.Raw -> FilePath -> Task.Task_ E.Problem (Module.Raw, Info)

53−readModule summary expectedName path =

54− do time <- liftIO $ Dir.getModificationTime path

55− source <- liftIO $ IO.readUtf8 path

56− (maybeName, info) <- parse (_project summary) path time source

57− name <- checkName path expectedName maybeName

58− return (name, info)

59−

60−

61−checkName :: FilePath -> Module.Raw -> Maybe Module.Raw -> Task.Task_ E.Problem Module.Raw

62−checkName path expectedName maybeName =

63− case maybeName of

64− Nothing ->

65− Task.throw (E.ModuleNameMissing path expectedName)

66−

67− Just actualName ->

68− if expectedName == actualName

69− then return expectedName

70− else Task.throw (E.ModuleNameMismatch path expectedName actualName)

71−

72−

73−

74−-- READ ONE FILE

75−

76−

77−readOneFile :: Summary -> FilePath -> Task.Task (Maybe Module.Raw, Info)

78−readOneFile summary path =

79− Task.mapError Exit.Crawl $

80− do (time, source) <- readOneHelp path

81− atRoot $ parse (_project summary) path time source

82−

83−

84−readOneHelp :: FilePath -> Task.Task_ E.Exit (Time.UTCTime, BS.ByteString)

85−readOneHelp path =

86− do exists <- IO.exists path

87− if exists

88− then liftIO $ (,) <$> Dir.getModificationTime path <*> IO.readUtf8 path

89− else Task.throw $ E.RootFileNotFound path

90−

91−

92−

93−-- READ MANY FILES

94−

95−

96−readManyFiles :: Summary -> FilePath -> [FilePath] -> Task.Task ((Module.Raw, Info), [(Module.Raw, Info)])

97−readManyFiles summary file files =

98− Task.mapError Exit.Crawl $

99− do info <- readManyFilesHelp summary file

100− infos <- traverse (readManyFilesHelp summary) files

101− let nameTable = foldr insert Map.empty (info:infos)

102− _ <- Map.traverseWithKey detectDuplicateNames nameTable

103− return (info, infos)

104− where

105− append (x,xs) (y,ys) = (x, xs ++ y : ys)

106− insert (k,v) dict = Map.insertWith append k (v, []) dict

107−

108−

109−readManyFilesHelp :: Summary -> FilePath -> Task.Task_ E.Exit (Module.Raw, Info)

110−readManyFilesHelp summary path =

111− do (time, source) <- readOneHelp path

112− (maybeName, info) <- atRoot $ parse (_project summary) path time source

113− case maybeName of

114− Nothing ->

115− Task.throw (E.RootNameless path)

116−

117− Just name ->

118− return (name, info)

119−

120−

121−detectDuplicateNames :: Module.Raw -> (Info, [Info]) -> Task.Task_ E.Exit ()

122−detectDuplicateNames name (info, otherInfos) =

123− case otherInfos of

124− [] ->

125− return ()

126−

127− _ ->

128− Task.throw (E.RootModuleNameDuplicate name (map _path (info : otherInfos)))

129−

130−

131−

132−

133−-- READ SOURCE

134−

135−

136−readSource :: Project -> BS.ByteString -> Task.Task (Maybe Module.Raw, Info)

137−readSource project source =

138− Task.mapError Exit.Crawl $

139− atRoot $ parse project "elm" fakeTime source

140−

141−

142−fakeTime :: Time.UTCTime

143−fakeTime =

144− Time.UTCTime (Day.fromGregorian 3000 1 1) 0

145−

146−

147−

148−-- PARSE HEADER

149−

150−

151−parse :: Project -> FilePath -> Time.UTCTime -> BS.ByteString -> Task.Task_ E.Problem (Maybe Module.Raw, Info)

152−parse project path time source =

153− -- TODO get regions on data extracted here

154− case Header.parse (Project.getName project) source of

155− Right (maybeDecl, deps) ->

156− do maybeName <- checkTag project path maybeDecl

157− return ( maybeName, Info path time source deps )

158−

159− Left msg ->

160− Task.throw (E.BadHeader path time source msg)

161−

162−

163−checkTag :: Project -> FilePath -> Maybe (Header.Tag, Module.Raw) -> Task.Task_ E.Problem (Maybe Module.Raw)

164−checkTag project path maybeDecl =

165− case maybeDecl of

166− Nothing ->

167− return Nothing

168−

169− Just (tag, name) ->

170− let

171− success =

172− return (Just name)

173− in

174− case tag of

175− Header.Normal ->

176− success

177−

178− Header.Port ->

179− case project of

180− Project.App _ ->

181− success

182−

183− Project.Pkg _ ->

184− Task.throw (E.PortsInPackage path name)

185−

186− Header.Effect ->

187− if Project.isPlatformPackage project then

188− success

189−

190− else

191− Task.throw (E.EffectsUnexpected path name)

builder/src/File/IO.hsdeleted−249

@@ -1,249 +0,0 @@

1−module File.IO

2− ( writeBinary, readBinary

3− , writeUtf8, readUtf8

4− , writeBuilder

5− , Writer

6− , put

7− , putByteString

8− , putBuilder

9− , putFile

10− , exists

11− , remove, removeDir

12− , find

13− , andM

14− )

15− where

16−

17−

18−import Control.Exception (catch)

19−import Control.Monad.Trans (liftIO)

20−import qualified Data.Binary as Binary

21−import qualified Data.ByteString as BS

22−import qualified Data.ByteString.Internal as BS

23−import qualified Data.ByteString.Builder as B

24−import qualified Data.ByteString.Builder.Extra as B (defaultChunkSize)

25−import qualified Foreign.ForeignPtr as FPtr

26−import GHC.IO.Exception (IOException, IOErrorType(InvalidArgument))

27−import qualified System.Directory as Dir

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

29−import qualified System.FilePath as FP

30−import qualified System.IO as IO

31−import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)

32−

33−import qualified Reporting.Exit as Exit

34−import qualified Reporting.Exit.Assets as E

35−import qualified Reporting.Task as Task

36−

37−

38−

39−-- BINARY

40−

41−

42−writeBinary :: (Binary.Binary a) => FilePath -> a -> Task.Task ()

43−writeBinary path value =

44− liftIO $

45− do let dir = FP.dropFileName path

46− Dir.createDirectoryIfMissing True dir

47− Binary.encodeFile path value

48−

49−

50−readBinary :: (Binary.Binary a) => FilePath -> Task.Task a

51−readBinary path =

52− do exists_ <- liftIO (Dir.doesFileExist path)

53− if not exists_

54− then throwCorruptBinary path

55− else

56− do result <- liftIO (Binary.decodeFileOrFail path)

57− case result of

58− Left _ ->

59− throwCorruptBinary path

60−

61− Right value ->

62− return value

63−

64−

65−throwCorruptBinary :: FilePath -> Task.Task a

66−throwCorruptBinary filePath =

67− Task.throw (Exit.Assets (E.CorruptBinary filePath))

68−

69−

70−

71−-- WRITE UTF-8

72−

73−

74−writeUtf8 :: FilePath -> BS.ByteString -> IO ()

75−writeUtf8 filePath content =

76− withUtf8 filePath IO.WriteMode $ \handle ->

77− BS.hPut handle content

78−

79−

80−withUtf8 :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a

81−withUtf8 filePath mode callback =

82− IO.withFile filePath mode $ \handle ->

83− do IO.hSetEncoding handle IO.utf8

84− callback handle

85−

86−

87−

88−-- READ UTF-8

89−

90−

91−readUtf8 :: FilePath -> IO BS.ByteString

92−readUtf8 filePath =

93− withUtf8 filePath IO.ReadMode $ \handle ->

94− modifyIOError (encodingError filePath) $

95− do fileSize <- catch (IO.hFileSize handle) useZeroIfNotRegularFile

96− let readSize = max 0 (fromIntegral fileSize) + 1

97− hGetContentsSizeHint handle readSize (max 255 readSize)

98−

99−

100−useZeroIfNotRegularFile :: IOException -> IO Integer

101−useZeroIfNotRegularFile _ =

102− return 0

103−

104−

105−hGetContentsSizeHint :: IO.Handle -> Int -> Int -> IO BS.ByteString

106−hGetContentsSizeHint handle =

107− readChunks []

108− where

109− readChunks chunks readSize incrementSize =

110− do fp <- BS.mallocByteString readSize

111− readCount <- FPtr.withForeignPtr fp $ \buf -> IO.hGetBuf handle buf readSize

112− let chunk = BS.PS fp 0 readCount

113− if readCount < readSize && readSize > 0

114− then return $! BS.concat (reverse (chunk:chunks))

115− else readChunks (chunk:chunks) incrementSize (min 32752 (readSize + incrementSize))

116−

117−

118−encodingError :: FilePath -> IOError -> IOError

119−encodingError filePath ioErr =

120− case ioeGetErrorType ioErr of

121− InvalidArgument ->

122− annotateIOError

123− (userError "Bad encoding; the file must be valid UTF-8")

124− ""

125− Nothing

126− (Just filePath)

127−

128− _ ->

129− ioErr

130−

131−

132−

133−-- WRITE BUILDER

134−

135−

136−writeBuilder :: FilePath -> B.Builder -> IO ()

137−writeBuilder path builder =

138− IO.withBinaryFile path IO.WriteMode $ \handle ->

139− do IO.hSetBuffering handle (IO.BlockBuffering Nothing)

140− B.hPutBuilder handle builder

141−

142−

143−

144−-- WRITER

145−

146−

147−newtype Writer =

148− Writer (IO.Handle -> IO ())

149−

150−

151−put :: FilePath -> Writer -> IO ()

152−put path (Writer callback) =

153− IO.withBinaryFile path IO.WriteMode callback

154−

155−

156−putByteString :: BS.ByteString -> Writer

157−putByteString chunk =

158− Writer $ \handle ->

159− BS.hPut handle chunk

160−

161−

162−putBuilder :: B.Builder -> Writer

163−putBuilder builder =

164− Writer $ \handle ->

165− B.hPutBuilder handle builder

166−

167−

168−putFile :: FilePath -> Writer

169−putFile path =

170− Writer $ \sink ->

171− IO.withBinaryFile path IO.ReadMode $ \source ->

172− putHelp source sink

173−

174−

175−putHelp :: IO.Handle -> IO.Handle -> IO ()

176−putHelp source sink =

177− do chunk <- BS.hGet source B.defaultChunkSize

178− if BS.null chunk

179− then return ()

180− else

181− do BS.hPut sink chunk

182− putHelp source sink

183−

184−

185−

186−-- EXISTS

187−

188−

189−exists :: FilePath -> Task.Task_ e Bool

190−exists filePath =

191− liftIO $ Dir.doesFileExist filePath

192−

193−

194−

195−-- REMOVE FILES

196−

197−

198−remove :: FilePath -> Task.Task_ e ()

199−remove filePath =

200− liftIO $

201− do exists_ <- Dir.doesFileExist filePath

202− if exists_

203− then Dir.removeFile filePath

204− else return ()

205−

206−

207−removeDir :: FilePath -> IO ()

208−removeDir path =

209− do exists_ <- Dir.doesDirectoryExist path

210− if exists_

211− then Dir.removeDirectoryRecursive path

212− else return ()

213−

214−

215−

216−-- FIND FILES

217−

218−

219−find :: FilePath -> IO (Maybe FilePath)

220−find name =

221− do subDir <- Dir.getCurrentDirectory

222− findHelp name (FP.splitDirectories subDir)

223−

224−

225−findHelp :: FilePath -> [String] -> IO (Maybe FilePath)

226−findHelp name dirs =

227− if null dirs then

228− return Nothing

229−

230− else

231− do exists_ <- Dir.doesFileExist (FP.joinPath dirs </> name)

232− if exists_

233− then return (Just (FP.joinPath dirs))

234− else findHelp name (init dirs)

235−

236−

237−

238−-- HELPER

239−

240−

241−andM :: (Monad m) => [m Bool] -> m Bool

242−andM checks =

243− case checks of

244− [] ->

245− return True

246−

247− check : otherChecks ->

248− do bool <- check

249− if bool then andM otherChecks else return False

builder/src/File/Plan.hsdeleted−205

@@ -1,205 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module File.Plan

4− ( plan

5− , Info(..)

6− )

7− where

8−

9−import Control.Concurrent (forkIO)

10−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

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

12−import Control.Monad (foldM, void, when)

13−import Control.Monad.Except (liftIO)

14−import qualified Data.Binary as Binary

15−import qualified Data.ByteString as BS

16−import qualified Data.Map as Map

17−import qualified Data.Time.Clock as Time

18−import qualified System.Directory as Dir

19−

20−import qualified Elm.Compiler.Module as Module

21−import qualified Elm.Package as Pkg

22−

23−import qualified Elm.Project.Json as Project

24−import qualified Elm.Project.Summary as Summary

25−import qualified File.Crawl as Crawl

26−import qualified File.Header as Header

27−import qualified Reporting.Task as Task

28−import qualified Stuff.Paths

29−

30−

31−

32−-- PLAN

33−

34−

35−type Dict value = Map.Map Module.Raw value

36−

37−

38−plan :: Maybe FilePath -> Summary.Summary -> Crawl.Result -> Task.Task (Dict Info, Module.Interfaces)

39−plan docs (Summary.Summary root project _ ifaces _) (Crawl.Graph _ locals _ foreigns _) =

40− liftIO $

41− do queue <- newChan

42− let env = Env queue root (Project.getName project) docs

43−

44− mvar <- newEmptyMVar

45− statusMVars <- Map.traverseWithKey (getStatus env mvar foreigns) locals

46− putMVar mvar statusMVars

47−

48− void $ forkIO $

49− do graph <- Map.traverseMaybeWithKey (\_ -> readMVar) statusMVars

50− writeChan queue (EndLoop graph)

51−

52− ifaceLoader queue ifaces

53−

54−

55−data Env =

56− Env

57− { _queue :: Chan Msg

58− , _root :: FilePath

59− , _pkg :: Pkg.Name

60− , _docs :: Maybe FilePath

61− }

62−

63−

64−

65−-- STATUS

66−

67−

68−type Status = Maybe Info

69− -- Nothing == clean

70− -- Just info == dirty

71−

72−

73−data Info =

74− Info

75− { _path :: FilePath

76− , _time :: Time.UTCTime

77− , _src :: BS.ByteString

78− , _clean :: [Module.Raw]

79− , _dirty :: [Module.Raw]

80− , _foreign :: [Module.Canonical] -- TODO is this needed?

81− }

82−

83−

84−

85−-- GET STATUS

86−

87−

88−getStatus

89− :: Env

90− -> MVar (Dict (MVar Status))

91− -> Dict Pkg.Package

92− -> Module.Raw

93− -> Header.Info

94− -> IO (MVar Status)

95−getStatus env statusMVars foreigns name (Header.Info path time src deps) =

96− do mvar <- newEmptyMVar

97−

98− void $ forkIO $ putMVar mvar =<<

99− do statuses <- readMVar statusMVars

100− info <- foldM (addDep statuses foreigns) (Info path time src [] [] []) deps

101−

102− let elmi = Stuff.Paths.elmi (_root env) name

103− let docs = Stuff.Paths.moduleDocs (_root env) name

104−

105− case _dirty info of

106− _ : _ ->

107− do remove elmi

108− remove docs

109− return (Just info)

110−

111− [] ->

112− do freshElmi <- isFresh time elmi

113− freshDocs <-

114− case _docs env of

115− Nothing -> return True

116− Just _ -> isFresh time docs

117−

118− if freshElmi && freshDocs

119− then

120− do let canonical = Module.Canonical (_pkg env) name

121− writeChan (_queue env) (Get canonical elmi)

122− return Nothing

123− else

124− do remove elmi

125− remove docs

126− return (Just info)

127−

128− return mvar

129−

130−

131−addDep :: Dict (MVar Status) -> Dict Pkg.Package -> Info -> Module.Raw -> IO Info

132−addDep locals foreigns info name =

133− case Map.lookup name locals of

134− Just mvar ->

135− do status <- readMVar mvar

136− case status of

137− Nothing ->

138− return $ info { _clean = name : _clean info }

139−

140− Just _ ->

141− return $ info { _dirty = name : _dirty info }

142−

143− Nothing ->

144− case Map.lookup name foreigns of

145− Just (Pkg.Package pkg _vsn) ->

146− return $ info { _foreign = Module.Canonical pkg name : _foreign info }

147−

148− Nothing ->

149− return info -- must be native

150−

151−

152−

153−-- IS FRESH

154−

155−

156−isFresh :: Time.UTCTime -> FilePath -> IO Bool

157−isFresh srcTime cachedFile =

158− andM

159− [ Dir.doesFileExist cachedFile

160− , do cacheTime <- Dir.getModificationTime cachedFile

161− return (cacheTime >= srcTime)

162− ]

163−

164−

165−andM :: [IO Bool] -> IO Bool

166−andM checks =

167− case checks of

168− [] ->

169− return True

170−

171− check : otherChecks ->

172− do bool <- check

173− if bool then andM otherChecks else return False

174−

175−

176−remove :: FilePath -> IO ()

177−remove path =

178− do exists <- Dir.doesFileExist path

179− when exists (Dir.removeFile path)

180−

181−

182−

183−-- INTERFACE LOADER

184−

185−

186−data Msg

187− = EndLoop (Dict Info)

188− | Get Module.Canonical FilePath

189−

190−

191−ifaceLoader :: Chan Msg -> Module.Interfaces -> IO (Dict Info, Module.Interfaces)

192−ifaceLoader queue ifaces =

193− do msg <- readChan queue

194− case msg of

195− EndLoop dirty ->

196− return ( dirty, ifaces )

197−

198− Get canonical elmi ->

199− case Map.lookup canonical ifaces of

200− Just _ ->

201− ifaceLoader queue ifaces

202−

203− Nothing ->

204− do iface <- Binary.decodeFile elmi

205− ifaceLoader queue $ Map.insert canonical iface ifaces

builder/src/File/Watcher.hsdeleted−76

@@ -1,76 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module File.Watcher where

3−

4−import Control.Concurrent (forkIO, threadDelay)

5−import Control.Concurrent.Chan (newChan, readChan, writeChan)

6−import qualified System.FSNotify as Notify

7−

8−import qualified Elm.Project as Project

9−import Elm.Project (Project)

10−

11−

12−

13−-- GRAPH

14−

15−

16−data Graph =

17− Graph

18− { _elm :: Map.Map Module.Raw Node

19− , _js :: Map.Map Module.Raw FilePath

20− }

21−

22−

23−data Node =

24− Node

25− { _path :: FilePath

26− , _time :: UTCTime

27− , _needs :: Set.Set Module.Raw

28− , _blocks :: Set.Set Module.Raw

29− , _iface :: Maybe (UTCTime, Interface)

30− }

31−

32−

33−

34−-- ABC

35−

36−

37−action :: Notify.Event -> IO ()

38−action event =

39− case event of

40− Notify.Added path time ->

41− return ()

42−

43− Notify.Modified path time ->

44− return ()

45−

46− Notify.Removed path time ->

47− return ()

48−

49−

50−watcher :: Project -> IO ()

51−watcher project =

52− let

53− srcDir =

54− Project.toSourceDir project

55−

56− action event =

57− case event of

58− Notify.Added _ _ ->

59− return ()

60−

61− Notify.Modified path time ->

62−

63− Notify.Removed path time ->

64−

65− in

66− do killer <- newChan

67− mapM_ (watcherHelp killer action) [srcDir]

68−

69−

70−

71−watcherHelp :: Notify.Action -> FilePath -> IO ()

72−watcherHelp killer action dir =

73− void $ forkIO $ Notify.withManager $ \manager ->

74− do stop <- Notify.watchTree manager dir (const True) action

75− _ <- readChan killer

76− stop

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/Generate/Html.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−module Generate.Html

4− ( sandwich

5− )

6− where

7−

8−

9−import qualified Data.ByteString.Builder as B

10−import Data.Monoid ((<>))

11−import Text.RawString.QQ (r)

12−

13−import qualified Elm.Name as N

14−

15−

16−

17−-- SANDWICH

18−

19−

20−sandwich :: N.Name -> B.Builder -> B.Builder

21−sandwich moduleName javascript =

22− let name = N.toBuilder moduleName in

23− [r|<!DOCTYPE HTML>

24−<html>

25−<head>

26− <meta charset="UTF-8">

27− <title>|] <> name <> [r|</title>

28−</head>

29−

30−<body>

31−<div id="embed"></div>

32−<script>

33−|] <> javascript <> [r|

34−

35−// It is too complicated to figure out which kind of Program you created

36−// based on only the code. So here we check for different possibilities.

37−//

38−// When you embed compiled Elm into HTML yourself, you should not copy/paste

39−// from here. Do just the part that makes sense for your application!

40−//

41−var app =

42− Elm.|] <> name <> [r|.fullscreen

43− ? Elm.|] <> name <> [r|.fullscreen()

44− :

45− Elm.|] <> name <> [r|.embed

46− ? Elm.|] <> name <> [r|.embed(document.getElementById('embed'))

47− :

48− Elm.|] <> name <> [r|.worker

49− ? (document.getElementById('embed').innerText = 'This is a headless program, meaning there is nothing to show here. I started the program anyway though, and you can access it as `app` in the developer console.', Elm.|] <> name <> [r|.worker())

50− : (document.getElementById('embed').innerText = 'I cannot figure out what kind of program this is supposed to be. Perhaps someone on Slack can help?', undefined);

51−</script>

52−</body>

53−</html>|]

builder/src/Generate/Output.hsdeleted−280

@@ -1,280 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Generate.Output

4− ( Mode(..)

5− , Mode.Target(..)

6− , generate

7− , generateReplFile

8− , noDebugUsesInPackage

9− , Output(..)

10− , output

11− )

12− where

13−

14−

15−import Control.Concurrent.MVar (MVar, putMVar)

16−import Control.Monad.Trans (liftIO)

17−import qualified Data.ByteString.Builder as B

18−import qualified Data.Map as Map

19−import Data.Monoid ((<>))

20−import qualified System.Directory as Dir

21−import qualified System.FilePath as FP

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

23−

24−import qualified Elm.Compiler as Compiler

25−import qualified Elm.Compiler.Module as Module

26−import qualified Elm.Compiler.Objects as Obj

27−import qualified Elm.Interface as I

28−import qualified Elm.Name as N

29−import qualified Elm.Package as Pkg

30−

31−import qualified AST.Module.Name as ModuleName

32−import qualified Elm.Project.Json as Project

33−import qualified Elm.Project.Summary as Summary

34−import qualified File.Args as Args

35−import qualified File.Crawl as Crawl

36−import qualified File.IO as IO

37−import qualified Generate.Functions as Functions

38−import qualified Generate.Html as Html

39−import qualified Generate.Nitpick as Nitpick

40−import qualified Generate.JavaScript.Mode as Mode

41−import qualified Reporting.Exit as Exit

42−import qualified Reporting.Exit.Make as E

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

44−import qualified Reporting.Task as Task

45−import qualified Stuff.Paths as Paths

46−import Terminal.Args (Parser(..))

47−

48−

49−

50−-- GENERATE

51−

52−

53−data Mode = Debug | Dev | Prod

54−

55−

56−generate

57− :: Mode

58− -> Mode.Target

59− -> Maybe Output

60− -> Summary.Summary

61− -> Crawl.Result

62− -> Map.Map Module.Raw Compiler.Artifacts

63− -> Task.Task ()

64−generate mode target maybeOutput summary graph@(Crawl.Graph args _ _ _ _) artifacts =

65− case args of

66− Args.Pkg _ ->

67− return ()

68−

69− Args.Roots name names ->

70− do objectGraph <- organize summary graph

71−

72− realMode <-

73− case mode of

74− Debug ->

75− return $ Mode.debug target (getInterfaces summary artifacts)

76−

77− Dev ->

78− return $ Mode.dev target

79−

80− Prod ->

81− do noDebugUses summary objectGraph

82− return $ Mode.prod target objectGraph

83−

84− generateMonolith realMode maybeOutput summary objectGraph (name:names)

85−

86−

87−getInterfaces :: Summary.Summary -> Map.Map Module.Raw Compiler.Artifacts -> I.Interfaces

88−getInterfaces (Summary.Summary _ project _ interfaces _) artifacts =

89− let

90− pkg = Project.getName project

91− addArtifact home (Compiler.Artifacts elmi _ _) ifaces =

92− Map.insert (ModuleName.Canonical pkg home) elmi ifaces

93− in

94− Map.foldrWithKey addArtifact interfaces artifacts

95−

96−

97−

98−-- GENERATE MONOLITH

99−

100−

101−generateMonolith

102− :: Mode.Mode

103− -> Maybe Output

104− -> Summary.Summary

105− -> Obj.Graph

106− -> [Module.Raw]

107− -> Task.Task ()

108−generateMonolith mode maybeOutput (Summary.Summary _ project _ _ _) graph rootNames =

109− do let pkg = Project.getName project

110− let roots = map (Module.Canonical pkg) rootNames

111− case Obj.generate mode graph roots of

112− Obj.None ->

113− return ()

114−

115− Obj.Some name _names builder ->

116− let

117− monolith =

118− "(function(scope){\n'use strict';"

119− <> Functions.functions <> builder <> "}(this));"

120− in

121− liftIO $

122− case maybeOutput of

123− Nothing ->

124− IO.writeBuilder "elm.js" monolith

125−

126− Just output_ ->

127− case output_ of

128− None ->

129− return ()

130−

131− JavaScript maybeDir fileName ->

132− do path <- toWritablePath maybeDir fileName

133− IO.writeBuilder path monolith

134−

135− HtmlBuilder mvar ->

136− putMVar mvar (Html.sandwich name monolith)

137−

138− Html maybeDir fileName ->

139− do path <- toWritablePath maybeDir fileName

140− IO.writeBuilder path (Html.sandwich name monolith)

141−

142−

143−

144−-- GENERATE REPL MONOLITH

145−

146−

147−generateReplFile

148− :: L.Localizer

149− -> Summary.Summary

150− -> Crawl.Result

151− -> I.Interface

152− -> N.Name

153− -> Task.Task FilePath

154−generateReplFile localizer summary@(Summary.Summary _ project _ _ _) graph iface name =

155− do

156− objectGraph <- organize summary graph

157−

158− let home = Module.Canonical (Project.getName project) N.replModule

159− let builder = Obj.generateForRepl True localizer objectGraph iface home name

160−

161− liftIO $ IO.writeBuilder (Paths.temp "js") $

162− replRecovery <> "(function(){\n'use strict';" <> Functions.functions <> builder <> "}());"

163−

164− return (Paths.temp "js")

165−

166−

167−replRecovery :: B.Builder

168−replRecovery =

169− "process.on('uncaughtException', function(err) { process.stderr.write(err.toString()); process.exit(1); });"

170−

171−

172−

173−-- ORGANIZE

174−

175−

176−organize :: Summary.Summary -> Crawl.Result -> Task.Task Obj.Graph

177−organize (Summary.Summary root _ _ _ deps) (Crawl.Graph _ locals _ _ _) =

178− do localObjs <- Obj.unions <$> traverse (loadModuleObj root) (Map.keys locals)

179− foreignObjs <- Obj.unions <$> traverse loadPackageObj (Map.toList deps)

180− return (Obj.union localObjs foreignObjs)

181−

182−

183−loadModuleObj :: FilePath -> Module.Raw -> Task.Task Obj.Graph

184−loadModuleObj root name =

185− IO.readBinary (Paths.elmo root name)

186−

187−

188−loadPackageObj :: ( Pkg.Name, (Pkg.Version, deps) ) -> Task.Task Obj.Graph

189−loadPackageObj ( name, (version,_) ) =

190− do dir <- Task.getPackageCacheDirFor name version

191− IO.readBinary (dir </> "objs.dat")

192−

193−

194−

195−-- NO DEBUG USES

196−

197−

198−noDebugUses :: Summary.Summary -> Obj.Graph -> Task.Task ()

199−noDebugUses (Summary.Summary _ project _ _ _) graph =

200− case Nitpick.findDebugUses (Project.getName project) graph of

201− [] ->

202− return ()

203−

204− m:ms ->

205− Task.throw (Exit.Make (E.CannotOptimizeDebugValues m ms))

206−

207−

208−noDebugUsesInPackage :: Summary.Summary -> Crawl.Result -> Task.Task ()

209−noDebugUsesInPackage summary graph =

210− noDebugUses summary =<< organize summary graph

211−

212−

213−

214−-- OUTPUT

215−

216−

217−data Output

218− = None

219− | Html (Maybe FilePath) FilePath

220− | JavaScript (Maybe FilePath) FilePath

221− | HtmlBuilder (MVar B.Builder)

222−

223−

224−toWritablePath :: Maybe FilePath -> FilePath -> IO FilePath

225−toWritablePath maybeDir fileName =

226− case maybeDir of

227− Nothing ->

228− do return fileName

229−

230− Just dir ->

231− do Dir.createDirectoryIfMissing True dir

232− return (dir </> fileName)

233−

234−

235−

236−-- OUTPUT PARSER

237−

238−

239−output :: Parser Output

240−output =

241− Parser

242− { _singular = "output file"

243− , _plural = "output files"

244− , _parser = parseOutput

245− , _suggest = \_ -> return []

246− , _examples = exampleOutput

247− }

248−

249−

250−parseOutput :: String -> Maybe Output

251−parseOutput string =

252− if string == "/dev/null" || string == "NUL" || string == "$null" then

253− Just None

254−

255− else if FP.takeExtension string == ".html" && length string > 5 then

256− splitOutput Html string

257−

258− else if FP.takeExtension string == ".js" && length string > 3 then

259− splitOutput JavaScript string

260−

261− else

262− Nothing

263−

264−

265−splitOutput :: (Maybe FilePath -> FilePath -> Output) -> String -> Maybe Output

266−splitOutput toOutput string =

267− case FP.splitPath string of

268− [] ->

269− Nothing

270−

271− [name] ->

272− Just $ toOutput Nothing name

273−

274− segments ->

275− Just $ toOutput (Just (FP.joinPath (init segments))) (last segments)

276−

277−

278−exampleOutput :: String -> IO [String]

279−exampleOutput _ =

280− return [ "elm.js", "index.html", "/dev/null" ]

builder/src/Http.hsnew file+244

@@ -0,0 +1,244 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Http

3+ ( Manager

4+ , getManager

5+ , toUrl

6+ -- fetch

7+ , get

8+ , post

9+ , Header

10+ , accept

11+ , Error(..)

12+ -- archives

13+ , Sha

14+ , shaToChars

15+ , getArchive

16+ -- upload

17+ , upload

18+ , filePart

19+ , jsonPart

20+ , stringPart

21+ )

22+ where

23+

24+

25+import Prelude hiding (zip)

26+import qualified Codec.Archive.Zip as Zip

27+import Control.Exception (SomeException, handle)

28+import qualified Data.Binary as Binary

29+import qualified Data.Binary.Get as Binary

30+import qualified Data.ByteString.Builder as B

31+import qualified Data.ByteString.Char8 as BS

32+import qualified Data.Digest.Pure.SHA as SHA

33+import qualified Data.String as String

34+import Network.HTTP (urlEncodeVars)

35+import Network.HTTP.Client

36+import Network.HTTP.Client.TLS (tlsManagerSettings)

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

38+import Network.HTTP.Types.Method (Method, methodGet, methodPost)

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

40+import qualified Network.HTTP.Client.MultipartFormData as Multi

41+

42+import qualified Json.Encode as Encode

43+import qualified Elm.Version as V

44+

45+

46+

47+-- MANAGER

48+

49+

50+getManager :: IO Manager

51+getManager =

52+ newManager tlsManagerSettings

53+

54+

55+

56+-- URL

57+

58+

59+toUrl :: String -> [(String,String)] -> String

60+toUrl url params =

61+ case params of

62+ [] -> url

63+ _:_ -> url ++ "?" ++ urlEncodeVars params

64+

65+

66+

67+-- FETCH

68+

69+

70+get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)

71+get =

72+ fetch methodGet

73+

74+

75+post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)

76+post =

77+ fetch methodPost

78+

79+

80+fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)

81+fetch methodVerb manager url headers onError onSuccess =

82+ handle (handleSomeException url onError) $

83+ handle (handleHttpException url onError) $

84+ do req0 <- parseUrlThrow url

85+ let req1 =

86+ req0

87+ { method = methodVerb

88+ , requestHeaders = addDefaultHeaders headers

89+ }

90+ withResponse req1 manager $ \response ->

91+ do chunks <- brConsume (responseBody response)

92+ onSuccess (BS.concat chunks)

93+

94+

95+addDefaultHeaders :: [Header] -> [Header]

96+addDefaultHeaders headers =

97+ (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers

98+

99+

100+{-# NOINLINE userAgent #-}

101+userAgent :: BS.ByteString

102+userAgent =

103+ BS.pack ("elm/" ++ V.toChars V.compiler)

104+

105+

106+accept :: BS.ByteString -> Header

107+accept mime =

108+ (hAccept, mime)

109+

110+

111+

112+-- EXCEPTIONS

113+

114+

115+data Error

116+ = BadUrl String String

117+ | BadHttp String HttpExceptionContent

118+ | BadMystery String SomeException

119+

120+

121+handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)

122+handleHttpException url onError httpException =

123+ case httpException of

124+ InvalidUrlException _ reason ->

125+ return (Left (onError (BadUrl url reason)))

126+

127+ HttpExceptionRequest _ content ->

128+ return (Left (onError (BadHttp url content)))

129+

130+

131+handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)

132+handleSomeException url onError exception =

133+ return (Left (onError (BadMystery url exception)))

134+

135+

136+

137+-- SHA

138+

139+

140+type Sha = SHA.Digest SHA.SHA1State

141+

142+

143+shaToChars :: Sha -> String

144+shaToChars =

145+ SHA.showDigest

146+

147+

148+

149+-- FETCH ARCHIVE

150+

151+

152+getArchive

153+ :: Manager

154+ -> String

155+ -> (Error -> e)

156+ -> e

157+ -> ((Sha, Zip.Archive) -> IO (Either e a))

158+ -> IO (Either e a)

159+getArchive manager url onError err onSuccess =

160+ handle (handleSomeException url onError) $

161+ handle (handleHttpException url onError) $

162+ do req0 <- parseUrlThrow url

163+ let req1 =

164+ req0

165+ { method = methodGet

166+ , requestHeaders = addDefaultHeaders []

167+ }

168+ withResponse req1 manager $ \response ->

169+ do result <- readArchive (responseBody response)

170+ case result of

171+ Nothing -> return (Left err)

172+ Just shaAndArchive -> onSuccess shaAndArchive

173+

174+

175+readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))

176+readArchive body =

177+ readArchiveHelp body $

178+ AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)

179+

180+

181+data ArchiveState =

182+ AS

183+ { _len :: !Int

184+ , _sha :: !(Binary.Decoder SHA.SHA1State)

185+ , _zip :: !(Binary.Decoder Zip.Archive)

186+ }

187+

188+

189+readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))

190+readArchiveHelp body (AS len sha zip) =

191+ case zip of

192+ Binary.Fail _ _ _ ->

193+ return Nothing

194+

195+ Binary.Partial k ->

196+ do chunk <- brRead body

197+ readArchiveHelp body $

198+ AS

199+ { _len = len + BS.length chunk

200+ , _sha = Binary.pushChunk sha chunk

201+ , _zip = k (if BS.null chunk then Nothing else Just chunk)

202+ }

203+

204+ Binary.Done _ _ archive ->

205+ return $ Just ( SHA.completeSha1Incremental sha len, archive )

206+

207+

208+

209+-- UPLOAD

210+

211+

212+upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())

213+upload manager url parts =

214+ handle (handleSomeException url id) $

215+ handle (handleHttpException url id) $

216+ do req0 <- parseUrlThrow url

217+ req1 <-

218+ Multi.formDataBody parts $

219+ req0

220+ { method = methodPost

221+ , requestHeaders = addDefaultHeaders []

222+ , responseTimeout = responseTimeoutNone

223+ }

224+ withResponse req1 manager $ \_ ->

225+ return (Right ())

226+

227+

228+filePart :: String -> FilePath -> Multi.Part

229+filePart name filePath =

230+ Multi.partFileSource (String.fromString name) filePath

231+

232+

233+jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part

234+jsonPart name filePath value =

235+ let

236+ body =

237+ Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value

238+ in

239+ Multi.partFileRequestBody (String.fromString name) filePath body

240+

241+

242+stringPart :: String -> String -> Multi.Part

243+stringPart name string =

244+ Multi.partBS (String.fromString name) (BS.pack string)

builder/src/Reporting.hsnew file+474

@@ -0,0 +1,474 @@

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

2+module Reporting

3+ ( Style

4+ , silent

5+ , json

6+ , terminal

7+ --

8+ , attempt

9+ , attemptWithStyle

10+ --

11+ , Key

12+ , report

13+ , ignorer

14+ , ask

15+ --

16+ , DKey

17+ , DMsg(..)

18+ , trackDetails

19+ --

20+ , BKey

21+ , BMsg(..)

22+ , trackBuild

23+ --

24+ , reportGenerate

25+ )

26+ where

27+

28+

29+import Control.Concurrent

30+import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)

31+import Control.Monad (when)

32+import qualified Data.ByteString.Builder as B

33+import qualified Data.NonEmptyList as NE

34+import qualified System.Exit as Exit

35+import qualified System.Info as Info

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

37+

38+import qualified Elm.ModuleName as ModuleName

39+import qualified Elm.Package as Pkg

40+import qualified Elm.Version as V

41+import qualified Json.Encode as Encode

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

43+import qualified Reporting.Doc as D

44+import qualified Reporting.Exit as Exit

45+import qualified Reporting.Exit.Help as Help

46+

47+

48+

49+-- STYLE

50+

51+

52+data Style

53+ = Silent

54+ | Json

55+ | Terminal (MVar ())

56+

57+

58+silent :: Style

59+silent =

60+ Silent

61+

62+

63+json :: Style

64+json =

65+ Json

66+

67+

68+terminal :: IO Style

69+terminal =

70+ Terminal <$> newMVar ()

71+

72+

73+

74+-- ATTEMPT

75+

76+

77+attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a

78+attempt toReport work =

79+ do result <- work `catch` reportExceptionsNicely

80+ case result of

81+ Right a ->

82+ return a

83+

84+ Left x ->

85+ do Exit.toStderr (toReport x)

86+ Exit.exitFailure

87+

88+

89+attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a

90+attemptWithStyle style toReport work =

91+ do result <- work `catch` reportExceptionsNicely

92+ case result of

93+ Right a ->

94+ return a

95+

96+ Left x ->

97+ case style of

98+ Silent ->

99+ do Exit.exitFailure

100+

101+ Json ->

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

103+ Exit.exitFailure

104+

105+ Terminal mvar ->

106+ do readMVar mvar

107+ Exit.toStderr (toReport x)

108+ Exit.exitFailure

109+

110+

111+

112+-- MARKS

113+

114+

115+goodMark :: D.Doc

116+goodMark =

117+ D.green $ if isWindows then "+" else "●"

118+

119+

120+badMark :: D.Doc

121+badMark =

122+ D.red $ if isWindows then "X" else "✗"

123+

124+

125+isWindows :: Bool

126+isWindows =

127+ Info.os == "mingw32"

128+

129+

130+

131+-- KEY

132+

133+

134+newtype Key msg = Key (msg -> IO ())

135+

136+

137+report :: Key msg -> msg -> IO ()

138+report (Key send) msg =

139+ send msg

140+

141+

142+ignorer :: Key msg

143+ignorer =

144+ Key (\_ -> return ())

145+

146+

147+

148+-- ASK

149+

150+

151+ask :: D.Doc -> IO Bool

152+ask doc =

153+ do Help.toStdout doc

154+ askHelp

155+

156+

157+askHelp :: IO Bool

158+askHelp =

159+ do hFlush stdout

160+ input <- getLine

161+ case input of

162+ "" -> return True

163+ "Y" -> return True

164+ "y" -> return True

165+ "n" -> return False

166+ _ ->

167+ do putStr "Must type 'y' for yes or 'n' for no: "

168+ askHelp

169+

170+

171+-- DETAILS

172+

173+

174+type DKey = Key DMsg

175+

176+

177+trackDetails :: Style -> (DKey -> IO a) -> IO a

178+trackDetails style callback =

179+ case style of

180+ Silent ->

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

182+

183+ Json ->

184+ callback (Key (\_ -> return ()))

185+

186+ Terminal mvar ->

187+ do chan <- newChan

188+

189+ _ <- forkIO $

190+ do takeMVar mvar

191+ detailsLoop chan (DState 0 0 0 0 0 0 0)

192+ putMVar mvar ()

193+

194+ answer <- callback (Key (writeChan chan . Just))

195+ writeChan chan Nothing

196+ return answer

197+

198+

199+detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()

200+detailsLoop chan state@(DState total _ _ _ _ built _) =

201+ do msg <- readChan chan

202+ case msg of

203+ Just dmsg ->

204+ detailsLoop chan =<< detailsStep dmsg state

205+

206+ Nothing ->

207+ putStrLn $ clear (toBuildProgress total total) $

208+ if built == total

209+ then "Dependencies ready!"

210+ else "Dependency problem!"

211+

212+

213+data DState =

214+ DState

215+ { _total :: !Int

216+ , _cached :: !Int

217+ , _requested :: !Int

218+ , _received :: !Int

219+ , _failed :: !Int

220+ , _built :: !Int

221+ , _broken :: !Int

222+ }

223+

224+

225+data DMsg

226+ = DStart Int

227+ | DCached

228+ | DRequested

229+ | DReceived Pkg.Name V.Version

230+ | DFailed Pkg.Name V.Version

231+ | DBuilt

232+ | DBroken

233+

234+

235+detailsStep :: DMsg -> DState -> IO DState

236+detailsStep msg (DState total cached rqst rcvd failed built broken) =

237+ case msg of

238+ DStart numDependencies ->

239+ return (DState numDependencies 0 0 0 0 0 0)

240+

241+ DCached ->

242+ putTransition (DState total (cached + 1) rqst rcvd failed built broken)

243+

244+ DRequested ->

245+ do when (rqst == 0) (putStrLn "Starting downloads...\n")

246+ return (DState total cached (rqst + 1) rcvd failed built broken)

247+

248+ DReceived pkg vsn ->

249+ do putDownload goodMark pkg vsn

250+ putTransition (DState total cached rqst (rcvd + 1) failed built broken)

251+

252+ DFailed pkg vsn ->

253+ do putDownload badMark pkg vsn

254+ putTransition (DState total cached rqst rcvd (failed + 1) built broken)

255+

256+ DBuilt ->

257+ putBuilt (DState total cached rqst rcvd failed (built + 1) broken)

258+

259+ DBroken ->

260+ putBuilt (DState total cached rqst rcvd failed built (broken + 1))

261+

262+

263+putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()

264+putDownload mark pkg vsn =

265+ Help.toStdout $ D.indent 2 $

266+ mark

267+ <+> D.fromPackage pkg

268+ <+> D.fromVersion vsn

269+ <> "\n"

270+

271+

272+putTransition :: DState -> IO DState

273+putTransition state@(DState total cached _ rcvd failed built broken) =

274+ if cached + rcvd + failed < total then

275+ return state

276+

277+ else

278+ do let char = if rcvd + failed == 0 then '\r' else '\n'

279+ putStrFlush (char : toBuildProgress (built + broken + failed) total)

280+ return state

281+

282+

283+putBuilt :: DState -> IO DState

284+putBuilt state@(DState total cached _ rcvd failed built broken) =

285+ do when (total == cached + rcvd + failed) $

286+ putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total

287+ return state

288+

289+

290+toBuildProgress :: Int -> Int -> [Char]

291+toBuildProgress built total =

292+ "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"

293+

294+

295+clear :: [Char] -> [Char] -> [Char]

296+clear before after =

297+ '\r' : replicate (length before) ' ' ++ '\r' : after

298+

299+

300+

301+-- BUILD

302+

303+

304+type BKey = Key BMsg

305+

306+type BResult a = Either Exit.BuildProblem a

307+

308+

309+trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)

310+trackBuild style callback =

311+ case style of

312+ Silent ->

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

314+

315+ Json ->

316+ callback (Key (\_ -> return ()))

317+

318+ Terminal mvar ->

319+ do chan <- newChan

320+

321+ _ <- forkIO $

322+ do takeMVar mvar

323+ putStrFlush "Compiling ..."

324+ buildLoop chan 0

325+ putMVar mvar ()

326+

327+ result <- callback (Key (writeChan chan . Left))

328+ writeChan chan (Right result)

329+ return result

330+

331+

332+data BMsg

333+ = BDone

334+

335+

336+buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()

337+buildLoop chan done =

338+ do msg <- readChan chan

339+ case msg of

340+ Left BDone ->

341+ do let !done1 = done + 1

342+ putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"

343+ buildLoop chan done1

344+

345+ Right result ->

346+ let

347+ !message = toFinalMessage done result

348+ !width = 12 + length (show done)

349+ in

350+ putStrLn $

351+ if length message < width

352+ then '\r' : replicate width ' ' ++ '\r' : message

353+ else '\r' : message

354+

355+

356+toFinalMessage :: Int -> BResult a -> [Char]

357+toFinalMessage done result =

358+ case result of

359+ Right _ ->

360+ case done of

361+ 0 -> "Success!"

362+ 1 -> "Success! Compiled 1 module."

363+ n -> "Success! Compiled " ++ show n ++ " modules."

364+

365+ Left problem ->

366+ case problem of

367+ Exit.BuildBadModules _ _ [] ->

368+ "Detected problems in 1 module."

369+

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

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

372+

373+ Exit.BuildProjectProblem _ ->

374+ "Detected a problem."

375+

376+

377+

378+-- GENERATE

379+

380+

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

382+reportGenerate style names output =

383+ case style of

384+ Silent ->

385+ return ()

386+

387+ Json ->

388+ return ()

389+

390+ Terminal mvar ->

391+ do readMVar mvar

392+ let cnames = fmap ModuleName.toChars names

393+ putStrLn ('\n' : toGenDiagram cnames output)

394+

395+

396+toGenDiagram :: NE.List [Char] -> FilePath -> [Char]

397+toGenDiagram (NE.List name names) output =

398+ let

399+ width = 3 + foldr (max . length) (length name) names

400+ in

401+ case names of

402+ [] ->

403+ toGenLine width name ('>' : ' ' : output ++ "\n")

404+

405+ _:_ ->

406+ unlines $

407+ toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)

408+ : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))

409+

410+

411+toGenLine :: Int -> [Char] -> [Char] -> [Char]

412+toGenLine width name end =

413+ " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end

414+

415+

416+hbar :: Char

417+hbar = if isWindows then '-' else '─'

418+

419+vtop :: Char

420+vtop = if isWindows then '+' else '┬'

421+

422+vmiddle :: Char

423+vmiddle = if isWindows then '+' else '┤'

424+

425+vbottom :: Char

426+vbottom = if isWindows then '+' else '┘'

427+

428+

429+--

430+

431+

432+putStrFlush :: String -> IO ()

433+putStrFlush str =

434+ hPutStr stdout str >> hFlush stdout

435+

436+

437+

438+-- REPORT EXCEPTIONS NICELY

439+

440+

441+reportExceptionsNicely :: SomeException -> IO a

442+reportExceptionsNicely e =

443+ case fromException e of

444+ Just UserInterrupt -> throw e

445+ _ -> putException e >> throw e

446+

447+

448+putException :: SomeException -> IO ()

449+putException e = do

450+ hPutStrLn stderr ""

451+ Help.toStderr $ D.stack $

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

453+ , D.reflow $

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

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

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

457+ , D.reflow $

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

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

460+ \ unstuck quickly."

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

462+ , D.reflow $

463+ "If you are feeling up to it, please try to get your code down to the smallest\

464+ \ version that still triggers this message. Ideally in a single Main.elm and\

465+ \ elm.json file."

466+ , D.reflow $

467+ "From there open a NEW issue at https://github.com/elm/compiler/issues with\

468+ \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\

469+ \ worry about if someone else saw something similar. More examples is better!"

470+ , D.reflow $

471+ "This kind of error is usually tied up in larger architectural choices that are\

472+ \ hard to change, so even when we have a couple good examples, it can take some\

473+ \ time to resolve in a solid way."

474+ ]

builder/src/Reporting/Exit.hs+2012−96

@@ -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,146 +29,2041 @@ module Reporting.Exit

829 where

930

1031

11−import qualified Elm.Compiler as Compiler

12−import qualified Elm.Compiler.Module as Module

32+import qualified Data.ByteString as BS

33+import qualified Data.ByteString.UTF8 as BS_UTF8

34+import qualified Data.List as List

35+import qualified Data.Map as Map

36+import qualified Data.Name as N

37+import qualified Data.NonEmptyList as NE

38+import qualified Network.HTTP.Client as HTTP

39+import qualified Network.HTTP.Types.Header as HTTP

40+import qualified Network.HTTP.Types.Status as HTTP

41+import qualified System.FilePath as FP

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

43+

44+import qualified Elm.Constraint as C

45+import qualified Elm.Magnitude as M

46+import qualified Elm.ModuleName as ModuleName

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

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

1557import qualified Reporting.Doc as D

16−import qualified Reporting.Exit.Assets as Asset

17−import qualified Reporting.Exit.Bump as Bump

18−import qualified Reporting.Exit.Compile as Compile

19−import qualified Reporting.Exit.Crawl as Crawl

20−import qualified Reporting.Exit.Deps as Deps

21−import qualified Reporting.Exit.Diff as Diff

58+import qualified Reporting.Error.Import as Import

59+import qualified Reporting.Error.Json as Json

2260import qualified Reporting.Exit.Help as Help

23−import qualified Reporting.Exit.Http as Http

24−import qualified Reporting.Exit.Make as Make

25−import qualified Reporting.Exit.Publish as Publish

61+import qualified Reporting.Error as Error

62+import qualified Reporting.Render.Code as Code

63+

2664

2765

66+-- RENDERERS

2867

29−-- ALL POSSIBLE ERRORS

3068

69+toString :: Help.Report -> String

70+toString report =

71+ Help.toString (Help.reportToDoc report)

3172

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 [Module.Raw] -- TODO write docs to help with this scenario

39− | Deps Deps.Exit

40− | Diff Diff.Exit

41− | Make Make.Exit

42− | Publish Publish.Exit

43− | BadHttp String Http.Exit

4473

45− -- misc

46− | NoSolution [Pkg.Name]

74+toStderr :: Help.Report -> IO ()

75+toStderr report =

76+ Help.toStderr (Help.reportToDoc report)

4777

4878

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

49676

50−-- RENDERERS

51677

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

52688

53−toString :: Exit -> String

54−toString exit =

55− Help.toString (Help.reportToDoc (toReport exit))

56689

57690

58−toStderr :: Exit -> IO ()

59−toStderr exit =

60− Help.toStderr (Help.reportToDoc (toReport exit))

691+-- DOCS

61692

62693

63−toJson :: Exit -> Encode.Value

64−toJson exit =

65− Help.reportToJson (toReport exit)

694+data DocsProblem

695+ = DP_Http Http.Error

696+ | DP_Data String BS.ByteString

697+ | DP_Cache

66698

67699

68−toReport :: Exit -> Help.Report

69−toReport exit =

700+toDocsProblemReport :: DocsProblem -> String -> Help.Report

701+toDocsProblemReport problem context =

702+ case problem of

703+ DP_Http httpError ->

704+ toHttpErrorReport "PROBLEM LOADING DOCS" httpError context

705+

706+ DP_Data url body ->

707+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", so I fetched:")

708+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

709+ , D.reflow $

710+ "I got the data back, but it was not what I was expecting. The response\

711+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

712+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

713+ , D.indent 4 $ D.dullyellow $ D.fromChars $

714+ if BS.length body <= 76

715+ then BS_UTF8.toString body

716+ else take 73 (BS_UTF8.toString body) ++ "..."

717+ , D.reflow $

718+ "Does this error keep showing up? Maybe there is something weird with your\

719+ \ internet connection. We have gotten reports that schools, businesses,\

720+ \ airports, etc. sometimes intercept requests and add things to the body\

721+ \ or change its contents entirely. Could that be the problem?"

722+ ]

723+

724+ DP_Cache ->

725+ Help.report "PROBLEM LOADING DOCS" Nothing (context ++ ", but the local copy seems to be corrupted.")

726+ [ D.reflow $

727+ "I deleted the cached version, so the next run should download a fresh copy of\

728+ \ the docs. Hopefully that will get you unstuck, but it will not resolve the root\

729+ \ problem if, for example, a 3rd party editor plugin is modifing cached files\

730+ \ for some reason."

731+ ]

732+

733+

734+

735+-- INSTALL

736+

737+

738+data Install

739+ = InstallNoOutline

740+ | InstallBadOutline Outline

741+ | InstallBadRegistry RegistryProblem

742+ | InstallNoArgs FilePath

743+ | InstallNoOnlineAppSolution Pkg.Name

744+ | InstallNoOfflineAppSolution Pkg.Name

745+ | InstallNoOnlinePkgSolution Pkg.Name

746+ | InstallNoOfflinePkgSolution Pkg.Name

747+ | InstallHadSolverTrouble Solver

748+ | InstallUnknownPackageOnline Pkg.Name [Pkg.Name]

749+ | InstallUnknownPackageOffline Pkg.Name [Pkg.Name]

750+ | InstallBadDetails Details

751+

752+

753+installToReport :: Install -> Help.Report

754+installToReport exit =

70755 case exit of

71− NoElmJson ->

72− Help.report "WELCOME" Nothing

73− "It looks like you are trying to start a new Elm project. Very exciting! :D"

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

741283 [ D.fillSep

75− ["I","very","highly","recommend","working","through"

76− ,D.green "<https://guide.elm-lang.org>","which","will","teach","you","the"

77− ,"basics","of","Elm,","including","how","to","start","new","projects."

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

781286 ]

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

791313 , D.fillSep

80− ["For","folks","who","have","already","built","stuff","with","Elm,","the"

81− ,"problem","is","just","that","there","is","no",D.dullyellow "elm.json","yet."

82− ,"If","you","want","to","work","from","an","example,","check","out","the"

83− ,"one","at","<https://github.com/evancz/elm-todomvc/blob/master/elm.json>"

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

841339 ]

85− , D.reflow

86− "Whatever your scenario, I hope you have a lovely time using Elm!"

1340+ , D.reflow $

1341+ "Please ask for help on the community forums if you try those paths and are still\

1342+ \ having problems!"

871343 ]

881344

89− Assets assetExit ->

90− Asset.toReport assetExit

1345+ DetailsBadOutline outline ->

1346+ toOutlineReport outline

911347

92− Bump bumpExit ->

93− Bump.toReport bumpExit

1348+ DetailsCannotGetRegistry problem ->

1349+ toRegistryProblemReport "PROBLEM LOADING PACKAGE LIST" problem $

1350+ "I need the list of published packages to verify your dependencies"

941351

95− Compile e es ->

96− Help.compilerReport e es

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

971365

98− Crawl crawlExit ->

99− Crawl.toReport crawlExit

1366+ d:_ ->

1367+ case d of

1368+ BD_BadDownload pkg vsn packageProblem ->

1369+ toPackageProblemReport pkg vsn packageProblem

1001370

101− Cycle names ->

102− Help.report "IMPORT CYCLE" Nothing

103− "Your module imports form a cycle:"

104− [ D.cycle 4 names

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

1051429 , D.reflow $

106− "Learn more about why this is disallowed and how to break cycles here:"

107− ++ D.makeLink "import-cycles"

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

1081433 ]

1091434

110− Deps depsExit ->

111− Deps.toReport depsExit

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+

1121470

113− Diff commandsExit ->

114− Diff.toReport commandsExit

1471+-- REGISTRY PROBLEM

1151472

116− Make makeExit ->

117− Make.toReport makeExit

1181473

119− Publish publishExit ->

120− Publish.toReport publishExit

1474+data RegistryProblem

1475+ = RP_Http Http.Error

1476+ | RP_Data String BS.ByteString

1211477

122− BadHttp url httpExit ->

123− Http.toReport url httpExit

1241478

125− NoSolution badPackages ->

126− case badPackages of

1479+toRegistryProblemReport :: String -> RegistryProblem -> String -> Help.Report

1480+toRegistryProblemReport title problem context =

1481+ case problem of

1482+ RP_Http err ->

1483+ toHttpErrorReport title err context

1484+

1485+ RP_Data url body ->

1486+ Help.report title Nothing (context ++ ", so I fetched:")

1487+ [ D.indent 4 $ D.dullyellow $ D.fromChars url

1488+ , D.reflow $

1489+ "I got the data back, but it was not what I was expecting. The response\

1490+ \ body contains " ++ show (BS.length body) ++ " bytes. Here is the "

1491+ ++ if BS.length body <= 76 then "whole thing:" else "beginning:"

1492+ , D.indent 4 $ D.dullyellow $ D.fromChars $

1493+ if BS.length body <= 76

1494+ then BS_UTF8.toString body

1495+ else take 73 (BS_UTF8.toString body) ++ "..."

1496+ , D.reflow $

1497+ "Does this error keep showing up? Maybe there is something weird with your\

1498+ \ internet connection. We have gotten reports that schools, businesses,\

1499+ \ airports, etc. sometimes intercept requests and add things to the body\

1500+ \ or change its contents entirely. Could that be the problem?"

1501+ ]

1502+

1503+

1504+toHttpErrorReport :: String -> Http.Error -> String -> Help.Report

1505+toHttpErrorReport title err context =

1506+ let

1507+ toHttpReport intro url details =

1508+ Help.report title Nothing intro $

1509+ D.indent 4 (D.dullyellow (D.fromChars url)) : details

1510+ in

1511+ case err of

1512+ Http.BadUrl url reason ->

1513+ toHttpReport (context ++ ", so I wanted to fetch:") url

1514+ [ D.reflow $ "But my HTTP library is saying this is not a valid URL. It is saying:"

1515+ , D.indent 4 $ D.fromChars reason

1516+ , D.reflow $

1517+ "This may indicate that there is some problem in the compiler, so please open an\

1518+ \ issue at https://github.com/elm/compiler/issues listing your operating system, Elm\

1519+ \ version, the command you ran, the terminal output, and any additional information\

1520+ \ that might help others reproduce the error."

1521+ ]

1522+

1523+ Http.BadHttp url httpExceptionContent ->

1524+ case httpExceptionContent of

1525+ HTTP.StatusCodeException response body ->

1526+ let

1527+ (HTTP.Status code message) = HTTP.responseStatus response

1528+ in

1529+ toHttpReport (context ++ ", so I tried to fetch:") url

1530+ [ D.fillSep $

1531+ ["But","it","came","back","as",D.red (D.fromInt code)]

1532+ ++ map D.fromChars (words (BS_UTF8.toString message))

1533+ , D.indent 4 $ D.reflow $ BS_UTF8.toString body

1534+ , D.reflow $

1535+ "This may mean some online endpoint changed in an unexpected way, so if does not\

1536+ \ seem like something on your side is causing this (e.g. firewall) please report\

1537+ \ this to https://github.com/elm/compiler/issues with your operating system, Elm\

1538+ \ version, the command you ran, the terminal output, and any additional information\

1539+ \ that can help others reproduce the error!"

1540+ ]

1541+

1542+ HTTP.TooManyRedirects responses ->

1543+ toHttpReport (context ++ ", so I tried to fetch:") url

1544+ [ D.reflow $ "But I gave up after following these " ++ show (length responses) ++ " redirects:"

1545+ , D.indent 4 $ D.vcat $ map toRedirectDoc responses

1546+ , D.reflow $

1547+ "Is it possible that your internet connection intercepts certain requests? That\

1548+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\

1549+ \ and certain countries. Try asking for help locally or in a community forum!"

1550+ ]

1551+

1552+ otherException ->

1553+ toHttpReport (context ++ ", so I tried to fetch:") url

1554+ [ D.reflow $ "But my HTTP library is giving me the following error message:"

1555+ , D.indent 4 $ D.fromChars (show otherException)

1556+ , D.reflow $

1557+ "Are you somewhere with a slow internet connection? Or no internet?\

1558+ \ Does the link I am trying to fetch work in your browser? Maybe the\

1559+ \ site is down? Does your internet connection have a firewall that\

1560+ \ blocks certain domains? It is usually something like that!"

1561+ ]

1562+

1563+ Http.BadMystery url someException ->

1564+ toHttpReport (context ++ ", so I tried to fetch:") url

1565+ [ D.reflow $ "But I ran into something weird! I was able to extract this error message:"

1566+ , D.indent 4 $ D.fromChars (show someException)

1567+ , D.reflow $

1568+ "Is it possible that your internet connection intercepts certain requests? That\

1569+ \ sometimes causes problems for folks in schools, businesses, airports, hotels,\

1570+ \ and certain countries. Try asking for help locally or in a community forum!"

1571+ ]

1572+

1573+

1574+toRedirectDoc :: HTTP.Response body -> D.Doc

1575+toRedirectDoc response =

1576+ let

1577+ (HTTP.Status code message) = HTTP.responseStatus response

1578+ in

1579+ case List.lookup HTTP.hLocation (HTTP.responseHeaders response) of

1580+ Just loc -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString loc)

1581+ Nothing -> D.red (D.fromInt code) <> " - " <> D.fromChars (BS_UTF8.toString message)

1582+

1583+

1584+

1585+-- MAKE

1586+

1587+

1588+data Make

1589+ = MakeNoOutline

1590+ | MakeCannotOptimizeAndDebug

1591+ | MakeBadDetails Details

1592+ | MakeAppNeedsFileNames

1593+ | MakePkgNeedsExposing

1594+ | MakeMultipleFilesIntoHtml

1595+ | MakeNoMain

1596+ | MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]

1597+ | MakeCannotBuild BuildProblem

1598+ | MakeBadGenerate Generate

1599+

1600+

1601+makeToReport :: Make -> Help.Report

1602+makeToReport make =

1603+ case make of

1604+ MakeNoOutline ->

1605+ Help.report "NO elm.json FILE" Nothing

1606+ "It looks like you are starting a new Elm project. Very exciting! Try running:"

1607+ [ D.indent 4 $ D.green $ "elm init"

1608+ , D.reflow $

1609+ "It will help you get set up. It is really simple!"

1610+ ]

1611+

1612+ MakeCannotOptimizeAndDebug ->

1613+ Help.docReport "CLASHING FLAGS" Nothing

1614+ ( D.fillSep

1615+ ["I","cannot","compile","with",D.red "--optimize","and"

1616+ ,D.red "--debug","at","the","same","time."

1617+ ]

1618+ )

1619+ [ D.reflow

1620+ "I need to take away information to optimize things, and I need to\

1621+ \ add information to add the debugger. It is impossible to do both\

1622+ \ at once though! Pick just one of those flags and it should work!"

1623+ ]

1624+

1625+ MakeBadDetails detailsProblem ->

1626+ toDetailsReport detailsProblem

1627+

1628+ MakeAppNeedsFileNames ->

1629+ Help.report "NO INPUT" Nothing

1630+ "What should I make though? I need specific files like:"

1631+ [ D.vcat

1632+ [ D.indent 4 $ D.green "elm make src/Main.elm"

1633+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

1634+ ]

1635+ , D.reflow $

1636+ "I recommend reading through https://guide.elm-lang.org for guidance on what to\

1637+ \ actually put in those files!"

1638+ ]

1639+

1640+ MakePkgNeedsExposing ->

1641+ Help.report "NO INPUT" Nothing

1642+ "What should I make though? I need specific files like:"

1643+ [ D.vcat

1644+ [ D.indent 4 $ D.green "elm make src/Main.elm"

1645+ , D.indent 4 $ D.green "elm make src/This.elm src/That.elm"

1646+ ]

1647+ , D.reflow $

1648+ "You can also entries to the \"exposed-modules\" list in your elm.json file, and\

1649+ \ I will try to compile the relevant files."

1650+ ]

1651+

1652+ MakeMultipleFilesIntoHtml ->

1653+ Help.report "TOO MANY FILES" Nothing

1654+ (

1655+ "When producing an HTML file, I can only handle one file."

1656+ )

1657+ [ D.fillSep

1658+ ["Switch","to",D.dullyellow "--output=/dev/null","if","you","just","want"

1659+ ,"to","get","compile","errors.","This","skips","the","code","gen","phase,"

1660+ ,"so","it","can","be","a","bit","faster","than","other","options","sometimes."

1661+ ]

1662+ , D.fillSep

1663+ ["Switch","to",D.dullyellow "--output=elm.js","if","you","want","multiple"

1664+ ,"`main`","values","available","in","a","single","JavaScript","file.","Then"

1665+ ,"you","can","make","your","own","customized","HTML","file","that","embeds"

1666+ ,"multiple","Elm","nodes.","The","generated","JavaScript","also","shares"

1667+ ,"dependencies","between","modules,","so","it","should","be","smaller","than"

1668+ ,"compiling","each","module","separately."

1669+ ]

1670+ ]

1671+

1672+ MakeNoMain ->

1673+ Help.report "NO MAIN" Nothing

1674+ (

1675+ "When producing an HTML file, I require that the given file has a `main` value.\

1676+ \ That way I have something to show on screen!"

1677+ )

1678+ [ D.reflow $

1679+ "Try adding a `main` value to your file? Or if you just want to verify that this\

1680+ \ module compiles, switch to --output=/dev/null to skip the code gen phase\

1681+ \ altogether."

1682+ , D.toSimpleNote $

1683+ "Adding a `main` value can be as brief as adding something like this:"

1684+ , D.vcat

1685+ [ D.fillSep [D.cyan "import","Html"]

1686+ , ""

1687+ , D.fillSep [D.green "main","="]

1688+ , D.indent 2 $ D.fillSep [D.cyan "Html" <> ".text",D.dullyellow "\"Hello!\""]

1689+ ]

1690+ , D.reflow $

1691+ "From there I can create an HTML file that says \"Hello!\" on screen. I recommend\

1692+ \ looking through https://guide.elm-lang.org for more guidance on how to fill in\

1693+ \ the `main` value."

1694+ ]

1695+

1696+ MakeNonMainFilesIntoJavaScript m ms ->

1697+ case ms of

1271698 [] ->

128− Help.report "UNSOLVABLE DEPENDENCIES" (Just "elm.json")

129− "This usually happens if you try to modify dependency constraints by\

130− \ hand. I recommend deleting any dependency you added recently (or all\

131− \ of them if things are bad) and then adding them again with:"

132− [ D.indent 4 $ D.green "elm install"

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

1331717 , D.reflow $

134− "And do not be afaid to ask for help on Slack if you get stuck!"

1718+ "Or use https://package.elm-lang.org/packages/elm/core/latest/Platform#worker to\

1719+ \ make a `main` with no user interface."

1351720 ]

1361721

1371722 _:_ ->

138− Help.report "OLD DEPENDENCIES" (Just "elm.json")

139− ( "The following packages do not work with Elm " ++ Pkg.versionToString Compiler.version ++ " right now:"

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

1401728 )

141− [ D.indent 4 $ D.vcat $ map (D.red . D.fromString . Pkg.toString) badPackages

1729+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromName (m:ms)

1421730 , D.reflow $

143− "This may be because it is not upgraded yet. It may be because a\

144− \ better solution came along, so there was no need to upgrade it.\

145− \ Etc. Try asking around on Slack to learn more about the topic."

146− , D.toSimpleNote

147− "Whatever the case, please be kind to the relevant package authors! Having\

148− \ friendly interactions with users is great motivation, and conversely, getting\

149− \ berated by strangers on the internet sucks your soul dry. Furthermore, package\

150− \ authors are humans with families, friends, jobs, vacations, responsibilities,\

151− \ goals, etc. They face obstacles outside of their technical work you will never\

152− \ know about, so please assume the best and try to be patient and supportive!"

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

1531745 ]

1746+

1747+ MakeCannotBuild buildProblem ->

1748+ toBuildProblemReport buildProblem

1749+

1750+ MakeBadGenerate generateProblem ->

1751+ toGenerateReport generateProblem

1752+

1753+

1754+

1755+-- BUILD PROBLEM

1756+

1757+

1758+data BuildProblem

1759+ = BuildBadModules FilePath Error.Module [Error.Module]

1760+ | BuildProjectProblem BuildProjectProblem

1761+

1762+

1763+data BuildProjectProblem

1764+ = BP_PathUnknown FilePath

1765+ | BP_WithBadExtension FilePath

1766+ | BP_WithAmbiguousSrcDir FilePath FilePath FilePath

1767+ | BP_MainPathDuplicate FilePath FilePath

1768+ | BP_RootNameDuplicate ModuleName.Raw FilePath FilePath

1769+ | BP_RootNameInvalid FilePath FilePath [String]

1770+ | BP_CannotLoadDependencies

1771+ | BP_Cycle ModuleName.Raw [ModuleName.Raw]

1772+ | BP_MissingExposed (NE.List (ModuleName.Raw, Import.Problem))

1773+

1774+

1775+toBuildProblemReport :: BuildProblem -> Help.Report

1776+toBuildProblemReport problem =

1777+ case problem of

1778+ BuildBadModules root e es ->

1779+ Help.compilerReport root e es

1780+

1781+ BuildProjectProblem projectProblem ->

1782+ toProjectProblemReport projectProblem

1783+

1784+

1785+toProjectProblemReport :: BuildProjectProblem -> Help.Report

1786+toProjectProblemReport projectProblem =

1787+ case projectProblem of

1788+ BP_PathUnknown path ->

1789+ Help.report "FILE NOT FOUND" Nothing

1790+ "I cannot find this file:"

1791+ [ D.indent 4 $ D.red $ D.fromChars path

1792+ , D.reflow $ "Is there a typo?"

1793+ , D.toSimpleNote $

1794+ "If you are just getting started, try working through the examples in the\

1795+ \ official guide https://guide.elm-lang.org to get an idea of the kinds of things\

1796+ \ that typically go in a src/Main.elm file."

1797+ ]

1798+

1799+ BP_WithBadExtension path ->

1800+ Help.report "UNEXPECTED FILE EXTENSION" Nothing

1801+ "I can only compile Elm files (with a .elm extension) but you want me to compile:"

1802+ [ D.indent 4 $ D.red $ D.fromChars path

1803+ , D.reflow $ "Is there a typo? Can the file extension be changed?"

1804+ ]

1805+

1806+ BP_WithAmbiguousSrcDir path srcDir1 srcDir2 ->

1807+ Help.report "CONFUSING FILE" Nothing

1808+ "I am getting confused when I try to compile this file:"

1809+ [ D.indent 4 $ D.red $ D.fromChars path

1810+ , D.reflow $

1811+ "I always check if files appear in any of the \"source-directories\" listed in\

1812+ \ your elm.json to see if there might be some cached information about them. That\

1813+ \ can help me compile faster! But in this case, it looks like this file may be in\

1814+ \ either of these directories:"

1815+ , D.indent 4 $ D.red $ D.vcat $ map D.fromChars [srcDir1,srcDir2]

1816+ , D.reflow $

1817+ "Try to make it so no source directory contains another source directory!"

1818+ ]

1819+

1820+ BP_MainPathDuplicate path1 path2 ->

1821+ Help.report "CONFUSING FILES" Nothing

1822+ "You are telling me to compile these two files:"

1823+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ path1, path2 ]

1824+ , D.reflow $

1825+ if path1 == path2 then

1826+ "Why are you telling me twice? Is something weird going on with a script?\

1827+ \ I figured I would let you know about it just in case something is wrong.\

1828+ \ Only list it once and you should be all set!"

1829+ else

1830+ "But seem to be the same file though... It makes me think something tricky is\

1831+ \ going on with symlinks in your project, so I figured I would let you know\

1832+ \ about it just in case. Remove one of these files from your command to get\

1833+ \ unstuck!"

1834+ ]

1835+

1836+ BP_RootNameDuplicate name outsidePath otherPath ->

1837+ Help.report "MODULE NAME CLASH" Nothing

1838+ "These two files are causing a module name clash:"

1839+ [ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [ outsidePath, otherPath ]

1840+ , D.reflow $

1841+ "They both say `module " ++ ModuleName.toChars name ++ " exposing (..)` up\

1842+ \ at the top, but they cannot have the same name!"

1843+ , D.reflow $

1844+ "Try changing to a different module name in one of them!"

1845+ ]

1846+

1847+ BP_RootNameInvalid givenPath srcDir _ ->

1848+ Help.report "UNEXPECTED FILE NAME" Nothing

1849+ "I am having trouble with this file name:"

1850+ [ D.indent 4 $ D.red $ D.fromChars givenPath

1851+ , D.reflow $

1852+ "I found it in your " ++ FP.addTrailingPathSeparator srcDir ++ " directory\

1853+ \ which is good, but I expect all of the files in there to use the following\

1854+ \ module naming convention:"

1855+ , toModuleNameConventionTable srcDir [ "Main", "HomePage", "Http.Helpers" ]

1856+ , D.reflow $

1857+ "Notice that the names always start with capital letters! Can you make your file\

1858+ \ use this naming convention?"

1859+ , D.toSimpleNote $

1860+ "Having a strict naming convention like this makes it a lot easier to find\

1861+ \ things in large projects. If you see a module imported, you know where to look\

1862+ \ for the corresponding file every time!"

1863+ ]

1864+

1865+ BP_CannotLoadDependencies ->

1866+ corruptCacheReport

1867+

1868+ BP_Cycle name names ->

1869+ Help.report "IMPORT CYCLE" Nothing

1870+ "Your module imports form a cycle:"

1871+ [ D.cycle 4 name names

1872+ , D.reflow $

1873+ "Learn more about why this is disallowed and how to break cycles here:"

1874+ ++ D.makeLink "import-cycles"

1875+ ]

1876+

1877+ BP_MissingExposed (NE.List (name, problem) _) ->

1878+ case problem of

1879+ Import.NotFound ->

1880+ Help.report "MISSING MODULE" (Just "elm.json")

1881+ "The \"exposed-modules\" of your elm.json lists the following module:"

1882+ [ D.indent 4 $ D.red $ D.fromName name

1883+ , D.reflow $

1884+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"

1885+ ]

1886+

1887+ Import.Ambiguous _ _ pkg _ ->

1888+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

1889+ "The \"exposed-modules\" of your elm.json lists the following module:"

1890+ [ D.indent 4 $ D.red $ D.fromName name

1891+ , D.reflow $

1892+ "But a module from " ++ Pkg.toChars pkg ++ " already uses that name. Try\

1893+ \ choosing a different name for your local file."

1894+ ]

1895+

1896+ Import.AmbiguousLocal path1 path2 paths ->

1897+ Help.report "AMBIGUOUS MODULE NAME" (Just "elm.json")

1898+ "The \"exposed-modules\" of your elm.json lists the following module:"

1899+ [ D.indent 4 $ D.red $ D.fromName name

1900+ , D.reflow $

1901+ "But I found multiple files with that name:"

1902+ , D.dullyellow $ D.indent 4 $ D.vcat $

1903+ map D.fromChars (path1:path2:paths)

1904+ , D.reflow $

1905+ "Change the module names to be distinct!"

1906+ ]

1907+

1908+ Import.AmbiguousForeign _ _ _ ->

1909+ Help.report "MISSING MODULE" (Just "elm.json")

1910+ "The \"exposed-modules\" of your elm.json lists the following module:"

1911+ [ D.indent 4 $ D.red $ D.fromName name

1912+ , D.reflow $

1913+ "But I cannot find it in your src/ directory. Is there a typo? Was it renamed?"

1914+ , D.toSimpleNote $

1915+ "It is not possible to \"re-export\" modules from other packages. You can only\

1916+ \ expose modules that you define in your own code."

1917+ ]

1918+

1919+

1920+toModuleNameConventionTable :: FilePath -> [String] -> D.Doc

1921+toModuleNameConventionTable srcDir names =

1922+ let

1923+ toPair name =

1924+ ( name

1925+ , srcDir </> map (\c -> if c == '.' then FP.pathSeparator else c) name <.> "elm"

1926+ )

1927+

1928+ namePairs = map toPair names

1929+ nameWidth = maximum (11 : map (length . fst) namePairs)

1930+ pathWidth = maximum ( 9 : map (length . snd) namePairs)

1931+

1932+ padded width str =

1933+ str ++ replicate (width - length str) ' '

1934+

1935+ toRow (name, path) =

1936+ D.fromChars $

1937+ "| " ++ padded nameWidth name ++ " | " ++ padded pathWidth path ++ " |"

1938+

1939+ bar =

1940+ D.fromChars $

1941+ "+-" ++ replicate nameWidth '-' ++ "-+-" ++ replicate pathWidth '-' ++ "-+"

1942+ in

1943+ D.indent 4 $ D.vcat $

1944+ [ bar, toRow ("Module Name", "File Path"), bar ] ++ map toRow namePairs ++ [ bar ]

1945+

1946+

1947+

1948+-- GENERATE

1949+

1950+

1951+data Generate

1952+ = GenerateCannotLoadArtifacts

1953+ | GenerateCannotOptimizeDebugValues ModuleName.Raw [ModuleName.Raw]

1954+

1955+

1956+toGenerateReport :: Generate -> Help.Report

1957+toGenerateReport problem =

1958+ case problem of

1959+ GenerateCannotLoadArtifacts ->

1960+ corruptCacheReport

1961+

1962+ GenerateCannotOptimizeDebugValues m ms ->

1963+ Help.report "DEBUG REMNANTS" Nothing

1964+ "There are uses of the `Debug` module in the following modules:"

1965+ [ D.indent 4 $ D.red $ D.vcat $ map (D.fromChars . ModuleName.toChars) (m:ms)

1966+ , D.reflow "But the --optimize flag only works if all `Debug` functions are removed!"

1967+ , D.toSimpleNote $

1968+ "The issue is that --optimize strips out info needed by `Debug` functions.\

1969+ \ Here are two examples:"

1970+ , D.indent 4 $ D.reflow $

1971+ "(1) It shortens record field names. This makes the generated JavaScript\

1972+ \ smaller, but `Debug.toString` cannot know the real field names anymore."

1973+ , D.indent 4 $ D.reflow $

1974+ "(2) Values like `type Height = Height Float` are unboxed. This reduces\

1975+ \ allocation, but it also means that `Debug.toString` cannot tell if it is\

1976+ \ looking at a `Height` or `Float` value."

1977+ , D.reflow $

1978+ "There are a few other cases like that, and it will be much worse once we start\

1979+ \ inlining code. That optimization could move `Debug.log` and `Debug.todo` calls,\

1980+ \ resulting in unpredictable behavior. I hope that clarifies why this restriction\

1981+ \ exists!"

1982+ ]

1983+

1984+

1985+

1986+-- CORRUPT CACHE

1987+

1988+

1989+corruptCacheReport :: Help.Report

1990+corruptCacheReport =

1991+ Help.report "CORRUPT CACHE" Nothing

1992+ "It looks like some of the information cached in elm-stuff/ has been corrupted."

1993+ [ D.reflow $

1994+ "Try deleting your elm-stuff/ directory to get unstuck."

1995+ , D.toSimpleNote $

1996+ "This almost certainly means that a 3rd party tool (or editor plugin) is\

1997+ \ causing problems your the elm-stuff/ directory. Try disabling 3rd party tools\

1998+ \ one by one until you figure out which it is!"

1999+ ]

2000+

2001+

2002+

2003+-- REACTOR

2004+

2005+

2006+data Reactor

2007+ = ReactorNoOutline

2008+ | ReactorBadDetails Details

2009+ | ReactorBadBuild BuildProblem

2010+ | ReactorBadGenerate Generate

2011+

2012+

2013+reactorToReport :: Reactor -> Help.Report

2014+reactorToReport problem =

2015+ case problem of

2016+ ReactorNoOutline ->

2017+ Help.report "NEW PROJECT?" Nothing

2018+ "Are you trying to start a new project? Try this command in the terminal:"

2019+ [ D.indent 4 $ D.green "elm init"

2020+ , D.reflow "It will help you get started!"

2021+ ]

2022+

2023+ ReactorBadDetails details ->

2024+ toDetailsReport details

2025+

2026+ ReactorBadBuild buildProblem ->

2027+ toBuildProblemReport buildProblem

2028+

2029+ ReactorBadGenerate generate ->

2030+ toGenerateReport generate

2031+

2032+

2033+

2034+-- REPL

2035+

2036+

2037+data Repl

2038+ = ReplBadDetails Details

2039+ | ReplBadInput BS.ByteString Error.Error

2040+ | ReplBadLocalDeps FilePath Error.Module [Error.Module]

2041+ | ReplProjectProblem BuildProjectProblem

2042+ | ReplBadGenerate Generate

2043+ | ReplBadCache

2044+ | ReplBlocked

2045+

2046+

2047+replToReport :: Repl -> Help.Report

2048+replToReport problem =

2049+ case problem of

2050+ ReplBadDetails details ->

2051+ toDetailsReport details

2052+

2053+ ReplBadInput source err ->

2054+ Help.compilerReport "/" (Error.Module N.replModule "REPL" File.zeroTime source err) []

2055+

2056+ ReplBadLocalDeps root e es ->

2057+ Help.compilerReport root e es

2058+

2059+ ReplProjectProblem projectProblem ->

2060+ toProjectProblemReport projectProblem

2061+

2062+ ReplBadGenerate generate ->

2063+ toGenerateReport generate

2064+

2065+ ReplBadCache ->

2066+ corruptCacheReport

2067+

2068+ ReplBlocked ->

2069+ corruptCacheReport

builder/src/Reporting/Exit/Assets.hsdeleted−225

@@ -1,225 +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

29−

30−

31−

32−-- ELM JSON PROBLEM

33−

34−

35−data ElmJsonProblem

36− = BadJson D.Doc

37− | BadDepDup String String Pkg.Name [Pkg.Name]

38− | BadSrcDir FilePath

39−

40−

41−

42−-- TO REPORT

43−

44−

45−toReport :: Exit -> Help.Report

46−toReport exit =

47− case exit of

48− CorruptElmJson pkg vsn ->

49− corruptJsonToReport "elm.json" pkg vsn

50−

51− CorruptDocumentation pkg vsn ->

52− corruptJsonToReport "docs.json" pkg vsn

53−

54− CorruptBinary path ->

55− Help.report "CORRUPT BINARY" (Just path)

56− ("The binary data at " ++ path ++ " is corrupt.")

57− [ D.reflow $

58− "Maybe a program is modifying your elm-stuff/ or ELM_HOME\

59− \ directory in unexpected ways? Both of those are just caches, so\

60− \ you can try deleting them and they will be rebuilt from scratch."

61− ]

62−

63− BadElmJson problem ->

64− elmJsonProblemToReport problem

65−

66−

67−

68−-- CORRUPT JSON

69−

70−

71−corruptJsonToReport :: FilePath -> Pkg.Name -> Pkg.Version -> Help.Report

72−corruptJsonToReport path pkg vsn =

73− Help.report "CORRUPT JSON" Nothing

74− ( "The " ++ path ++ " for " ++ Pkg.toString pkg

75− ++ " " ++ Pkg.versionToString vsn ++ " got corrupted somehow."

76− )

77− [ D.reflow $

78− "I removed it from my file cache, so if it was some transient\

79− \ error it should be fixed if you try the same thing again.\

80− \ Please report this if it seems like an Elm problem though!"

81− ]

82−

83−

84−

85−-- BAD ELM JSON

86−

87−

88−elmJsonProblemToReport :: ElmJsonProblem -> Help.Report

89−elmJsonProblemToReport problem =

90− case problem of

91− BadJson doc ->

92− Help.jsonReport "BAD JSON" (Just "elm.json") doc

93−

94− BadSrcDir dir ->

95− Help.report "BAD JSON" (Just "elm.json")

96− "The \"source-directories\" in your elm.json lists the following directory:"

97− [ D.indent 4 (D.dullyellow (D.fromString dir))

98− , D.reflow "I cannot find that directory though! Is it missing? Is there a typo?"

99− ]

100−

101− BadDepDup field1 field2 dup dups ->

102− let

103− packagesAre =

104− if null dups then "package is" else "packages are"

105−

106− advice =

107− if null dups then

108− "Delete one of the entries."

109− else

110− "Delete duplicates until each package lives in ONE category."

111− in

112− Help.report "BAD JSON" (Just "elm.json")

113− (

114− if null dups then

115− "The following package appears twice in your elm.json file:"

116− else

117− "The following packages appear twice in your elm.json file:"

118− )

119− [ D.dullyellow $ D.indent 4 $ D.vcat $

120− map (D.fromString . Pkg.toString) (dup:dups)

121− , D.reflow $

122− "The " ++ packagesAre ++ " available in \"" ++ field1

123− ++ "\", so it is redundant to list it again in \"" ++ field2

124− ++ "\". It is already available! " ++ advice

125− , D.reflow "More help at <https://github.com/elm-lang/elm-package/blob/master/TODO>"

126− ]

127−

128−

129−

130−-- PROBLEM TO DOCS

131−

132−

133−data BadElmJsonContent

134− = BadType Text.Text

135− | BadPkgName String

136− | BadVersion Text.Text

137− | BadConstraint String

138− | BadModuleName Text.Text

139− | BadModuleHeaderTooLong Text.Text

140− | BadDependencyName Text.Text

141− | BadLicense Text.Text [Text.Text]

142− | BadDirectoryNotString

143− | BadSummaryTooLong

144−

145−

146−badContentToDocs :: BadElmJsonContent -> [D.Doc]

147−badContentToDocs badContent =

148− case badContent of

149− BadType _ ->

150− ["The","only","valid","types","of","elm.json","are"

151− ,D.green "\"application\"","and",D.green "\"package\"" <> "."

152− ]

153−

154− BadPkgName problem ->

155− map D.fromString (words problem)

156−

157− BadVersion txt ->

158− ["You","provided",D.red (D.fromString (show txt))

159− ,"which","is","not","a","valid","version.","I","need","something","like"

160− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."

161− ]

162−

163− BadConstraint problem ->

164− map D.fromString (words ("It is not a valid constraint. " ++ problem))

165−

166− BadModuleName name ->

167− ["You","provided",D.fromString (show name),"which","is","not","a","valid","module","name."

168− ,"I","need","something","like",D.green "\"Html.Events\"","or",D.green "\"Browser.Navigation\"" <> "."

169− ]

170−

171− BadModuleHeaderTooLong header ->

172− ["The",D.fromString (show header),"header","is","too","long."

173− ,"I","need","it","to","be",D.green "under",D.green "20",D.green "characters"

174− ,"to","ensure","that","formatting","is","nice","on","the","package","website."

175− ]

176−

177− BadDependencyName name ->

178− ["The",D.fromString (show name),"entry","is","not","a","valid","package","name."

179− ,"I","recommend","deleting","it,","finding","the","package","you","want","on"

180− ,"the","package","website,","and","installing","it","with","the"

181− ,D.green "`elm install`","command","instead."

182− ]

183−

184− BadLicense _given suggestions ->

185− case suggestions of

186− [] ->

187− ["I","need","an","OSI","approved","SPDX","license,","like"

188− ,D.green "\"BSD-3-Clause\"","or",D.green "\"MIT\".","See"

189− ,"<https://spdx.org/licenses/>","for","a","full","list","of","options."

190− ]

191−

192− code:codes ->

193− ["I","need","an","OSI","approved","SPDX","license."]

194− ++ ["Maybe you wanted"] ++ oneOf code codes ++ ["instead?"]

195− ++ ["See","<https://spdx.org/licenses/>","for","a","full","list","of","options."]

196−

197− BadDirectoryNotString ->

198− ["I","need","a",D.green "STRING","that","points","to","a","directory","of","Elm","code."

199− ]

200−

201− BadSummaryTooLong ->

202− ["Your","summary","is","too","long.","I","need","it","to"

203− ,"be",D.green "under",D.green "80",D.green "characters."

204− ]

205−

206−

207−oneOf :: Text.Text -> [Text.Text] -> [D.Doc]

208−oneOf code codes =

209− let

210− toDoc spdx =

211− D.green (D.fromString (show spdx))

212− in

213− case codes of

214− [] ->

215− [toDoc code]

216−

217− [code2] ->

218− [toDoc code,"or",toDoc code2]

219−

220− _:_ ->

221− let

222− these = code : init codes

223− final = last codes

224− in

225− 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.Package as Pkg

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 Pkg.Version [Pkg.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.fromText (Pkg.versionToText 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.fromText . Pkg.versionToText) versions

51− ]

builder/src/Reporting/Exit/Compile.hsdeleted−105

@@ -1,105 +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.Text as Text

13−import qualified Data.Time.Clock as Time

14−

15−import qualified Elm.Compiler as Compiler

16−import qualified Elm.Compiler.Module as Module

17−import qualified Json.Encode as Encode

18−import qualified Reporting.Doc as D

19−

20−

21−

22−-- EXITS

23−

24−

25−data Exit =

26− Exit

27− { _name :: Module.Raw

28− , _path :: FilePath

29− , _time :: Time.UTCTime

30− , _source :: Text.Text

31− , _errors :: [Compiler.Error]

32− }

33−

34−

35−

36−-- TO JSON

37−

38−

39−toJson :: Exit -> Encode.Value

40−toJson (Exit name path _ source errors) =

41− Compiler.errorsToJson name path source errors

42−

43−

44−

45−-- TO DOC

46−

47−

48−toDoc :: Exit -> [Exit] -> D.Doc

49−toDoc e es =

50− let

51− (exit, exits) = sortByTime e es

52− in

53− D.vcat (toDocHelp exit exits)

54−

55−

56−toDocHelp :: Exit -> [Exit] -> [D.Doc]

57−toDocHelp e1 exits =

58− case exits of

59− [] ->

60− [exitToDoc e1]

61−

62− e2 : otherErrors ->

63− exitToDoc e1 : separator (_name e1) (_name e2) : toDocHelp e2 otherErrors

64−

65−

66−exitToDoc :: Exit -> D.Doc

67−exitToDoc (Exit _name path _time source errors) =

68− Compiler.errorsToDoc path source errors

69−

70−

71−separator :: Module.Raw -> Module.Raw -> D.Doc

72−separator beforeName afterName =

73− let

74− before = Module.nameToString beforeName ++ " ↑ "

75− after = " ↓ " ++ Module.nameToString afterName

76− in

77− D.dullred $ D.vcat $

78− [ D.indent (80 - length before) (D.fromString before)

79− , "====o======================================================================o===="

80− , D.fromString after

81− , D.empty

82− , D.empty

83− ]

84−

85−

86−

87−-- SORT BY TIME

88−

89−

90−sortByTime :: Exit -> [Exit] -> (Exit, [Exit])

91−sortByTime exit exits =

92− case List.sortBy timeCompare exits of

93− [] ->

94− (exit, [])

95−

96− e:es ->

97− if _time exit < _time e then

98− (exit, e:es)

99− else

100− (e, List.insertBy timeCompare exit es)

101−

102−

103−timeCompare :: Exit -> Exit -> Ordering

104−timeCompare e1 e2 =

105− compare (_time e1) (_time e2)

builder/src/Reporting/Exit/Crawl.hsdeleted−326

@@ -1,326 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Crawl

3− ( Exit(..)

4− , Problem(..)

5− , Origin(..)

6− , toReport

7− )

8− where

9−

10−

11−import qualified Data.ByteString as BS

12−import qualified Data.Char as Char

13−import qualified Data.Map as Map

14−import qualified Data.Text.Encoding as Text

15−import qualified Data.Time.Clock as Time

16−

17−import qualified Elm.Compiler as Compiler

18−import qualified Elm.Compiler.Module as Module

19−import qualified Elm.Package as Pkg

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 Module.Raw [FilePath]

33− | RootNameless FilePath

34− | DependencyProblems Problem [Problem]

35− | BadKernelHeader FilePath

36−

37−

38−data Problem

39− = ModuleNotFound Origin Module.Raw [FilePath]

40− | ModuleAmbiguous Origin Module.Raw [FilePath] [Pkg.Package]

41− | BadHeader FilePath Time.UTCTime BS.ByteString Compiler.Error

42− | ModuleNameReservedForKernel Origin Module.Raw

43− | ModuleNameMissing FilePath Module.Raw

44− | ModuleNameMismatch

45− FilePath

46− Module.Raw -- expected

47− Module.Raw -- actual

48− | PortsInPackage FilePath Module.Raw

49− | EffectsUnexpected FilePath Module.Raw

50−

51−

52−data Origin

53− = ElmJson

54− | File FilePath

55− | Module FilePath Module.Raw

56−

57−

58−

59−-- TO REPORT

60−

61−

62−toReport :: Exit -> Help.Report

63−toReport exit =

64− case exit of

65− RootFileNotFound path ->

66− Help.report "FILE NOT FOUND" Nothing

67− "You want me to compile this file:"

68− [ D.indent 4 $ D.dullyellow $ D.fromString path

69− , "I cannot find it though! Is there a typo?"

70− ]

71−

72− RootModuleNameDuplicate name paths ->

73− Help.report "DUPLICATE NAMES" Nothing

74− "I am trying to compile multiple modules with the same name:"

75− [ D.indent 4 $ D.dullyellow $ D.vcat $

76− map D.fromString paths

77− , D.fillSep $

78− [ "These", "modules", if length paths == 2 then "both" else "all", "claim"

79− , "to", "be", "named", D.dullyellow (D.fromString (Module.nameToString name)) <> "."

80− , "Change", "them", "to", "have", "unique", "names", "and", "you"

81− , "should", "be", "all", "set!"

82− ]

83− ]

84−

85− RootNameless path ->

86− namelessToDoc path "Main"

87−

88− DependencyProblems problem otherProblems ->

89− case otherProblems of

90− [] ->

91− problemToReport problem

92−

93− _ ->

94− problemToReport problem

95− -- error "TODO handle multiple dependency errors"

96−

97− BadKernelHeader filePath ->

98− Help.report "BAD KERNEL HEADER" Nothing

99− "I ran into a bad header in this file:"

100− [ D.indent 4 $ D.dullyellow $ D.fromString filePath

101− , D.reflow $

102− "NOTE: Kernel code is only available to core Elm libraries to ensure\

103− \ the portability and security of the Elm ecosystem. This restriction\

104− \ also makes it possible to improve code gen (i.e. performance) without\

105− \ disrupting the ecosystem."

106− ]

107−

108−

109−

110−-- PROBLEM TO REPORT

111−

112−

113−problemToReport :: Problem -> Help.Report

114−problemToReport problem =

115− case problem of

116− ModuleNotFound origin name dirs ->

117− notFoundToDoc origin name dirs

118−

119− ModuleAmbiguous origin child paths pkgs ->

120− ambiguousToDoc origin child paths pkgs

121−

122− BadHeader path time source compilerError ->

123− let

124− compilerExit =

125− Compile.Exit "???" path time (Text.decodeUtf8 source) [compilerError]

126− in

127− Help.compilerReport compilerExit []

128−

129− ModuleNameMissing path name ->

130− namelessToDoc path name

131−

132− ModuleNameMismatch path expected actual ->

133− Help.report "MODULE NAME MISMATCH" (Just path)

134− ( "The file at " ++ path ++ " has a typo in the module name. It says:"

135− )

136− [ D.indent 4 $ D.dullyellow $ "module" <+> D.red (D.fromString (Module.nameToString actual)) <+> "exposing (..)"

137− , "Looks like a typo or copy/paste error. Instead it needs to say:"

138− , D.indent 4 $ D.dullyellow $ "module" <+> D.green (D.fromString (Module.nameToString expected)) <+> "exposing (..)"

139− , "Make the change and you should be all set!"

140− ]

141−

142− ModuleNameReservedForKernel origin name ->

143− kernelNameToDoc origin name

144−

145− PortsInPackage path name ->

146− badTagToDoc path name "port" "port-modules" $

147− "Packages cannot have any `port` modules."

148−

149− EffectsUnexpected path name ->

150− badTagToDoc path name "effect" "effect-modules" $

151− "Creating `effect` modules is relatively experimental. There are a\

152− \ couple in @elm-lang repos right now, but we have decided to be\

153− \ very cautious in expanding its usage."

154−

155−

156−badTagToDoc :: FilePath -> Module.Raw -> String -> String -> String -> Help.Report

157−badTagToDoc path name tag hintName summary =

158− Help.report

159− ("UNEXPECTED " ++ map Char.toUpper tag ++ " MODULE")

160− (Just path)

161− summary

162− [ D.fillSep $

163− [ "Get", "rid", "of", "all", "the"

164− , D.red (D.fromString tag)

165− , "stuff", "in"

166− , D.dullyellow (D.fromString (Module.nameToString name))

167− , "to", "proceed."

168− ]

169− , D.toSimpleNote $

170− "You can learn the reasoning behind this design choice at "

171− ++ D.makeLink hintName

172− ]

173−

174−

175−

176−-- HELPERS

177−

178−

179−namelessToDoc :: FilePath -> Module.Raw -> Help.Report

180−namelessToDoc path name =

181− Help.report "UNNAMED MODULE" (Just path)

182− ( "The `" ++ Module.nameToString name

183− ++ "` module must start with a line like this:"

184− )

185− [ D.indent 4 $ D.dullyellow $ D.fromString $

186− "module " ++ Module.nameToString name ++ " exposing (..)"

187− , D.reflow $

188− "Try adding that as the first line of your file!"

189− , D.toSimpleNote $

190− "It is best to replace (..) with an explicit list of types and\

191− \ functions you want to expose. If you know a value is only used\

192− \ WITHIN this module, it is extra easy to refactor. This kind of\

193− \ information is great, especially as your project grows!"

194− ]

195−

196−

197−notFoundToDoc :: Origin -> Module.Raw -> [FilePath] -> Help.Report

198−notFoundToDoc origin child dirs =

199− case origin of

200− ElmJson ->

201− Help.report "MODULE NOT FOUND" (Just "elm.json")

202− "Your elm.json says your project has the following module:"

203− [ D.indent 4 $ D.red $ D.fromString $ Module.nameToString child

204− , D.reflow $

205− "When creating packages, all modules must live in the\

206− \ src/ directory, but I cannot find it there."

207− ]

208−

209− File path ->

210− Help.report "UNKNOWN IMPORT" (Just path)

211− ("I cannot find a `" ++ Module.nameToString child ++ "` module to import.")

212− (notFoundDetails child dirs)

213−

214− Module path parent ->

215− Help.report "UNKNOWN IMPORT" (Just path)

216− ("The " ++ Module.nameToString parent ++ " module has a bad import:")

217− (notFoundDetails child dirs)

218−

219−

220−notFoundDetails :: Module.Raw -> [FilePath] -> [D.Doc]

221−notFoundDetails child dirs =

222− let

223− simulatedCode =

224− D.indent 4 $ D.red $ D.fromString $ "import " ++ Module.nameToString child

225− in

226− case Map.lookup child Pkg.suggestions of

227− Just pkg ->

228− [ simulatedCode

229− , D.reflow $

230− "Do you want the one from the " ++ Pkg.toString pkg

231− ++ " package? If so, run this command to add that dependency to your elm.json file:"

232− , D.indent 4 $ D.green $ D.fromString $ "elm install " ++ Pkg.toString pkg

233− , D.reflow $

234− "If you want a local file, make sure the directory that contains the `"

235− ++ Module.nameToString child

236− ++ "` module is listed in your elm.json \"source-directories\" field."

237− ]

238−

239− Nothing ->

240− [ simulatedCode

241− , "I cannot find that module! Is there a typo in the module name?"

242− , D.reflow $

243− case dirs of

244− [] ->

245− "The \"source-directories\" field of your elm.json is empty, so I only\

246− \ searched in packages. Maybe you need to add a \"src\" directory there?"

247−

248− [dir] ->

249− "The \"source-directories\" field of your elm.json tells me to only look in the "

250− ++ dir ++ " directory, but it is not there. Maybe it is in a package that is not installed yet?"

251−

252− dir:_:_ ->

253− "The \"source-directories\" field of your elm.json tells me to look in directories like "

254− ++ dir ++ ", but it is not in any of them. Maybe it is in a package that is not installed yet?"

255− ]

256−

257−

258−ambiguousToDoc :: Origin -> Module.Raw -> [FilePath] -> [Pkg.Package] -> Help.Report

259−ambiguousToDoc origin child paths pkgs =

260− let

261− pkgToString (Pkg.Package pkg vsn) =

262− "exposed by " ++ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn

263−

264− makeReport maybePath summary yellowString =

265− Help.report "AMBIGUOUS IMPORT" maybePath summary

266− [ D.indent 4 $ D.dullyellow $ D.fromString yellowString

267− , D.reflow $

268− "I found multiple module with that name though:"

269− , D.indent 4 $ D.dullyellow $ D.vcat $

270− map D.fromString $ paths ++ map pkgToString pkgs

271− , D.reflow $

272− if null paths then

273− "It looks like the name clash is in your dependencies, which is\

274− \ out of your control. Elm does not support this scenario right\

275− \ now, but it may be worthwhile. Please open an issue describing\

276− \ your scenario so we can gather more usage information!"

277− else

278− "Which is the right one? Try renaming your modules to have unique names."

279− ]

280− in

281− case origin of

282− ElmJson ->

283− makeReport

284− Nothing

285− "Your elm.json wants the following module:"

286− (Module.nameToString child)

287−

288− File path ->

289− makeReport

290− (Just path)

291− ("The file at " ++ path ++ " has an ambiguous import:")

292− ("import " ++ Module.nameToString child)

293−

294− Module path parent ->

295− makeReport

296− (Just path)

297− ("The " ++ Module.nameToString parent ++ " module has an ambiguous import:")

298− ("import " ++ Module.nameToString child)

299−

300−

301−kernelNameToDoc :: Origin -> Module.Raw -> Help.Report

302−kernelNameToDoc origin kernelName =

303− let

304− (maybePath, statement) =

305− case origin of

306− ElmJson ->

307− ( Nothing

308− , "Your elm.json says your project has the following module:"

309− )

310−

311− File path ->

312− ( Just path

313− , "This file is trying to import the following module:"

314− )

315−

316− Module path parent ->

317− ( Just path

318− , "Your " ++ Module.nameToString parent ++ " module is trying to import:"

319− )

320− in

321− Help.report "BAD MODULE NAME" maybePath statement

322− [ D.indent 4 $ D.dullyellow $ D.fromString $ Module.nameToString kernelName

323− , D.reflow $

324− "But names like that are reserved for internal use.\

325− \ Switch to a name outside of the Elm/Kernel/ namespace."

326− ]

builder/src/Reporting/Exit/Deps.hsdeleted−104

@@ -1,104 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Reporting.Exit.Deps

3− ( Exit(..)

4− , toReport

5− )

6− where

7−

8−

9−import qualified Elm.Compiler as Compiler

10−import qualified Elm.Package as Pkg

11−import qualified Elm.Project.Constraint as Con

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 Pkg.Name

23− | PackageNotFound Pkg.Name [Pkg.Name]

24− -- verify

25− | AppBadElm Pkg.Version

26− | PkgBadElm Con.Constraint

27− | BadDeps

28− | BuildFailure Pkg.Name Pkg.Version

29−

30−

31−

32−-- TO DOC

33−

34−

35−toReport :: Exit -> Help.Report

36−toReport exit =

37− case exit of

38− CorruptVersionCache pkg ->

39− Help.report "CORRUPT CACHE" Nothing

40− ( "I ran into an unknown package while exploring dependencies:"

41− )

42− [ D.indent 4 $ D.dullyellow $ D.fromString $ Pkg.toString pkg

43− , D.reflow $

44− "This suggests that your ELM_HOME directory has been corrupted.\

45− \ Maybe some program is messing with it? It is just cached files,\

46− \ so you can delete it and see if that fixes the issue."

47− ]

48−

49− PackageNotFound package suggestions ->

50− Help.docReport "PACKAGE NOT FOUND" Nothing

51− ( D.fillSep

52− ["I","cannot","find","a"

53− ,D.red (D.fromString (Pkg.toString package))

54− ,"package","on","the","package","website."

55− ]

56− )

57− [ "Maybe you want one of these instead?"

58− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromString . Pkg.toString) suggestions

59− , "But check <https://package.elm-lang.org> to see all possibilities!"

60− ]

61−

62− AppBadElm version ->

63− Help.report "ELM VERSION MISMATCH" Nothing

64− "Your elm.json says this application needs a different version of Elm."

65− [ D.fillSep

66− [ "It", "requires"

67− , D.green (D.fromString (Pkg.versionToString version)) <> ","

68− , "but", "you", "are", "using"

69− , D.red (D.fromString (Pkg.versionToString Compiler.version))

70− , "right", "now."

71− ]

72− ]

73−

74− PkgBadElm constraint ->

75− Help.report "ELM VERSION MISMATCH" Nothing

76− "Your elm.json says this package needs a version of Elm in this range:"

77− [ D.indent 4 $ D.dullyellow $ D.fromString $ Con.toString constraint

78− , D.fillSep

79− [ "But", "you", "are", "using", "Elm"

80− , D.red (D.fromString (Pkg.versionToString Compiler.version))

81− , "right", "now."

82− ]

83− ]

84−

85− BadDeps ->

86− Help.report "CLASHING PACKAGE DEPENDENCIES" Nothing

87− "The dependencies in your elm.json are not compatible."

88− [ D.reflow $

89− "Did you change them by hand? Try to change it back! It is much\

90− \ better to add dependencies with commands like this:"

91− , D.indent 4 $ D.dullyellow "elm install elm-lang/http"

92− , D.reflow $

93− "Please ask for help on the Elm slack <http://elmlang.herokuapp.com/> if\

94− \ you are running into something that seems trickier than this."

95− ]

96−

97− BuildFailure pkg vsn ->

98− Help.report "CORRUPT DEPENDENCY" Nothing

99− "I ran into a problem while building the following package:"

100− [ D.indent 4 $ D.dullyellow $ D.fromString $ Pkg.toString pkg ++ " " ++ Pkg.versionToString vsn

101− , D.reflow $

102− "This probably means the downloaded files got corrupted somehow.\

103− \ Maybe try deleting your ELM_HOME and see if that resolves the issue?"

104− ]

builder/src/Reporting/Exit/Diff.hsdeleted−66

@@ -1,66 +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 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− | UnknownPackage Pkg.Name [Pkg.Name]

23− | UnknownVersion Pkg.Name Pkg.Version [Pkg.Version]

24−

25−

26−

27−-- TO DOC

28−

29−

30−toReport :: Exit -> Help.Report

31−toReport exit =

32− case exit of

33− Application ->

34− Help.report "CANNOT DIFF APPLICATIONS" Nothing

35− "I cannot perform diffs on applications, only packages! If you are\

36− \ just curious to see a diff, try running this command:"

37− [ D.indent 4 $ D.green $ "elm diff elm-lang/html 5.1.1 6.0.0"

38− ]

39−

40− UnknownPackage pkg suggestions ->

41− Help.report "UNKNOWN PACKAGE" Nothing

42− ( "I cannot find a package called:"

43− )

44− [ D.indent 4 $ D.red $ D.fromText $ Pkg.toText pkg

45− , "Maybe you want one of these instead?"

46− , D.indent 4 $ D.dullyellow $ D.vcat $ map (D.fromText . Pkg.toText) suggestions

47− , "But check <https://package.elm-lang.org> to see all possibilities!"

48− ]

49−

50− UnknownVersion _pkg vsn realVersions ->

51− Help.docReport "UNKNOWN VERSION" Nothing

52− ( D.fillSep $

53− [ "Version", D.red (D.fromText (Pkg.versionToText vsn))

54− , "has", "never", "been", "published,", "so", "I"

55− , "cannot", "diff", "against", "it."

56− ]

57− )

58− [ "Here are all the versions that HAVE been published:"

59− , D.indent 4 $ D.dullyellow $ D.vcat $

60− let

61− sameMajor v1 v2 = Pkg._major v1 == Pkg._major v2

62− mkRow vsns = D.hsep $ map (D.fromText . Pkg.versionToText) vsns

63− in

64− map mkRow $ List.groupBy sameMajor (List.sort realVersions)

65− , "Want one of those instead?"

66− ]

builder/src/Reporting/Exit/Help.hs+18−18

@@ -14,14 +14,14 @@ module Reporting.Exit.Help

1414 where

1515

1616

17−import qualified Data.Text as Text

1817import GHC.IO.Handle (hIsTerminalDevice)

1918import System.IO (Handle, hPutStr, stderr, stdout)

2019

21−import qualified Json.Encode as Encode

20+import qualified Json.Encode as E

21+import Json.Encode ((==>))

2222import Reporting.Doc ((<+>))

2323import qualified Reporting.Doc as D

24−import qualified Reporting.Exit.Compile as Compile

24+import qualified Reporting.Error as Error

2525

2626

2727

@@ -29,7 +29,7 @@ import qualified Reporting.Exit.Compile as Compile

2929

3030

3131data Report

32− = CompilerReport Compile.Exit [Compile.Exit]

32+ = CompilerReport FilePath Error.Module [Error.Module]

3333 | Report

3434 { _title :: String

3535 , _path :: Maybe FilePath

@@ -52,7 +52,7 @@ jsonReport =

5252 Report

5353

5454

55−compilerReport :: Compile.Exit -> [Compile.Exit] -> Report

55+compilerReport :: FilePath -> Error.Module -> [Error.Module] -> Report

5656compilerReport =

5757 CompilerReport

5858

@@ -64,8 +64,8 @@ compilerReport =

6464reportToDoc :: Report -> D.Doc

6565reportToDoc report_ =

6666 case report_ of

67− CompilerReport e es ->

68− Compile.toDoc e es

67+ CompilerReport root e es ->

68+ Error.toDoc root e es

6969

7070 Report title maybePath message ->

7171 let

@@ -82,7 +82,7 @@ reportToDoc report_ =

8282

8383 errorBar =

8484 D.dullcyan $

85− "--" <+> D.fromString title <+> D.fromString errorBarEnd

85+ "--" <+> D.fromChars title <+> D.fromChars errorBarEnd

8686 in

8787 D.stack [errorBar, message, ""]

8888

@@ -91,21 +91,21 @@ reportToDoc report_ =

9191-- TO JSON

9292

9393

94−reportToJson :: Report -> Encode.Value

94+reportToJson :: Report -> E.Value

9595reportToJson report_ =

9696 case report_ of

97− CompilerReport e es ->

98− Encode.object

99− [ ("type", Encode.text "compile-errors")

100− , ("errors", Encode.list Compile.toJson (e:es))

97+ CompilerReport _ e es ->

98+ E.object

99+ [ "type" ==> E.chars "compile-errors"

100+ , "errors" ==> E.list Error.toJson (e:es)

101101 ]

102102

103103 Report title maybePath message ->

104− Encode.object

105− [ ("type", Encode.text "error")

106− , ("path", maybe Encode.null (Encode.text . Text.pack) maybePath)

107− , ("title", Encode.text (Text.pack title))

108− , ("message", D.encode message)

104+ E.object

105+ [ "type" ==> E.chars "error"

106+ , "path" ==> maybe E.null E.chars maybePath

107+ , "title" ==> E.chars title

108+ , "message" ==> D.encode message

109109 ]

110110

111111

builder/src/Reporting/Exit/Http.hsdeleted−101

@@ -1,101 +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 $

64− "I was expecting the hash of content to be " ++ expectedHash

65− ++ ", but it is " ++ actualHash

66− , D.reflow $

67− "Most likely the package author may have moved the version\

68− \ tag, so report it to them and see if that is the issue."

69− ]

70−

71−

72−

73−-- BAD JSON

74−

75−

76−data BadJson

77− = BadNewPkg Text.Text

78− | BadAllPkg Text.Text String

79− | BadAllVsn Text.Text

80−

81−

82−badJsonToDocs :: BadJson -> [D.Doc]

83−badJsonToDocs badJson =

84− case badJson of

85− BadNewPkg txt ->

86− ["I","ran","into",D.red (D.fromString (show txt)) <> ","

87− ,"but","I","need","entries","like"

88− ,D.green "\"elm-lang/core@6.0.0\"" <> "."

89− ]

90−

91− BadAllPkg txt suggestion ->

92− ["The",D.red (D.fromString (show txt)),"value","is","not","a","valid","package","name."

93− ]

94− ++ map D.fromString (words suggestion)

95−

96− BadAllVsn txt ->

97− ["You","provided",D.red (D.fromString (show txt))

98− ,"which","is","not","a","valid","version.","I","need","something","like"

99− ,D.green "\"1.0.0\"","or",D.green "\"2.0.4\"" <> "."

100− ]

101−

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.Compiler.Module as Module

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 Module.Raw [Module.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 MyThing.elm"

36− , D.indent 4 $ D.green "elm make This.elm 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.fromString . Module.nameToString) (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.Package as Pkg

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 Pkg.Version

23− | AlreadyPublished Pkg.Version

24− | InvalidBump Pkg.Version Pkg.Version

25− | BadBump Pkg.Version Pkg.Version Magnitude Pkg.Version Magnitude

26− | NoSummary

27− | NoExposed

28− | NoReadme

29− | ShortReadme

30− | NoLicense

31− | MissingTag Pkg.Version

32− | NoGit

33− | LocalChanges Pkg.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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString 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.fromString (Pkg.versionToString new)) <> ","

104− ,"indicating","a",D.fromString (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.fromString $

110− "elm diff " ++ Pkg.versionToString old

111−

112− , D.fillSep $

113− ["This","command","says","this","is","a"

114− ,D.fromString (magnitudeToString realMagnitude)

115− ,"change,","so","the","next","version","should","be"

116− ,D.green (D.fromString (Pkg.versionToString 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 = Pkg.versionToString 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.fromString 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.fromString $

185− [ "git tag -a alpha-" ++ vsn ++ " -m \"preparing for Elm 0.19\""

186− , "git push origin alpha-" ++ 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 = Pkg.versionToString version in

206− Help.docReport "LOCAL CHANGES" Nothing

207− ( D.fillSep $

208− [ "The", "code", "tagged", "as", D.green (D.fromString 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−106

@@ -1,106 +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, readMVar)

17−import qualified Elm.Compiler.Module as Module

18−import Deps.Diff (Magnitude)

19−import Elm.Package (Name, Version)

20−import Reporting.Exit (Exit)

21−

22−

23−

24−-- REPORTER

25−

26−

27−data Reporter =

28− Reporter

29− { _tell :: Progress -> IO ()

30− , _end :: Maybe Exit -> IO ()

31− }

32−

33−

34−makeReporter :: Chan Msg -> MVar () -> Reporter

35−makeReporter chan mvar =

36− let

37− tell progress =

38− writeChan chan (Progress progress)

39−

40− end maybeError =

41− do writeChan chan (End maybeError)

42− readMVar mvar

43− in

44− Reporter tell end

45−

46−

47−silentReporter :: Reporter

48−silentReporter =

49− Reporter

50− (\_ -> return ())

51− (\_ -> return ())

52−

53−

54−

55−-- MESSAGES

56−

57−

58−data Msg = Progress Progress | End (Maybe Exit)

59−

60−

61−data Progress

62− -- download packages

63− = DownloadSkip

64− | DownloadStart [(Name, Version)]

65− | DownloadPkgStart Name Version

66− | DownloadPkgEnd Name Version Outcome

67− | DownloadEnd Outcome

68−

69− -- build dependencies

70− | BuildDepsStart Int

71− | BuildDepsProgress

72− | BuildDepsEnd

73−

74− -- compile files

75− | CompileStart Int

76− | CompileFileStart Module.Raw

77− | CompileFileEnd Module.Raw Outcome

78− | CompileEnd

79−

80− -- publish

81− | PublishStart Name Version (Maybe [Version])

82− | PublishCheckBump Version BumpPhase

83− | PublishProgress PublishPhase (Maybe Outcome)

84− | PublishEnd

85−

86− -- solver

87− | UnableToLoadLatestPackages

88−

89−

90−data Outcome = Good | Bad

91−

92−

93−data PublishPhase

94− = CheckReadme

95− | CheckLicense

96− | CheckTag Version

97− | CheckDownload

98− | CheckBuild

99− | CheckChanges

100−

101−

102−data BumpPhase

103− = StatedVersion

104− | GoodStart

105− | GoodBump Version Magnitude

106− | BadBump

builder/src/Reporting/Progress/Bar.hsdeleted−43

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

1−{-# OPTIONS_GHC -Wall #-}

2−module Reporting.Progress.Bar

3− ( render

4− , clear

5− )

6− where

7−

8−

9−

10−-- PROGRESS BAR

11−

12−

13−width :: Float

14−width =

15− 50.0

16−

17−

18−render :: Int -> Int -> Int -> String

19−render successes failures total =

20− let

21− numDone =

22− successes + failures

23−

24− fraction =

25− fromIntegral numDone / fromIntegral total

26−

27− unitsDone =

28− truncate (fraction * width)

29−

30− unitsLeft =

31− truncate width - unitsDone

32− in

33− "\r["

34− ++ replicate unitsDone '='

35− ++ replicate unitsLeft ' '

36− ++ "] - "

37− ++ show numDone ++ " / " ++ show total

38−

39−

40−clear :: String

41−clear =

42− '\r' : replicate (length (render 49999 50000 99999)) ' ' ++ "\r"

43−

builder/src/Reporting/Progress/Json.hsdeleted−31

@@ -1,31 +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 (\_ -> return ()) end

22−

23−

24−end :: Maybe Exit.Exit -> IO ()

25−end maybeExit =

26− case maybeExit of

27− Just exit ->

28− B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson exit))

29−

30− Nothing ->

31− return ()

builder/src/Reporting/Progress/Repl.hsdeleted−27

@@ -1,27 +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 (\_ -> return ()) end

18−

19−

20−end :: Maybe Exit.Exit -> IO ()

21−end maybeExit =

22− case maybeExit of

23− Just exit ->

24− Exit.toStderr exit

25−

26− Nothing ->

27− return ()

builder/src/Reporting/Progress/Terminal.hsdeleted−360

@@ -1,360 +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 Elm.Package (Name, Version)

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

66− loopHelp chan progress state

67−

68−

69−loopHelp :: Chan Msg -> Progress -> State -> IO ()

70−loopHelp chan progress state@(State total good bad) =

71− case progress of

72−

73−

74− -- DOWNLOADS

75−

76− DownloadSkip ->

77− do putStrLn "Dependencies loaded from local cache."

78− loop chan state

79−

80− DownloadStart [] ->

81− loop chan state

82−

83− DownloadStart _ ->

84− do putStrLn "Starting downloads...\n"

85− loop chan state

86−

87− DownloadPkgStart _name _version ->

88− loop chan state

89−

90− DownloadPkgEnd name version outcome ->

91− do Help.toStdout (makeBullet name version outcome)

92− loop chan state

93−

94− DownloadEnd Bad ->

95− do putStrLn ""

96− loop chan state

97−

98− DownloadEnd Good ->

99− do putStrLn ""

100− loop chan state

101−

102−

103− -- BUILD DEPS

104−

105− BuildDepsStart size ->

106− do hPutStr stdout "Verifying dependencies..."

107− hFlush stdout

108− loop chan (State size 0 0)

109−

110− BuildDepsProgress ->

111− do let n = good + 1

112− let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"

113− hPutStr stdout msg

114− hFlush stdout

115− loop chan (State total n 0)

116−

117− BuildDepsEnd ->

118− do putStrLn "\rDependencies ready! "

119− loop chan (State 0 0 0)

120−

121−

122− -- COMPILE

123−

124− CompileStart size ->

125− loop chan (State size 0 0)

126−

127− CompileFileStart _ ->

128− loop chan state

129−

130− CompileFileEnd _ Good ->

131− do hPutStr stdout $ Bar.render (good + 1) bad total

132− hFlush stdout

133− loop chan (State total (good + 1) bad)

134−

135− CompileFileEnd _ Bad ->

136− do hPutStr stdout $ Bar.render good (bad + 1) total

137− hFlush stdout

138− loop chan (State total good (bad + 1))

139−

140− CompileEnd ->

141− let

142− message =

143− case (bad, total) of

144− (0, 0) -> "Success!"

145− (0, 1) -> "Success! Compiled 1 module."

146− (0, n) -> "Success! Compiled " ++ show n ++ " modules."

147− (1, _) -> "Detected errors in 1 module."

148− (n, _) -> "Detected errors in " ++ show n ++ " modules."

149− in

150− do hPutStr stdout $ Bar.clear

151− putStrLn message

152− loop chan (State 0 0 0)

153−

154−

155− -- PUBLISH

156−

157− PublishStart name version maybePublishedVersions ->

158− case maybePublishedVersions of

159− Nothing ->

160− do putStrLn newPackageOverview

161− putStrLn "I will now verify that everything is in order..."

162− putStrLn ""

163− loop chan state

164−

165− Just _ ->

166− do putStrLn $ unwords [ "Verifying", Pkg.toString name, Pkg.versionToString version, "..." ]

167− putStrLn ""

168− loop chan state

169−

170− PublishCheckBump version bumpPhase ->

171− do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase

172− hFlush stdout

173− loop chan state

174−

175− PublishProgress phase status ->

176− do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)

177− hFlush stdout

178− loop chan state

179−

180− PublishEnd ->

181− do putStrLn "Success!"

182− loop chan state

183−

184−

185− -- SOLVER

186−

187− UnableToLoadLatestPackages ->

188− do putStrLn ""

189− Help.toStdout $ D.dullyellow "WARNING:" <+> "I normally check <https://package.elm-lang.org> for new packages\n"

190− putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"

191− loop chan state

192−

193−

194−

195−-- BULLETS

196−

197−

198−makeBullet :: Name -> Version -> Outcome -> D.Doc

199−makeBullet name version outcome =

200− let

201− nm = D.fromText (Pkg.toText name)

202− vsn = D.fromText (Pkg.versionToText version)

203−

204− bullet =

205− case outcome of

206− Good -> goodMark

207− Bad -> badMark

208− in

209− D.indent 2 $ bullet <+> nm <+> vsn <> "\n"

210−

211−

212−goodMark :: D.Doc

213−goodMark =

214− D.green $

215− if Info.os == "mingw32" then "+" else "●"

216−

217−

218−badMark :: D.Doc

219−badMark =

220− D.red $

221− if Info.os == "mingw32" then "X" else "✗"

222−

223−

224−waitingMark :: D.Doc

225−waitingMark =

226− D.dullyellow $

227− if Info.os == "mingw32" then "-" else "→"

228−

229−

230−

231−-- OVERVIEW OF VERSIONING

232−

233−

234−newPackageOverview :: String

235−newPackageOverview =

236− unlines

237− [ "This package has never been published before. Here's how things work:"

238− , ""

239− , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"

240− , ""

241− , " - All packages start with initial version " ++ Pkg.versionToString Pkg.initialVersion

242− , ""

243− , " - Versions are incremented based on how the API changes:"

244− , ""

245− , " PATCH = the API is the same, no risk of breaking code"

246− , " MINOR = values have been added, existing values are unchanged"

247− , " MAJOR = existing values have been changed or removed"

248− , ""

249− , " - I will bump versions for you, automatically enforcing these rules"

250− , ""

251− ]

252−

253−

254−

255−-- CHECKLIST

256−

257−

258−toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc

259−toChecklistDoc status (ChecklistMessages waiting success failure) =

260− let

261− padded message =

262− message ++ replicate (length waiting - length message) ' '

263− in

264− case status of

265− Nothing ->

266− " " <> waitingMark <+> D.fromString waiting

267−

268− Just Good ->

269− "\r " <> goodMark <+> D.fromString (padded success ++ "\n")

270−

271− Just Bad ->

272− "\r " <> badMark <+> D.fromString (padded failure ++ "\n\n")

273−

274−

275−data ChecklistMessages =

276− ChecklistMessages

277− { _waiting :: String

278− , _success :: String

279− , _failure :: String

280− }

281−

282−

283−toChecklistMessages :: PublishPhase -> ChecklistMessages

284−toChecklistMessages phase =

285− case phase of

286− CheckReadme ->

287− ChecklistMessages

288− "Looking for README.md"

289− "Found README.md"

290− "Problem with your README.md"

291−

292− CheckLicense ->

293− ChecklistMessages

294− "Looking for LICENSE"

295− "Found LICENSE"

296− "Problem with your LICENSE"

297−

298− CheckTag version ->

299− ChecklistMessages

300− ("Is version " ++ Pkg.versionToString version ++ " tagged on GitHub?")

301− ("Version " ++ Pkg.versionToString version ++ " is tagged on GitHub")

302− ("Version " ++ Pkg.versionToString version ++ " is not tagged on GitHub!")

303−

304− CheckDownload ->

305− ChecklistMessages

306− "Downloading code from GitHub..."

307− "Code downloaded successfully from GitHub"

308− "Could not download code from GitHub!"

309−

310− CheckBuild ->

311− ChecklistMessages

312− "Building downloaded code and generated docs..."

313− "Downloaded code compiles successfully / docs generated\n"

314− "Cannot compile downloaded code!"

315−

316− CheckChanges ->

317− ChecklistMessages

318− "Checking for uncommitted changes..."

319− "No uncommitted changes in local code"

320− "Your local code is different than the code tagged on GitHub"

321−

322−

323−

324−-- BUMP PHASE

325−

326−

327−bumpPhaseToChecklistDoc :: Pkg.Version -> BumpPhase -> D.Doc

328−bumpPhaseToChecklistDoc version bumpPhase =

329− let

330− mkMsgs success =

331− ChecklistMessages

332− ("Checking semantic versioning rules. Is " ++ Pkg.versionToString version ++ " correct?")

333− success

334− ("Version " ++ Pkg.versionToString version ++ " is not correct!")

335− in

336−

337− case bumpPhase of

338− StatedVersion ->

339− toChecklistDoc Nothing $ mkMsgs ""

340−

341− GoodStart ->

342− toChecklistDoc (Just Good) $ mkMsgs $

343− "All packages start at version " ++ Pkg.versionToString Pkg.initialVersion

344−

345− GoodBump old magnitude ->

346− toChecklistDoc (Just Good) $ mkMsgs $

347− toCheckVersionSuccessMessage old version magnitude

348−

349− BadBump ->

350− toChecklistDoc (Just Bad) $ mkMsgs ""

351−

352−

353−toCheckVersionSuccessMessage :: Pkg.Version -> Pkg.Version -> Diff.Magnitude -> String

354−toCheckVersionSuccessMessage oldVersion newVersion magnitude =

355− let

356− old = Pkg.versionToString oldVersion

357− new = Pkg.versionToString newVersion

358− mag = Diff.magnitudeToString magnitude

359− in

360− "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"

builder/src/Reporting/Task.hs+76−165

@@ -1,203 +1,114 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE Rank2Types #-}

22module Reporting.Task

3− ( Task, Task_

4− , try

3+ ( Task

54 , run

65 , throw

76 , mapError

8− , Env

9− , getPackageCacheDir

10− , getPackageCacheDirFor

11− , report

12− , getReporter

13− , withApproval

14− , getApproval

15− , silently

16− , getSilentRunner

17− , workerChan

18− , runHttp

7+ --

8+ , io

9+ , mio

10+ , eio

1911 )

2012 where

2113

22−import Control.Concurrent (forkIO)

23−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

24−import Control.Monad (forever, join, replicateM_)

25−import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)

26−import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)

27−import Control.Monad.Trans (liftIO)

28−import qualified Network.HTTP.Client as Http

29−import qualified Network.HTTP.Client.TLS as Http

30−import qualified System.Directory as Dir

31−import qualified System.Exit as Exit

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

33−import qualified System.IO as IO

34−

35−import Elm.Package (Name, Version)

36−import qualified Elm.Package as Pkg

37−import qualified Elm.PerUserCache as PerUserCache

38−import qualified Reporting.Exit as Exit

39−import qualified Reporting.Progress as Progress

40−

4114

4215

4316-- TASKS

4417

4518

46−type Task =

47− Task_ Exit.Exit

48−

49−

50−type Task_ e =

51− ExceptT e (ReaderT Env IO)

52−

53−

54−data Env =

55− Env

56− { _cacheDir :: FilePath

57− , _worker :: IO () -> IO ()

58− , _httpManager :: Http.Manager

59− , _tell :: Progress.Progress -> IO ()

60− }

61−

62−

63−try :: Progress.Reporter -> Task a -> IO (Maybe a)

64−try (Progress.Reporter tell end) task =

65− do root <- PerUserCache.getPackageRoot

66− pool <- initPool 4

67− httpManager <- Http.newManager Http.tlsManagerSettings

68− let env = Env root pool httpManager tell

69− result <- runReaderT (runExceptT task) env

70− case result of

71− Left err ->

72− do end (Just err)

73− return Nothing

74−

75− Right answer ->

76− do end Nothing

77− return (Just answer)

78−

79−

80−run :: Progress.Reporter -> Task a -> IO ()

81−run reporter task =

82− do maybeAnswer <- try reporter task

83− case maybeAnswer of

84− Nothing -> Exit.exitFailure

85− Just _ -> return ()

86−

87−

88−throw :: e -> Task_ e a

89−throw =

90− throwError

91−

92−

93−mapError :: (x -> y) -> Task_ x a -> Task_ y a

94−mapError =

95− withExceptT

96−

97−

98−

99−-- CACHING

100−

101−

102−getPackageCacheDir :: Task_ e FilePath

103−getPackageCacheDir =

104− asks _cacheDir

105−

106−

107−getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath

108−getPackageCacheDirFor name version =

109− do cacheDir <- getPackageCacheDir

110− let dir = cacheDir </> Pkg.toFilePath name </> Pkg.versionToString version

111− liftIO (Dir.createDirectoryIfMissing True dir)

112− return dir

113−

114−

115−

116−-- REPORTER

117−

118−

119−report :: Progress.Progress -> Task_ e ()

120−report progress =

121− do tell <- asks _tell

122− liftIO (tell progress)

123−

124−

125−getReporter :: Task (Progress.Progress -> IO ())

126−getReporter =

127− asks _tell

128−

129−

130−

131−-- APPROVAL

19+newtype Task x a =

20+ Task

21+ (

22+ forall result. (a -> IO result) -> (x -> IO result) -> IO result

23+ )

13224

13325

134−withApproval :: Task_ e () -> Task_ e ()

135−withApproval task =

136− do approval <- getApproval

137− if approval then task else return ()

26+run :: Task x a -> IO (Either x a)

27+run (Task task) =

28+ task (return . Right) (return . Left)

13829

13930

140−getApproval :: Task_ e Bool

141−getApproval =

142− do liftIO $ IO.hFlush IO.stdout

143− input <- liftIO getLine

144− case input of

145− "" -> return True

146− "Y" -> return True

147− "y" -> return True

148− "n" -> return False

149− _ ->

150− do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "

151− getApproval

31+throw :: x -> Task x a

32+throw x =

33+ Task $ \_ err -> err x

15234

15335

36+mapError :: (x -> y) -> Task x a -> Task y a

37+mapError func (Task task) =

38+ Task $ \ok err ->

39+ task ok (err . func)

15440

155−-- RUNNER

15641

15742

158−silently :: Task_ e a -> Task_ e a

159−silently task =

160− do runner <- getSilentRunner

161− result <- liftIO (runner task)

162− either throw return result

43+-- IO

16344

16445

165−getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))

166−getSilentRunner =

167− do env <- ask

168− let silentEnv = env { _tell = \_ -> return () }

169− return $ \task -> runReaderT (runExceptT task) silentEnv

46+{-# INLINE io #-}

47+io :: IO a -> Task x a

48+io work =

49+ Task $ \ok _ -> work >>= ok

17050

17151

52+mio :: x -> IO (Maybe a) -> Task x a

53+mio x work =

54+ Task $ \ok err ->

55+ do result <- work

56+ case result of

57+ Just a -> ok a

58+ Nothing -> err x

17259

173−-- THREAD POOL

17460

61+eio :: (x -> y) -> IO (Either x a) -> Task y a

62+eio func work =

63+ Task $ \ok err ->

64+ do result <- work

65+ case result of

66+ Right a -> ok a

67+ Left x -> err (func x)

17568

176−workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()

177−workerChan chan task =

178− do env <- ask

17969

180− liftIO $ _worker env $

181− do result <- runReaderT (runExceptT task) env

182− writeChan chan result

18370

71+-- INSTANCES

18472

185−initPool :: Int -> IO (IO () -> IO ())

186−initPool size =

187− do chan <- newChan

18873

189− replicateM_ size $ forkIO $ forever $

190− join (readChan chan)

74+instance Functor (Task x) where

75+ {-# INLINE fmap #-}

76+ fmap func (Task taskA) =

77+ Task $ \ok err ->

78+ let

79+ okA arg = ok (func arg)

80+ in

81+ taskA okA err

19182

192− return $ writeChan chan

19383

84+instance Applicative (Task x) where

85+ {-# INLINE pure #-}

86+ pure a =

87+ Task $ \ok _ -> ok a

19488

89+ {-# INLINE (<*>) #-}

90+ (<*>) (Task taskFunc) (Task taskArg) =

91+ Task $ \ok err ->

92+ let

93+ okFunc func =

94+ let

95+ okArg arg = ok (func arg)

96+ in

97+ taskArg okArg err

98+ in

99+ taskFunc okFunc err

195100

196−-- HTTP

197101

102+instance Monad (Task x) where

103+ {-# INLINE return #-}

104+ return = pure

198105

199−runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a

200−runHttp fetcher =

201− do (Env _ _ manager tell) <- ask

202− result <- liftIO $ fetcher manager tell

203− either throwError return result

106+ {-# INLINE (>>=) #-}

107+ (>>=) (Task taskA) callback =

108+ Task $ \ok err ->

109+ let

110+ okA a =

111+ case callback a of

112+ Task taskB -> taskB ok err

113+ in

114+ taskA okA err

builder/src/Reporting/Task/Http.hsdeleted−184

@@ -1,184 +0,0 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Reporting.Task.Http

4− ( Fetch

5− , Handler

6− , run

7− , package

8− , anything

9− , andThen

10− , parallel

11− , report

12− )

13− where

14−

15−

16−import Control.Concurrent (forkIO)

17−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

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

19−import Control.Exception (Exception, SomeException, catch)

20−import Control.Monad (forever, join, replicateM_, void)

21−import qualified Network.HTTP as Http (urlEncodeVars)

22−import qualified Network.HTTP.Client as Http

23−

24−import qualified Elm.Compiler as Compiler

25−import qualified Elm.Package as Pkg

26−import qualified Reporting.Exit as Exit

27−import qualified Reporting.Exit.Http as E

28−import qualified Reporting.Progress as Progress

29−import qualified Reporting.Task as Task

30−

31−

32−

33−-- FETCH

34−

35−

36−data Fetch a where

37− Package :: String -> [(String,String)] -> Handler a -> Fetch a

38− Anything :: String -> Handler a -> Fetch a

39− AndThen :: Fetch a -> (a -> Fetch b) -> Fetch b

40− Parallel :: [Fetch a] -> Fetch [a]

41− Report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a

42−

43−

44−type Handler a =

45− Http.Request -> Http.Manager -> IO (Either E.Exit a)

46−

47−

48−package :: String -> [(String,String)] -> Handler a -> Fetch a

49−package =

50− Package

51−

52−

53−anything :: String -> Handler a -> Fetch a

54−anything =

55− Anything

56−

57−

58−andThen :: Fetch a -> (a -> Fetch b) -> Fetch b

59−andThen =

60− AndThen

61−

62−

63−parallel :: [Fetch a] -> Fetch [a]

64−parallel =

65− Parallel

66−

67−

68−report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a

69−report =

70− Report

71−

72−

73−

74−-- RUN

75−

76−

77−run :: Fetch a -> Task.Task a

78−run fetch =

79− Task.runHttp $ \manager tell ->

80− do chan <- newChan

81− replicateM_ 4 $ forkIO $ forever $ join (readChan chan)

82− readMVar =<< runHelp chan manager tell fetch

83−

84−

85−runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Exit.Exit a))

86−runHelp chan manager tell fetch =

87− case fetch of

88− Package path params handler ->

89− do mvar <- newEmptyMVar

90− let url = makePackageUrl path params

91− writeChan chan $ putMVar mvar =<< fetchSafe url manager handler

92− return mvar

93−

94− Anything url handler ->

95− do mvar <- newEmptyMVar

96− writeChan chan $ putMVar mvar =<< fetchSafe url manager handler

97− return mvar

98−

99− AndThen subFetch callback ->

100− do subMVar <- runHelp chan manager tell subFetch

101− mvar <- newEmptyMVar

102− void $ forkIO $

103− do result <- readMVar subMVar

104− putMVar mvar =<<

105− case result of

106− Left err ->

107− return (Left err)

108− Right value ->

109− readMVar =<< runHelp chan manager tell (callback value)

110− return mvar

111−

112− Parallel fetches ->

113− do mvars <- mapM (runHelp chan manager tell) fetches

114− mvar <- newEmptyMVar

115− void $ forkIO $

116− do results <- mapM readMVar mvars

117− putMVar mvar (sequence results)

118− return mvar

119−

120− Report start toEnd subFetch ->

121− do tell start

122− subMVar <- runHelp chan manager tell subFetch

123− mvar <- newEmptyMVar

124− void $ forkIO $

125− do result <- readMVar subMVar

126− tell $ toEnd $

127− either (\_ -> Progress.Bad) (\_ -> Progress.Good) result

128− putMVar mvar result

129− return mvar

130−

131−

132−

133−-- PACKAGE URLS

134−

135−

136−packageDomain :: String

137−packageDomain =

138− "http://159.89.227.162:8000"

139−

140−

141−makePackageUrl :: String -> [(String,String)] -> String

142−makePackageUrl path params =

143− let

144− query =

145− if null params then

146− ""

147− else

148− "?" ++ Http.urlEncodeVars (versionParam : params)

149− in

150− packageDomain ++ "/" ++ path ++ query

151−

152−

153−versionParam :: (String, String)

154−versionParam =

155− ( "elm-package-version"

156− , Pkg.versionToString Compiler.version

157− )

158−

159−

160−

161−-- HTTP HELP

162−

163−

164−fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)

165−fetchSafe url manager handler =

166− fetchUnsafe url manager handler

167− `catch` \e -> handleAnyError url (e :: SomeException)

168−

169−

170−fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)

171−fetchUnsafe url manager handler =

172− do request <- Http.parseUrlThrow url

173− result <- handler request manager

174− case result of

175− Right value ->

176− return (Right value)

177−

178− Left problem ->

179− return (Left (Exit.BadHttp url problem))

180−

181−

182−handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)

183−handleAnyError url exception =

184− return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception

builder/src/Stuff.hsnew file+179

@@ -0,0 +1,179 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Stuff

3+ ( details

4+ , interfaces

5+ , objects

6+ , prepublishDir

7+ , elmi

8+ , elmo

9+ , temp

10+ , findRoot

11+ , withRootLock

12+ , withRegistryLock

13+ , PackageCache

14+ , getPackageCache

15+ , registry

16+ , package

17+ , getReplCache

18+ , getElmHome

19+ )

20+ where

21+

22+

23+import qualified System.Directory as Dir

24+import qualified System.Environment as Env

25+import qualified System.FileLock as Lock

26+import qualified System.FilePath as FP

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

28+

29+import qualified Elm.ModuleName as ModuleName

30+import qualified Elm.Package as Pkg

31+import qualified Elm.Version as V

32+

33+

34+

35+-- PATHS

36+

37+

38+stuff :: FilePath -> FilePath

39+stuff root =

40+ root </> "elm-stuff" </> compilerVersion

41+

42+

43+details :: FilePath -> FilePath

44+details root =

45+ stuff root </> "d.dat"

46+

47+

48+interfaces :: FilePath -> FilePath

49+interfaces root =

50+ stuff root </> "i.dat"

51+

52+

53+objects :: FilePath -> FilePath

54+objects root =

55+ stuff root </> "o.dat"

56+

57+

58+prepublishDir :: FilePath -> FilePath

59+prepublishDir root =

60+ stuff root </> "prepublish"

61+

62+

63+compilerVersion :: FilePath

64+compilerVersion =

65+ V.toChars V.compiler

66+

67+

68+

69+-- ELMI and ELMO

70+

71+

72+elmi :: FilePath -> ModuleName.Raw -> FilePath

73+elmi root name =

74+ toArtifactPath root name "elmi"

75+

76+

77+elmo :: FilePath -> ModuleName.Raw -> FilePath

78+elmo root name =

79+ toArtifactPath root name "elmo"

80+

81+

82+toArtifactPath :: FilePath -> ModuleName.Raw -> String -> FilePath

83+toArtifactPath root name ext =

84+ stuff root </> ModuleName.toHyphenPath name <.> ext

85+

86+

87+

88+-- TEMP

89+

90+

91+temp :: FilePath -> String -> FilePath

92+temp root ext =

93+ stuff root </> "temp" <.> ext

94+

95+

96+

97+-- ROOT

98+

99+

100+findRoot :: IO (Maybe FilePath)

101+findRoot =

102+ do dir <- Dir.getCurrentDirectory

103+ findRootHelp (FP.splitDirectories dir)

104+

105+

106+findRootHelp :: [String] -> IO (Maybe FilePath)

107+findRootHelp dirs =

108+ case dirs of

109+ [] ->

110+ return Nothing

111+

112+ _:_ ->

113+ do exists <- Dir.doesFileExist (FP.joinPath dirs </> "elm.json")

114+ if exists

115+ then return (Just (FP.joinPath dirs))

116+ else findRootHelp (init dirs)

117+

118+

119+

120+-- LOCKS

121+

122+

123+withRootLock :: FilePath -> IO a -> IO a

124+withRootLock root work =

125+ do let dir = stuff root

126+ Dir.createDirectoryIfMissing True dir

127+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

128+

129+

130+withRegistryLock :: PackageCache -> IO a -> IO a

131+withRegistryLock (PackageCache dir) work =

132+ Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)

133+

134+

135+

136+-- PACKAGE CACHES

137+

138+

139+newtype PackageCache = PackageCache FilePath

140+

141+

142+getPackageCache :: IO PackageCache

143+getPackageCache =

144+ PackageCache <$> getCacheDir "packages"

145+

146+

147+registry :: PackageCache -> FilePath

148+registry (PackageCache dir) =

149+ dir </> "registry.dat"

150+

151+

152+package :: PackageCache -> Pkg.Name -> V.Version -> FilePath

153+package (PackageCache dir) name version =

154+ dir </> Pkg.toFilePath name </> V.toChars version

155+

156+

157+

158+-- CACHE

159+

160+

161+getReplCache :: IO FilePath

162+getReplCache =

163+ getCacheDir "repl"

164+

165+

166+getCacheDir :: FilePath -> IO FilePath

167+getCacheDir projectName =

168+ do home <- getElmHome

169+ let root = home </> compilerVersion </> projectName

170+ Dir.createDirectoryIfMissing True root

171+ return root

172+

173+

174+getElmHome :: IO FilePath

175+getElmHome =

176+ do maybeCustomHome <- Env.lookupEnv "ELM_HOME"

177+ case maybeCustomHome of

178+ Just customHome -> return customHome

179+ Nothing -> Dir.getAppUserDataDirectory "elm"

builder/src/Stuff/Paths.hsdeleted−99

@@ -1,99 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Stuff.Paths

3− ( docs

4− , solution

5− , summary

6− , prepublishDir

7− , removeStuff

8− , elmi

9− , elmo

10− , moduleDocs

11− , temp

12− )

13− where

14−

15−

16−import Control.Monad.Trans (liftIO)

17−import qualified System.Directory as Dir

18−import System.FilePath ((</>), (<.>))

19−

20−import qualified Elm.Compiler as Compiler

21−import qualified Elm.Compiler.Module as Module

22−import qualified Elm.Package as Pkg

23−import qualified Reporting.Task as Task

24−

25−

26−

27−-- PATHS

28−

29−

30−stuff :: FilePath

31−stuff =

32− "elm-stuff" </> Pkg.versionToString Compiler.version

33−

34−

35−docs :: FilePath

36−docs =

37− stuff </> "docs.json"

38−

39−

40−solution :: FilePath

41−solution =

42− stuff </> "solution.dat"

43−

44−

45−summary :: FilePath

46−summary =

47− stuff </> "summary.dat"

48−

49−

50−prepublishDir :: FilePath

51−prepublishDir =

52− stuff </> "prepublish"

53−

54−

55−

56−-- REMOVE STUFF

57−

58−

59−removeStuff :: FilePath -> Task.Task_ e ()

60−removeStuff root =

61− liftIO $

62− do let dir = root </> "elm-stuff"

63− exists <- Dir.doesDirectoryExist dir

64− if exists

65− then Dir.removeDirectoryRecursive dir

66− else return ()

67−

68−

69−

70−-- ELMI and ELMO

71−

72−

73−elmi :: FilePath -> Module.Raw -> FilePath

74−elmi root name =

75− toArtifactPath root name "elmi"

76−

77−

78−elmo :: FilePath -> Module.Raw -> FilePath

79−elmo root name =

80− toArtifactPath root name "elmo"

81−

82−

83−moduleDocs :: FilePath -> Module.Raw -> FilePath

84−moduleDocs root name =

85− toArtifactPath root name "json"

86−

87−

88−toArtifactPath :: FilePath -> Module.Raw -> String -> FilePath

89−toArtifactPath root name ext =

90− root </> stuff </> Module.nameToHyphenPath name <.> ext

91−

92−

93−

94−-- TEMP

95−

96−

97−temp :: String -> FilePath

98−temp ext =

99− stuff </> "temp" <.> ext

builder/src/Stuff/Verify.hsdeleted−96

@@ -1,96 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Stuff.Verify

3− ( verify

4− )

5− where

6−

7−

8−import Prelude hiding (read)

9−import qualified Data.Map as Map

10−import Data.Map (Map)

11−

12−import Elm.Package (Name, Version)

13−

14−import qualified Deps.Verify as Verify

15−import Elm.Project.Json (Project(..), PkgInfo(..))

16−import qualified Elm.Project.Json as Project

17−import qualified Elm.Project.Constraint as Con

18−import qualified Elm.Project.Summary as Summary

19−import qualified File.IO as IO

20−import qualified Reporting.Task as Task

21−import qualified Stuff.Paths as Path

22−

23−

24−

25−-- VERIFY

26−

27−

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

29−verify root project =

30− do fresh <-

31− IO.andM

32− [ IO.exists Path.solution

33− , IO.exists Path.summary

34− , checkSolution project

35− ]

36−

37− if fresh

38− then read root project

39− else rebuildCache root project

40−

41−

42−rebuildCache :: FilePath -> Project -> Task.Task Summary.Summary

43−rebuildCache root project =

44− do IO.remove Path.solution

45− IO.remove Path.summary

46−

47− (solution, summary) <- Verify.verify root project

48−

49− IO.writeBinary Path.solution solution

50− write summary

51− return summary

52−

53−

54−

55−-- READ / WRITE

56−

57−

58−read :: FilePath -> Project -> Task.Task Summary.Summary

59−read root project =

60− do (exposed, ifaces, graph) <- IO.readBinary Path.summary

61− return (Summary.Summary root project exposed ifaces graph)

62−

63−

64−write :: Summary.Summary -> Task.Task ()

65−write (Summary.Summary _ _ exposed ifaces graph) =

66− IO.writeBinary Path.summary ( exposed, ifaces, graph )

67−

68−

69−

70−-- CHECK SOLUTION

71−

72−

73−checkSolution :: Project -> Task.Task Bool

74−checkSolution project =

75− checkSolutionHelp project <$> IO.readBinary Path.solution

76−

77−

78−checkSolutionHelp :: Project -> Map Name Version -> Bool

79−checkSolutionHelp project solution =

80− case project of

81− App info ->

82− solution == Project.appSolution info

83−

84− Pkg info ->

85− allGood (_pkg_test_deps info) solution

86− && allGood (_pkg_deps info) solution

87−

88−

89−allGood :: Map Name Con.Constraint -> Map Name Version -> Bool

90−allGood cons vsns =

91− let

92− bools =

93− Map.intersectionWith Con.satisfies cons vsns

94− in

95− Map.size cons == Map.size bools

96− && Map.foldr (&&) True bools

cabal.confignew file+2

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

1+profiling: False

2+library-profiling: True

compiler/src/AST/Canonical.hs+68−73

@@ -23,7 +23,6 @@ module AST.Canonical

2323 , Binop(..)

2424 , Union(..)

2525 , Ctor(..)

26− , Docs(..)

2726 , Exports(..)

2827 , Export(..)

2928 , Effects(..)

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

3332 where

3433

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

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

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

3736package in the List module.

3837

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

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

5453

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

5655import Data.Binary

57−import qualified Data.ByteString as B

5856import qualified Data.List as List

5957import qualified Data.Map as Map

60−import Data.Text (Text)

58+import Data.Name (Name)

6159

60+import qualified AST.Source as Src

6261import qualified AST.Utils.Binop as Binop

63−import qualified AST.Module.Name as ModuleName

6462import qualified AST.Utils.Shader as Shader

6563import qualified Data.Index as Index

66−import qualified Elm.Name as N

64+import qualified Elm.Float as EF

65+import qualified Elm.ModuleName as ModuleName

66+import qualified Elm.String as ES

6767import qualified Reporting.Annotation as A

68−import qualified Reporting.Region as R

6968

7069

7170

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

7877

7978-- CACHE Annotations for type inference

8079data Expr_

81− = VarLocal N.Name

82− | VarTopLevel ModuleName.Canonical N.Name

83− | VarKernel N.Name N.Name

84− | VarForeign ModuleName.Canonical N.Name Annotation

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

86− | VarDebug ModuleName.Canonical N.Name Annotation

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

88− | Chr Text

89− | Str Text

80+ = VarLocal Name

81+ | VarTopLevel ModuleName.Canonical Name

82+ | VarKernel Name Name

83+ | VarForeign ModuleName.Canonical Name Annotation

84+ | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation

85+ | VarDebug ModuleName.Canonical Name Annotation

86+ | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization

87+ | Chr ES.String

88+ | Str ES.String

9089 | Int Int

91− | Float Double

90+ | Float EF.Float

9291 | List [Expr]

9392 | Negate Expr

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

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

9594 | Lambda [Pattern] Expr

9695 | Call Expr [Expr]

9796 | If [(Expr, Expr)] Expr

@@ -99,13 +98,13 @@ data Expr_

9998 | LetRec [Def] Expr

10099 | LetDestruct Pattern Expr Expr

101100 | Case Expr [CaseBranch]

102− | Accessor N.Name

103− | Access Expr (A.Located N.Name)

104− | Update N.Name Expr (Map.Map N.Name FieldUpdate)

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

101+ | Accessor Name

102+ | Access Expr (A.Located Name)

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

104+ | Record (Map.Map Name Expr)

106105 | Unit

107106 | Tuple Expr Expr (Maybe Expr)

108− | Shader Text Text Shader.Shader

107+ | Shader Shader.Source Shader.Types

109108

110109

111110data CaseBranch =

@@ -113,7 +112,7 @@ data CaseBranch =

113112

114113

115114data FieldUpdate =

116− FieldUpdate R.Region Expr

115+ FieldUpdate A.Region Expr

117116

118117

119118

@@ -121,8 +120,8 @@ data FieldUpdate =

121120

122121

123122data Def

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

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

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

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

126125

127126

128127

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

131130

132131data Decls

133132 = Declare Def Decls

134− | DeclareRec [Def] Decls

133+ | DeclareRec Def [Def] Decls

135134 | SaveTheEnvironment

136135

137136

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

145144

146145data Pattern_

147146 = PAnything

148− | PVar N.Name

149− | PRecord [N.Name]

150− | PAlias Pattern N.Name

147+ | PVar Name

148+ | PRecord [Name]

149+ | PAlias Pattern Name

151150 | PUnit

152151 | PTuple Pattern Pattern (Maybe Pattern)

153152 | PList [Pattern]

154153 | PCons Pattern Pattern

155− | PChr Text

156− | PStr Text

154+ | PBool Union Bool

155+ | PChr ES.String

156+ | PStr ES.String

157157 | PInt Int

158158 | PCtor

159159 { _p_home :: ModuleName.Canonical

160− , _p_type :: N.Name

160+ , _p_type :: Name

161161 , _p_union :: Union

162− , _p_name :: N.Name

162+ , _p_name :: Name

163163 , _p_index :: Index.ZeroBased

164164 , _p_args :: [PatternCtorArg]

165165 }

@@ -182,35 +182,38 @@ data PatternCtorArg =

182182

183183

184184data Annotation = Forall FreeVars Type

185+ deriving (Eq)

185186

186187

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

188+type FreeVars = Map.Map Name ()

188189

189190

190191data Type

191192 = TLambda Type Type

192− | TVar N.Name

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

194− | TRecord (Map.Map N.Name FieldType) (Maybe N.Name)

193+ | TVar Name

194+ | TType ModuleName.Canonical Name [Type]

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

195196 | TUnit

196197 | TTuple Type Type (Maybe Type)

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

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

199+ deriving (Eq)

198200

199201

200202data AliasType

201203 = Holey Type

202204 | Filled Type

205+ deriving (Eq)

203206

204207

205−data FieldType =

206− FieldType {-# UNPACK #-} !Word16 Type

208+data FieldType = FieldType {-# UNPACK #-} !Word16 Type

209+ deriving (Eq)

207210

208211

209212-- NOTE: The Word16 marks the source order, but it may not be available

210213-- for every canonical type. For example, if the canonical type is inferred

211214-- the orders will all be zeros.

212215--

213−fieldsToList :: Map.Map N.Name FieldType -> [(N.Name, Type)]

216+fieldsToList :: Map.Map Name FieldType -> [(Name, Type)]

214217fieldsToList fields =

215218 let

216219 getIndex (_, FieldType index _) =

@@ -229,27 +232,32 @@ fieldsToList fields =

229232data Module =

230233 Module

231234 { _name :: ModuleName.Canonical

232− , _docs :: Docs

233235 , _exports :: Exports

236+ , _docs :: Src.Docs

234237 , _decls :: Decls

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

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

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

238+ , _unions :: Map.Map Name Union

239+ , _aliases :: Map.Map Name Alias

240+ , _binops :: Map.Map Name Binop

238241 , _effects :: Effects

239242 }

240243

241244

242−data Alias = Alias [N.Name] Type

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

245+data Alias = Alias [Name] Type

246+ deriving (Eq)

247+

248+

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

250+ deriving (Eq)

244251

245252

246253data Union =

247254 Union

248− { _u_vars :: [N.Name]

255+ { _u_vars :: [Name]

249256 , _u_alts :: [Ctor]

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

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

252259 }

260+ deriving (Eq)

253261

254262

255263data CtorOpts

@@ -259,21 +267,8 @@ data CtorOpts

259267 deriving (Eq, Ord)

260268

261269

262−data Ctor =

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

264−

265−

266−

267−-- DOCS

268−

269−

270−data Docs

271− = NoDocs R.Region

272− | YesDocs

273− { _region :: R.Region

274− , _overview :: B.ByteString

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

276− }

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

271+ deriving (Eq)

277272

278273

279274

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

281276

282277

283278data Exports

284− = ExportEverything R.Region

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

279+ = ExportEverything A.Region

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

286281

287282

288283data Export

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

300295

301296data Effects

302297 = NoEffects

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

304− | Manager R.Region R.Region R.Region Manager

298+ | Ports (Map.Map Name Port)

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

305300

306301

307302data Port

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

310305

311306

312307data Manager

313− = Cmd N.Name

314− | Sub N.Name

315− | Fx N.Name N.Name

308+ = Cmd Name

309+ | Sub Name

310+ | Fx Name Name

316311

317312

318313

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

347342 0 -> return Normal

348343 1 -> return Enum

349344 2 -> return Unbox

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

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

351346

352347

353348instance Binary Annotation where

@@ -398,7 +393,7 @@ instance Binary AliasType where

398393 case n of

399394 0 -> liftM Holey get

400395 1 -> liftM Filled get

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

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

402397

403398

404399instance Binary FieldType where

compiler/src/AST/Module/Name.hsdeleted−203

@@ -1,203 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module AST.Module.Name

4− ( Canonical(..)

5− , basics, char, string

6− , maybe, result, list, array, dict, tuple

7− , platform, cmd, sub

8− , virtualDom, debug, bitwise

9− , jsonDecode, jsonEncode

10− , webgl, vector2, vector3, vector4, matrix4

11− , isKernel, getKernel, canonicalIsKernel

12− )

13− where

14−

15−

16−import Prelude hiding (maybe)

17−import Control.Monad (liftM2)

18−import Data.Binary

19−

20−import qualified Elm.Name as N

21−import qualified Elm.Package as Pkg

22−

23−

24−

25−-- NAMES

26−

27−

28−data Canonical =

29− Canonical

30− { _package :: !Pkg.Name

31− , _module :: !N.Name

32− }

33− deriving (Ord)

34−

35−

36−instance Eq Canonical where

37− (==) (Canonical pkg home) (Canonical pkg' home') =

38− home == home' && pkg == pkg'

39−

40−

41−

42−-- PRIMITIVES

43−

44−

45−{-# NOINLINE basics #-}

46−basics :: Canonical

47−basics = Canonical Pkg.core "Basics"

48−

49−

50−{-# NOINLINE char #-}

51−char :: Canonical

52−char = Canonical Pkg.core N.char

53−

54−

55−{-# NOINLINE string #-}

56−string :: Canonical

57−string = Canonical Pkg.core N.string

58−

59−

60−

61−-- CONTAINERS

62−

63−

64−{-# NOINLINE maybe #-}

65−maybe :: Canonical

66−maybe = Canonical Pkg.core N.maybe

67−

68−

69−{-# NOINLINE result #-}

70−result :: Canonical

71−result = Canonical Pkg.core N.result

72−

73−

74−{-# NOINLINE list #-}

75−list :: Canonical

76−list = Canonical Pkg.core N.list

77−

78−

79−{-# NOINLINE array #-}

80−array :: Canonical

81−array = Canonical Pkg.core N.array

82−

83−

84−{-# NOINLINE dict #-}

85−dict :: Canonical

86−dict = Canonical Pkg.core N.dict

87−

88−

89−{-# NOINLINE tuple #-}

90−tuple :: Canonical

91−tuple = Canonical Pkg.core N.tuple

92−

93−

94−

95−-- EFFECTS

96−

97−

98−{-# NOINLINE platform #-}

99−platform :: Canonical

100−platform = Canonical Pkg.core N.platform

101−

102−

103−{-# NOINLINE cmd #-}

104−cmd :: Canonical

105−cmd = Canonical Pkg.core "Platform.Cmd"

106−

107−

108−{-# NOINLINE sub #-}

109−sub :: Canonical

110−sub = Canonical Pkg.core "Platform.Sub"

111−

112−

113−

114−-- MISC

115−

116−

117−{-# NOINLINE virtualDom #-}

118−virtualDom :: Canonical

119−virtualDom = Canonical Pkg.virtualDom N.virtualDom

120−

121−

122−{-# NOINLINE debug #-}

123−debug :: Canonical

124−debug = Canonical Pkg.core N.debug

125−

126−

127−{-# NOINLINE bitwise #-}

128−bitwise :: Canonical

129−bitwise = Canonical Pkg.core N.bitwise

130−

131−

132−

133−-- JSON

134−

135−

136−{-# NOINLINE jsonDecode #-}

137−jsonDecode :: Canonical

138−jsonDecode = Canonical Pkg.json "Json.Decode"

139−

140−

141−{-# NOINLINE jsonEncode #-}

142−jsonEncode :: Canonical

143−jsonEncode = Canonical Pkg.json "Json.Encode"

144−

145−

146−

147−-- WEBGL

148−

149−

150−{-# NOINLINE webgl #-}

151−webgl :: Canonical

152−webgl = Canonical Pkg.webgl "WebGL"

153−

154−

155−{-# NOINLINE vector2 #-}

156−vector2 :: Canonical

157−vector2 = Canonical Pkg.linearAlgebra "Math.Vector2"

158−

159−

160−{-# NOINLINE vector3 #-}

161−vector3 :: Canonical

162−vector3 = Canonical Pkg.linearAlgebra "Math.Vector3"

163−

164−

165−{-# NOINLINE vector4 #-}

166−vector4 :: Canonical

167−vector4 = Canonical Pkg.linearAlgebra "Math.Vector4"

168−

169−

170−{-# NOINLINE matrix4 #-}

171−matrix4 :: Canonical

172−matrix4 = Canonical Pkg.linearAlgebra "Math.Matrix4"

173−

174−

175−

176−-- IS KERNEL

177−

178−

179−isKernel :: N.Name -> Bool

180−isKernel name =

181− N.startsWith "Elm.Kernel." name

182−

183−

184−getKernel :: N.Name -> N.Name

185−getKernel name =

186− N.drop 11 name

187−

188−

189−canonicalIsKernel :: Canonical -> Bool

190−canonicalIsKernel (Canonical _ name) =

191− isKernel name

192−

193−

194−

195−-- BINARY

196−

197−

198−instance Binary Canonical where

199− put (Canonical a b) =

200− put a >> put b

201−

202− get =

203− liftM2 Canonical get get

compiler/src/AST/Optimized.hs+141−104

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

33 ( Def(..)

44 , Expr(..)

55 , Global(..)

6− , kernel

76 , Path(..)

87 , Destructor(..)

98 , Decider(..)

109 , Choice(..)

11− , Graph(..)

10+ , GlobalGraph(..)

11+ , LocalGraph(..)

1212 , Main(..)

1313 , Node(..)

1414 , EffectsType(..)

15− , KContent(..)

16− , KChunk(..)

15+ , empty

16+ , addGlobalGraph

17+ , addLocalGraph

18+ , addKernel

19+ , toKernelGlobal

1720 )

1821 where

1922

2023

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

22−import Data.Binary

23−import qualified Data.ByteString as BS

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

2426import qualified Data.Map as Map

27+import qualified Data.Name as Name

28+import Data.Name (Name)

2529import qualified Data.Set as Set

26−import Data.Text (Text)

2730

2831import qualified AST.Canonical as Can

29−import qualified AST.Module.Name as ModuleName

32+import qualified AST.Utils.Shader as Shader

3033import qualified Data.Index as Index

31−import qualified Elm.Name as N

34+import qualified Elm.Float as EF

35+import qualified Elm.Kernel as K

36+import qualified Elm.ModuleName as ModuleName

3237import qualified Elm.Package as Pkg

38+import qualified Elm.String as ES

3339import qualified Optimize.DecisionTree as DT

34−import qualified Reporting.Region as R

40+import qualified Reporting.Annotation as A

3541

3642

3743

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

4046

4147data Expr

4248 = Bool Bool

43− | Chr Text

44− | Str Text

49+ | Chr ES.String

50+ | Str ES.String

4551 | Int Int

46− | Float Double

47− | VarLocal N.Name

52+ | Float EF.Float

53+ | VarLocal Name

4854 | VarGlobal Global

4955 | VarEnum Global Index.ZeroBased

5056 | VarBox Global

51− | VarCycle ModuleName.Canonical N.Name

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

53− | VarKernel N.Name N.Name

57+ | VarCycle ModuleName.Canonical Name

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

59+ | VarKernel Name Name

5460 | List [Expr]

55− | Function [N.Name] Expr

61+ | Function [Name] Expr

5662 | Call Expr [Expr]

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

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

5864 | If [(Expr, Expr)] Expr

5965 | Let Def Expr

6066 | Destruct Destructor Expr

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

62− | Accessor N.Name

63− | Access Expr N.Name

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

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

67+ | Case Name Name (Decider Choice) [(Int, Expr)]

68+ | Accessor Name

69+ | Access Expr Name

70+ | Update Expr (Map.Map Name Expr)

71+ | Record (Map.Map Name Expr)

6672 | Unit

6773 | Tuple Expr Expr (Maybe Expr)

68− | Shader Text

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

6975

7076

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

72− deriving (Eq, Ord)

73−

74−

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

76−--

77−kernel :: N.Name -> Global

78−kernel home =

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

77+data Global = Global ModuleName.Canonical Name

8078

8179

8280

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

8482

8583

8684data Def

87− = Def N.Name Expr

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

85+ = Def Name Expr

86+ | TailDef Name [Name] Expr

8987

9088

9189data Destructor =

92− Destructor N.Name Path

90+ Destructor Name Path

9391

9492

9593data Path

9694 = Index Index.ZeroBased Path

97− | Field N.Name Path

95+ | Field Name Path

9896 | Unbox Path

99− | Root N.Name

97+ | Root Name

10098

10199

102100

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

127125-- OBJECT GRAPH

128126

129127

130−data Graph =

131− Graph

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

133− , _nodes :: Map.Map Global Node

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

128+data GlobalGraph =

129+ GlobalGraph

130+ { _g_nodes :: Map.Map Global Node

131+ , _g_fields :: Map.Map Name Int

132+ }

133+

134+

135+data LocalGraph =

136+ LocalGraph

137+ { _l_main :: Maybe Main

138+ , _l_nodes :: Map.Map Global Node -- PERF profile switching Global to Name

139+ , _l_fields :: Map.Map Name Int

135140 }

136141

137142

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

145150

146151data Node

147152 = Define Expr (Set.Set Global)

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

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

149154 | Ctor Index.ZeroBased Int

150155 | Enum Index.ZeroBased

151156 | Box

152157 | Link Global

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

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

154159 | Manager EffectsType

155− | Kernel KContent (Maybe KContent)

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

156161 | PortIncoming Expr (Set.Set Global)

157162 | PortOutgoing Expr (Set.Set Global)

158163

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

160165data EffectsType = Cmd | Sub | Fx

161166

162167

163−data KContent =

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

165168

169+-- GRAPHS

170+

171+

172+{-# NOINLINE empty #-}

173+empty :: GlobalGraph

174+empty =

175+ GlobalGraph Map.empty Map.empty

176+

177+

178+addGlobalGraph :: GlobalGraph -> GlobalGraph -> GlobalGraph

179+addGlobalGraph (GlobalGraph nodes1 fields1) (GlobalGraph nodes2 fields2) =

180+ GlobalGraph

181+ { _g_nodes = Map.union nodes1 nodes2

182+ , _g_fields = Map.union fields1 fields2

183+ }

184+

185+

186+addLocalGraph :: LocalGraph -> GlobalGraph -> GlobalGraph

187+addLocalGraph (LocalGraph _ nodes1 fields1) (GlobalGraph nodes2 fields2) =

188+ GlobalGraph

189+ { _g_nodes = Map.union nodes1 nodes2

190+ , _g_fields = Map.union fields1 fields2

191+ }

192+

193+

194+addKernel :: Name.Name -> [K.Chunk] -> GlobalGraph -> GlobalGraph

195+addKernel shortName chunks (GlobalGraph nodes fields) =

196+ let

197+ global = toKernelGlobal shortName

198+ node = Kernel chunks (foldr addKernelDep Set.empty chunks)

199+ in

200+ GlobalGraph

201+ { _g_nodes = Map.insert global node nodes

202+ , _g_fields = Map.union (K.countFields chunks) fields

203+ }

204+

205+

206+addKernelDep :: K.Chunk -> Set.Set Global -> Set.Set Global

207+addKernelDep chunk deps =

208+ case chunk of

209+ K.JS _ -> deps

210+ K.ElmVar home name -> Set.insert (Global home name) deps

211+ K.JsVar shortName _ -> Set.insert (toKernelGlobal shortName) deps

212+ K.ElmField _ -> deps

213+ K.JsField _ -> deps

214+ K.JsEnum _ -> deps

215+ K.Debug -> deps

216+ K.Prod -> deps

217+

218+

219+toKernelGlobal :: Name.Name -> Global

220+toKernelGlobal shortName =

221+ Global (ModuleName.Canonical Pkg.kernel shortName) Name.dollar

222+

223+

224+

225+-- INSTANCES

166226

167−data KChunk

168− = JS BS.ByteString

169− | ElmVar ModuleName.Canonical N.Name

170− | JsVar N.Name N.Name

171− | ElmField N.Name

172− | JsField Int

173− | JsEnum Int

174− | Debug

175− | Prod

227+

228+instance Eq Global where

229+ (==) (Global home1 name1) (Global home2 name2) =

230+ name1 == name2 && home1 == home2

231+

232+

233+instance Ord Global where

234+ compare (Global home1 name1) (Global home2 name2) =

235+ case compare name1 name2 of

236+ LT -> LT

237+ EQ -> compare home1 home2

238+ GT -> GT

176239

177240

178241

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

213276 Record a -> putWord8 23 >> put a

214277 Unit -> putWord8 24

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

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

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

217280

218281 get =

219282 do word <- getWord8

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

244307 23 -> liftM Record get

245308 24 -> pure Unit

246309 25 -> liftM3 Tuple get get get

247− 26 -> liftM Shader get

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

310+ 26 -> liftM3 Shader get get get

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

249312

250313

251314instance Binary Def where

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

259322 case word of

260323 0 -> liftM2 Def get get

261324 1 -> liftM3 TailDef get get get

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

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

263326

264327

265328instance Binary Destructor where

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

282345 1 -> liftM2 Field get get

283346 2 -> liftM Unbox get

284347 3 -> liftM Root get

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

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

286349

287350

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

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

298361 0 -> liftM Leaf get

299362 1 -> liftM3 Chain get get get

300363 2 -> liftM3 FanOut get get get

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

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

302365

303366

304367instance Binary Choice where

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

312375 case word of

313376 0 -> liftM Inline get

314377 1 -> liftM Jump get

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

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

379+

316380

317381

382+instance Binary GlobalGraph where

383+ get = liftM2 GlobalGraph get get

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

318385

319−instance Binary Graph where

320− get = liftM3 Graph get get get

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

386+

387+instance Binary LocalGraph where

388+ get = liftM3 LocalGraph get get get

389+ put (LocalGraph a b c) = put a >> put b >> put c

322390

323391

324392instance Binary Main where

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

332400 case word of

333401 0 -> return Static

334402 1 -> liftM2 Dynamic get get

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

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

336404

337405

338406instance Binary Node where

@@ -344,7 +412,7 @@ instance Binary Node where

344412 Enum a -> putWord8 3 >> put a

345413 Box -> putWord8 4

346414 Link a -> putWord8 5 >> put a

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

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

348416 Manager a -> putWord8 7 >> put a

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

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

@@ -359,12 +427,12 @@ instance Binary Node where

359427 3 -> liftM Enum get

360428 4 -> return Box

361429 5 -> liftM Link get

362− 6 -> liftM2 Cycle get get

430+ 6 -> liftM4 Cycle get get get get

363431 7 -> liftM Manager get

364432 8 -> liftM2 Kernel get get

365433 9 -> liftM2 PortIncoming get get

366434 10 -> liftM2 PortOutgoing get get

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

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

368436

369437

370438instance Binary EffectsType where

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

380448 0 -> return Cmd

381449 1 -> return Sub

382450 2 -> return Fx

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

384−

385−

386−instance Binary KContent where

387− get = liftM2 KContent get get

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

389−

390−

391−instance Binary KChunk where

392− put chunk =

393− case chunk of

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

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

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

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

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

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

400− Debug -> putWord8 6

401− Prod -> putWord8 7

402−

403− get =

404− do word <- getWord8

405− case word of

406− 0 -> liftM JS get

407− 1 -> liftM2 ElmVar get get

408− 2 -> liftM2 JsVar get get

409− 3 -> liftM ElmField get

410− 4 -> liftM JsField get

411− 5 -> liftM JsEnum get

412− 6 -> return Debug

413− 7 -> return Prod

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

451+ _ -> fail "problem getting Opt.EffectsType binary"

compiler/src/AST/Source.hs+88−72

@@ -1,16 +1,22 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Source

33 ( Expr, Expr_(..), VarType(..)

4− , Decl, Decl_(..)

54 , Def(..)

65 , Pattern, Pattern_(..)

76 , Type, Type_(..)

87 , Module(..)

9− , Header(..)

10− , Docs(..)

8+ , getName

9+ , getImportName

1110 , Import(..)

11+ , Value(..)

12+ , Union(..)

13+ , Alias(..)

14+ , Infix(..)

15+ , Port(..)

1216 , Effects(..)

1317 , Manager(..)

18+ , Docs(..)

19+ , Comment(..)

1420 , Exposing(..)

1521 , Exposed(..)

1622 , Privacy(..)

@@ -18,14 +24,15 @@ module AST.Source

1824 where

1925

2026

21−import qualified Data.ByteString as B

22−import Data.Text (Text)

27+import Data.Name (Name)

28+import qualified Data.Name as Name

2329

2430import qualified AST.Utils.Binop as Binop

2531import qualified AST.Utils.Shader as Shader

26−import qualified Elm.Name as N

32+import qualified Elm.Float as EF

33+import qualified Elm.String as ES

34+import qualified Parse.Primitives as P

2735import qualified Reporting.Annotation as A

28−import qualified Reporting.Region as R

2936

3037

3138

@@ -36,31 +43,31 @@ type Expr = A.Located Expr_

3643

3744

3845data Expr_

39− = Chr Text

40− | Str Text

46+ = Chr ES.String

47+ | Str ES.String

4148 | Int Int

42− | Float Double

43− | Var VarType N.Name

44− | VarQual VarType N.Name N.Name

49+ | Float EF.Float

50+ | Var VarType Name

51+ | VarQual VarType Name Name

4552 | List [Expr]

46− | Op N.Name

53+ | Op Name

4754 | Negate Expr

48− | Binops [(Expr, A.Located N.Name)] Expr

55+ | Binops [(Expr, A.Located Name)] Expr

4956 | Lambda [Pattern] Expr

5057 | Call Expr [Expr]

5158 | If [(Expr, Expr)] Expr

5259 | Let [A.Located Def] Expr

5360 | Case Expr [(Pattern, Expr)]

54− | Accessor N.Name

55− | Access Expr (A.Located N.Name)

56− | Update (A.Located N.Name) [(A.Located N.Name, Expr)]

57− | Record [(A.Located N.Name, Expr)]

61+ | Accessor Name

62+ | Access Expr (A.Located Name)

63+ | Update (A.Located Name) [(A.Located Name, Expr)]

64+ | Record [(A.Located Name, Expr)]

5865 | Unit

5966 | Tuple Expr Expr [Expr]

60− | Shader Text Text Shader.Shader

67+ | Shader Shader.Source Shader.Types

6168

6269

63−data VarType = Value | Ctor

70+data VarType = LowVar | CapVar

6471

6572

6673

@@ -68,8 +75,7 @@ data VarType = Value | Ctor

6875

6976

7077data Def

71− = Annotate N.Name Type

72− | Define (A.Located N.Name) [Pattern] Expr

78+ = Define (A.Located Name) [Pattern] Expr (Maybe Type)

7379 | Destruct Pattern Expr

7480

7581

@@ -82,17 +88,17 @@ type Pattern = A.Located Pattern_

8288

8389data Pattern_

8490 = PAnything

85− | PVar N.Name

86− | PRecord [A.Located N.Name]

87− | PAlias Pattern (A.Located N.Name)

91+ | PVar Name

92+ | PRecord [A.Located Name]

93+ | PAlias Pattern (A.Located Name)

8894 | PUnit

8995 | PTuple Pattern Pattern [Pattern]

90− | PCtor R.Region N.Name [Pattern]

91− | PCtorQual R.Region N.Name N.Name [Pattern]

96+ | PCtor A.Region Name [Pattern]

97+ | PCtorQual A.Region Name Name [Pattern]

9298 | PList [Pattern]

9399 | PCons Pattern Pattern

94− | PChr Text

95− | PStr Text

100+ | PChr ES.String

101+ | PStr ES.String

96102 | PInt Int

97103

98104

@@ -106,71 +112,81 @@ type Type =

106112

107113data Type_

108114 = TLambda Type Type

109− | TVar N.Name

110− | TType R.Region N.Name [Type]

111− | TTypeQual R.Region N.Name N.Name [Type]

112− | TRecord [(A.Located N.Name, Type)] (Maybe (A.Located N.Name))

115+ | TVar Name

116+ | TType A.Region Name [Type]

117+ | TTypeQual A.Region Name Name [Type]

118+ | TRecord [(A.Located Name, Type)] (Maybe (A.Located Name))

113119 | TUnit

114120 | TTuple Type Type [Type]

115121

116122

117123

118−-- DECLARATIONS

119−

120−

121−type Decl = A.Located Decl_

122−

124+-- MODULE

123125

124−data Decl_

125− = Union (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Type])]

126− | Alias (A.Located N.Name) [A.Located N.Name] Type

127− | Binop N.Name Binop.Associativity Binop.Precedence N.Name

128− | Port (A.Located N.Name) Type

129− | Docs Text

130− | Annotation (A.Located N.Name) Type

131− | Definition (A.Located N.Name) [Pattern] Expr

132126

127+data Module =

128+ Module

129+ { _name :: Maybe (A.Located Name)

130+ , _exports :: A.Located Exposing

131+ , _docs :: Docs

132+ , _imports :: [Import]

133+ , _values :: [A.Located Value]

134+ , _unions :: [A.Located Union]

135+ , _aliases :: [A.Located Alias]

136+ , _binops :: [A.Located Infix]

137+ , _effects :: Effects

138+ }

133139

134140

135−-- MODULE

141+getName :: Module -> Name

142+getName (Module maybeName _ _ _ _ _ _ _ _) =

143+ case maybeName of

144+ Just (A.At _ name) ->

145+ name

136146

147+ Nothing ->

148+ Name._Main

137149

138−data Module decls =

139− Module (Maybe Header) [Import] decls

140150

141−

142−data Header

143− = Header

144− { _name :: N.Name

145− , _effects :: Effects

146− , _exports :: A.Located Exposing

147− , _docs :: Docs

148− }

151+getImportName :: Import -> Name

152+getImportName (Import (A.At _ name) _ _) =

153+ name

149154

150155

151156data Import =

152157 Import

153− { _import :: A.Located N.Name

154− , _alias :: Maybe N.Name

158+ { _import :: A.Located Name

159+ , _alias :: Maybe Name

155160 , _exposing :: Exposing

156161 }

157162

158163

159−data Docs

160− = NoDocs R.Region

161− | YesDocs R.Region B.ByteString

164+data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)

165+data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]

166+data Alias = Alias (A.Located Name) [A.Located Name] Type

167+data Infix = Infix Name Binop.Associativity Binop.Precedence Name

168+data Port = Port (A.Located Name) Type

162169

163170

164171data Effects

165172 = NoEffects

166− | Ports R.Region

167− | Manager R.Region Manager

173+ | Ports [Port]

174+ | Manager A.Region Manager

168175

169176

170177data Manager

171− = Cmd (A.Located N.Name)

172− | Sub (A.Located N.Name)

173− | Fx (A.Located N.Name) (A.Located N.Name)

178+ = Cmd (A.Located Name)

179+ | Sub (A.Located Name)

180+ | Fx (A.Located Name) (A.Located Name)

181+

182+

183+data Docs

184+ = NoDocs A.Region

185+ | YesDocs Comment [(Name, Comment)]

186+

187+

188+newtype Comment =

189+ Comment P.Snippet

174190

175191

176192

@@ -179,15 +195,15 @@ data Manager

179195

180196data Exposing

181197 = Open

182− | Explicit ![A.Located Exposed]

198+ | Explicit [Exposed]

183199

184200

185201data Exposed

186− = Lower !N.Name

187− | Upper !N.Name !Privacy

188− | Operator !N.Name

202+ = Lower (A.Located Name)

203+ | Upper (A.Located Name) Privacy

204+ | Operator A.Region Name

189205

190206

191207data Privacy

192− = Public

208+ = Public A.Region

193209 | 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+65−10

@@ -1,29 +1,42 @@

11{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE EmptyDataDecls #-}

23module AST.Utils.Shader

3− ( Shader(..)

4+ ( Source

5+ , Types(..)

46 , Type(..)

7+ , fromChars

8+ , toJsStringBuilder

59 )

610 where

711

812

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

918import qualified Data.Map as Map

10−import qualified Elm.Name as N

19+import qualified Data.Name as Name

1120

1221

1322

14−-- SHADERS

23+-- SOURCE

24+

25+

26+newtype Source =

27+ Source BS.ByteString

1528

1629

17−data Shader =

18− Shader

19− { _attribute :: Map.Map N.Name Type

20− , _uniform :: Map.Map N.Name Type

21− , _varying :: Map.Map N.Name Type

22− }

2330

31+-- TYPES

2432

2533

26−-- GL TYPES

34+data Types =

35+ Types

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

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

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

39+ }

2740

2841

2942data Type

@@ -34,3 +47,45 @@ data Type

3447 | V4

3548 | M4

3649 | 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+4−5

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

11{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

32module AST.Utils.Type

43 ( delambda

54 , dealias

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

109

1110

1211import qualified Data.Map as Map

12+import qualified Data.Name as Name

1313

1414import AST.Canonical (Type(..), AliasType(..), FieldType(..))

15−import qualified Elm.Name as N

1615

1716

1817

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

3332-- DEALIAS

3433

3534

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

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

3736dealias args aliasType =

3837 case aliasType of

3938 Holey tipe ->

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

4342 tipe

4443

4544

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

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

4746dealiasHelp typeTable tipe =

4847 case tipe of

4948 TLambda a b ->

@@ -73,7 +72,7 @@ dealiasHelp typeTable tipe =

7372 (fmap (dealiasHelp typeTable) maybeC)

7473

7574

76−dealiasField :: Map.Map N.Name Type -> FieldType -> FieldType

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

7776dealiasField typeTable (FieldType index tipe) =

7877 FieldType index (dealiasHelp typeTable tipe)

7978

compiler/src/AST/Valid.hsdeleted−124

@@ -1,124 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module AST.Valid

4− ( Expr, Expr_(..)

5− , Def(..)

6− , Module(..)

7− , Decl(..)

8− , Union(..)

9− , Alias(..)

10− , Binop(..)

11− , Effects(..)

12− , Port(..)

13− , Manager(..)

14− , defaultModule

15− )

16− where

17−

18−

19−import qualified Data.Map as Map

20−import Data.Text (Text)

21−

22−import qualified AST.Utils.Binop as Binop

23−import qualified AST.Source as Src

24−import qualified AST.Utils.Shader as Shader

25−import qualified Elm.Name as N

26−import qualified Reporting.Annotation as A

27−import qualified Reporting.Region as R

28−

29−

30−

31−-- EXPRESSIONS

32−

33−

34−type Expr = A.Located Expr_

35−

36−

37−data Expr_

38− = Chr Text

39− | Str Text

40− | Int Int

41− | Float Double

42− | Var Src.VarType N.Name

43− | VarQual Src.VarType N.Name N.Name

44− | List [Expr]

45− | Op N.Name

46− | Negate Expr

47− | Binops [(Expr, A.Located N.Name)] Expr

48− | Lambda [Src.Pattern] Expr

49− | Call Expr [Expr]

50− | If [(Expr, Expr)] Expr

51− | Let [Def] Expr

52− | Case Expr [(Src.Pattern, Expr)]

53− | Accessor N.Name

54− | Access Expr (A.Located N.Name)

55− | Update (A.Located N.Name) [(A.Located N.Name, Expr)]

56− | Record [(A.Located N.Name, Expr)]

57− | Unit

58− | Tuple Expr Expr [Expr]

59− | Shader Text Text Shader.Shader

60−

61−

62−

63−-- DEFINITIONS

64−

65−

66−data Def

67− = Define R.Region (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)

68− | Destruct R.Region Src.Pattern Expr

69−

70−

71−

72−-- MODULE

73−

74−

75−data Module =

76− Module

77− { _name :: N.Name

78− , _overview :: Src.Docs

79− , _docs :: Map.Map N.Name Text

80− , _exports :: A.Located Src.Exposing

81− , _imports :: [Src.Import]

82− , _decls :: [A.Located Decl]

83− , _unions :: [Union]

84− , _aliases :: [Alias]

85− , _binop :: [Binop]

86− , _effects :: Effects

87− }

88−

89−

90−data Decl = Decl (A.Located N.Name) [Src.Pattern] Expr (Maybe Src.Type)

91−data Union = Union R.Region (A.Located N.Name) [A.Located N.Name] [(A.Located N.Name, [Src.Type])]

92−data Alias = Alias R.Region (A.Located N.Name) [A.Located N.Name] Src.Type

93−data Binop = Binop N.Name Binop.Associativity Binop.Precedence N.Name

94−

95−

96−data Effects

97− = NoEffects

98− | Ports [Port]

99− | Manager R.Region Manager

100−

101−

102−data Manager

103− = Cmd (A.Located N.Name)

104− | Sub (A.Located N.Name)

105− | Fx (A.Located N.Name) (A.Located N.Name)

106−

107−

108−data Port = Port (A.Located N.Name) Src.Type

109−

110−

111−defaultModule :: Map.Map N.Name Text -> [Src.Import] -> [A.Located Decl] -> [Union] -> [Alias] -> [Binop] -> Module

112−defaultModule docs imports decls unions aliases binop =

113− Module

114− { _name = "Main"

115− , _overview = Src.NoDocs R.one

116− , _docs = docs

117− , _exports = A.At R.one Src.Open

118− , _imports = imports

119− , _decls = decls

120− , _unions = unions

121− , _aliases = aliases

122− , _binop = binop

123− , _effects = NoEffects

124− }

compiler/src/Canonicalize/Effects.hs+36−37

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

88

99import qualified Data.Foldable as F

1010import qualified Data.Map as Map

11+import qualified Data.Name as Name

1112

1213import qualified AST.Canonical as Can

13−import qualified AST.Valid as Valid

14−import qualified AST.Module.Name as ModuleName

14+import qualified AST.Source as Src

1515import qualified AST.Utils.Type as Type

1616import qualified Canonicalize.Environment as Env

1717import qualified Canonicalize.Type as Type

18−import qualified Elm.Name as N

18+import qualified Elm.ModuleName as ModuleName

1919import qualified Reporting.Annotation as A

2020import qualified Reporting.Error.Canonicalize as Error

21−import qualified Reporting.Region as R

2221import qualified Reporting.Result as Result

2322

2423

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

3635

3736canonicalize

3837 :: Env.Env

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

40− -> Map.Map N.Name union

41− -> Valid.Effects

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

39+ -> Map.Map Name.Name union

40+ -> Src.Effects

4241 -> Result i w Can.Effects

43−canonicalize env decls unions effects =

42+canonicalize env values unions effects =

4443 case effects of

45− Valid.NoEffects ->

44+ Src.NoEffects ->

4645 Result.ok Can.NoEffects

4746

48− Valid.Ports ports ->

47+ Src.Ports ports ->

4948 do pairs <- traverse (canonicalizePort env) ports

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

5150

52− Valid.Manager region manager ->

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

51+ Src.Manager region manager ->

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

5453 Can.Manager

5554 <$> verifyManager region dict "init"

5655 <*> verifyManager region dict "onEffects"

5756 <*> verifyManager region dict "onSelfMsg"

5857 <*>

5958 case manager of

60− Valid.Cmd cmdType ->

59+ Src.Cmd cmdType ->

6160 Can.Cmd

6261 <$> verifyEffectType cmdType unions

6362 <* verifyManager region dict "cmdMap"

6463

65− Valid.Sub subType ->

64+ Src.Sub subType ->

6665 Can.Sub

6766 <$> verifyEffectType subType unions

6867 <* verifyManager region dict "subMap"

6968

70− Valid.Fx cmdType subType ->

69+ Src.Fx cmdType subType ->

7170 Can.Fx

7271 <$> verifyEffectType cmdType unions

7372 <*> verifyEffectType subType unions

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

7978-- CANONICALIZE PORT

8079

8180

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

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

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

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

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

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

8685 Can.TType home name [msg] : revArgs

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

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

8887 case revArgs of

8988 [] ->

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

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

105104 _ ->

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

107106

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

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

109108 case revArgs of

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

111110 case msg of

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

131130-- VERIFY MANAGER

132131

133132

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

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

135134verifyEffectType (A.At region name) unions =

136135 if Map.member name unions then

137136 Result.ok name

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

139138 Result.throw (Error.EffectNotFound region name)

140139

141140

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

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

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

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

144143 (name, region)

145144

146145

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

148−verifyManager tagRegion decls name =

149− case Map.lookup name decls of

146+verifyManager :: A.Region -> Map.Map Name.Name A.Region -> Name.Name -> Result i w A.Region

147+verifyManager tagRegion values name =

148+ case Map.lookup name values of

150149 Just region ->

151150 Result.ok region

152151

@@ -210,43 +209,43 @@ checkFieldPayload (Can.FieldType _ tipe) =

210209 checkPayload tipe

211210

212211

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

212+isIntFloatBool :: ModuleName.Canonical -> Name.Name -> Bool

214213isIntFloatBool home name =

215214 home == ModuleName.basics

216215 &&

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

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

218217

219218

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

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

221220isString home name =

222221 home == ModuleName.string

223222 &&

224− name == N.string

223+ name == Name.string

225224

226225

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

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

228227isJson home name =

229228 home == ModuleName.jsonEncode

230229 &&

231− name == N.value

230+ name == Name.value

232231

233232

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

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

235234isList home name =

236235 home == ModuleName.list

237236 &&

238− name == N.list

237+ name == Name.list

239238

240239

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

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

242241isMaybe home name =

243242 home == ModuleName.maybe

244243 &&

245− name == N.maybe

244+ name == Name.maybe

246245

247246

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

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

249248isArray home name =

250249 home == ModuleName.array

251250 &&

252− name == N.array

251+ name == Name.array

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

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

44 ( Env(..)

55 , Exposed

66 , Qualified

7+ , Info(..)

8+ , mergeInfo

79 , Var(..)

810 , Type(..)

911 , Ctor(..)

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

2022

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

2224import qualified Data.Map.Strict as Map

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

25+import qualified Data.Name as Name

26+import qualified Data.OneOrMore as OneOrMore

2427

2528import qualified AST.Utils.Binop as Binop

2629import qualified AST.Canonical as Can

27−import qualified AST.Module.Name as ModuleName

2830import qualified Data.Index as Index

29−import qualified Elm.Name as N

31+import qualified Elm.ModuleName as ModuleName

32+import qualified Reporting.Annotation as A

3033import qualified Reporting.Error.Canonicalize as Error

31−import qualified Reporting.Region as R

3234import qualified Reporting.Result as Result

3335

3436

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

4749data Env =

4850 Env

4951 { _home :: ModuleName.Canonical

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

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

5153 , _types :: Exposed Type

5254 , _ctors :: Exposed Ctor

5355 , _binops :: Exposed Binop

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

5860

5961

6062type Exposed a =

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

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

6264

6365

6466type Qualified a =

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

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

68+

69+

70+

71+-- INFO

72+

73+

74+data Info a

75+ = Specific ModuleName.Canonical a

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

77+

78+

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

80+mergeInfo info1 info2 =

81+ case info1 of

82+ Specific h1 _ ->

83+ case info2 of

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

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

86+

87+ Ambiguous h1 hs1 ->

88+ case info2 of

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

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

6691

6792

6893

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

7095

7196

7297data Var

73− = Local R.Region

74− | TopLevel R.Region

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

98+ = Local A.Region

99+ | TopLevel A.Region

100+ | Foreign ModuleName.Canonical Can.Annotation

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

76102

77103

78104

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

80106

81107

82108data Type

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

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

84110 | Union Int ModuleName.Canonical

85111

86112

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

89115

90116

91117data Ctor

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

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

93119 | Ctor

94120 { _c_home :: ModuleName.Canonical

95− , _c_type :: N.Name

121+ , _c_type :: Name.Name

96122 , _c_union :: Can.Union

97123 , _c_index :: Index.ZeroBased

98124 , _c_args :: [Can.Type]

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

105131

106132data Binop =

107133 Binop

108− { _op :: N.Name

134+ { _op :: Name.Name

109135 , _op_home :: ModuleName.Canonical

110− , _op_name :: N.Name

136+ , _op_name :: Name.Name

111137 , _op_annotation :: Can.Annotation

112138 , _op_associativity :: Binop.Associativity

113139 , _op_precedence :: Binop.Precedence

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

118144-- VARIABLE -- ADD LOCALS

119145

120146

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

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

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

123149 do newVars <-

124150 Map.mergeA

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

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

132158

133159

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

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

135161addLocalLeft _ region =

136162 Local region

137163

138164

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

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

140166addLocalBoth name region var =

141167 case var of

142− Foreign _ ->

168+ Foreign _ _ ->

169+ Result.ok (Local region)

170+

171+ Foreigns _ _ ->

143172 Result.ok (Local region)

144173

145174 Local parentRegion ->

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

150179

151180

152181

182+

153183-- FIND TYPE

154184

155185

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

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

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

158188 case Map.lookup name ts of

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

189+ Just (Specific _ tipe) ->

160190 Result.ok tipe

161191

162− Just homes ->

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

192+ Just (Ambiguous h hs) ->

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

164194

165195 Nothing ->

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

167197

168198

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

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

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

171201 case Map.lookup prefix qts of

172202 Just qualified ->

173203 case Map.lookup name qualified of

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

204+ Just (Specific _ tipe) ->

175205 Result.ok tipe

176206

177− Just homes ->

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

207+ Just (Ambiguous h hs) ->

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

179209

180210 Nothing ->

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

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

188218-- FIND CTOR

189219

190220

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

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

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

193223 case Map.lookup name cs of

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

224+ Just (Specific _ ctor) ->

195225 Result.ok ctor

196226

197− Just homes ->

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

227+ Just (Ambiguous h hs) ->

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

199229

200230 Nothing ->

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

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

202232

203233

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

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

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

206236 case Map.lookup prefix qcs of

207237 Just qualified ->

208238 case Map.lookup name qualified of

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

239+ Just (Specific _ pattern) ->

210240 Result.ok pattern

211241

212− Just homes ->

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

242+ Just (Ambiguous h hs) ->

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

214244

215245 Nothing ->

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

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

217247

218248 Nothing ->

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

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

220250

221251

222252

223253-- FIND BINOP

224254

225255

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

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

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

228258 case Map.lookup name binops of

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

259+ Just (Specific _ binop) ->

230260 Result.ok binop

231261

232− Just homes ->

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

262+ Just (Ambiguous h hs) ->

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

234264

235265 Nothing ->

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

compiler/src/Canonicalize/Environment/Dups.hs+18−16

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

1515

1616

1717import qualified Data.Map as Map

18+import qualified Data.Name as Name

1819

1920import qualified Data.OneOrMore as OneOrMore

20−import qualified Elm.Name as N

2121import qualified Reporting.Annotation as A

2222import qualified Reporting.Error.Canonicalize as Error

23−import qualified Reporting.Region as R

2423import qualified Reporting.Result as Result

2524

2625

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

2928

3029

3130type Dict value =

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

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

3332

3433

3534data Info value =

3635 Info

37− { _region :: R.Region

36+ { _region :: A.Region

3837 , _value :: value

3938 }

4039

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

4443

4544

4645type ToError =

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

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

4847

4948

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

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

5150detect toError dict =

5251 Map.traverseWithKey (detectHelp toError) dict

5352

5453

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

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

5655detectHelp toError name values =

5756 case values of

5857 OneOrMore.One (Info _ value) ->

5958 return value

6059

61− OneOrMore.More _ _ ->

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

6365 Result.throw (toError name r1 r2)

6466

6567

@@ -67,22 +69,22 @@ detectHelp toError name values =

6769-- CHECK FIELDS

6870

6971

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

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

7173checkFields fields =

7274 detect Error.DuplicateField (foldr addField none fields)

7375

7476

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

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

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

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

7880

7981

80−checkFields' :: (R.Region -> a -> b) -> [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name b)

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

8183checkFields' toValue fields =

8284 detect Error.DuplicateField (foldr (addField' toValue) none fields)

8385

8486

85−addField' :: (R.Region -> a -> b) -> (A.Located N.Name, a) -> Dict b -> Dict b

87+addField' :: (A.Region -> a -> b) -> (A.Located Name.Name, a) -> Dict b -> Dict b

8688addField' toValue (A.At region name, value) dups =

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

8890

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

9698 Map.empty

9799

98100

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

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

100102one name region value =

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

102104

103105

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

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

105107insert name region value dict =

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

107109

108110

109111union :: Dict a -> Dict a -> Dict a

compiler/src/Canonicalize/Environment/Foreign.hs+90−92

@@ -8,15 +8,17 @@ module Canonicalize.Environment.Foreign

88

99

1010import Control.Monad (foldM)

11+import qualified Data.List as List

1112import qualified Data.Map.Strict as Map

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

14+import qualified Data.Name as Name

1215

1316import qualified AST.Canonical as Can

1417import qualified AST.Source as Src

15−import qualified AST.Module.Name as ModuleName

1618import qualified Canonicalize.Environment as Env

17−import qualified Data.List as List

1819import qualified Elm.Interface as I

19−import qualified Elm.Name as N

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

35−

36−

37−type ImportDict =

38− Map.Map N.Name ModuleName.Canonical

3940

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 (ModuleName.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,10 +136,10 @@ 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

121−addQualified :: N.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a

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

122143addQualified prefix exposed qualified =

123144 Map.insertWith addExposed prefix exposed qualified

124145

@@ -127,16 +148,16 @@ addQualified prefix exposed qualified =

127148-- UNION

128149

129150

130−unionToType :: ModuleName.Canonical -> N.Name -> I.Union -> Maybe (Env.Type, Env.Exposed Env.Ctor)

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

131152unionToType home name union =

132153 unionToTypeHelp home name <$> I.toPublicUnion union

133154

134155

135−unionToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)

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

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

@@ -147,12 +168,12 @@ unionToTypeHelp home name union@(Can.Union vars ctors _ _) =

147168-- ALIAS

148169

149170

150−aliasToType :: ModuleName.Canonical -> N.Name -> I.Alias -> Maybe (Env.Type, Env.Exposed Env.Ctor)

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

151172aliasToType home name alias =

152173 aliasToTypeHelp home name <$> I.toPublicAlias alias

153174

154175

155−aliasToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)

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

156177aliasToTypeHelp home name (Can.Alias vars tipe) =

157178 (

158179 Env.Alias (length vars) home vars tipe

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

@@ -190,22 +211,22 @@ binopToBinop home op (I.Binop name annotation associativity precedence) =

190211addExposedValue

191212 :: ModuleName.Canonical

192213 -> Env.Exposed Can.Annotation

193− -> Map.Map N.Name (Env.Type, Env.Exposed Env.Ctor)

194− -> Map.Map N.Name I.Binop

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

215+ -> 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 N.Name (Env.Type, Env.Exposed Env.Ctor) -> Map.Map N.Name N.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 :: N.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+52−54

@@ -10,19 +10,17 @@ import Control.Monad (foldM)

1010import qualified Data.Graph as Graph

1111import qualified Data.List as List

1212import qualified Data.Map.Strict as Map

13+import qualified Data.Name as Name

1314

1415import qualified AST.Canonical as Can

1516import qualified AST.Source as Src

16−import qualified AST.Valid as Valid

17−import qualified AST.Module.Name as ModuleName

1817import qualified Canonicalize.Environment as Env

1918import qualified Canonicalize.Environment.Dups as Dups

2019import qualified Canonicalize.Type as Type

2120import qualified Data.Index as Index

22−import qualified Elm.Name as N

21+import qualified Elm.ModuleName as ModuleName

2322import qualified Reporting.Annotation as A

2423import qualified Reporting.Error.Canonicalize as Error

25−import qualified Reporting.Region as R

2624import qualified Reporting.Result as Result

2725

2826

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

3432 Result.Result i w Error.Error a

3533

3634

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

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

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

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

3937

4038

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

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

4240add module_ env =

4341 addCtors module_ =<< addVars module_ =<< addTypes module_ env

4442

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

4745-- ADD VARS

4846

4947

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

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

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

5250 do topLevelVars <- collectVars module_

5351 let vs2 = Map.union topLevelVars vs

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

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

5654

5755

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

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

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

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

6058 let

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

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

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

6361 in

6462 Dups.detect Error.DuplicateDecl $

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

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

6664

6765

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

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

6967toEffectDups effects =

7068 case effects of

71− Valid.NoEffects ->

69+ Src.NoEffects ->

7270 Dups.none

7371

74− Valid.Ports ports ->

72+ Src.Ports ports ->

7573 let

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

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

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

7876 in

7977 List.foldl' addPort Dups.none ports

8078

81− Valid.Manager _ manager ->

79+ Src.Manager _ manager ->

8280 case manager of

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

81+ Src.Cmd (A.At region _) ->

8482 Dups.one "command" region (Env.TopLevel region)

8583

86− Valid.Sub (A.At region _) ->

84+ Src.Sub (A.At region _) ->

8785 Dups.one "subscription" region (Env.TopLevel region)

8886

89− Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->

87+ Src.Fx (A.At regionCmd _) (A.At regionSub _) ->

9088 Dups.union

9189 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))

9290 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))

@@ -96,11 +94,11 @@ toEffectDups effects =

9694-- ADD TYPES

9795

9896

99−addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env

100−addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =

97+addTypes :: Src.Module -> Env.Env -> Result i w Env.Env

98+addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =

10199 let

102− addAliasDups dups (Valid.Alias _ (A.At region name) _ _) = Dups.insert name region () dups

103− addUnionDups dups (Valid.Union _ (A.At region name) _ _) = Dups.insert name region () dups

100+ addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups

101+ addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups

104102 typeNameDups =

105103 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions

106104 in

@@ -109,10 +107,10 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs

109107 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)

110108

111109

112−addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)

113−addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =

110+addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)

111+addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =

114112 do arity <- checkUnionFreeVars union

115− let one = Map.singleton home (Env.Union arity home)

113+ let one = Env.Specific home (Env.Union arity home)

116114 Result.ok $ Map.insert name one types

117115

118116

@@ -120,7 +118,7 @@ addUnion home types union@(Valid.Union _ (A.At _ name) _ _) =

120118-- ADD TYPE ALIASES

121119

122120

123−addAliases :: [Valid.Alias] -> Env.Env -> Result i w Env.Env

121+addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env

124122addAliases aliases env =

125123 let

126124 nodes = map toNode aliases

@@ -129,22 +127,22 @@ addAliases aliases env =

129127 foldM addAlias env sccs

130128

131129

132−addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env

130+addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env

133131addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =

134132 case scc of

135− Graph.AcyclicSCC alias@(Valid.Alias _ (A.At _ name) _ tipe) ->

133+ Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->

136134 do args <- checkAliasFreeVars alias

137135 ctype <- Type.canonicalize env tipe

138− 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)

139137 let ts1 = Map.insert name one ts

140138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs

141139

142140 Graph.CyclicSCC [] ->

143141 Result.ok env

144142

145− Graph.CyclicSCC (alias@(Valid.Alias _ (A.At region name1) _ tipe) : others) ->

143+ Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->

146144 do args <- checkAliasFreeVars alias

147− let toName (Valid.Alias _ (A.At _ name) _ _) = name

145+ let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name

148146 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))

149147

150148

@@ -152,12 +150,12 @@ addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =

152150-- DETECT TYPE ALIAS CYCLES

153151

154152

155−toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])

156−toNode alias@(Valid.Alias _ (A.At _ name) _ tipe) =

153+toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name])

154+toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) =

157155 ( alias, name, getEdges [] tipe )

158156

159157

160−getEdges :: [N.Name] -> Src.Type -> [N.Name]

158+getEdges :: [Name.Name] -> Src.Type -> [Name.Name]

161159getEdges edges (A.At _ tipe) =

162160 case tipe of

163161 Src.TLambda arg result ->

@@ -186,8 +184,8 @@ getEdges edges (A.At _ tipe) =

186184-- CHECK FREE VARIABLES

187185

188186

189−checkUnionFreeVars :: Valid.Union -> Result i w Int

190−checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =

187+checkUnionFreeVars :: A.Located Src.Union -> Result i w Int

188+checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =

191189 let

192190 addArg (A.At region arg) dict =

193191 Dups.insert arg region region dict

@@ -206,8 +204,8 @@ checkUnionFreeVars (Valid.Union unionRegion (A.At _ name) args ctors) =

206204 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds

207205

208206

209−checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]

210−checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =

207+checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]

208+checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =

211209 let

212210 addArg (A.At region arg) dict =

213211 Dups.insert arg region region dict

@@ -225,7 +223,7 @@ checkAliasFreeVars (Valid.Alias aliasRegion (A.At _ name) args tipe) =

225223 (Map.toList (Map.difference freeVars boundVars))

226224

227225

228−addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region

226+addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region

229227addFreeVars freeVars (A.At region tipe) =

230228 case tipe of

231229 Src.TLambda arg result ->

@@ -263,8 +261,8 @@ addFreeVars freeVars (A.At region tipe) =

263261-- ADD CTORS

264262

265263

266−addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)

267−addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =

264+addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)

265+addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =

268266 do unionInfo <- traverse (canonicalizeUnion env) unions

269267 aliasInfo <- traverse (canonicalizeAlias env) aliases

270268

@@ -283,15 +281,15 @@ addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts c

283281 )

284282

285283

286−type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)

284+type CtorDups = Dups.Dict (Env.Info Env.Ctor)

287285

288286

289287

290288-- CANONICALIZE ALIAS

291289

292290

293−canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )

294−canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =

291+canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups )

292+canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) =

295293 do let vars = map A.toValue args

296294 ctipe <- Type.canonicalize env tipe

297295 Result.ok

@@ -299,13 +297,13 @@ canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region n

299297 ,

300298 case ctipe of

301299 Can.TRecord fields Nothing ->

302− 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))

303301

304302 _ ->

305303 Dups.none

306304 )

307305

308−toRecordCtor :: ModuleName.Canonical -> N.Name -> [N.Name] -> Map.Map N.Name Can.FieldType -> Env.Ctor

306+toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor

309307toRecordCtor home name vars fields =

310308 let

311309 avars = map (\var -> (var, Can.TVar var)) vars

@@ -322,8 +320,8 @@ toRecordCtor home name vars fields =

322320-- CANONICALIZE UNION

323321

324322

325−canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )

326−canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name) avars ctors) =

323+canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups )

324+canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Union (A.At _ name) avars ctors)) =

327325 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors

328326 let vars = map A.toValue avars

329327 let alts = map A.toValue cctors

@@ -334,14 +332,14 @@ canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union _ (A.At _ name)

334332 )

335333

336334

337−canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)

335+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located Name.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)

338336canonicalizeCtor env index (A.At region ctor, tipes) =

339337 do ctipes <- traverse (Type.canonicalize env) tipes

340338 Result.ok $ A.At region $

341339 Can.Ctor ctor index (length ctipes) ctipes

342340

343341

344−toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts

342+toOpts :: [(A.Located Name.Name, [Src.Type])] -> Can.CtorOpts

345343toOpts ctors =

346344 case ctors of

347345 [ (_,[_]) ] ->

@@ -351,7 +349,7 @@ toOpts ctors =

351349 if all (null . snd) ctors then Can.Enum else Can.Normal

352350

353351

354−toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups

352+toCtor :: ModuleName.Canonical -> Name.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups

355353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =

356− Dups.one name region $ Map.singleton home $

354+ Dups.one name region $ Env.Specific home $

357355 Env.Ctor home typeName union index args

compiler/src/Canonicalize/Expression.hs+71−73

@@ -14,23 +14,21 @@ import Control.Monad (foldM)

1414import qualified Data.Graph as Graph

1515import qualified Data.List as List

1616import qualified Data.Map.Strict as Map

17−import qualified Data.Map.Strict.Internal as I

17+import qualified Data.Name as Name

1818

1919import qualified AST.Canonical as Can

2020import qualified AST.Source as Src

21−import qualified AST.Module.Name as ModuleName

2221import qualified AST.Utils.Binop as Binop

2322import qualified AST.Utils.Type as Type

24−import qualified AST.Valid as Valid

2523import qualified Canonicalize.Environment as Env

2624import qualified Canonicalize.Environment.Dups as Dups

2725import qualified Canonicalize.Pattern as Pattern

2826import qualified Canonicalize.Type as Type

2927import qualified Data.Index as Index

30−import qualified Elm.Name as N

28+import qualified Elm.ModuleName as ModuleName

29+import qualified Elm.Package as Pkg

3130import qualified Reporting.Annotation as A

3231import qualified Reporting.Error.Canonicalize as Error

33−import qualified Reporting.Region as R

3432import qualified Reporting.Result as Result

3533import qualified Reporting.Warning as W

3634

@@ -44,7 +42,7 @@ type Result i w a =

4442

4543

4644type FreeLocals =

47− Map.Map N.Name Uses

45+ Map.Map Name.Name Uses

4846

4947

5048data Uses =

@@ -58,46 +56,46 @@ data Uses =

5856-- CANONICALIZE

5957

6058

61−canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

59+canonicalize :: Env.Env -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr

6260canonicalize env (A.At region expression) =

6361 A.At region <$>

6462 case expression of

65− Valid.Str string ->

63+ Src.Str string ->

6664 Result.ok (Can.Str string)

6765

68− Valid.Chr char ->

66+ Src.Chr char ->

6967 Result.ok (Can.Chr char)

7068

71− Valid.Int int ->

69+ Src.Int int ->

7270 Result.ok (Can.Int int)

7371

74− Valid.Float float ->

72+ Src.Float float ->

7573 Result.ok (Can.Float float)

7674

77− Valid.Var varType name ->

75+ Src.Var varType name ->

7876 case varType of

79− Src.Value -> findVar region env name

80− Src.Ctor -> toVarCtor name <$> Env.findCtor region env name

77+ Src.LowVar -> findVar region env name

78+ Src.CapVar -> toVarCtor name <$> Env.findCtor region env name

8179

82− Valid.VarQual varType prefix name ->

80+ Src.VarQual varType prefix name ->

8381 case varType of

84− Src.Value -> findVarQual region env prefix name

85− Src.Ctor -> toVarCtor name <$> Env.findCtorQual region env prefix name

82+ Src.LowVar -> findVarQual region env prefix name

83+ Src.CapVar -> toVarCtor name <$> Env.findCtorQual region env prefix name

8684

87− Valid.List exprs ->

85+ Src.List exprs ->

8886 Can.List <$> traverse (canonicalize env) exprs

8987

90− Valid.Op op ->

88+ Src.Op op ->

9189 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op

9290 return (Can.VarOperator op home name annotation)

9391

94− Valid.Negate expr ->

92+ Src.Negate expr ->

9593 Can.Negate <$> canonicalize env expr

9694

97− Valid.Binops ops final ->

95+ Src.Binops ops final ->

9896 A.toValue <$> canonicalizeBinops region env ops final

9997

100− Valid.Lambda srcArgs body ->

98+ Src.Lambda srcArgs body ->

10199 delayedUsage $

102100 do (args, bindings) <-

103101 Pattern.verify Error.DPLambdaArgs $

@@ -111,33 +109,33 @@ canonicalize env (A.At region expression) =

111109

112110 return (Can.Lambda args cbody, freeLocals)

113111

114− Valid.Call func args ->

112+ Src.Call func args ->

115113 Can.Call

116114 <$> canonicalize env func

117115 <*> traverse (canonicalize env) args

118116

119− Valid.If branches finally ->

117+ Src.If branches finally ->

120118 Can.If

121119 <$> traverse (canonicalizeIfBranch env) branches

122120 <*> canonicalize env finally

123121

124− Valid.Let defs expr ->

122+ Src.Let defs expr ->

125123 A.toValue <$> canonicalizeLet region env defs expr

126124

127− Valid.Case expr branches ->

125+ Src.Case expr branches ->

128126 Can.Case

129127 <$> canonicalize env expr

130128 <*> traverse (canonicalizeCaseBranch env) branches

131129

132− Valid.Accessor field ->

130+ Src.Accessor field ->

133131 Result.ok $ Can.Accessor field

134132

135− Valid.Access record field ->

133+ Src.Access record field ->

136134 Can.Access

137135 <$> canonicalize env record

138136 <*> Result.ok field

139137

140− Valid.Update (A.At reg name) fields ->

138+ Src.Update (A.At reg name) fields ->

141139 let

142140 makeCanFields =

143141 Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields

@@ -146,28 +144,28 @@ canonicalize env (A.At region expression) =

146144 <$> (A.At reg <$> findVar reg env name)

147145 <*> (sequenceA =<< makeCanFields)

148146

149− Valid.Record fields ->

147+ Src.Record fields ->

150148 do fieldDict <- Dups.checkFields fields

151149 Can.Record <$> traverse (canonicalize env) fieldDict

152150

153− Valid.Unit ->

151+ Src.Unit ->

154152 Result.ok Can.Unit

155153

156− Valid.Tuple a b cs ->

154+ Src.Tuple a b cs ->

157155 Can.Tuple

158156 <$> canonicalize env a

159157 <*> canonicalize env b

160158 <*> canonicalizeTupleExtras region env cs

161159

162− Valid.Shader uid src tipe ->

163− Result.ok (Can.Shader uid src tipe)

160+ Src.Shader src tipe ->

161+ Result.ok (Can.Shader src tipe)

164162

165163

166164

167165-- CANONICALIZE TUPLE EXTRAS

168166

169167

170−canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)

168+canonicalizeTupleExtras :: A.Region -> Env.Env -> [Src.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)

171169canonicalizeTupleExtras region env extras =

172170 case extras of

173171 [] ->

@@ -184,7 +182,7 @@ canonicalizeTupleExtras region env extras =

184182-- CANONICALIZE IF BRANCH

185183

186184

187−canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)

185+canonicalizeIfBranch :: Env.Env -> (Src.Expr, Src.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)

188186canonicalizeIfBranch env (condition, branch) =

189187 (,)

190188 <$> canonicalize env condition

@@ -195,7 +193,7 @@ canonicalizeIfBranch env (condition, branch) =

195193-- CANONICALIZE CASE BRANCH

196194

197195

198−canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch

196+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Src.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch

199197canonicalizeCaseBranch env (pattern, expr) =

200198 directUsage $

201199 do (cpattern, bindings) <-

@@ -213,7 +211,7 @@ canonicalizeCaseBranch env (pattern, expr) =

213211-- CANONICALIZE BINOPS

214212

215213

216−canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

214+canonicalizeBinops :: A.Region -> Env.Env -> [(Src.Expr, A.Located Name.Name)] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr

217215canonicalizeBinops overallRegion env ops final =

218216 let

219217 canonicalizeHelp (expr, A.At region op) =

@@ -234,7 +232,7 @@ data Step

234232 | Error Env.Binop Env.Binop

235233

236234

237−runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr

235+runBinopStepper :: A.Region -> Step -> Result FreeLocals w Can.Expr

238236runBinopStepper overallRegion step =

239237 case step of

240238 Done expr ->

@@ -296,7 +294,7 @@ toBinop (Env.Binop op home name annotation _ _) left right =

296294-- CANONICALIZE LET

297295

298296

299−canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr

297+canonicalizeLet :: A.Region -> Env.Env -> [A.Located Src.Def] -> Src.Expr -> Result FreeLocals [W.Warning] Can.Expr

300298canonicalizeLet letRegion env defs body =

301299 directUsage $

302300 do bindings <-

@@ -315,17 +313,17 @@ canonicalizeLet letRegion env defs body =

315313-- ADD BINDINGS

316314

317315

318−addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region

319−addBindings bindings def =

316+addBindings :: Dups.Dict A.Region -> A.Located Src.Def -> Dups.Dict A.Region

317+addBindings bindings (A.At _ def) =

320318 case def of

321− Valid.Define _ (A.At region name) _ _ _ ->

319+ Src.Define (A.At region name) _ _ _ ->

322320 Dups.insert name region region bindings

323321

324− Valid.Destruct _ pattern _ ->

322+ Src.Destruct pattern _ ->

325323 addBindingsHelp bindings pattern

326324

327325

328−addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region

326+addBindingsHelp :: Dups.Dict A.Region -> Src.Pattern -> Dups.Dict A.Region

329327addBindingsHelp bindings (A.At region pattern) =

330328 case pattern of

331329 Src.PAnything ->

@@ -378,19 +376,19 @@ addBindingsHelp bindings (A.At region pattern) =

378376

379377

380378type Node =

381− (Binding, N.Name, [N.Name])

379+ (Binding, Name.Name, [Name.Name])

382380

383381

384382data Binding

385383 = Define Can.Def

386− | Edge (A.Located N.Name)

384+ | Edge (A.Located Name.Name)

387385 | Destruct Can.Pattern Can.Expr

388386

389387

390−addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]

391−addDefNodes env nodes def =

388+addDefNodes :: Env.Env -> [Node] -> A.Located Src.Def -> Result FreeLocals [W.Warning] [Node]

389+addDefNodes env nodes (A.At _ def) =

392390 case def of

393− Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->

391+ Src.Define aname@(A.At _ name) srcArgs body maybeType ->

394392 case maybeType of

395393 Nothing ->

396394 do (args, argBindings) <-

@@ -423,7 +421,7 @@ addDefNodes env nodes def =

423421 let node = ( Define cdef, name, Map.keys freeLocals )

424422 logLetLocals args freeLocals (node:nodes)

425423

426− Valid.Destruct _ pattern body ->

424+ Src.Destruct pattern body ->

427425 do (cpattern, _bindings) <-

428426 Pattern.verify Error.DPDestruct $

429427 Pattern.canonicalize env pattern

@@ -438,7 +436,7 @@ addDefNodes env nodes def =

438436 (\freeLocals warnings cbody ->

439437 let

440438 names = getPatternNames [] pattern

441− name = N.toCompositeName (map A.toValue names)

439+ name = Name.fromManyNames (map A.toValue names)

442440 node = ( Destruct cpattern cbody, name, Map.keys freeLocals )

443441 in

444442 good

@@ -461,12 +459,12 @@ logLetLocals args letLocals value =

461459 value

462460

463461

464−addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]

462+addEdge :: [Name.Name] -> [Node] -> A.Located Name.Name -> [Node]

465463addEdge edges nodes aname@(A.At _ name) =

466464 (Edge aname, name, edges) : nodes

467465

468466

469−getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]

467+getPatternNames :: [A.Located Name.Name] -> Src.Pattern -> [A.Located Name.Name]

470468getPatternNames names (A.At region pattern) =

471469 case pattern of

472470 Src.PAnything -> names

@@ -490,7 +488,7 @@ getPatternNames names (A.At region pattern) =

490488

491489gatherTypedArgs

492490 :: Env.Env

493− -> N.Name

491+ -> Name.Name

494492 -> [Src.Pattern]

495493 -> Can.Type

496494 -> Index.ZeroBased

@@ -511,14 +509,14 @@ gatherTypedArgs env name srcArgs tipe index revTypedArgs =

511509 _ ->

512510 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in

513511 Result.throw $

514− Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)

512+ Error.AnnotationTooShort (A.mergeRegions start end) name index (length srcArgs)

515513

516514

517515

518516-- DETECT CYCLES

519517

520518

521−detectCycles :: R.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr

519+detectCycles :: A.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr

522520detectCycles letRegion sccs body =

523521 case sccs of

524522 [] ->

@@ -574,7 +572,7 @@ checkCycle bindings defs =

574572 checkCycle otherBindings defs

575573

576574

577−toNames :: [Binding] -> [Can.Def] -> [N.Name]

575+toNames :: [Binding] -> [Can.Def] -> [Name.Name]

578576toNames bindings revDefs =

579577 case bindings of

580578 [] ->

@@ -587,7 +585,7 @@ toNames bindings revDefs =

587585 Destruct _ _ -> toNames otherBindings revDefs

588586

589587

590−getDefName :: Can.Def -> N.Name

588+getDefName :: Can.Def -> Name.Name

591589getDefName def =

592590 case def of

593591 Can.Def (A.At _ name) _ _ ->

@@ -601,7 +599,7 @@ getDefName def =

601599-- LOG VARIABLE USES

602600

603601

604−logVar :: N.Name -> a -> Result FreeLocals w a

602+logVar :: Name.Name -> a -> Result FreeLocals w a

605603logVar name value =

606604 Result.Result $ \freeLocals warnings _ good ->

607605 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value

@@ -656,7 +654,7 @@ verifyBindings context bindings (Result.Result k) =

656654 )

657655

658656

659−addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> R.Region -> [W.Warning]

657+addUnusedWarning :: W.Context -> [W.Warning] -> Name.Name -> A.Region -> [W.Warning]

660658addUnusedWarning context warnings name region =

661659 W.UnusedVariable region context name : warnings

662660

@@ -686,7 +684,7 @@ delayedUsage (Result.Result k) =

686684-- FIND VARIABLE

687685

688686

689−findVar :: R.Region -> Env.Env -> N.Name -> Result FreeLocals w Can.Expr_

687+findVar :: A.Region -> Env.Env -> Name.Name -> Result FreeLocals w Can.Expr_

690688findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =

691689 case Map.lookup name vs of

692690 Just var ->

@@ -697,46 +695,46 @@ findVar region (Env.Env localHome vs _ _ _ qvs _ _) name =

697695 Env.TopLevel _ ->

698696 logVar name (Can.VarTopLevel localHome name)

699697

700− Env.Foreign (I.Bin 1 home annotation _ _) ->

698+ Env.Foreign home annotation ->

701699 Result.ok $

702700 if home == ModuleName.debug then

703701 Can.VarDebug localHome name annotation

704702 else

705703 Can.VarForeign home name annotation

706704

707− Env.Foreign homes ->

708− 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)

709707

710708 Nothing ->

711709 Result.throw (Error.NotFoundVar region Nothing name (toPossibleNames vs qvs))

712710

713711

714−findVarQual :: R.Region -> Env.Env -> N.Name -> N.Name -> Result FreeLocals w Can.Expr_

712+findVarQual :: A.Region -> Env.Env -> Name.Name -> Name.Name -> Result FreeLocals w Can.Expr_

715713findVarQual region (Env.Env localHome vs _ _ _ qvs _ _) prefix name =

716714 case Map.lookup prefix qvs of

717715 Just qualified ->

718716 case Map.lookup name qualified of

719− Just (I.Bin 1 home annotation _ _) ->

717+ Just (Env.Specific home annotation) ->

720718 Result.ok $

721719 if home == ModuleName.debug then

722720 Can.VarDebug localHome name annotation

723721 else

724722 Can.VarForeign home name annotation

725723

726− Just homes ->

727− 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)

728726

729727 Nothing ->

730728 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))

731729

732730 Nothing ->

733− if ModuleName.isKernel prefix then

734− Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name

731+ if Name.isKernel prefix && Pkg.isKernel (ModuleName._package localHome) then

732+ Result.ok $ Can.VarKernel (Name.getKernel prefix) name

735733 else

736734 Result.throw (Error.NotFoundVar region (Just prefix) name (toPossibleNames vs qvs))

737735

738736

739−toPossibleNames :: Map.Map N.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames

737+toPossibleNames :: Map.Map Name.Name Env.Var -> Env.Qualified Can.Annotation -> Error.PossibleNames

740738toPossibleNames exposed qualified =

741739 Error.PossibleNames (Map.keysSet exposed) (Map.map Map.keysSet qualified)

742740

@@ -745,7 +743,7 @@ toPossibleNames exposed qualified =

745743-- FIND CTOR

746744

747745

748−toVarCtor :: N.Name -> Env.Ctor -> Can.Expr_

746+toVarCtor :: Name.Name -> Env.Ctor -> Can.Expr_

749747toVarCtor name ctor =

750748 case ctor of

751749 Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->

compiler/src/Canonicalize/Module.hs+65−74

@@ -7,11 +7,10 @@ module Canonicalize.Module

77

88import qualified Data.Graph as Graph

99import qualified Data.Map as Map

10+import qualified Data.Name as Name

1011

1112import qualified AST.Canonical as Can

1213import qualified AST.Source as Src

13−import qualified AST.Valid as Valid

14−import qualified AST.Module.Name as ModuleName

1514import qualified Canonicalize.Effects as Effects

1615import qualified Canonicalize.Environment as Env

1716import qualified Canonicalize.Environment.Dups as Dups

@@ -22,11 +21,10 @@ import qualified Canonicalize.Pattern as Pattern

2221import qualified Canonicalize.Type as Type

2322import qualified Data.Index as Index

2423import qualified Elm.Interface as I

25−import qualified Elm.Name as N

24+import qualified Elm.ModuleName as ModuleName

2625import qualified Elm.Package as Pkg

2726import qualified Reporting.Annotation as A

2827import qualified Reporting.Error.Canonicalize as Error

29−import qualified Reporting.Region as R

3028import qualified Reporting.Result as Result

3129import qualified Reporting.Warning as W

3230

@@ -43,47 +41,28 @@ type Result i w a =

4341-- MODULES

4442

4543

46−canonicalize

47− :: Pkg.Name

48− -> Map.Map N.Name ModuleName.Canonical

49− -> I.Interfaces

50− -> Valid.Module

51− -> Result i [W.Warning] Can.Module

52−canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls _ _ binops effects) =

53− do let home = ModuleName.Canonical pkg name

44+canonicalize :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Result i [W.Warning] Can.Module

45+canonicalize pkg ifaces modul@(Src.Module _ exports docs imports values _ _ binops effects) =

46+ do let home = ModuleName.Canonical pkg (Src.getName modul)

5447 let cbinops = Map.fromList (map canonicalizeBinop binops)

5548

5649 (env, cunions, caliases) <-

57− Local.add module_ =<<

58− Foreign.createInitialEnv home importDict interfaces imports

50+ Local.add modul =<<

51+ Foreign.createInitialEnv home ifaces imports

5952

60− cdecls <- canonicalizeDecls env decls

61− ceffects <- Effects.canonicalize env decls cunions effects

62− cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports

53+ cvalues <- canonicalizeValues env values

54+ ceffects <- Effects.canonicalize env values cunions effects

55+ cexports <- canonicalizeExports values cunions caliases cbinops ceffects exports

6356

64− return $ Can.Module home (toDocs module_) cexports cdecls cunions caliases cbinops ceffects

65−

66−

67−

68−-- DOCUMENTATION

69−

70−

71−toDocs :: Valid.Module -> Can.Docs

72−toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =

73− case docs of

74− Src.NoDocs region ->

75− Can.NoDocs region

76−

77− Src.YesDocs region overview ->

78− Can.YesDocs region overview comments

57+ return $ Can.Module home cexports docs cvalues cunions caliases cbinops ceffects

7958

8059

8160

8261-- CANONICALIZE BINOP

8362

8463

85−canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )

86−canonicalizeBinop (Valid.Binop op associativity precedence func) =

64+canonicalizeBinop :: A.Located Src.Infix -> ( Name.Name, Can.Binop )

65+canonicalizeBinop (A.At _ (Src.Infix op associativity precedence func)) =

8766 ( op, Can.Binop_ associativity precedence func )

8867

8968

@@ -97,9 +76,9 @@ canonicalizeBinop (Valid.Binop op associativity precedence func) =

9776--

9877

9978

100−canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls

101−canonicalizeDecls env decls =

102− do nodes <- traverse (toNodeOne env) decls

79+canonicalizeValues :: Env.Env -> [A.Located Src.Value] -> Result i [W.Warning] Can.Decls

80+canonicalizeValues env values =

81+ do nodes <- traverse (toNodeOne env) values

10382 detectCycles (Graph.stronglyConnComp nodes)

10483

10584

@@ -114,13 +93,11 @@ detectCycles sccs =

11493 Graph.AcyclicSCC (def, _, _) ->

11594 Can.Declare def <$> detectCycles otherSccs

11695

117− Graph.CyclicSCC [] ->

118− detectCycles otherSccs

119−

12096 Graph.CyclicSCC subNodes ->

121− Can.DeclareRec

122− <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)

123− <*> detectCycles otherSccs

97+ do defs <- traverse detectBadCycles (Graph.stronglyConnComp subNodes)

98+ case defs of

99+ [] -> detectCycles otherSccs

100+ d:ds -> Can.DeclareRec d ds <$> detectCycles otherSccs

124101

125102

126103detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def

@@ -129,8 +106,22 @@ detectBadCycles scc =

129106 Graph.AcyclicSCC def ->

130107 Result.ok def

131108

132− Graph.CyclicSCC cyclicValueDefs ->

133− Result.throw (Error.RecursiveDecl cyclicValueDefs)

109+ Graph.CyclicSCC [] ->

110+ error "The definition of Data.Graph.SCC should not allow empty CyclicSCC!"

111+

112+ Graph.CyclicSCC (def:defs) ->

113+ let

114+ (A.At region name) = extractDefName def

115+ names = map (A.toValue . extractDefName) defs

116+ in

117+ Result.throw (Error.RecursiveDecl region name names)

118+

119+

120+extractDefName :: Can.Def -> A.Located Name.Name

121+extractDefName def =

122+ case def of

123+ Can.Def name _ _ -> name

124+ Can.TypedDef name _ _ _ _ -> name

134125

135126

136127

@@ -142,17 +133,17 @@ detectBadCycles scc =

142133-- Phase one nodes track ALL dependencies.

143134-- This allows us to find cyclic values for type inference.

144135type NodeOne =

145− (NodeTwo, N.Name, [N.Name])

136+ (NodeTwo, Name.Name, [Name.Name])

146137

147138

148139-- Phase two nodes track DIRECT dependencies.

149140-- This allows us to detect cycles that definitely do not terminate.

150141type NodeTwo =

151− (Can.Def, N.Name, [N.Name])

142+ (Can.Def, Name.Name, [Name.Name])

152143

153144

154−toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne

155−toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =

145+toNodeOne :: Env.Env -> A.Located Src.Value -> Result i [W.Warning] NodeOne

146+toNodeOne env (A.At _ (Src.Value aname@(A.At _ name) srcArgs body maybeType)) =

156147 case maybeType of

157148 Nothing ->

158149 do (args, argBindings) <-

@@ -193,7 +184,7 @@ toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =

193184 )

194185

195186

196−toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo

187+toNodeTwo :: Name.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo

197188toNodeTwo name args def freeLocals =

198189 case args of

199190 [] ->

@@ -203,7 +194,7 @@ toNodeTwo name args def freeLocals =

203194 (def, name, [])

204195

205196

206−addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]

197+addDirects :: Name.Name -> Expr.Uses -> [Name.Name] -> [Name.Name]

207198addDirects name (Expr.Uses directUses _) directDeps =

208199 if directUses > 0 then

209200 name:directDeps

@@ -216,41 +207,41 @@ addDirects name (Expr.Uses directUses _) directDeps =

216207

217208

218209canonicalizeExports

219− :: [A.Located Valid.Decl]

220− -> Map.Map N.Name union

221− -> Map.Map N.Name alias

222− -> Map.Map N.Name binop

210+ :: [A.Located Src.Value]

211+ -> Map.Map Name.Name union

212+ -> Map.Map Name.Name alias

213+ -> Map.Map Name.Name binop

223214 -> Can.Effects

224215 -> A.Located Src.Exposing

225216 -> Result i w Can.Exports

226−canonicalizeExports decls unions aliases binops effects (A.At region exposing) =

217+canonicalizeExports values unions aliases binops effects (A.At region exposing) =

227218 case exposing of

228219 Src.Open ->

229220 Result.ok (Can.ExportEverything region)

230221

231222 Src.Explicit exposeds ->

232− do let names = Map.fromList (map declToName decls)

223+ do let names = Map.fromList (map valueToName values)

233224 infos <- traverse (checkExposed names unions aliases binops effects) exposeds

234225 Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)

235226

236227

237−declToName :: A.Located Valid.Decl -> ( N.Name, () )

238−declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =

228+valueToName :: A.Located Src.Value -> ( Name.Name, () )

229+valueToName (A.At _ (Src.Value (A.At _ name) _ _ _)) =

239230 ( name, () )

240231

241232

242233checkExposed

243− :: Map.Map N.Name decl

244− -> Map.Map N.Name union

245− -> Map.Map N.Name alias

246− -> Map.Map N.Name binop

234+ :: Map.Map Name.Name value

235+ -> Map.Map Name.Name union

236+ -> Map.Map Name.Name alias

237+ -> Map.Map Name.Name binop

247238 -> Can.Effects

248− -> A.Located Src.Exposed

239+ -> Src.Exposed

249240 -> Result i w (Dups.Dict (A.Located Can.Export))

250−checkExposed decls unions aliases binops effects (A.At region exposed) =

241+checkExposed values unions aliases binops effects exposed =

251242 case exposed of

252− Src.Lower name ->

253− if Map.member name decls then

243+ Src.Lower (A.At region name) ->

244+ if Map.member name values then

254245 ok name region Can.ExportValue

255246 else

256247 case checkPorts effects name of

@@ -259,25 +250,25 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =

259250

260251 Just ports ->

261252 Result.throw $ Error.ExportNotFound region Error.BadVar name $

262− ports ++ Map.keys decls

253+ ports ++ Map.keys values

263254

264− Src.Operator name ->

255+ Src.Operator region name ->

265256 if Map.member name binops then

266257 ok name region Can.ExportBinop

267258 else

268259 Result.throw $ Error.ExportNotFound region Error.BadOp name $

269260 Map.keys binops

270261

271− Src.Upper name Src.Public ->

262+ Src.Upper (A.At region name) (Src.Public dotDotRegion) ->

272263 if Map.member name unions then

273264 ok name region Can.ExportUnionOpen

274265 else if Map.member name aliases then

275− Result.throw $ Error.ExportOpenAlias region name

266+ Result.throw $ Error.ExportOpenAlias dotDotRegion name

276267 else

277268 Result.throw $ Error.ExportNotFound region Error.BadType name $

278269 Map.keys unions ++ Map.keys aliases

279270

280− Src.Upper name Src.Private ->

271+ Src.Upper (A.At region name) Src.Private ->

281272 if Map.member name unions then

282273 ok name region Can.ExportUnionClosed

283274 else if Map.member name aliases then

@@ -287,7 +278,7 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =

287278 Map.keys unions ++ Map.keys aliases

288279

289280

290−checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]

281+checkPorts :: Can.Effects -> Name.Name -> Maybe [Name.Name]

291282checkPorts effects name =

292283 case effects of

293284 Can.NoEffects ->

@@ -300,6 +291,6 @@ checkPorts effects name =

300291 Just []

301292

302293

303−ok :: N.Name -> R.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))

294+ok :: Name.Name -> A.Region -> Can.Export -> Result i w (Dups.Dict (A.Located Can.Export))

304295ok name region export =

305296 Result.ok $ Dups.one name region (A.At region export)

compiler/src/Canonicalize/Pattern.hs+16−12

@@ -8,17 +8,18 @@ module Canonicalize.Pattern

88 where

99

1010

11+import qualified Data.List as List

1112import qualified Data.Map.Strict as Map

13+import qualified Data.Name as Name

1214

1315import qualified AST.Canonical as Can

1416import qualified AST.Source as Src

1517import qualified Canonicalize.Environment as Env

1618import qualified Canonicalize.Environment.Dups as Dups

1719import qualified Data.Index as Index

18−import qualified Elm.Name as N

20+import qualified Elm.ModuleName as ModuleName

1921import qualified Reporting.Annotation as A

2022import qualified Reporting.Error.Canonicalize as Error

21−import qualified Reporting.Region as R

2223import qualified Reporting.Result as Result

2324

2425

@@ -31,7 +32,7 @@ type Result i w a =

3132

3233

3334type Bindings =

34− Map.Map N.Name R.Region

35+ Map.Map Name.Name A.Region

3536

3637

3738

@@ -59,7 +60,7 @@ verify context (Result.Result k) =

5960

6061

6162type DupsDict =

62− Dups.Dict R.Region

63+ Dups.Dict A.Region

6364

6465

6566canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern

@@ -112,7 +113,7 @@ canonicalize env (A.At region pattern) =

112113 Result.ok (Can.PInt int)

113114

114115

115−canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_

116+canonicalizeCtor :: Env.Env -> A.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_

116117canonicalizeCtor env region name patterns ctor =

117118 case ctor of

118119 Env.Ctor home tipe union index args ->

@@ -123,16 +124,19 @@ canonicalizeCtor env region name patterns ctor =

123124 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args

124125 case verifiedList of

125126 Index.LengthMatch cargs ->

126− Result.ok (Can.PCtor home tipe union name index cargs)

127+ if tipe == Name.bool && home == ModuleName.basics then

128+ Result.ok (Can.PBool union (name == Name.true))

129+ else

130+ Result.ok (Can.PCtor home tipe union name index cargs)

127131

128132 Index.LengthMismatch actualLength expectedLength ->

129− Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)

133+ Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)

130134

131135 Env.RecordCtor _ _ _ ->

132136 Result.throw (Error.PatternHasRecordCtor region name)

133137

134138

135−canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)

139+canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)

136140canonicalizeTuple tupleRegion env extras =

137141 case extras of

138142 [] ->

@@ -161,17 +165,17 @@ canonicalizeList env list =

161165-- LOG BINDINGS

162166

163167

164−logVar :: N.Name -> R.Region -> a -> Result DupsDict w a

168+logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a

165169logVar name region value =

166170 Result.Result $ \bindings warnings _ ok ->

167171 ok (Dups.insert name region region bindings) warnings value

168172

169173

170−logFields :: [A.Located N.Name] -> a -> Result DupsDict w a

174+logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a

171175logFields fields value =

172176 let

173− addField (A.At region name) dict =

177+ addField dict (A.At region name) =

174178 Dups.insert name region region dict

175179 in

176180 Result.Result $ \bindings warnings _ ok ->

177− ok (foldr addField bindings fields) warnings value

181+ ok (List.foldl' addField bindings fields) warnings value

compiler/src/Canonicalize/Type.hs+6−7

@@ -9,15 +9,14 @@ module Canonicalize.Type

99

1010import qualified Data.List as List

1111import qualified Data.Map as Map

12+import qualified Data.Name as Name

1213

1314import qualified AST.Canonical as Can

1415import qualified AST.Source as Src

1516import qualified Canonicalize.Environment as Env

1617import qualified Canonicalize.Environment.Dups as Dups

17−import qualified Elm.Name as N

1818import qualified Reporting.Annotation as A

1919import qualified Reporting.Error.Canonicalize as Error

20−import qualified Reporting.Region as R

2120import qualified Reporting.Result as Result

2221

2322

@@ -85,7 +84,7 @@ canonicalize env (A.At typeRegion tipe) =

8584 Result.throw $ Error.TupleLargerThanThree typeRegion

8685

8786

88−canonicalizeFields :: Env.Env -> [(A.Located N.Name, Src.Type)] -> [(A.Located N.Name, Result i w Can.FieldType)]

87+canonicalizeFields :: Env.Env -> [(A.Located Name.Name, Src.Type)] -> [(A.Located Name.Name, Result i w Can.FieldType)]

8988canonicalizeFields env fields =

9089 let

9190 len = fromIntegral (length fields)

@@ -99,7 +98,7 @@ canonicalizeFields env fields =

9998-- CANONICALIZE TYPE

10099

101100

102−canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type

101+canonicalizeType :: Env.Env -> A.Region -> Name.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type

103102canonicalizeType env region name args info =

104103 do cargs <- traverse (canonicalize env) args

105104 case info of

@@ -112,7 +111,7 @@ canonicalizeType env region name args info =

112111 Can.TType home name cargs

113112

114113

115−checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer

114+checkArity :: Int -> A.Region -> Name.Name -> [A.Located arg] -> answer -> Result i w answer

116115checkArity expected region name args answer =

117116 let actual = length args in

118117 if expected == actual then

@@ -125,7 +124,7 @@ checkArity expected region name args answer =

125124-- ADD FREE VARS

126125

127126

128−addFreeVars :: Map.Map N.Name () -> Can.Type -> Map.Map N.Name ()

127+addFreeVars :: Map.Map Name.Name () -> Can.Type -> Map.Map Name.Name ()

129128addFreeVars freeVars tipe =

130129 case tipe of

131130 Can.TLambda arg result ->

@@ -158,6 +157,6 @@ addFreeVars freeVars tipe =

158157 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args

159158

160159

161−addFieldFreeVars :: Map.Map N.Name () -> Can.FieldType -> Map.Map N.Name ()

160+addFieldFreeVars :: Map.Map Name.Name () -> Can.FieldType -> Map.Map Name.Name ()

162161addFieldFreeVars freeVars (Can.FieldType _ tipe) =

163162 addFreeVars freeVars tipe

compiler/src/Compile.hs+41−76

@@ -1,30 +1,26 @@

11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

22module Compile

3− ( DocsFlag(..)

3+ ( Artifacts(..)

44 , compile

5− , Artifacts(..)

65 )

76 where

87

98

10−import qualified Data.ByteString as BS

119import qualified Data.Map as Map

10+import 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

15−import qualified AST.Module.Name as ModuleName

1615import qualified Canonicalize.Module as Canonicalize

17−import qualified Elm.Docs as Docs

1816import qualified Elm.Interface as I

19−import qualified Elm.Name as N

17+import qualified Elm.ModuleName as ModuleName

2018import qualified Elm.Package as Pkg

2119import qualified Nitpick.PatternMatches as PatternMatches

2220import qualified Optimize.Module as Optimize

23−import qualified Parse.Parse as Parse

24−import qualified Reporting.Error as Error

25−import qualified Reporting.Render.Type.Localizer as L

26−import qualified Reporting.Result as Result

27−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

2824import qualified Type.Constrain.Module as Type

2925import qualified Type.Solve as Type

3026

@@ -35,93 +31,62 @@ import System.IO.Unsafe (unsafePerformIO)

3531-- COMPILE

3632

3733

38−type Result i a =

39− Result.Result i [Warning.Warning] Error.Error a

40−

41−

42−type ImportDict =

43− Map.Map N.Name ModuleName.Canonical

44−

45−

4634data Artifacts =

4735 Artifacts

48− { _elmi :: I.Interface

49− , _elmo :: Opt.Graph

50− , _docs :: Maybe Docs.Module

36+ { _modul :: Can.Module

37+ , _types :: Map.Map Name.Name Can.Annotation

38+ , _graph :: Opt.LocalGraph

5139 }

5240

5341

54−compile :: DocsFlag -> Pkg.Name -> ImportDict -> I.Interfaces -> BS.ByteString -> Result i Artifacts

55−compile flag pkg importDict interfaces source =

56− do

57− valid <- Result.mapError Error.Syntax $

58− Parse.program pkg source

59−

60− canonical <- Result.mapError Error.Canonicalize $

61− Canonicalize.canonicalize pkg importDict interfaces valid

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)

6249

63− let localizer = L.fromModule valid -- TODO should this be strict for GC?

6450

65− annotations <-

66− runTypeInference localizer canonical

6751

68− () <-

69− exhaustivenessCheck canonical

52+-- PHASES

7053

71− graph <- Result.mapError (Error.Main localizer) $

72− Optimize.optimize annotations canonical

7354

74− documentation <-

75− genarateDocs flag 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

7660

77− Result.ok $

78− Artifacts

79− { _elmi = I.fromModule annotations canonical

80− , _elmo = graph

81− , _docs = documentation

82− }

83−

84−

85−

86−-- TYPE INFERENCE

61+ Left errors ->

62+ Left $ E.BadNames errors

8763

8864

89−runTypeInference :: L.Localizer -> Can.Module -> Result i (Map.Map N.Name Can.Annotation)

90−runTypeInference localizer canonical =

65+typeCheck :: Src.Module -> Can.Module -> Either E.Error (Map.Map Name.Name Can.Annotation)

66+typeCheck modul canonical =

9167 case unsafePerformIO (Type.run =<< Type.constrain canonical) of

9268 Right annotations ->

93− Result.ok annotations

69+ Right annotations

9470

9571 Left errors ->

96− Result.throw (Error.Type localizer errors)

97−

72+ Left (E.BadTypes (Localizer.fromModule modul) errors)

9873

9974

100−-- EXHAUSTIVENESS CHECK

101−

102−

103−exhaustivenessCheck :: Can.Module -> Result i ()

104−exhaustivenessCheck canonical =

75+nitpick :: Can.Module -> Either E.Error ()

76+nitpick canonical =

10577 case PatternMatches.check canonical of

106− Left errors ->

107− Result.throw (Error.Pattern errors)

108−

10978 Right () ->

110− Result.ok ()

111−

79+ Right ()

11280

113−

114−-- DOCUMENTATION

115−

116−

117−data DocsFlag = YesDocs | NoDocs

81+ Left errors ->

82+ Left (E.BadPatterns errors)

11883

11984

120−genarateDocs :: DocsFlag -> Can.Module -> Result.Result i w Error.Error (Maybe Docs.Module)

121−genarateDocs flag modul =

122− case flag of

123− NoDocs ->

124− Result.ok Nothing

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

12590

126− YesDocs ->

127− Just <$> Docs.fromModule modul

91+ Left errors ->

92+ Left (E.BadMains (Localizer.fromModule modul) errors)

compiler/src/Data/Bag.hs−11

@@ -108,14 +108,3 @@ fromList func list =

108108add :: (a -> b) -> Bag b -> a -> Bag b

109109add func bag value =

110110 Two (One (func value)) bag

111−

112−

113−

114−-- MONOID

115−

116−

117−instance Monoid (Bag a) where

118− {-# INLINE mempty #-}

119− mempty = Empty

120− {-# INLINE mappend #-}

121− mappend = Two

compiler/src/Data/Map/Utils.hsnew file+43

@@ -0,0 +1,43 @@

1+module Data.Map.Utils

2+ ( fromKeys

3+ , fromKeysA

4+ , fromValues

5+ , any

6+ )

7+ where

8+

9+

10+import Prelude hiding (any)

11+import qualified Data.Map as Map

12+import Data.Map.Internal (Map(..))

13+

14+

15+

16+-- FROM KEYS

17+

18+

19+fromKeys :: (Ord k) => (k -> v) -> [k] -> Map.Map k v

20+fromKeys toValue keys =

21+ Map.fromList $ map (\k -> (k, toValue k)) keys

22+

23+

24+fromKeysA :: (Applicative f, Ord k) => (k -> f v) -> [k] -> f (Map.Map k v)

25+fromKeysA toValue keys =

26+ Map.fromList <$> traverse (\k -> (,) k <$> toValue k) keys

27+

28+

29+fromValues :: (Ord k) => (v -> k) -> [v] -> Map.Map k v

30+fromValues toKey values =

31+ Map.fromList $ map (\v -> (toKey v, v)) values

32+

33+

34+

35+-- ANY

36+

37+

38+{-# INLINE any #-}

39+any :: (v -> Bool) -> Map.Map k v -> Bool

40+any isGood = go

41+ where

42+ go Tip = False

43+ go (Bin _ _ v l r) = isGood v || go l || go r

compiler/src/Data/Name.hsnew file+610

@@ -0,0 +1,610 @@

1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}

3+module Data.Name

4+ ( Name

5+ --

6+ , toChars

7+ , toElmString

8+ , toBuilder

9+ --

10+ , fromPtr

11+ , fromChars

12+ --

13+ , getKernel

14+ , hasDot

15+ , splitDots

16+ , isKernel

17+ , isNumberType

18+ , isComparableType

19+ , isAppendableType

20+ , isCompappendType

21+ , fromVarIndex

22+ , fromWords

23+ , fromManyNames

24+ , fromTypeVariable

25+ , fromTypeVariableScheme

26+ , sepBy

27+ --

28+ , int, float, bool, char, string

29+ , maybe, result, list, array, dict, tuple, jsArray

30+ , task, router, cmd, sub, platform, virtualDom

31+ , shader, debug, debugger, bitwise, basics

32+ , utils, negate, true, false, value

33+ , node, program, _main, _Main, dollar, identity

34+ , replModule, replValueToPrint

35+ )

36+ where

37+

38+

39+import Prelude hiding (length, maybe, negate)

40+import Control.Exception (assert)

41+import qualified Data.Binary as Binary

42+import qualified Data.ByteString.Builder.Internal as B

43+import qualified Data.Coerce as Coerce

44+import qualified Data.List as List

45+import qualified Data.String as Chars

46+import qualified Data.Utf8 as Utf8

47+import GHC.Exts

48+ ( Int(I#), Ptr

49+ , MutableByteArray#

50+ , isTrue#

51+ , newByteArray#

52+ , sizeofByteArray#

53+ , unsafeFreezeByteArray#

54+ )

55+import GHC.ST (ST(ST), runST)

56+import GHC.Prim

57+import GHC.Word (Word8(W8#))

58+

59+import qualified Elm.String as ES

60+

61+

62+

63+-- NAME

64+

65+

66+type Name =

67+ Utf8.Utf8 ELM_NAME

68+

69+

70+data ELM_NAME

71+

72+

73+

74+-- INSTANCES

75+

76+

77+instance Chars.IsString (Utf8.Utf8 ELM_NAME) where

78+ fromString = Utf8.fromChars

79+

80+instance Binary.Binary (Utf8.Utf8 ELM_NAME) where

81+ get = Utf8.getUnder256

82+ put = Utf8.putUnder256

83+

84+

85+

86+-- TO

87+

88+

89+toChars :: Name -> [Char]

90+toChars =

91+ Utf8.toChars

92+

93+

94+toElmString :: Name -> ES.String

95+toElmString =

96+ Coerce.coerce

97+

98+

99+{-# INLINE toBuilder #-}

100+toBuilder :: Name -> B.Builder

101+toBuilder =

102+ Utf8.toBuilder

103+

104+

105+

106+-- FROM

107+

108+

109+fromPtr :: Ptr Word8 -> Ptr Word8 -> Name

110+fromPtr =

111+ Utf8.fromPtr

112+

113+

114+fromChars :: [Char] -> Name

115+fromChars =

116+ Utf8.fromChars

117+

118+

119+

120+-- HAS DOT

121+

122+

123+hasDot :: Name -> Bool

124+hasDot name =

125+ Utf8.contains 0x2E {- . -} name

126+

127+

128+splitDots :: Name -> [Name]

129+splitDots name =

130+ Utf8.split 0x2E {- . -} name

131+

132+

133+

134+-- GET KERNEL

135+

136+

137+getKernel :: Name -> Name

138+getKernel name@(Utf8.Utf8 ba#) =

139+ assert (isKernel name)

140+ (

141+ runST

142+ (

143+ let

144+ !size# = sizeofByteArray# ba# -# 11#

145+ in

146+ ST $ \s ->

147+ case newByteArray# size# s of

148+ (# s, mba# #) ->

149+ case copyByteArray# ba# 11# mba# 0# size# s of

150+ s ->

151+ case unsafeFreezeByteArray# mba# s of

152+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

153+ )

154+ )

155+

156+

157+

158+-- STARTS WITH

159+

160+

161+isKernel :: Name -> Bool

162+isKernel = Utf8.startsWith prefix_kernel

163+

164+isNumberType :: Name -> Bool

165+isNumberType = Utf8.startsWith prefix_number

166+

167+isComparableType :: Name -> Bool

168+isComparableType = Utf8.startsWith prefix_comparable

169+

170+isAppendableType :: Name -> Bool

171+isAppendableType = Utf8.startsWith prefix_appendable

172+

173+isCompappendType :: Name -> Bool

174+isCompappendType = Utf8.startsWith prefix_compappend

175+

176+{-# NOINLINE prefix_kernel #-}

177+prefix_kernel :: Name

178+prefix_kernel = fromChars "Elm.Kernel."

179+

180+{-# NOINLINE prefix_number #-}

181+prefix_number :: Name

182+prefix_number = fromChars "number"

183+

184+{-# NOINLINE prefix_comparable #-}

185+prefix_comparable :: Name

186+prefix_comparable = fromChars "comparable"

187+

188+{-# NOINLINE prefix_appendable #-}

189+prefix_appendable :: Name

190+prefix_appendable = fromChars "appendable"

191+

192+{-# NOINLINE prefix_compappend #-}

193+prefix_compappend :: Name

194+prefix_compappend = fromChars "compappend"

195+

196+

197+

198+-- FROM VAR INDEX

199+

200+

201+fromVarIndex :: Int -> Name

202+fromVarIndex n =

203+ runST

204+ (

205+ do let !size = 2 + getIndexSize n

206+ mba <- newByteArray size

207+ writeWord8 mba 0 0x5F {- _ -}

208+ writeWord8 mba 1 0x76 {- v -}

209+ writeDigitsAtEnd mba size n

210+ freeze mba

211+ )

212+

213+

214+{-# INLINE getIndexSize #-}

215+getIndexSize :: Int -> Int

216+getIndexSize n

217+ | n < 10 = 1

218+ | n < 100 = 2

219+ | True = ceiling (logBase 10 (fromIntegral n + 1) :: Float)

220+

221+

222+

223+writeDigitsAtEnd :: MBA s -> Int -> Int -> ST s ()

224+writeDigitsAtEnd !mba !oldOffset !n =

225+ do let (q,r) = quotRem n 10

226+ let !newOffset = oldOffset - 1

227+ writeWord8 mba newOffset (0x30 + fromIntegral r)

228+ if q <= 0

229+ then return ()

230+ else writeDigitsAtEnd mba newOffset q

231+

232+

233+

234+-- FROM TYPE VARIABLE

235+

236+

237+fromTypeVariable :: Name -> Int -> Name

238+fromTypeVariable name@(Utf8.Utf8 ba#) index =

239+ if index <= 0 then

240+ name

241+ else

242+ let

243+ len# = sizeofByteArray# ba#

244+ end# = indexWord8Array# ba# (len# -# 1#)

245+ in

246+ if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then

247+ runST

248+ (

249+ do let !size = I# len# + 1 + getIndexSize index

250+ mba <- newByteArray size

251+ copyToMBA name mba

252+ writeWord8 mba (I# len#) 0x5F {- _ -}

253+ writeDigitsAtEnd mba size index

254+ freeze mba

255+ )

256+ else

257+ runST

258+ (

259+ do let !size = I# len# + getIndexSize index

260+ mba <- newByteArray size

261+ copyToMBA name mba

262+ writeDigitsAtEnd mba size index

263+ freeze mba

264+ )

265+

266+

267+

268+-- FROM TYPE VARIABLE SCHEME

269+

270+

271+fromTypeVariableScheme :: Int -> Name

272+fromTypeVariableScheme scheme =

273+ runST

274+ (

275+ if scheme < 26 then

276+ do mba <- newByteArray 1

277+ writeWord8 mba 0 (0x61 + fromIntegral scheme)

278+ freeze mba

279+ else

280+ do let (extra, letter) = quotRem scheme 26

281+ let !size = 1 + getIndexSize extra

282+ mba <- newByteArray size

283+ writeWord8 mba 0 (0x61 + fromIntegral letter)

284+ writeDigitsAtEnd mba size extra

285+ freeze mba

286+ )

287+

288+

289+

290+-- FROM MANY NAMES

291+--

292+-- Creating a unique name by combining all the subnames can create names

293+-- longer than 256 bytes relatively easily. So instead, the first given name

294+-- (e.g. foo) is prefixed chars that are valid in JS but not Elm (e.g. _M$foo)

295+--

296+-- This should be a unique name since 0.19 disallows shadowing. It would not

297+-- be possible for multiple top-level cycles to include values with the same

298+-- name, so the important thing is to make the cycle name distinct from the

299+-- normal name. Same logic for destructuring patterns like (x,y)

300+

301+

302+fromManyNames :: [Name] -> Name

303+fromManyNames names =

304+ case names of

305+ [] ->

306+ blank

307+ -- NOTE: this case is needed for (let _ = Debug.log "x" x in ...)

308+ -- but maybe unused patterns should be stripped out instead

309+

310+ Utf8.Utf8 ba# : _ ->

311+ let

312+ len# = sizeofByteArray# ba#

313+ in

314+ runST

315+ (

316+ ST $ \s ->

317+ case newByteArray# (len# +# 3#) s of

318+ (# s, mba# #) ->

319+ case writeWord8Array# mba# 0# 0x5F## {-_-} s of

320+ s ->

321+ case writeWord8Array# mba# 1# 0x4D## {-M-} s of

322+ s ->

323+ case writeWord8Array# mba# 2# 0x24## {-$-} s of

324+ s ->

325+ case copyByteArray# ba# 0# mba# 3# len# s of

326+ s ->

327+ case unsafeFreezeByteArray# mba# s of

328+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

329+ )

330+

331+

332+{-# NOINLINE blank #-}

333+blank :: Name

334+blank =

335+ fromWords [0x5F,0x4D,0x24] {-_M$-}

336+

337+

338+

339+-- FROM WORDS

340+

341+

342+fromWords :: [Word8] -> Name

343+fromWords words =

344+ runST

345+ (

346+ do mba <- newByteArray (List.length words)

347+ writeWords mba 0 words

348+ freeze mba

349+ )

350+

351+

352+writeWords :: MBA s -> Int -> [Word8] -> ST s ()

353+writeWords !mba !i words =

354+ case words of

355+ [] ->

356+ return ()

357+

358+ w:ws ->

359+ do writeWord8 mba i w

360+ writeWords mba (i+1) ws

361+

362+

363+

364+-- SEP BY

365+

366+

367+sepBy :: Word8 -> Name -> Name -> Name

368+sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =

369+ let

370+ !len1# = sizeofByteArray# ba1#

371+ !len2# = sizeofByteArray# ba2#

372+ in

373+ runST

374+ (

375+ ST $ \s ->

376+ case newByteArray# (len1# +# len2# +# 1#) s of

377+ (# s, mba# #) ->

378+ case copyByteArray# ba1# 0# mba# 0# len1# s of

379+ s ->

380+ case writeWord8Array# mba# len1# sep# s of

381+ s ->

382+ case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of

383+ s ->

384+ case unsafeFreezeByteArray# mba# s of

385+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

386+ )

387+

388+

389+

390+-- PRIMITIVES

391+

392+

393+data MBA s =

394+ MBA# (MutableByteArray# s)

395+

396+

397+{-# INLINE newByteArray #-}

398+newByteArray :: Int -> ST s (MBA s)

399+newByteArray (I# len#) =

400+ ST $ \s ->

401+ case newByteArray# len# s of

402+ (# s, mba# #) -> (# s, MBA# mba# #)

403+

404+

405+{-# INLINE freeze #-}

406+freeze :: MBA s -> ST s Name

407+freeze (MBA# mba#) =

408+ ST $ \s ->

409+ case unsafeFreezeByteArray# mba# s of

410+ (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)

411+

412+

413+{-# INLINE writeWord8 #-}

414+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()

415+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

416+ ST $ \s ->

417+ case writeWord8Array# mba# offset# w# s of

418+ s -> (# s, () #)

419+

420+

421+{-# INLINE copyToMBA #-}

422+copyToMBA :: Name -> MBA s -> ST s ()

423+copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =

424+ ST $ \s ->

425+ case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of

426+ s -> (# s, () #)

427+

428+

429+

430+-- COMMON NAMES

431+

432+

433+{-# NOINLINE int #-}

434+int :: Name

435+int = fromChars "Int"

436+

437+

438+{-# NOINLINE float #-}

439+float :: Name

440+float = fromChars "Float"

441+

442+

443+{-# NOINLINE bool #-}

444+bool :: Name

445+bool = fromChars "Bool"

446+

447+

448+{-# NOINLINE char #-}

449+char :: Name

450+char = fromChars "Char"

451+

452+

453+{-# NOINLINE string #-}

454+string :: Name

455+string = fromChars "String"

456+

457+

458+{-# NOINLINE maybe #-}

459+maybe :: Name

460+maybe = fromChars "Maybe"

461+

462+

463+{-# NOINLINE result #-}

464+result :: Name

465+result = fromChars "Result"

466+

467+

468+{-# NOINLINE list #-}

469+list :: Name

470+list = fromChars "List"

471+

472+

473+{-# NOINLINE array #-}

474+array :: Name

475+array = fromChars "Array"

476+

477+

478+{-# NOINLINE dict #-}

479+dict :: Name

480+dict = fromChars "Dict"

481+

482+

483+{-# NOINLINE tuple #-}

484+tuple :: Name

485+tuple = fromChars "Tuple"

486+

487+

488+{-# NOINLINE jsArray #-}

489+jsArray :: Name

490+jsArray = fromChars "JsArray"

491+

492+

493+{-# NOINLINE task #-}

494+task :: Name

495+task = fromChars "Task"

496+

497+

498+{-# NOINLINE router #-}

499+router :: Name

500+router = fromChars "Router"

501+

502+

503+{-# NOINLINE cmd #-}

504+cmd :: Name

505+cmd = fromChars "Cmd"

506+

507+

508+{-# NOINLINE sub #-}

509+sub :: Name

510+sub = fromChars "Sub"

511+

512+

513+{-# NOINLINE platform #-}

514+platform :: Name

515+platform = fromChars "Platform"

516+

517+

518+{-# NOINLINE virtualDom #-}

519+virtualDom :: Name

520+virtualDom = fromChars "VirtualDom"

521+

522+

523+{-# NOINLINE shader #-}

524+shader :: Name

525+shader = fromChars "Shader"

526+

527+

528+{-# NOINLINE debug #-}

529+debug :: Name

530+debug = fromChars "Debug"

531+

532+

533+{-# NOINLINE debugger #-}

534+debugger :: Name

535+debugger = fromChars "Debugger"

536+

537+

538+{-# NOINLINE bitwise #-}

539+bitwise :: Name

540+bitwise = fromChars "Bitwise"

541+

542+

543+{-# NOINLINE basics #-}

544+basics :: Name

545+basics = fromChars "Basics"

546+

547+

548+{-# NOINLINE utils #-}

549+utils :: Name

550+utils = fromChars "Utils"

551+

552+

553+{-# NOINLINE negate #-}

554+negate :: Name

555+negate = fromChars "negate"

556+

557+

558+{-# NOINLINE true #-}

559+true :: Name

560+true = fromChars "True"

561+

562+

563+{-# NOINLINE false #-}

564+false :: Name

565+false = fromChars "False"

566+

567+

568+{-# NOINLINE value #-}

569+value :: Name

570+value = fromChars "Value"

571+

572+

573+{-# NOINLINE node #-}

574+node :: Name

575+node = fromChars "Node"

576+

577+

578+{-# NOINLINE program #-}

579+program :: Name

580+program = fromChars "Program"

581+

582+

583+{-# NOINLINE _main #-}

584+_main :: Name

585+_main = fromChars "main"

586+

587+

588+{-# NOINLINE _Main #-}

589+_Main :: Name

590+_Main = fromChars "Main"

591+

592+

593+{-# NOINLINE dollar #-}

594+dollar :: Name

595+dollar = fromChars "$"

596+

597+

598+{-# NOINLINE identity #-}

599+identity :: Name

600+identity = fromChars "identity"

601+

602+

603+{-# NOINLINE replModule #-}

604+replModule :: Name

605+replModule = fromChars "Elm_Repl"

606+

607+

608+{-# NOINLINE replValueToPrint #-}

609+replValueToPrint :: Name

610+replValueToPrint = fromChars "repl_input_value_"

compiler/src/Data/NonEmptyList.hsnew file+78

@@ -0,0 +1,78 @@

1+module Data.NonEmptyList

2+ ( List(..)

3+ , singleton

4+ , toList

5+ , sortBy

6+ )

7+ where

8+

9+

10+import Control.Monad (liftM2)

11+import Data.Binary (Binary, get, put)

12+import qualified Data.List as List

13+

14+

15+

16+-- LIST

17+

18+

19+data List a =

20+ List a [a]

21+

22+

23+singleton :: a -> List a

24+singleton a =

25+ List a []

26+

27+

28+toList :: List a -> [a]

29+toList (List x xs) =

30+ x:xs

31+

32+

33+

34+-- INSTANCES

35+

36+

37+instance Functor List where

38+ fmap func (List x xs) = List (func x) (map func xs)

39+

40+

41+instance Traversable List where

42+ traverse func (List x xs) = List <$> func x <*> traverse func xs

43+

44+

45+instance Foldable List where

46+ foldr step state (List x xs) = step x (foldr step state xs)

47+ foldl step state (List x xs) = foldl step (step state x) xs

48+ foldl1 step (List x xs) = foldl step x xs

49+

50+

51+

52+-- SORT BY

53+

54+

55+sortBy :: (Ord b) => (a -> b) -> List a -> List a

56+sortBy toRank (List x xs) =

57+ let

58+ comparison a b =

59+ compare (toRank a) (toRank b)

60+ in

61+ case List.sortBy comparison xs of

62+ [] ->

63+ List x []

64+

65+ y:ys ->

66+ case comparison x y of

67+ LT -> List x (y:ys)

68+ EQ -> List x (y:ys)

69+ GT -> List y (List.insertBy comparison x ys)

70+

71+

72+

73+-- BINARY

74+

75+

76+instance (Binary a) => Binary (List a) where

77+ put (List x xs) = put x >> put xs

78+ get = liftM2 List get get

compiler/src/Data/OneOrMore.hs+51−16

@@ -3,8 +3,9 @@ module Data.OneOrMore

33 ( OneOrMore(..)

44 , one

55 , more

6− , toList

76 , map

7+ , destruct

8+ , getFirstTwo

89 )

910 where

1011

@@ -32,33 +33,67 @@ more =

3233

3334

3435

35−-- TO LIST

36+-- MAP

37+

38+

39+map :: (a -> b) -> OneOrMore a -> OneOrMore b

40+map func oneOrMore =

41+ case oneOrMore of

42+ One value ->

43+ One (func value)

44+

45+ More left right ->

46+ More (map func left) (map func right)

47+

48+

49+

50+-- DESTRUCT

51+

52+

53+destruct :: (a -> [a] -> b) -> OneOrMore a -> b

54+destruct func oneOrMore =

55+ destructLeft func oneOrMore []

3656

3757

38−toList :: OneOrMore a -> [a]

39−toList oneOrMore =

40− toListHelp oneOrMore []

58+destructLeft :: (a -> [a] -> b) -> OneOrMore a -> [a] -> b

59+destructLeft func oneOrMore xs =

60+ case oneOrMore of

61+ One x ->

62+ func x xs

63+

64+ More a b ->

65+ destructLeft func a (destructRight b xs)

4166

4267

43−toListHelp :: OneOrMore a -> [a] -> [a]

44−toListHelp oneOrMore list =

68+destructRight :: OneOrMore a -> [a] -> [a]

69+destructRight oneOrMore xs =

4570 case oneOrMore of

4671 One x ->

47− x : list

72+ x : xs

4873

4974 More a b ->

50− toListHelp a (toListHelp b list)

75+ destructRight a (destructRight b xs)

5176

5277

5378

54−-- MAP

79+-- GET FIRST TWO

5580

5681

57−map :: (a -> b) -> OneOrMore a -> OneOrMore b

58−map func oneOrMore =

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 =

5994 case oneOrMore of

60− One value ->

61− One (func value)

95+ One x ->

96+ x

6297

63− More left right ->

64− More (map func left) (map func right)

98+ More left _ ->

99+ getFirstOne left

compiler/src/Data/Utf8.hsnew file+618

@@ -0,0 +1,618 @@

1+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2+{-# LANGUAGE BangPatterns, FlexibleInstances, MagicHash, UnboxedTuples #-}

3+module Data.Utf8

4+ ( Utf8(..)

5+ , isEmpty

6+ , empty

7+ , size

8+ , contains

9+ , startsWith

10+ , startsWithChar

11+ , endsWithWord8

12+ , split

13+ , join

14+ --

15+ , getUnder256

16+ , putUnder256

17+ --

18+ , getVeryLong

19+ , putVeryLong

20+ --

21+ , toChars

22+ , toBuilder

23+ , toEscapedBuilder

24+ --

25+ , fromPtr

26+ , fromSnippet

27+ , fromChars

28+ --

29+ , MBA

30+ , newByteArray

31+ , copyFromPtr

32+ , writeWord8

33+ , freeze

34+ )

35+ where

36+

37+

38+import Prelude hiding (String, all, any, concat)

39+import Data.Binary (Get, get, getWord8, Put, put, putWord8)

40+import Data.Binary.Put (putBuilder)

41+import Data.Binary.Get.Internal (readN)

42+import Data.Bits ((.&.), shiftR)

43+import qualified Data.ByteString.Internal as B

44+import qualified Data.ByteString.Builder.Internal as B

45+import qualified Data.Char as Char

46+import qualified Data.List as List

47+import Foreign.ForeignPtr (touchForeignPtr)

48+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

49+import Foreign.Ptr (minusPtr, plusPtr)

50+import GHC.Exts

51+ ( Int(I#), Ptr(Ptr), Char(C#)

52+ , RealWorld

53+ , ByteArray#, MutableByteArray#

54+ , isTrue#

55+ , newByteArray#

56+ , unsafeFreezeByteArray#

57+ , sizeofByteArray#

58+ , copyByteArray#

59+ , copyAddrToByteArray#

60+ , copyByteArrayToAddr#

61+ , writeWord8Array#

62+ )

63+import GHC.IO

64+import GHC.ST (ST(ST), runST)

65+import GHC.Prim

66+import GHC.Word (Word8(W8#))

67+

68+import qualified Parse.Primitives as P

69+

70+

71+

72+-- UTF-8

73+

74+

75+data Utf8 tipe =

76+ Utf8 ByteArray#

77+

78+

79+

80+-- EMPTY

81+

82+

83+{-# NOINLINE empty #-}

84+empty :: Utf8 t

85+empty =

86+ runST (freeze =<< newByteArray 0)

87+

88+

89+isEmpty :: Utf8 t -> Bool

90+isEmpty (Utf8 ba#) =

91+ isTrue# (sizeofByteArray# ba# ==# 0#)

92+

93+

94+

95+-- SIZE

96+

97+

98+size :: Utf8 t -> Int

99+size (Utf8 ba#) =

100+ I# (sizeofByteArray# ba#)

101+

102+

103+

104+-- CONTAINS

105+

106+

107+contains :: Word8 -> Utf8 t -> Bool

108+contains (W8# word#) (Utf8 ba#) =

109+ containsHelp word# ba# 0# (sizeofByteArray# ba#)

110+

111+

112+containsHelp :: Word# -> ByteArray# -> Int# -> Int# -> Bool

113+containsHelp word# ba# !offset# len# =

114+ if isTrue# (offset# <# len#) then

115+ if isTrue# (eqWord# word# (indexWord8Array# ba# offset#))

116+ then True

117+ else containsHelp word# ba# (offset# +# 1#) len#

118+ else

119+ False

120+

121+

122+

123+-- STARTS WITH

124+

125+

126+{-# INLINE startsWith #-}

127+startsWith :: Utf8 t -> Utf8 t -> Bool

128+startsWith (Utf8 ba1#) (Utf8 ba2#) =

129+ let

130+ !len1# = sizeofByteArray# ba1#

131+ !len2# = sizeofByteArray# ba2#

132+ in

133+ isTrue# (len1# <=# len2#)

134+ &&

135+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)

136+

137+

138+

139+-- STARTS WITH CHAR

140+

141+

142+startsWithChar :: (Char -> Bool) -> Utf8 t -> Bool

143+startsWithChar isGood bytes@(Utf8 ba#) =

144+ if isEmpty bytes then

145+ False

146+ else

147+ let

148+ !w# = indexWord8Array# ba# 0#

149+ !char

150+ | isTrue# (ltWord# w# 0xC0##) = C# (chr# (word2Int# w#))

151+ | isTrue# (ltWord# w# 0xE0##) = chr2 ba# 0# w#

152+ | isTrue# (ltWord# w# 0xF0##) = chr3 ba# 0# w#

153+ | True = chr4 ba# 0# w#

154+ in

155+ isGood char

156+

157+

158+

159+-- ENDS WITH WORD

160+

161+

162+endsWithWord8 :: Word8 -> Utf8 t -> Bool

163+endsWithWord8 (W8# w#) (Utf8 ba#) =

164+ let len# = sizeofByteArray# ba# in

165+ isTrue# (len# ># 0#)

166+ &&

167+ isTrue# (eqWord# w# (indexWord8Array# ba# (len# -# 1#)))

168+

169+

170+

171+-- SPLIT

172+

173+

174+split :: Word8 -> Utf8 t -> [Utf8 t]

175+split (W8# divider#) str@(Utf8 ba#) =

176+ splitHelp str 0 (findDividers divider# ba# 0# (sizeofByteArray# ba#) [])

177+

178+

179+splitHelp :: Utf8 t -> Int -> [Int] -> [Utf8 t]

180+splitHelp str start offsets =

181+ case offsets of

182+ [] ->

183+ [ unsafeSlice str start (size str) ]

184+

185+ offset : offsets ->

186+ unsafeSlice str start offset : splitHelp str (offset + 1) offsets

187+

188+

189+findDividers :: Word# -> ByteArray# -> Int# -> Int# -> [Int] -> [Int]

190+findDividers divider# ba# !offset# len# revOffsets =

191+ if isTrue# (offset# <# len#) then

192+ findDividers divider# ba# (offset# +# 1#) len# $

193+ if isTrue# (eqWord# divider# (indexWord8Array# ba# offset#))

194+ then I# offset# : revOffsets

195+ else revOffsets

196+ else

197+ reverse revOffsets

198+

199+

200+unsafeSlice :: Utf8 t -> Int -> Int -> Utf8 t

201+unsafeSlice str start end =

202+ let !len = end - start in

203+ if len == 0 then

204+ empty

205+ else

206+ runST $

207+ do mba <- newByteArray len

208+ copy str start mba 0 len

209+ freeze mba

210+

211+

212+

213+-- JOIN

214+

215+

216+join :: Word8 -> [Utf8 t] -> Utf8 t

217+join sep strings =

218+ case strings of

219+ [] ->

220+ empty

221+

222+ str:strs ->

223+ runST $

224+ do let !len = List.foldl' (\w s -> w + 1 + size s) (size str) strs

225+ mba <- newByteArray len

226+ joinHelp sep mba 0 str strs

227+ freeze mba

228+

229+

230+joinHelp :: Word8 -> MBA s -> Int -> Utf8 t -> [Utf8 t] -> ST s ()

231+joinHelp sep mba offset str strings =

232+ let

233+ !len = size str

234+ in

235+ case strings of

236+ [] ->

237+ copy str 0 mba offset len

238+

239+ s:ss ->

240+ do copy str 0 mba offset len

241+ let !dotOffset = offset + len

242+ writeWord8 mba dotOffset sep

243+ let !newOffset = dotOffset + 1

244+ joinHelp sep mba newOffset s ss

245+

246+

247+

248+-- EQUAL

249+

250+

251+instance Eq (Utf8 t) where

252+ (==) (Utf8 ba1#) (Utf8 ba2#) =

253+ let

254+ !len1# = sizeofByteArray# ba1#

255+ !len2# = sizeofByteArray# ba2#

256+ in

257+ isTrue# (len1# ==# len2#)

258+ &&

259+ isTrue# (0# ==# compareByteArrays# ba1# 0# ba2# 0# len1#)

260+

261+

262+

263+-- COMPARE

264+--

265+-- TODO: is it fine to sort by length and only compare bytes on length ties?

266+--

267+

268+instance Ord (Utf8 t) where

269+ compare (Utf8 ba1#) (Utf8 ba2#) =

270+ let

271+ !len1# = sizeofByteArray# ba1#

272+ !len2# = sizeofByteArray# ba2#

273+ !len# = if isTrue# (len1# <# len2#) then len1# else len2#

274+ !cmp# = compareByteArrays# ba1# 0# ba2# 0# len#

275+ in

276+ case () of

277+ _ | isTrue# (cmp# <# 0#) -> LT

278+ | isTrue# (cmp# ># 0#) -> GT

279+ | isTrue# (len1# <# len2#) -> LT

280+ | isTrue# (len1# ># len2#) -> GT

281+ | True -> EQ

282+

283+

284+

285+-- FROM STRING

286+

287+

288+fromChars :: [Char] -> Utf8 t

289+fromChars chars =

290+ runST

291+ (

292+ do mba <- newByteArray (sum (map getWidth chars))

293+ writeChars mba 0 chars

294+ )

295+

296+

297+writeChars :: MBA s -> Int -> [Char] -> ST s (Utf8 t)

298+writeChars !mba !offset chars =

299+ case chars of

300+ [] ->

301+ freeze mba

302+

303+ char : chars

304+ | n < 0x80 ->

305+ do writeWord8 mba (offset ) (fromIntegral n)

306+ writeChars mba (offset + 1) chars

307+

308+ | n < 0x800 ->

309+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))

310+ writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))

311+ writeChars mba (offset + 2) chars

312+

313+ | n < 0x10000 ->

314+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))

315+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

316+ writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))

317+ writeChars mba (offset + 3) chars

318+

319+ | otherwise ->

320+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))

321+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))

322+ writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))

323+ writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))

324+ writeChars mba (offset + 4) chars

325+

326+ where

327+ n = Char.ord char

328+

329+

330+{-# INLINE getWidth #-}

331+getWidth :: Char -> Int

332+getWidth char

333+ | code < 0x80 = 1

334+ | code < 0x800 = 2

335+ | code < 0x10000 = 3

336+ | otherwise = 4

337+ where

338+ code = Char.ord char

339+

340+

341+

342+-- TO CHARS

343+

344+

345+toChars :: Utf8 t -> [Char]

346+toChars (Utf8 ba#) =

347+ toCharsHelp ba# 0# (sizeofByteArray# ba#)

348+

349+

350+toCharsHelp :: ByteArray# -> Int# -> Int# -> [Char]

351+toCharsHelp ba# offset# len# =

352+ if isTrue# (offset# >=# len#) then

353+ []

354+ else

355+ let

356+ !w# = indexWord8Array# ba# offset#

357+ !(# char, width# #)

358+ | isTrue# (ltWord# w# 0xC0##) = (# C# (chr# (word2Int# w#)), 1# #)

359+ | isTrue# (ltWord# w# 0xE0##) = (# chr2 ba# offset# w#, 2# #)

360+ | isTrue# (ltWord# w# 0xF0##) = (# chr3 ba# offset# w#, 3# #)

361+ | True = (# chr4 ba# offset# w#, 4# #)

362+

363+ !newOffset# = offset# +# width#

364+ in

365+ char : toCharsHelp ba# newOffset# len#

366+

367+

368+{-# INLINE chr2 #-}

369+chr2 :: ByteArray# -> Int# -> Word# -> Char

370+chr2 ba# offset# firstWord# =

371+ let

372+ !i1# = word2Int# firstWord#

373+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))

374+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#

375+ !c2# = i2# -# 0x80#

376+ in

377+ C# (chr# (c1# +# c2#))

378+

379+

380+{-# INLINE chr3 #-}

381+chr3 :: ByteArray# -> Int# -> Word# -> Char

382+chr3 ba# offset# firstWord# =

383+ let

384+ !i1# = word2Int# firstWord#

385+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))

386+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))

387+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#

388+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#

389+ !c3# = i3# -# 0x80#

390+ in

391+ C# (chr# (c1# +# c2# +# c3#))

392+

393+

394+{-# INLINE chr4 #-}

395+chr4 :: ByteArray# -> Int# -> Word# -> Char

396+chr4 ba# offset# firstWord# =

397+ let

398+ !i1# = word2Int# firstWord#

399+ !i2# = word2Int# (indexWord8Array# ba# (offset# +# 1#))

400+ !i3# = word2Int# (indexWord8Array# ba# (offset# +# 2#))

401+ !i4# = word2Int# (indexWord8Array# ba# (offset# +# 3#))

402+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#

403+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#

404+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#

405+ !c4# = i4# -# 0x80#

406+ in

407+ C# (chr# (c1# +# c2# +# c3# +# c4#))

408+

409+

410+

411+-- TO BUILDER

412+

413+

414+{-# INLINE toBuilder #-}

415+toBuilder :: Utf8 t -> B.Builder

416+toBuilder =

417+ \bytes -> B.builder (toBuilderHelp bytes)

418+

419+

420+{-# INLINE toBuilderHelp #-}

421+toBuilderHelp :: Utf8 t -> B.BuildStep a -> B.BuildStep a

422+toBuilderHelp !bytes@(Utf8 ba#) k =

423+ go 0 (I# (sizeofByteArray# ba#))

424+ where

425+ go !offset !end !(B.BufferRange bOffset bEnd) =

426+ let

427+ !bLen = minusPtr bEnd bOffset

428+ !len = end - offset

429+ in

430+ if len <= bLen then

431+ do copyToPtr bytes offset bOffset len

432+ let !br' = B.BufferRange (plusPtr bOffset len) bEnd

433+ k br'

434+ else

435+ do copyToPtr bytes offset bOffset bLen

436+ let !offset' = offset + bLen

437+ return $ B.bufferFull 1 bEnd (go offset' end)

438+

439+

440+

441+-- TO ESCAPED BUILDER

442+

443+

444+{-# INLINE toEscapedBuilder #-}

445+toEscapedBuilder :: Word8 -> Word8 -> Utf8 t -> B.Builder

446+toEscapedBuilder before after =

447+ \name -> B.builder (toEscapedBuilderHelp before after name)

448+

449+

450+{-# INLINE toEscapedBuilderHelp #-}

451+toEscapedBuilderHelp :: Word8 -> Word8 -> Utf8 t -> B.BuildStep a -> B.BuildStep a

452+toEscapedBuilderHelp before after !name@(Utf8 ba#) k =

453+ go 0 (I# (sizeofByteArray# ba#))

454+ where

455+ go !offset !len !(B.BufferRange bOffset bEnd) =

456+ let

457+ !bLen = minusPtr bEnd bOffset

458+ in

459+ if len <= bLen then

460+ do -- PERF test if writing word-by-word is faster

461+ copyToPtr name offset bOffset len

462+ escape before after bOffset name offset len 0

463+ let !newBufferRange = B.BufferRange (plusPtr bOffset len) bEnd

464+ k newBufferRange

465+ else

466+ do copyToPtr name offset bOffset bLen

467+ escape before after bOffset name offset bLen 0

468+ let !newOffset = offset + bLen

469+ let !newLength = len - bLen

470+ return $ B.bufferFull 1 bEnd (go newOffset newLength)

471+

472+

473+escape :: Word8 -> Word8 -> Ptr a -> Utf8 t -> Int -> Int -> Int -> IO ()

474+escape before@(W8# before#) after ptr name@(Utf8 ba#) offset@(I# offset#) len@(I# len#) i@(I# i#) =

475+ if isTrue# (i# <# len#) then

476+ if isTrue# (eqWord# before# (indexWord8Array# ba# (offset# +# i#)))

477+ then

478+ do writeWordToPtr ptr i after

479+ escape before after ptr name offset len (i + 1)

480+ else

481+ do escape before after ptr name offset len (i + 1)

482+

483+ else

484+ return ()

485+

486+

487+

488+-- FROM PTR

489+

490+

491+fromPtr :: Ptr Word8 -> Ptr Word8 -> Utf8 t

492+fromPtr pos end =

493+ unsafeDupablePerformIO (stToIO (

494+ do let !len = minusPtr end pos

495+ mba <- newByteArray len

496+ copyFromPtr pos mba 0 len

497+ freeze mba

498+ ))

499+

500+

501+

502+-- FROM SNIPPET

503+

504+

505+fromSnippet :: P.Snippet -> Utf8 t

506+fromSnippet (P.Snippet fptr off len _ _) =

507+ unsafeDupablePerformIO (stToIO (

508+ do mba <- newByteArray len

509+ let !pos = plusPtr (unsafeForeignPtrToPtr fptr) off

510+ copyFromPtr pos mba 0 len

511+ freeze mba

512+ ))

513+

514+

515+

516+-- BINARY

517+

518+

519+putUnder256 :: Utf8 t -> Put

520+putUnder256 bytes =

521+ do putWord8 (fromIntegral (size bytes))

522+ putBuilder (toBuilder bytes)

523+

524+

525+getUnder256 :: Get (Utf8 t)

526+getUnder256 =

527+ do word <- getWord8

528+ let !n = fromIntegral word

529+ readN n (copyFromByteString n)

530+

531+

532+putVeryLong :: Utf8 t -> Put

533+putVeryLong bytes =

534+ do put (size bytes)

535+ putBuilder (toBuilder bytes)

536+

537+

538+getVeryLong :: Get (Utf8 t)

539+getVeryLong =

540+ do n <- get

541+ if n > 0

542+ then readN n (copyFromByteString n)

543+ else return empty

544+

545+

546+

547+-- COPY FROM BYTESTRING

548+

549+

550+{-# INLINE copyFromByteString #-}

551+copyFromByteString :: Int -> B.ByteString -> Utf8 t

552+copyFromByteString len (B.PS fptr offset _) =

553+ unsafeDupablePerformIO

554+ (

555+ do mba <- stToIO (newByteArray len)

556+ stToIO (copyFromPtr (unsafeForeignPtrToPtr fptr `plusPtr` offset) mba 0 len)

557+ touchForeignPtr fptr

558+ stToIO (freeze mba)

559+ )

560+

561+

562+

563+-- PRIMITIVES

564+

565+

566+data MBA s =

567+ MBA# (MutableByteArray# s)

568+

569+

570+newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive

571+newByteArray (I# len#) =

572+ ST $ \s ->

573+ case newByteArray# len# s of

574+ (# s, mba# #) -> (# s, MBA# mba# #)

575+

576+

577+freeze :: MBA s -> ST s (Utf8 t)

578+freeze (MBA# mba#) =

579+ ST $ \s ->

580+ case unsafeFreezeByteArray# mba# s of

581+ (# s, ba# #) -> (# s, Utf8 ba# #)

582+

583+

584+copy :: Utf8 t -> Int -> MBA s -> Int -> Int -> ST s ()

585+copy (Utf8 ba#) (I# offset#) (MBA# mba#) (I# i#) (I# len#) =

586+ ST $ \s ->

587+ case copyByteArray# ba# offset# mba# i# len# s of

588+ s -> (# s, () #)

589+

590+

591+copyFromPtr :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld ()

592+copyFromPtr (Ptr src#) (MBA# mba#) (I# offset#) (I# len#) =

593+ ST $ \s ->

594+ case copyAddrToByteArray# src# mba# offset# len# s of

595+ s -> (# s, () #)

596+

597+

598+copyToPtr :: Utf8 t -> Int -> Ptr a -> Int -> IO ()

599+copyToPtr (Utf8 ba#) (I# offset#) (Ptr mba#) (I# len#) =

600+ IO $ \s ->

601+ case copyByteArrayToAddr# ba# offset# mba# len# s of

602+ s -> (# s, () #)

603+

604+

605+{-# INLINE writeWord8 #-}

606+writeWord8 :: MBA s -> Int -> Word8 -> ST s ()

607+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =

608+ ST $ \s ->

609+ case writeWord8Array# mba# offset# w# s of

610+ s -> (# s, () #)

611+

612+

613+{-# INLINE writeWordToPtr #-}

614+writeWordToPtr :: Ptr a -> Int -> Word8 -> IO ()

615+writeWordToPtr (Ptr addr#) (I# offset#) (W8# word#) =

616+ IO $ \s ->

617+ case writeWord8OffAddr# addr# offset# word# s of

618+ s -> (# s, () #)

compiler/src/Elm/Compiler.hsdeleted−97

This diff is too big to show here.

compiler/src/Elm/Compiler/Imports.hs+24−36

This diff is too big to show here.

compiler/src/Elm/Compiler/Module.hsdeleted−96

This diff is too big to show here.

compiler/src/Elm/Compiler/Objects.hsdeleted−108

This diff is too big to show here.

compiler/src/Elm/Compiler/Type.hs+40−42

This diff is too big to show here.

compiler/src/Elm/Compiler/Type/Extract.hs+79−27

This diff is too big to show here.

compiler/src/Elm/Compiler/Version.hsdeleted−27

This diff is too big to show here.

compiler/src/Elm/Constraint.hsnew file+260

This diff is too big to show here.

compiler/src/Elm/Docs.hs+243−189

This diff is too big to show here.

compiler/src/Elm/Float.hsnew file+51

This diff is too big to show here.

compiler/src/Elm/Header.hsdeleted−73

This diff is too big to show here.

compiler/src/Elm/Interface.hs+101−73

This diff is too big to show here.

compiler/src/Elm/Kernel.hs+268−151

This diff is too big to show here.

builder/src/Elm/Project/Licenses.hs → compiler/src/Elm/Licenses.hsrenamed+65−59

This diff is too big to show here.

compiler/src/Elm/Magnitude.hsnew file+24

This diff is too big to show here.

compiler/src/Elm/ModuleName.hsnew file+283

This diff is too big to show here.

compiler/src/Elm/Name.hsdeleted−337

This diff is too big to show here.

compiler/src/Elm/Package.hs+208−262

This diff is too big to show here.

compiler/src/Elm/String.hsnew file+133

This diff is too big to show here.

compiler/src/Elm/Version.hsnew file+196

This diff is too big to show here.

compiler/src/Generate/Html.hsnew file+54

This diff is too big to show here.

compiler/src/Generate/JavaScript.hs+234−187

This diff is too big to show here.

compiler/src/Generate/JavaScript/Builder.hs+209−219

This diff is too big to show here.

compiler/src/Generate/JavaScript/Expression.hs+227−212

This diff is too big to show here.

builder/src/Generate/Functions.hs → compiler/src/Generate/JavaScript/Functions.hsrenamed+6−3

This diff is too big to show here.

compiler/src/Generate/JavaScript/Mode.hsdeleted−106

This diff is too big to show here.

compiler/src/Generate/JavaScript/Name.hs+50−44

This diff is too big to show here.

compiler/src/Generate/Mode.hsnew file+63

This diff is too big to show here.

compiler/src/Json/Decode.hs+698−209

This diff is too big to show here.

compiler/src/Json/Decode/Error.hsdeleted−266

This diff is too big to show here.

compiler/src/Json/Decode/Internals.hsdeleted−368

This diff is too big to show here.

compiler/src/Json/Encode.hs+46−58

This diff is too big to show here.

compiler/src/Json/String.hsnew file+192

This diff is too big to show here.

builder/src/Generate/Nitpick.hs → compiler/src/Nitpick/Debug.hsrenamed+10−22

This diff is too big to show here.

compiler/src/Nitpick/PatternMatches.hs+33−30

This diff is too big to show here.

compiler/src/Optimize/Case.hs+2−2

This diff is too big to show here.

compiler/src/Optimize/DecisionTree.hs+29−8

This diff is too big to show here.

compiler/src/Optimize/Expression.hs+46−32

This diff is too big to show here.

compiler/src/Optimize/Module.hs+86−91

This diff is too big to show here.

compiler/src/Optimize/Names.hs+18−24

This diff is too big to show here.

compiler/src/Optimize/Port.hs+47−43

This diff is too big to show here.

compiler/src/Parse/Declaration.hs+200−131

This diff is too big to show here.

compiler/src/Parse/Expression.hs+375−363

This diff is too big to show here.

compiler/src/Parse/Keyword.hsnew file+265

This diff is too big to show here.

compiler/src/Parse/Module.hs+411−220

This diff is too big to show here.

compiler/src/Parse/Number.hsnew file+305

This diff is too big to show here.

compiler/src/Parse/Parse.hsdeleted−65

This diff is too big to show here.

compiler/src/Parse/Pattern.hs+165−159

This diff is too big to show here.

compiler/src/Parse/Primitives.hs+318−142

This diff is too big to show here.

compiler/src/Parse/Primitives/Internals.hsdeleted−251

This diff is too big to show here.

compiler/src/Parse/Primitives/Kernel.hsdeleted−116

This diff is too big to show here.

compiler/src/Parse/Primitives/Keyword.hsdeleted−235

This diff is too big to show here.

compiler/src/Parse/Primitives/Number.hsdeleted−297

This diff is too big to show here.

compiler/src/Parse/Primitives/Shader.hsdeleted−69

This diff is too big to show here.

compiler/src/Parse/Primitives/Symbol.hsdeleted−259

This diff is too big to show here.

compiler/src/Parse/Primitives/Utf8.hsdeleted−471

This diff is too big to show here.

compiler/src/Parse/Primitives/Variable.hsdeleted−376

This diff is too big to show here.

compiler/src/Parse/Primitives/Whitespace.hsdeleted−223

This diff is too big to show here.

compiler/src/Parse/Repl.hsdeleted−128

This diff is too big to show here.

compiler/src/Parse/Shader.hs+111−31

This diff is too big to show here.

compiler/src/Parse/Space.hsnew file+273

This diff is too big to show here.

compiler/src/Parse/String.hsnew file+343

This diff is too big to show here.

compiler/src/Parse/Symbol.hsnew file+79

This diff is too big to show here.

compiler/src/Parse/Type.hs+127−152

This diff is too big to show here.

compiler/src/Parse/Variable.hsnew file+387

This diff is too big to show here.

compiler/src/Reporting/Annotation.hs+67−24

This diff is too big to show here.

compiler/src/Reporting/Doc.hs+101−63

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+238−250

This diff is too big to show here.

compiler/src/Reporting/Error/Docs.hs+146−36

This diff is too big to show here.

compiler/src/Reporting/Error/Import.hsnew file+162

This diff is too big to show here.

compiler/src/Reporting/Error/Json.hsnew file+344

This diff is too big to show here.

compiler/src/Reporting/Error/Main.hs+13−12

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+5689−628

This diff is too big to show here.

compiler/src/Reporting/Error/Type.hs+158−143

This diff is too big to show here.

compiler/src/Reporting/Region.hsdeleted−93

This diff is too big to show here.

compiler/src/Reporting/Render/Code.hs+181−44

This diff is too big to show here.

compiler/src/Reporting/Render/Type.hs+5−6

This diff is too big to show here.

compiler/src/Reporting/Render/Type/Localizer.hs+29−42

This diff is too big to show here.

compiler/src/Reporting/Report.hs+2−65

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/Suggest.hs+17

This diff is too big to show here.

compiler/src/Reporting/Warning.hs+14−14

This diff is too big to show here.

compiler/src/Type/Constrain/Expression.hs+35−36

This diff is too big to show here.

compiler/src/Type/Constrain/Module.hs+21−22

This diff is too big to show here.

compiler/src/Type/Constrain/Pattern.hs+15−11

This diff is too big to show here.

compiler/src/Type/Error.hs+107−183

This diff is too big to show here.

compiler/src/Type/Instantiate.hs+4−4

This diff is too big to show here.

compiler/src/Type/Solve.hs+24−16

This diff is too big to show here.

compiler/src/Type/Type.hs+43−50

This diff is too big to show here.

compiler/src/Type/Unify.hs+24−22

This diff is too big to show here.

compiler/src/Validate.hsdeleted−334

This diff is too big to show here.

docs/elm.json/application.md+18−12

This diff is too big to show here.

docs/elm.json/package.md+5−5

This diff is too big to show here.

docs/repl.mddeleted−66

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.

docs/upgrade-instructions/0.19.0.mdnew file+164

This diff is too big to show here.

docs/upgrade-instructions/0.19.1.mdnew file+60

This diff is too big to show here.

upgrade-docs/earlier.md → docs/upgrade-instructions/earlier.mdrenamed

The content is the same.

elm.cabal+149−174

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.mdnew file+59

This diff is too big to show here.

installers/npm/README.md+30−23

This diff is too big to show here.

installers/npm/UPLOADING.mddeleted−8

This diff is too big to show here.

installers/npm/bin/elmnew file+54

This diff is too big to show here.

installers/npm/binaries/elmdeleted−1

This diff is too big to show here.

installers/npm/binaries/elm-makedeleted−1

This diff is too big to show here.

installers/npm/binaries/elm-packagedeleted−1

This diff is too big to show here.

installers/npm/binaries/elm-reactordeleted−1

This diff is too big to show here.

installers/npm/binaries/elm-repldeleted−1

This diff is too big to show here.

installers/npm/download.jsnew file+114

This diff is too big to show here.

installers/npm/install.js+2−32

This diff is too big to show here.

installers/npm/package.json+16−24

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.

ui/browser/assets/favicon.ico → reactor/assets/favicon.icorenamed

Binary file not shown.

ui/browser/assets/source-code-pro.ttf → reactor/assets/source-code-pro.ttfrenamed

Binary file not shown.

ui/browser/assets/source-sans-pro.ttf → reactor/assets/source-sans-pro.ttfrenamed

Binary file not shown.

ui/browser/assets/styles.css → reactor/assets/styles.cssrenamed+1−90

This diff is too big to show here.

ui/browser/check.py → reactor/check.pyrenamed

The content is the same.

reactor/elm.jsonnew file+31

This diff is too big to show here.

reactor/src/Deps.elmnew file+1210

This diff is too big to show here.

ui/browser/src/Errors.elm → reactor/src/Errors.elmrenamed+19−10

This diff is too big to show here.

ui/browser/src/Index.elm → reactor/src/Index.elmrenamed+52−31

This diff is too big to show here.

ui/browser/src/Index/Icon.elm → reactor/src/Index/Icon.elmrenamed

The content is the same.

ui/browser/src/Index/Navigator.elm → reactor/src/Index/Navigator.elmrenamed+1−1

This diff is too big to show here.

ui/browser/src/Index/Skeleton.elm → reactor/src/Index/Skeleton.elmrenamed

The content is the same.

ui/browser/src/NotFound.elm → reactor/src/NotFound.elmrenamed+2−2

This diff is too big to show here.

reactor/src/mock.txtnew file+33

This diff is too big to show here.

roadmap.mdnew file+29

This diff is too big to show here.

ui/terminal/src/Terminal/Args.hs → terminal/impl/Terminal.hsrenamed+42−41

This diff is too big to show here.

ui/terminal/src/Terminal/Args/Chomp.hs → terminal/impl/Terminal/Chomp.hsrenamed+4−5

This diff is too big to show here.

ui/terminal/src/Terminal/Args/Error.hs → terminal/impl/Terminal/Error.hsrenamed+32−19

This diff is too big to show here.

terminal/impl/Terminal/Helpers.hsnew file+148

This diff is too big to show here.

ui/terminal/src/Terminal/Args/Internal.hs → terminal/impl/Terminal/Internal.hsrenamed+8−8

This diff is too big to show here.

terminal/src/Bump.hsnew file+169

This diff is too big to show here.

ui/terminal/src/Develop.hs → terminal/src/Develop.hsrenamed+70−78

This diff is too big to show here.

ui/terminal/src/Develop/Generate/Help.hs → terminal/src/Develop/Generate/Help.hsrenamed+6−4

This diff is too big to show here.

terminal/src/Develop/Generate/Index.hsnew file+213

This diff is too big to show here.

ui/terminal/src/Develop/Socket.hs → terminal/src/Develop/Socket.hsrenamed

The content is the same.

ui/terminal/src/Develop/StaticFiles.hs → terminal/src/Develop/StaticFiles.hsrenamed+1−7

This diff is too big to show here.

terminal/src/Develop/StaticFiles/Build.hsnew file+73

This diff is too big to show here.

terminal/src/Diff.hsnew file+359

This diff is too big to show here.

terminal/src/Init.hsnew file+104

This diff is too big to show here.

terminal/src/Install.hsnew file+425

This diff is too big to show here.

ui/terminal/src/Main.hs → terminal/src/Main.hsrenamed+71−52

This diff is too big to show here.

terminal/src/Make.hsnew file+319

This diff is too big to show here.

terminal/src/Publish.hsnew file+540

This diff is too big to show here.

terminal/src/Repl.hsnew file+726

This diff is too big to show here.

ui/browser/assets/waiting.gifdeleted

Binary file not shown.

ui/browser/elm.jsondeleted−25

This diff is too big to show here.

ui/terminal/src/Bump.hsdeleted−19

This diff is too big to show here.

ui/terminal/src/Develop/Generate/Index.hsdeleted−134

This diff is too big to show here.

ui/terminal/src/Develop/StaticFiles/Build.hsdeleted−56

This diff is too big to show here.

ui/terminal/src/Diff.hsdeleted−17

This diff is too big to show here.

ui/terminal/src/Install.hsdeleted−17

This diff is too big to show here.

ui/terminal/src/Make.hsdeleted−94

This diff is too big to show here.

ui/terminal/src/Publish.hsdeleted−19

This diff is too big to show here.

ui/terminal/src/Repl.hsdeleted−401

This diff is too big to show here.

ui/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.