@@ -6,17 +6,20 @@ module Elm.Details
66 , Local(..)
77 , Foreign(..)
88 , verify
9+ , loadObjects
10+ , loadInterfaces
911 )
1012 where
1113
1214
1315import Control.Concurrent (forkIO)
14−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
15−import Control.Monad (liftM, liftM2, liftM3, liftM4)
16+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar, takeMVar)
17+import Control.Monad (liftM, liftM2, liftM4)
1618import Data.Binary (Binary, get, put, getWord8, putWord8)
17−import Data.Foldable (traverse_)
1819import qualified Data.Map as Map
20+import qualified Data.Map.Utils as Map
1921import qualified Data.Map.Merge.Strict as Map
22+import qualified Data.Name as Name
2023import qualified Data.OneOrMore as OneOrMore
2124import qualified Data.Set as Set
2225import qualified Data.Utf8 as Utf8
@@ -31,6 +34,7 @@ import qualified Deps.Solver as Solver
3134import qualified Deps.Website as Website
3235import qualified Elm.Constraint as Con
3336import qualified Elm.Interface as I
37+import qualified Elm.Kernel as Kernel
3438import qualified Elm.ModuleName as ModuleName
3539import qualified Elm.Outline as Outline
3640import qualified Elm.Package as Pkg
@@ -39,6 +43,7 @@ import qualified File
3943import qualified Http
4044import qualified Json.Decode as D
4145import qualified Parse.Module as Parse
46+import qualified Reporting
4247import qualified Reporting.Exit as Exit
4348import qualified Reporting.Task as Task
4449import qualified Stuff
@@ -67,6 +72,7 @@ data Local =
6772 { _path :: FilePath
6873 , _time :: File.Time
6974 , _deps :: [ModuleName.Raw]
75+ , _main :: Bool
7076 }
7177
7278
@@ -75,37 +81,68 @@ data Foreign =
7581
7682
7783
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+
78102-- VERIFY
79103
80104
81−verify :: FilePath -> Task.Task Details
82−verify root =
83− do newTime <- Task.io $ File.getTime (root </> "elm.json")
84− maybeDetails <- Task.io $ File.readBinary (root </> Stuff.details)
105+verify :: Reporting.Style -> FilePath -> IO (Either Exit.Details Details)
106+verify style root =
107+ do newTime <- File.getTime (root </> "elm.json")
108+ maybeDetails <- File.readBinary (Stuff.details root)
85109 case maybeDetails of
86110 Nothing ->
87− rebuild root newTime
111+ verifyFromScratch style root newTime
88112
89113 Just details@(Details oldTime _ _ _) ->
90114 if oldTime == newTime
91− then return details
92− else rebuild root newTime
115+ then return (Right details)
116+ else verifyFromScratch style root newTime
93117
94118
95119
96−-- REBUILD
120+-- VERIFY FROM SCRATCH
97121
98122
99−rebuild :: FilePath -> File.Time -> Task.Task Details
100−rebuild root time =
101− do (outline, info) <- rebuildHelp root
102− case outline of
103− Outline.Pkg pkg -> solvePkg info time pkg
104− Outline.App app -> solveApp info time app
123+verifyFromScratch :: Reporting.Style -> FilePath -> File.Time -> IO (Either Exit.Details Details)
124+verifyFromScratch style root time =
125+ Reporting.trackDetails style $ \key ->
126+ do result <- initEnv key root
127+ case result of
128+ Left exit ->
129+ return (Left exit)
105130
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)
106135
107−data Info =
108− Info Stuff.PackageCache Http.Manager Connection Registry.Registry
136+
137+data Env =
138+ Env
139+ { _key :: Reporting.DKey
140+ , _root :: FilePath
141+ , _cache :: Stuff.PackageCache
142+ , _manager :: Http.Manager
143+ , _connection :: Connection
144+ , _registry :: Registry.Registry
145+ }
109146
110147
111148data Connection
@@ -113,9 +150,8 @@ data Connection
113150 | Offline
114151
115152
116−rebuildHelp :: FilePath -> Task.Task (Outline.Outline, Info)
117−rebuildHelp root =
118− Task.eio id $
153+initEnv :: Reporting.DKey -> FilePath -> IO (Either Exit.Details (Env, Outline.Outline))
154+initEnv key root =
119155 do cacheMVar <- fork Stuff.getPackageCache
120156 managerMVar <- fork Http.getManager
121157 registryMVar <- fork (Registry.read =<< readMVar cacheMVar)
@@ -133,7 +169,7 @@ rebuildHelp root =
133169 do eitherRegistry <- Registry.fetch manager cache
134170 case eitherRegistry of
135171 Right latestRegistry ->
136− return $ Right (outline, Info cache manager Online latestRegistry)
172+ return $ Right (Env key root cache manager Online latestRegistry, outline)
137173
138174 Left problem ->
139175 return $ Left $ Exit.DetailsCannotGetRegistry problem
@@ -142,49 +178,44 @@ rebuildHelp root =
142178 do eitherRegistry <- Registry.update manager cache cachedRegistry
143179 case eitherRegistry of
144180 Right latestRegistry ->
145− return $ Right (outline, Info cache manager Online latestRegistry)
181+ return $ Right (Env key root cache manager Online latestRegistry, outline)
146182
147183 Left _ ->
148− return $ Right (outline, Info cache manager Offline cachedRegistry)
184+ return $ Right (Env key root cache manager Offline cachedRegistry, outline)
185+
149186
150187
188+-- VERIFY PROJECT
151189
152−-- SOLVE PKG
153190
191+type Task a = Task.Task Exit.Details a
154192
155−solvePkg :: Info -> File.Time -> Outline.PkgOutline -> Task.Task Details
156−solvePkg info time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
193+
194+verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
195+verifyPkg env time outline@(Outline.PkgOutline _ _ _ _ _ direct testDirect elm) =
157196 if Con.goodElm elm
158197 then
159− do solution <- solve info =<< union noDups direct testDirect
160− foreigns <- verifyDependencies info solution direct
198+ do solution <- solve env =<< union noDups direct testDirect
161199 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
163201 else
164202 Task.throw $ Exit.DetailsBadElmInPkg elm
165203
166204
167−
168−-- SOLVE APP
169−
170−
171−solveApp :: Info -> File.Time -> Outline.AppOutline -> Task.Task Details
172−solveApp info time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
205+verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
206+verifyApp env time outline@(Outline.AppOutline elmVersion _ direct _ _ _) =
173207 if elmVersion == V.compiler
174208 then
175209 do stated <- checkAppDeps outline
176− actual <- solve info (Map.map Con.exactly stated)
210+ actual <- solve env (Map.map Con.exactly stated)
177211 if Map.size stated == Map.size actual
178− then
179− do foreigns <- verifyDependencies info actual direct
180− return $ Details time (ValidApp outline) Map.empty foreigns
181− else
182− Task.throw $ error "TODO solveApp"
212+ then verifyDependencies env time (ValidApp outline) actual direct
213+ else Task.throw $ Exit.DetailsHandEditedDependencies
183214 else
184− Task.throw $ Exit.DetailsBadElmInApp elmVersion
215+ Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion
185216
186217
187−checkAppDeps :: Outline.AppOutline -> Task.Task (Map.Map Pkg.Name V.Version)
218+checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
188219checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
189220 do x <- union allowEqualDups indirect testDirect
190221 y <- union noDups direct testIndirect
@@ -195,8 +226,8 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
195226-- SOLVE
196227
197228
198−solve :: Info -> Map.Map Pkg.Name Con.Constraint -> Task.Task (Map.Map Pkg.Name Solver.Details)
199−solve (Info cache manager connection registry) constraints =
229+solve :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
230+solve (Env _ _ cache manager connection registry) constraints =
200231 Task.eio (error "TODO solve problem") $
201232 case connection of
202233 Online -> Solver.online cache manager registry constraints
@@ -207,17 +238,17 @@ solve (Info cache manager connection registry) constraints =
207238-- UNION
208239
209240
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)
211242union tieBreaker deps1 deps2 =
212243 Map.mergeA Map.preserveMissing Map.preserveMissing (Map.zipWithAMatched tieBreaker) deps1 deps2
213244
214245
215−noDups :: k -> v -> v -> Task.Task v
246+noDups :: k -> v -> v -> Task v
216247noDups _ _ _ =
217248 Task.throw Exit.DetailsHandEditedDependencies
218249
219250
220−allowEqualDups :: (Eq v) => k -> v -> v -> Task.Task v
251+allowEqualDups :: (Eq v) => k -> v -> v -> Task v
221252allowEqualDups _ v1 v2 =
222253 if v1 == v2
223254 then return v1
@@ -239,36 +270,39 @@ fork work =
239270-- VERIFY DEPENDENCIES
240271
241272
242−verifyDependencies :: Info -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task.Task (Map.Map ModuleName.Raw Foreign)
243−verifyDependencies info solution directDeps =
244− Task.eio (error "TODO verifyDependencies") $
245− do mvar <- newEmptyMVar
246− mvars <- Map.traverseWithKey (\k v -> fork (verifyDep info mvar solution k v)) solution
273+verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Task Details
274+verifyDependencies env@(Env key root _ _ _ _) time outline solution directDeps =
275+ Task.eio id $
276+ do Reporting.report key (Reporting.DStart (Map.size solution))
277+ mvar <- newEmptyMVar
278+ mvars <- Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k v)) solution
247279 putMVar mvar mvars
248− results <- traverse readMVar mvars
249− case sequence results of
250− Left _ ->
251− return (Left (error "TODO one of the dependencies did not build"))
280+ deps <- traverse readMVar mvars
281+ case sequence deps of
282+ Left problem ->
283+ error "TODO problem in verifyDependencies"
252284
253285 Right artifacts ->
254286 let
255− objs = Map.foldr gatherObjects Opt.empty artifacts
256− ifaces = Map.foldrWithKey (gatherInterfaces directDeps) Map.empty artifacts
287+ objs = Map.foldr addObjects Opt.empty artifacts
288+ ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
257289 foreigns = Map.map (OneOrMore.destruct Foreign) $ Map.foldrWithKey gatherForeigns Map.empty artifacts
290+ details = Details time outline Map.empty foreigns
258291 in
259− do File.writeBinary Stuff.objects objs
260− File.writeBinary Stuff.interfaces ifaces
261− return (Right foreigns)
292+ do File.writeBinary (Stuff.objects root) objs
293+ File.writeBinary (Stuff.interfaces root) ifaces
294+ File.writeBinary (Stuff.details root) details
295+ return (Right details)
262296
263297
264−gatherObjects :: Artifacts -> Opt.Graph -> Opt.Graph
265−gatherObjects (Artifacts _ objs) graph =
266− Opt.union objs graph
298+addObjects :: Artifacts -> Opt.GlobalGraph -> Opt.GlobalGraph
299+addObjects (Artifacts _ objs) graph =
300+ Opt.addGlobalGraph objs graph
267301
268302
269−gatherInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Map.Map ModuleName.Canonical I.DependencyInterface -> Map.Map ModuleName.Canonical I.DependencyInterface
270−gatherInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
271− Map.union dependencyInterfaces $ Map.mapKeys (ModuleName.Canonical pkg) $
303+addInterfaces :: Map.Map Pkg.Name a -> Pkg.Name -> Artifacts -> Interfaces -> Interfaces
304+addInterfaces directDeps pkg (Artifacts ifaces _) dependencyInterfaces =
305+ Map.union dependencyInterfaces $ Map.mapKeysMonotonic (ModuleName.Canonical pkg) $
272306 if Map.member pkg directDeps
273307 then ifaces
274308 else Map.map I.privatize ifaces
@@ -279,8 +313,8 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns =
279313 let
280314 isPublic di =
281315 case di of
282− I.Public _ -> Just (OneOrMore.one pkg)
283− I.Private _ _ -> Nothing
316+ I.Public _ -> Just (OneOrMore.one pkg)
317+ I.Private _ _ _ -> Nothing
284318 in
285319 Map.unionWith OneOrMore.more foreigns (Map.mapMaybe isPublic ifaces)
286320
@@ -292,11 +326,11 @@ gatherForeigns pkg (Artifacts ifaces _) foreigns =
292326data Artifacts =
293327 Artifacts
294328 { _ifaces :: Map.Map ModuleName.Raw I.DependencyInterface
295− , _objects :: Opt.Graph
329+ , _objects :: Opt.GlobalGraph
296330 }
297331
298332
299−type Result =
333+type Dep =
300334 Either Problem Artifacts
301335
302336
@@ -306,28 +340,35 @@ data Problem
306340 | BadDependency
307341
308342
309−verifyDep :: Info -> MVar (Map.Map Pkg.Name (MVar Result)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Result
310−verifyDep (Info cache manager _ _) resultsMVar solution name details@(Solver.Details version directDeps) =
343+verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Solver.Details -> IO Dep
344+verifyDep (Env key _ cache manager _ _) depsMVar solution pkg details@(Solver.Details vsn directDeps) =
311345 let
312346 fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps
313347 in
314− do exists <- Dir.doesDirectoryExist (Stuff.package cache name version </> "src")
348+ do exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn </> "src")
315349 if exists
316350 then
317− do maybeCache <- File.readBinary (Stuff.package cache name version </> "artifacts.dat")
351+ do Reporting.report key Reporting.DCached
352+ maybeCache <- File.readBinary (Stuff.package cache pkg vsn </> "artifacts.dat")
318353 case maybeCache of
319354 Nothing ->
320− build cache resultsMVar name details (Set.singleton fingerprint)
355+ build key cache depsMVar pkg details (Set.singleton fingerprint)
321356
322357 Just (ArtifactCache fingerprints artifacts) ->
323358 if Set.member fingerprint fingerprints
324− then return (Right artifacts)
325− else build cache resultsMVar name details (Set.insert fingerprint fingerprints)
359+ then Reporting.report key Reporting.DBuilt >> return (Right artifacts)
360+ else build key cache depsMVar pkg details (Set.insert fingerprint fingerprints)
326361 else
327− do result <- downloadPackage cache manager name version
362+ do Reporting.report key Reporting.DRequested
363+ result <- downloadPackage cache manager pkg vsn
328364 case result of
329− Left p -> return (Left (BadDownload p))
330− Right () -> build cache resultsMVar name details (Set.singleton fingerprint)
365+ Left p ->
366+ do Reporting.report key (Reporting.DFailed pkg vsn)
367+ return (Left (BadDownload p))
368+
369+ Right () ->
370+ do Reporting.report key (Reporting.DReceived pkg vsn)
371+ build key cache depsMVar pkg details (Set.singleton fingerprint)
331372
332373
333374
@@ -349,65 +390,101 @@ type Fingerprint =
349390-- BUILD
350391
351392
352−build :: Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Result)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Result
353−build cache resultsMVar name (Solver.Details version _) fingerprints =
354− do eitherOutline <- Outline.read (Stuff.package cache name version </> "elm.json")
393+build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Solver.Details -> Set.Set Fingerprint -> IO Dep
394+build key cache depsMVar pkg (Solver.Details vsn _) fingerprints =
395+ do eitherOutline <- Outline.read (Stuff.package cache pkg vsn)
355396 case eitherOutline of
356397 Left _ ->
357− return (Left BadBuild)
398+ do Reporting.report key Reporting.DBroken
399+ return (Left BadBuild)
358400
359401 Right (Outline.App _) ->
360− return (Left BadBuild)
402+ do Reporting.report key Reporting.DBroken
403+ return (Left BadBuild)
361404
362405 Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
363− do allResults <- readMVar resultsMVar
364− directResults <- traverse readMVar (Map.intersection allResults deps)
365− case sequence directResults of
406+ do allDeps <- readMVar depsMVar
407+ directDeps <- traverse readMVar (Map.intersection allDeps deps)
408+ case sequence directDeps of
366409 Left _ ->
367− return (Left BadDependency)
410+ do Reporting.report key Reporting.DBroken
411+ return (Left BadDependency)
368412
369413 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"
372415 let foreignDeps = gatherForeignInterfaces directArtifacts
373− let exposedDict = Map.fromList $ map (\n -> (n,())) (Outline.flattenExposed exposed)
374− traverse_ readMVar =<<
375− Map.traverseWithKey (const . fork . buildModule foreignDeps mvar name src) exposedDict
376− result <- traverse readMVar =<< readMVar mvar
377− case Map.traverseMaybeWithKey checkStatus result of
416+ let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed)
417+ mvar <- newEmptyMVar
418+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) exposedDict
419+ putMVar mvar mvars
420+ mapM_ readMVar mvars
421+ maybeStatuses <- traverse readMVar =<< readMVar mvar
422+ case sequence maybeStatuses of
378423 Nothing ->
379− return (Left BadBuild)
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
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+
380448
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)
390449
450+-- GATHER
391451
392−checkStatus :: ModuleName.Raw -> Status -> Maybe (Maybe (I.Interface, Opt.Graph))
393−checkStatus _ status =
452+
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 =
394460 case status of
395− SFailure -> Nothing
396− SLocal i g -> Just (Just (i,g))
397− SForeign _ -> Just Nothing
461+ RLocal _ objs -> Opt.addLocalGraph objs graph
462+ RForeign _ -> graph
463+ RKernelLocal cs -> Opt.addKernel (Name.getKernel name) cs graph
464+ RKernelForeign -> graph
398465
399466
400−gatherPackageInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw (I.Interface, Opt.Graph) -> Map.Map ModuleName.Raw I.DependencyInterface
401−gatherPackageInterfaces exposed artifacts =
402− Map.merge onLeft onRight onBoth exposed artifacts
403− where
404− onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherPackageInterfaces")
405− onRight = Map.mapMissing (\_ (i,_) -> I.private i)
406− onBoth = Map.zipWithMatched (\_ () (i,_) -> I.public i)
467+gatherInterfaces :: Map.Map ModuleName.Raw () -> Map.Map ModuleName.Raw Result -> Map.Map ModuleName.Raw I.DependencyInterface
468+gatherInterfaces exposed artifacts =
469+ let
470+ onLeft = Map.mapMissing (error "compiler bug manifesting in Elm.Details.gatherInterfaces")
471+ onRight = Map.mapMaybeMissing (\_ iface -> toLocalInterface I.private iface)
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
407484
408485
409486
410−-- FOREIGN INTERFACES
487+-- GATHER FOREIGN INTERFACES
411488
412489
413490data ForeignInterface
@@ -433,72 +510,143 @@ gatherForeignInterfaces directArtifacts =
433510 isPublic :: I.DependencyInterface -> Maybe (OneOrMore.OneOrMore I.Interface)
434511 isPublic di =
435512 case di of
436− I.Public iface -> Just (OneOrMore.one iface)
437− I.Private _ _ -> Nothing
513+ I.Public iface -> Just (OneOrMore.one iface)
514+ I.Private _ _ _ -> Nothing
438515
439516
440517
441−-- BUILD MODULE
518+-- CRAWL
442519
443520
444521type StatusDict =
445− Map.Map ModuleName.Raw (MVar Status)
522+ Map.Map ModuleName.Raw (MVar (Maybe Status))
446523
447524
448525data Status
449− = SLocal !I.Interface !Opt.Graph
526+ = SLocal (Map.Map ModuleName.Raw ()) Src.Module
450527 | SForeign I.Interface
451− | SFailure
528+ | SKernelLocal [Kernel.Chunk]
529+ | SKernelForeign
452530
453531
454−buildModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO Status
455−buildModule foreignDeps mvar pkg src name =
532+crawlModule :: Map.Map ModuleName.Raw ForeignInterface -> MVar StatusDict -> Pkg.Name -> FilePath -> ModuleName.Raw -> IO (Maybe Status)
533+crawlModule foreignDeps mvar pkg src name =
456534 do let path = src </> ModuleName.toFilePath name <.> "elm"
457535 exists <- File.exists path
458536 case Map.lookup name foreignDeps of
459537 Just ForeignAmbiguous ->
460− return SFailure
538+ return Nothing
461539
462540 Just (ForeignSpecific iface) ->
463541 if exists
464− then return SFailure
465− else return (SForeign iface)
542+ then return Nothing
543+ else return (Just (SForeign iface))
466544
467545 Nothing ->
468− if not exists
469− then return SFailure
546+ if exists then
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+
470552 else
471− do result <- Parse.fromFile pkg path
472− case result of
473− Right modul@(Src.Module (Just actualName) _ deps _ _ _ _ _) | name == actualName ->
474− do statusDict <- takeMVar mvar
475− let depsDict = Map.fromList $ map (\i -> (Src.getImport i, ())) deps
476− let newsDict = Map.difference depsDict statusDict
477− statusMVars <- Map.traverseWithKey (const . fork . buildModule foreignDeps mvar pkg src) newsDict
478− putMVar mvar (Map.union statusMVars statusDict)
479− statuses <- traverse readMVar statusMVars
480− case traverse getInterface statuses of
481− Nothing ->
482− return SFailure
483−
484− Just imports ->
485− case Compile.compile pkg imports modul of
486− (_, Right (Compile.Artifacts canonical annotations objects)) ->
487− return (SLocal (I.fromModule pkg canonical annotations) objects)
488−
489− (_, Left _) ->
490− return SFailure
491−
492− _ ->
493− return SFailure
494−
495−
496−getInterface :: Status -> Maybe I.Interface
497−getInterface status =
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 =
558+ do result <- Parse.fromFile pkg path
559+ case result of
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 =
570+ do statusDict <- takeMVar mvar
571+ let deps = Map.fromList (map (\i -> (Src.getImportName i, ())) imports)
572+ let news = Map.difference deps statusDict
573+ mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src) news
574+ putMVar mvar (Map.union mvars statusDict)
575+ mapM_ readMVar mvars
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
587+ Nothing ->
588+ return Nothing
589+
590+ Just (Kernel.Content imports chunks) ->
591+ do _ <- crawlImports foreignDeps mvar pkg src imports
592+ return (Just (SKernelLocal chunks))
593+ else
594+ return (Just SKernelForeign)
595+
596+
597+getDepHome :: ForeignInterface -> Maybe Pkg.Name
598+getDepHome fi =
599+ case fi of
600+ ForeignSpecific (I.Interface pkg _ _ _ _) -> Just pkg
601+ ForeignAmbiguous -> Nothing
602+
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 =
498617 case status of
499− SLocal iface _ -> Just iface
500− SForeign iface -> Just iface
501− SFailure -> Nothing
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+
633+ SForeign iface ->
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
502650
503651
504652
@@ -506,9 +654,9 @@ getInterface status =
506654
507655
508656downloadPackage :: Stuff.PackageCache -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ())
509−downloadPackage cache manager name version =
657+downloadPackage cache manager pkg vsn =
510658 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)
512660
513661 case eitherByteString of
514662 Left err ->
@@ -520,10 +668,10 @@ downloadPackage cache manager name version =
520668 return (Left Exit.PP_BadEndpointContent)
521669
522670 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 $
524672 \(sha, archive) ->
525673 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
527675 else return $ Left $ Exit.PP_BadArchiveHash expectedHash (Http.shaToChars sha)
528676
529677
@@ -558,8 +706,8 @@ instance Binary ValidOutline where
558706
559707
560708instance Binary Local where
561− get = liftM3 Local get get get
562− put (Local a b c) = put a >> put b >> put c
709+ get = liftM4 Local get get get get
710+ put (Local a b c d) = put a >> put b >> put c >> put d
563711
564712
565713instance Binary Foreign where