29fbe6b · elk · git.iko.soy

6 , Local(..)

7 , Foreign(..)

8 , verify

9+ , loadObjects

10+ , loadInterfaces

9 )

11 )

10 where

12 where

11

13

12

14

13import Control.Concurrent (forkIO)

15import Control.Concurrent (forkIO)

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

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

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

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

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

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

17−import Data.Foldable (traverse_)

18import qualified Data.Map as Map

19import qualified Data.Map as Map

20+import qualified Data.Map.Utils as Map

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

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

22+import qualified Data.Name as Name

20import qualified Data.OneOrMore as OneOrMore

23import qualified Data.OneOrMore as OneOrMore

21import qualified Data.Set as Set

24import qualified Data.Set as Set

22import qualified Data.Utf8 as Utf8

25import qualified Data.Utf8 as Utf8

31import qualified Deps.Website as Website

34import qualified Deps.Website as Website

32import qualified Elm.Constraint as Con

35import qualified Elm.Constraint as Con

33import qualified Elm.Interface as I

36import qualified Elm.Interface as I

37+import qualified Elm.Kernel as Kernel

34import qualified Elm.ModuleName as ModuleName

38import qualified Elm.ModuleName as ModuleName

35import qualified Elm.Outline as Outline

39import qualified Elm.Outline as Outline

36import qualified Elm.Package as Pkg

40import qualified Elm.Package as Pkg

39import qualified Http

43import qualified Http

40import qualified Json.Decode as D

44import qualified Json.Decode as D

41import qualified Parse.Module as Parse

45import qualified Parse.Module as Parse

46+import qualified Reporting

42import qualified Reporting.Exit as Exit

47import qualified Reporting.Exit as Exit

43import qualified Reporting.Task as Task

48import qualified Reporting.Task as Task

44import qualified Stuff

49import qualified Stuff

67 { _path :: FilePath

72 { _path :: FilePath

68 , _time :: File.Time

73 , _time :: File.Time

69 , _deps :: [ModuleName.Raw]

74 , _deps :: [ModuleName.Raw]

75+ , _main :: Bool

70 }

76 }

71

77

72

78

75

81

76

82

77

83

84+-- LOAD

85+

86+

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

88+loadObjects root _ =

89+ fork (File.readBinary (Stuff.objects root))

90+

91+

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

93+loadInterfaces root _ =

94+ fork (File.readBinary (Stuff.interfaces root))

95+

96+

97+type Interfaces =

98+ Map.Map ModuleName.Canonical I.DependencyInterface

99+

100+

101+

78-- VERIFY

102-- VERIFY

79

103

80

104

81−verify :: FilePath -> Task.Task Details

105+verify :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)

82−verify root =

106+verify style root =

83− do newTime <- Task.io $ File.getTime (root </> "elm.json")

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

84− maybeDetails <- Task.io $ File.readBinary (root </> Stuff.details)

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

85 case maybeDetails of

109 case maybeDetails of

86 Nothing ->

110 Nothing ->

87− rebuild root newTime

111+ verifyFromScratch style root newTime

88

112

89 Just details@(Details oldTime _ _ _) ->

113 Just details@(Details oldTime _ _ _) ->

90 if oldTime == newTime

114 if oldTime == newTime

91− then return details

115+ then return (Right details)

92− else rebuild root newTime

116+ else verifyFromScratch style root newTime

93

117

94

118

95

119

96−-- REBUILD

120+-- VERIFY FROM SCRATCH

97

121

98

122

99−rebuild :: FilePath -> File.Time -> Task.Task Details

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

100−rebuild root time =

124+verifyFromScratch style root time =

101− do (outline, info) <- rebuildHelp root

125+ Reporting.trackDetails style $ \key ->

126+ do result <- initEnv key root

102− case outline of

127+ case result of

103− Outline.Pkg pkg -> solvePkg info time pkg

128+ Left exit ->

104− Outline.App app -> solveApp info time app

129+ return (Left exit)

105

130

131+ Right (env, outline) ->

132+ case outline of

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

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

106

135

136+

107−data Info =

137+data Env =

138+ Env

139+ { _key :: Reporting.DKey

140+ , _root :: FilePath

108− Info Stuff.PackageCache Http.Manager Connection Registry.Registry

141+ , _cache :: Stuff.PackageCache

142+ , _manager :: Http.Manager

143+ , _connection :: Connection

144+ , _registry :: Registry.Registry

145+ }

109

146

110

147

111data Connection

148data Connection

113 | Offline

150 | Offline

114

151

115

152

116−rebuildHelp :: FilePath -> Task.Task (Outline.Outline, Info)

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

117−rebuildHelp root =

154+initEnv key root =

118− Task.eio id $

119 do cacheMVar <- fork Stuff.getPackageCache

155 do cacheMVar <- fork Stuff.getPackageCache

120 managerMVar <- fork Http.getManager

156 managerMVar <- fork Http.getManager

121 registryMVar <- fork (Registry.read =<< readMVar cacheMVar)

157 registryMVar <- fork (Registry.read =<< readMVar cacheMVar)

133 do eitherRegistry <- Registry.fetch manager cache

169 do eitherRegistry <- Registry.fetch manager cache

134 case eitherRegistry of

170 case eitherRegistry of

135 Right latestRegistry ->

171 Right latestRegistry ->

136− return $ Right (outline, Info cache manager Online latestRegistry)

172+ return $ Right (Env key root cache manager Online latestRegistry, outline)

137

173

138 Left problem ->

174 Left problem ->

139 return $ Left $ Exit.DetailsCannotGetRegistry problem

175 return $ Left $ Exit.DetailsCannotGetRegistry problem

142 do eitherRegistry <- Registry.update manager cache cachedRegistry

178 do eitherRegistry <- Registry.update manager cache cachedRegistry

143 case eitherRegistry of

179 case eitherRegistry of

144 Right latestRegistry ->

180 Right latestRegistry ->

145− return $ Right (outline, Info cache manager Online latestRegistry)

181+ return $ Right (Env key root cache manager Online latestRegistry, outline)

146

182

147 Left _ ->

183 Left _ ->

148− return $ Right (outline, Info cache manager Offline cachedRegistry)

184+ return $ Right (Env key root cache manager Offline cachedRegistry, outline)

185+

149

186

150

187

188+-- VERIFY PROJECT

151

189

152−-- SOLVE PKG

153

190

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

154

192

193+

155−solvePkg :: Info -> File.Time -> Outline.PkgOutline -> Task.Task Details

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

156−solvePkg info time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =

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

157 if Con.goodElm elm

196 if Con.goodElm elm

158 then

197 then

159− do solution <- solve info =<< union noDups direct testDirect

198+ do solution <- solve env =<< union noDups direct testDirect

160− foreigns <- verifyDependencies info solution direct

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

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

162− return $ Details time (ValidPkg outline vsns) Map.empty foreigns

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

163 else

201 else

164 Task.throw $ Exit.DetailsBadElmInPkg elm

202 Task.throw $ Exit.DetailsBadElmInPkg elm

165

203

166

204

167−

168−-- SOLVE APP

169−

170−

171−solveApp :: Info -> File.Time -> Outline.AppOutline -> Task.Task Details

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

172−solveApp info time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =

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

173 if elmVersion == V.compiler

207 if elmVersion == V.compiler

174 then

208 then

175 do stated <- checkAppDeps outline

209 do stated <- checkAppDeps outline

176− actual <- solve info (Map.map Con.exactly stated)

210+ actual <- solve env (Map.map Con.exactly stated)

177 if Map.size stated == Map.size actual

211 if Map.size stated == Map.size actual

178− then

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

179− do foreigns <- verifyDependencies info actual direct

213+ else Task.throw $ Exit.DetailsHandEditedDependencies

180− return $ Details time (ValidApp outline) Map.empty foreigns

181− else

182− Task.throw $ error "TODO solveApp"

183 else

214 else

184− Task.throw $ Exit.DetailsBadElmInApp elmVersion

215+ Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion

185

216

186

217

187−checkAppDeps :: Outline.AppOutline -> Task.Task (Map.Map Pkg.Name V.Version)

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

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

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

189 do x <- union allowEqualDups indirect testDirect

220 do x <- union allowEqualDups indirect testDirect

190 y <- union noDups direct testIndirect

221 y <- union noDups direct testIndirect

195-- SOLVE

226-- SOLVE

196

227

197

228

198−solve :: Info -> Map.Map Pkg.Name Con.Constraint -> Task.Task (Map.Map Pkg.Name Solver.Details)

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

199−solve (Info cache manager connection registry) constraints =

230+solve (Env _ _ cache manager connection registry) constraints =

200 Task.eio (error "TODO solve problem") $

231 Task.eio (error "TODO solve problem") $

201 case connection of

232 case connection of

202 Online -> Solver.online cache manager registry constraints

233 Online -> Solver.online cache manager registry constraints

207-- UNION

238-- UNION

208

239

209

240

210−union :: (Ord k) => (k -> v -> v -> Task.Task v) -> Map.Map k v -> Map.Map k v -> Task.Task (Map.Map k v)

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

211union tieBreaker deps1 deps2 =

242union tieBreaker deps1 deps2 =

212 Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2

243 Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2

213

244

214

245

215−noDups :: k -> v -> v -> Task.Task v

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

216noDups _ _ _ =

247noDups _ _ _ =

217 Task.throw Exit.DetailsHandEditedDependencies

248 Task.throw Exit.DetailsHandEditedDependencies

218

249

219

250

220−allowEqualDups :: (Eq v) => k -> v -> v -> Task.Task v

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

221allowEqualDups _ v1 v2 =

252allowEqualDups _ v1 v2 =

222 if v1 == v2

253 if v1 == v2

223 then return v1

254 then return v1

239-- VERIFY DEPENDENCIES

270-- VERIFY DEPENDENCIES

240

271

241

272

242−verifyDependencies :: Info -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task.Task (Map.Map ModuleName.Raw Foreign)

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

243−verifyDependencies info solution directDeps =

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

244− Task.eio (error "TODO verifyDependencies") $

275+ Task.eio id $

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

245− do mvar <- newEmptyMVar

277+ mvar <- newEmptyMVar

246− mvars <- Map.traverseWithKey (\k v -> fork (verifyDep info mvar solution k v)) solution

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

247 putMVar mvar mvars

279 putMVar mvar mvars

248− results <- traverse readMVar mvars

280+ deps <- traverse readMVar mvars

249− case sequence results of

281+ case sequence deps of

250− Left _ ->

282+ Left problem ->

251− return (Left (error "TODO one of the dependencies did not build"))

283+ error "TODO problem in verifyDependencies"

252

284

253 Right artifacts ->

285 Right artifacts ->

254 let

286 let

255− objs = Map.foldr gatherObjects Opt.empty artifacts

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

256− ifaces = Map.foldrWithKey (gatherInterfaces directDeps) Map.empty artifacts

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

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

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

290+ details = Details time outline Map.empty foreigns

258 in

291 in

259− do File.writeBinary Stuff.objects objs

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

260− File.writeBinary Stuff.interfaces ifaces

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

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

261− return (Right foreigns)

295+ return (Right details)

262

296

263

297

264−gatherObjects :: Artifacts -> Opt.Graph -> Opt.Graph

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

265−gatherObjects (Artifacts _ objs) graph =

299+addObjects (Artifacts _ objs) graph =

266− Opt.union objs graph

300+ Opt.addGlobalGraph objs graph

267

301

268

302

269−gatherInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Canonical I.DependencyInterface

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

270−gatherInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =

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

271− Map.union dependencyInterfaces $ Map.mapKeys (ModuleName.Canonical pkg) $

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

272 if Map.member pkg directDeps

306 if Map.member pkg directDeps

273 then ifaces

307 then ifaces

274 else Map.map I.privatize ifaces

308 else Map.map I.privatize ifaces

279 let

313 let

280 isPublic di =

314 isPublic di =

281 case di of

315 case di of

282− I.Public _ -> Just (OneOrMore.one pkg)

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

283− I.Private _ _ -> Nothing

317+ I.Private _ _ _ -> Nothing

284 in

318 in

285 Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)

319 Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)

286

320

292data Artifacts =

326data Artifacts =

293 Artifacts

327 Artifacts

294 { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface

328 { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface

295− , _objects :: Opt.Graph

329+ , _objects :: Opt.GlobalGraph

296 }

330 }

297

331

298

332

299−type Result =

333+type Dep =

300 Either Problem Artifacts

334 Either Problem Artifacts

301

335

302

336

306 | BadDependency

340 | BadDependency

307

341

308

342

309−verifyDep :: Info -> MVar (Map.Map Pkg.Name (MVar Result)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Result

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

310−verifyDep (Info cache manager _ _) resultsMVar solution name details@(Solver.Details version directDeps) =

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

311 let

345 let

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

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

313 in

347 in

314− do exists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")

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

315 if exists

349 if exists

316 then

350 then

351+ do Reporting.report key Reporting.DCached

317− do maybeCache <- File.readBinary (Stuff.package cache name version </> "artifacts.dat")

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

318 case maybeCache of

353 case maybeCache of

319 Nothing ->

354 Nothing ->

320− build cache resultsMVar name details (Set.singleton fingerprint)

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

321

356

322 Just (ArtifactCache fingerprints artifacts) ->

357 Just (ArtifactCache fingerprints artifacts) ->

323 if Set.member fingerprint fingerprints

358 if Set.member fingerprint fingerprints

324− then return (Right artifacts)

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

325− else build cache resultsMVar name details (Set.insert fingerprint fingerprints)

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

326 else

361 else

362+ do Reporting.report key Reporting.DRequested

327− do result <- downloadPackage cache manager name version

363+ result <- downloadPackage cache manager pkg vsn

328 case result of

364 case result of

365+ Left p ->

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

329− Left p -> return (Left (BadDownload p))

367+ return (Left (BadDownload p))

368+

369+ Right () ->

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

330− Right () -> build cache resultsMVar name details (Set.singleton fingerprint)

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

331

372

332

373

333

374

349-- BUILD

390-- BUILD

350

391

351

392

352−build :: Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Result)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Result

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

353−build cache resultsMVar name (Solver.Details version _) fingerprints =

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

354− do eitherOutline <- Outline.read (Stuff.package cache name version </> "elm.json")

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

355 case eitherOutline of

396 case eitherOutline of

356 Left _ ->

397 Left _ ->

398+ do Reporting.report key Reporting.DBroken

357− return (Left BadBuild)

399+ return (Left BadBuild)

358

400

359 Right (Outline.App _) ->

401 Right (Outline.App _) ->

402+ do Reporting.report key Reporting.DBroken

360− return (Left BadBuild)

403+ return (Left BadBuild)

361

404

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

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

363− do allResults <- readMVar resultsMVar

406+ do allDeps <- readMVar depsMVar

364− directResults <- traverse readMVar (Map.intersection allResults deps)

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

365− case sequence directResults of

408+ case sequence directDeps of

366 Left _ ->

409 Left _ ->

410+ do Reporting.report key Reporting.DBroken

367− return (Left BadDependency)

411+ return (Left BadDependency)

368

412

369 Right directArtifacts ->

413 Right directArtifacts ->

370− do mvar <- newMVar Map.empty

371− let src = Stuff.package cache name version </> "src"

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

372 let foreignDeps = gatherForeignInterfaces directArtifacts

415 let foreignDeps = gatherForeignInterfaces directArtifacts

373− let exposedDict = Map.fromList $ map (\n -> (n,())) (Outline.flattenExposed exposed)

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

374− traverse_ readMVar =<<

417+ mvar <- newEmptyMVar

375− Map.traverseWithKey (const . fork . buildModule foreignDeps mvar name src) exposedDict

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

419+ putMVar mvar mvars

420+ mapM_ readMVar mvars

376− result <- traverse readMVar =<< readMVar mvar

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

377− case Map.traverseMaybeWithKey checkStatus result of

422+ case sequence maybeStatuses of

378 Nothing ->

423 Nothing ->

424+ do Reporting.report key Reporting.DBroken

425+ return (Left BadBuild)

426+

427+ Just statuses ->

428+ do rmvar <- newEmptyMVar

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

430+ putMVar rmvar rmvars

431+ maybeResults <- traverse readMVar rmvars

432+ case sequence maybeResults of

433+ Nothing ->

434+ do Reporting.report key Reporting.DBroken

379− return (Left BadBuild)

435+ return (Left BadBuild)

436+

437+ Just results ->

438+ let

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

440+ ifaces = gatherInterfaces exposedDict results

441+ objects = gatherObjects results

442+ artifacts = Artifacts ifaces objects

443+ in

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

445+ Reporting.report key Reporting.DBuilt

446+ return (Right artifacts)

447+

380

448

381− Just artifactsDict ->

382− let

383− path = Stuff.package cache name version </> "artifacts.dat"

384− ifaces = gatherPackageInterfaces exposedDict artifactsDict

385− objects = Map.foldr (Opt.union . snd) Opt.empty artifactsDict

386− artifacts = Artifacts ifaces objects

387− in

388− do File.writeBinary path (ArtifactCache fingerprints artifacts)

389− return (Right artifacts)

390

449

450+-- GATHER

391

451

392−checkStatus :: ModuleName.Raw -> Status -> Maybe (Maybe (I.Interface, Opt.Graph))

452+

393−checkStatus _ status =

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

454+gatherObjects results =

455+ Map.foldrWithKey addLocalGraph Opt.empty results

456+

457+

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

459+addLocalGraph name status graph =

394 case status of

460 case status of

395− SFailure -> Nothing

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

396− SLocal i g -> Just (Just (i,g))

462+ RForeign _ -> graph

397− SForeign _ -> Just Nothing

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

464+ RKernelForeign -> graph

398

465

399

466

400−gatherPackageInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw (I.Interface, Opt.Graph) -> Map.Map ModuleName.Raw I.DependencyInterface

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

401−gatherPackageInterfaces exposed artifacts =

468+gatherInterfaces exposed artifacts =

402− Map.merge onLeft onRight onBoth exposed artifacts

469+ let

403− where

404− onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherPackageInterfaces")

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

405− onRight = Map.mapMissing (\_ (i,_) -> I.private i)

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

406− onBoth = Map.zipWithMatched (\_ () (i,_) -> I.public i)

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

473+ in

474+ Map.merge onLeft onRight onBoth exposed artifacts

475+

476+

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

478+toLocalInterface func result =

479+ case result of

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

481+ RForeign _ -> Nothing

482+ RKernelLocal _ -> Nothing

483+ RKernelForeign -> Nothing

407

484

408

485

409

486

410−-- FOREIGN INTERFACES

487+-- GATHER FOREIGN INTERFACES

411

488

412

489

413data ForeignInterface

490data ForeignInterface

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

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

434 isPublic di =

511 isPublic di =

435 case di of

512 case di of

436− I.Public iface -> Just (OneOrMore.one iface)

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

437− I.Private _ _ -> Nothing

514+ I.Private _ _ _ -> Nothing

438

515

439

516

440

517

441−-- BUILD MODULE

518+-- CRAWL

442

519

443

520

444type StatusDict =

521type StatusDict =

445− Map.Map ModuleName.Raw (MVar Status)

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

446

523

447

524

448data Status

525data Status

449− = SLocal !I.Interface !Opt.Graph

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

450 | SForeign I.Interface

527 | SForeign I.Interface

451− | SFailure

528+ | SKernelLocal [Kernel.Chunk]

529+ | SKernelForeign

452

530

453

531

454−buildModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO Status

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

455−buildModule foreignDeps mvar pkg src name =

533+crawlModule foreignDeps mvar pkg src name =

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

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

457 exists <- File.exists path

535 exists <- File.exists path

458 case Map.lookup name foreignDeps of

536 case Map.lookup name foreignDeps of

459 Just ForeignAmbiguous ->

537 Just ForeignAmbiguous ->

460− return SFailure

538+ return Nothing

461

539

462 Just (ForeignSpecific iface) ->

540 Just (ForeignSpecific iface) ->

463 if exists

541 if exists

464− then return SFailure

542+ then return Nothing

465− else return (SForeign iface)

543+ else return (Just (SForeign iface))

466

544

467 Nothing ->

545 Nothing ->

468− if not exists

546+ if exists then

469− then return SFailure

547+ crawlFile foreignDeps mvar pkg src name path

548+

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

550+ crawlKernel foreignDeps mvar pkg src name

551+

470 else

552 else

553+ return Nothing

554+

555+

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

557+crawlFile foreignDeps mvar pkg src name path =

471− do result <- Parse.fromFile pkg path

558+ do result <- Parse.fromFile pkg path

472− case result of

559+ case result of

473− Right modul@(Src.Module (Just actualName) _ deps _ _ _ _ _) | name == actualName ->

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

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

562+ return (Just (SLocal deps modul))

563+

564+ _ ->

565+ return Nothing

566+

567+

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

569+crawlImports foreignDeps mvar pkg src imports =

474− do statusDict <- takeMVar mvar

570+ do statusDict <- takeMVar mvar

475− let depsDict = Map.fromList $ map (\i -> (Src.getImport i, ())) deps

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

476− let newsDict = Map.difference depsDict statusDict

572+ let news = Map.difference deps statusDict

477− statusMVars <- Map.traverseWithKey (const . fork . buildModule foreignDeps mvar pkg src) newsDict

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

478− putMVar mvar (Map.union statusMVars statusDict)

574+ putMVar mvar (Map.union mvars statusDict)

479− statuses <- traverse readMVar statusMVars

575+ mapM_ readMVar mvars

480− case traverse getInterface statuses of

576+ return deps

577+

578+

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

580+crawlKernel foreignDeps mvar pkg src name =

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

582+ exists <- File.exists path

583+ if exists

584+ then

585+ do maybeContent <- Kernel.fromFile pkg (Map.mapMaybe getDepHome foreignDeps) path

586+ case maybeContent of

481− Nothing ->

587+ Nothing ->

482− return SFailure

588+ return Nothing

483−

589+

484− Just imports ->

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

485− case Compile.compile pkg imports modul of

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

486− (_, Right (Compile.Artifacts canonical annotations objects)) ->

592+ return (Just (SKernelLocal chunks))

487− return (SLocal (I.fromModule pkg canonical annotations) objects)

593+ else

488−

594+ return (Just SKernelForeign)

489− (_, Left _) ->

595+

490− return SFailure

596+

491−

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

492− _ ->

598+getDepHome fi =

493− return SFailure

599+ case fi of

494−

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

495−

601+ ForeignAmbiguous -> Nothing

496−getInterface :: Status -> Maybe I.Interface

602+

497−getInterface status =

603+

604+

605+-- COMPILE

606+

607+

608+data Result

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

610+ | RForeign I.Interface

611+ | RKernelLocal [Kernel.Chunk]

612+ | RKernelForeign

613+

614+

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

616+compile pkg mvar status =

498 case status of

617 case status of

499− SLocal iface _ -> Just iface

618+ SLocal deps modul ->

619+ do resultsDict <- readMVar mvar

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

621+ case sequence maybeResults of

622+ Nothing ->

623+ return Nothing

624+

625+ Just results ->

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

627+ Left _ ->

628+ return Nothing

629+

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

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

632+

500− SForeign iface -> Just iface

633+ SForeign iface ->

501− SFailure -> Nothing

634+ return (Just (RForeign iface))

635+

636+ SKernelLocal chunks ->

637+ return (Just (RKernelLocal chunks))

638+

639+ SKernelForeign ->

640+ return (Just RKernelForeign)

641+

642+

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

644+getInterface result =

645+ case result of

646+ RLocal iface _ -> Just iface

647+ RForeign iface -> Just iface

648+ RKernelLocal _ -> Nothing

649+ RKernelForeign -> Nothing

502

650

503

651

504

652

506

654

507

655

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

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

509−downloadPackage cache manager name version =

657+downloadPackage cache manager pkg vsn =

510 do eitherByteString <-

658 do eitherByteString <-

511− Http.post manager (Website.metadata name version "endpoint.json") [] id (return . Right)

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

512

660

513 case eitherByteString of

661 case eitherByteString of

514 Left err ->

662 Left err ->

520 return (Left Exit.PP_BadEndpointContent)

668 return (Left Exit.PP_BadEndpointContent)

521

669

522 Right (endpoint, expectedHash) ->

670 Right (endpoint, expectedHash) ->

523− Http.fetchArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $

671+ Http.getArchive manager endpoint Exit.PP_BadArchiveRequest Exit.PP_BadArchiveContent $

524 \(sha, archive) ->

672 \(sha, archive) ->

525 if expectedHash == Http.shaToChars sha

673 if expectedHash == Http.shaToChars sha

526− then Right <$> File.writeArchive (Stuff.package cache name version) archive

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

527 else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)

675 else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)

528

676

529

677

558

706

559

707

560instance Binary Local where

708instance Binary Local where

561− get = liftM3 Local get get get

709+ get = liftM4 Local get get get get

562− put (Local a b c) = put a >> put b >> put c

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

563

711

564

712

565instance Binary Foreign where

713instance Binary Foreign where