git.iko.soy/elk
on master help sign in
Add new build manager that should allow more concurrency
481620fEvan Czaplicki
builder/src/Build.hsnew file+939
compare with master
unifiedsplit
@@ -0,0 +1,939 @@
1+{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2+{-# LANGUAGE BangPatterns #-}
3+module Build
4+ ( fromExposed
5+ , fromMains
6+ , Artifacts(..)
7+ , Main(..)
8+ , Module(..)
9+ , CachedInterface(..)
10+ )
11+ where
12+
13+
14+import Control.Concurrent (forkIO)
15+import Control.Concurrent.MVar
16+import Control.Monad (filterM, mapM_, sequence_)
17+import qualified Data.Char as Char
18+import qualified Data.Either as Either
19+import qualified Data.Graph as Graph
20+import qualified Data.List as List
21+import qualified Data.Map.Utils as Map
22+import qualified Data.Map.Strict as Map
23+import Data.Map.Strict ((!))
24+import qualified Data.Maybe as Maybe
25+import qualified Data.Name as Name
26+import qualified Data.NonEmptyList as NE
27+import qualified Data.OneOrMore as OneOrMore
28+import qualified System.Directory as Dir
29+import qualified System.FilePath as FP
30+import System.FilePath ((</>), (<.>))
31+
32+import qualified AST.Source as Src
33+import qualified AST.Optimized as Opt
34+import qualified Compile
35+import qualified Elm.Details as Details
36+import qualified Elm.Interface as I
37+import qualified Elm.ModuleName as ModuleName
38+import qualified Elm.Outline as Outline
39+import qualified Elm.Package as Pkg
40+import qualified File
41+import qualified Parse.Module as Parse
42+import qualified Reporting
43+import qualified Reporting.Annotation as A
44+import qualified Reporting.Exit as Exit
45+import qualified Reporting.Problem as Problem
46+import qualified Reporting.Render.Type.Localizer as Localizer
47+import qualified Stuff
48+
49+
50+
51+-- ENVIRONMENT
52+
53+
54+data Env =
55+ Env
56+ { _key :: Reporting.BKey
57+ , _root :: FilePath
58+ , _pkg :: Pkg.Name
59+ , _srcDirs :: [FilePath]
60+ , _locals :: Map.Map ModuleName.Raw Details.Local
61+ , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
62+ }
63+
64+
65+makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
66+makeEnv key root (Details.Details _ validOutline locals foreigns) =
67+ case validOutline of
68+ Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->
69+ Env key root Pkg.dummyName srcDirs locals foreigns
70+
71+ Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
72+ Env key root pkg ["src"] locals foreigns
73+
74+
75+
76+-- FORK
77+
78+
79+fork :: IO a -> IO (MVar a)
80+fork work =
81+ do mvar <- newEmptyMVar
82+ _ <- forkIO $ putMVar mvar =<< work
83+ return mvar
84+
85+
86+{-# INLINE forkWithKey #-}
87+forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
88+forkWithKey func dict =
89+ Map.traverseWithKey (\k v -> fork (func k v)) dict
90+
91+
92+
93+-- FROM EXPOSED
94+
95+
96+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
97+fromExposed style root details (NE.List e es) =
98+ Reporting.trackBuild style $ \key ->
99+ do let env = makeEnv key root details
100+ dmvar <- Details.loadInterfaces root details
101+
102+ -- crawl
103+ mvar <- newEmptyMVar
104+ roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
105+ putMVar mvar roots
106+ mapM_ readMVar roots
107+ statuses <- traverse readMVar =<< readMVar mvar
108+
109+ -- compile
110+ midpoint <- checkExposedMidpoint dmvar statuses
111+ case midpoint of
112+ Left problem ->
113+ return (Left (Exit.BuildProjectProblem problem))
114+
115+ Right foreigns ->
116+ do rmvar <- newEmptyMVar
117+ resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
118+ putMVar rmvar resultMVars
119+ results <- traverse readMVar resultMVars
120+ writeDetails root details results
121+ return (detectProblems results)
122+
123+
124+
125+-- FROM MAINS
126+
127+
128+data Artifacts =
129+ Artifacts
130+ { _name :: Pkg.Name
131+ , _deps :: Dependencies
132+ , _mains :: NE.List Main
133+ , _modules :: [Module]
134+ }
135+
136+
137+data Module
138+ = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
139+ | Cached ModuleName.Raw Bool (MVar CachedInterface)
140+
141+
142+type Dependencies =
143+ Map.Map ModuleName.Canonical I.DependencyInterface
144+
145+
146+fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
147+fromMains style root details paths =
148+ Reporting.trackBuild style $ \key ->
149+ do let env = makeEnv key root details
150+
151+ elmains <- findMains env paths
152+ case elmains of
153+ Left problem ->
154+ return (Left (Exit.BuildProjectProblem problem))
155+
156+ Right lmains ->
157+ do -- crawl
158+ dmvar <- Details.loadInterfaces root details
159+ smvar <- newMVar Map.empty
160+ smainMVars <- traverse (fork . crawlMain env smvar) lmains
161+ smains <- traverse readMVar smainMVars
162+ statuses <- traverse readMVar =<< readMVar smvar
163+
164+ midpoint <- checkMainsMidpoint dmvar statuses smains
165+ case midpoint of
166+ Left problem ->
167+ return (Left (Exit.BuildProjectProblem problem))
168+
169+ Right foreigns ->
170+ do -- compile
171+ rmvar <- newEmptyMVar
172+ resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
173+ putMVar rmvar resultsMVars
174+ rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
175+ results <- traverse readMVar resultsMVars
176+ writeDetails root details results
177+ toArtifacts env foreigns results <$> traverse readMVar rmainMVars
178+
179+
180+
181+-- CRAWL
182+
183+
184+type StatusDict =
185+ Map.Map ModuleName.Raw (MVar Status)
186+
187+
188+data Status
189+ = SCached Details.Local
190+ | SChanged Details.Local Src.Module
191+ | SNotFound Problem.Find
192+ | SNotValid Problem.Syntax
193+ | SForeign Pkg.Name
194+ | SKernel
195+
196+
197+crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
198+crawlDeps env mvar deps blockedValue =
199+ do statusDict <- takeMVar mvar
200+ let depsDict = Map.fromKeys (\_ -> ()) deps
201+ let newsDict = Map.difference depsDict statusDict
202+ statuses <- Map.traverseWithKey crawlNew newsDict
203+ putMVar mvar (Map.union statuses statusDict)
204+ mapM_ readMVar statuses
205+ return blockedValue
206+ where
207+ crawlNew name () = fork (crawlModule env mvar name)
208+
209+
210+crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
211+crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
212+ do let fileName = ModuleName.toFilePath name <.> "elm"
213+ let inRoot path = File.exists (root </> path)
214+
215+ paths <- filterM inRoot (map (</> fileName) srcDirs)
216+
217+ case paths of
218+ [path] ->
219+ case Map.lookup name foreigns of
220+ Just (Details.Foreign dep deps) ->
221+ return $ SNotFound $ Problem.Ambiguous path [] dep deps
222+
223+ Nothing ->
224+ case Map.lookup name locals of
225+ Nothing ->
226+ crawlFile env mvar name path
227+
228+ Just local@(Details.Local oldPath oldTime deps _) ->
229+ if path /= oldPath
230+ then crawlFile env mvar name path
231+ else
232+ do newTime <- File.getTime path
233+ if oldTime < newTime
234+ then crawlFile env mvar name path
235+ else crawlDeps env mvar deps (SCached local)
236+
237+ p1:p2:ps ->
238+ return $ SNotFound $ Problem.AmbiguousLocal p1 p2 ps
239+
240+ [] ->
241+ case Map.lookup name foreigns of
242+ Just (Details.Foreign dep deps) ->
243+ case deps of
244+ [] ->
245+ return $ SForeign dep
246+
247+ d:ds ->
248+ return $ SNotFound $ Problem.AmbiguousForeign dep d ds
249+
250+ Nothing ->
251+ if Name.isKernel name && Pkg.isKernel pkg then
252+ do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
253+ return $ if exists then SKernel else SNotFound Problem.NotFound
254+ else
255+ return $ SNotFound Problem.NotFound
256+
257+
258+crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
259+crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
260+ do time <- File.getTime path
261+ result <- Parse.fromFile pkg (root </> path)
262+
263+ case result of
264+ Right modul@(Src.Module maybeActualName _ imports values _ _ _ _) ->
265+ case maybeActualName of
266+ Just actualName ->
267+ if expectedName == actualName then
268+ let
269+ deps = map Src.getImportName imports
270+ local = Details.Local path time deps (any isMain values)
271+ in
272+ crawlDeps env mvar deps (SChanged local modul)
273+ else
274+ return $ SNotValid $ Problem.BadModuleName_Mismatch expectedName actualName
275+
276+ Nothing ->
277+ return $ SNotValid $ Problem.BadModuleName_Unspecified expectedName
278+
279+ Left syntaxError ->
280+ return $ SNotValid $ Problem.SyntaxProblem path time syntaxError
281+
282+
283+isMain :: A.Located Src.Value -> Bool
284+isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
285+ name == Name.main
286+
287+
288+
289+-- CHECK MODULE
290+
291+
292+type ResultDict =
293+ Map.Map ModuleName.Raw (MVar Result)
294+
295+
296+data Result
297+ = RNew Details.Local I.Interface Opt.LocalGraph
298+ | RSame Details.Local I.Interface Opt.LocalGraph
299+ | RCached Bool (MVar CachedInterface)
300+ | RProblem Problem.Problem
301+ | RBlocked
302+ | RForeign I.Interface
303+ | RKernel
304+
305+
306+data CachedInterface
307+ = Unneeded
308+ | Loaded I.Interface
309+ | Corrupted
310+
311+
312+checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
313+checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
314+ case status of
315+ SCached local@(Details.Local path time deps hasMain) ->
316+ do results <- readMVar resultsMVar
317+ depsStatus <- checkDeps root results deps
318+ case depsStatus of
319+ DepsChange ifaces ->
320+ do result <- Parse.fromFile pkg path
321+ case result of
322+ Right modul -> compile env local ifaces modul
323+ Left syntaxError ->
324+ return $ RProblem $ Problem.BadSyntax $
325+ Problem.SyntaxProblem path time syntaxError
326+
327+ DepsSame _ _ ->
328+ do mvar <- newMVar Unneeded
329+ return (RCached hasMain mvar)
330+
331+ DepsBlock ->
332+ return RBlocked
333+
334+ SChanged local@(Details.Local _ _ deps _) modul ->
335+ do results <- readMVar resultsMVar
336+ depsStatus <- checkDeps root results deps
337+ case depsStatus of
338+ DepsChange ifaces ->
339+ compile env local ifaces modul
340+
341+ DepsSame same cached ->
342+ do maybeLoaded <- checkCachedInterfaces root cached
343+ case maybeLoaded of
344+ Nothing ->
345+ return RBlocked
346+
347+ Just loaded ->
348+ do let ifaces = Map.union loaded (Map.fromList same)
349+ compile env local ifaces modul
350+
351+ DepsBlock ->
352+ return RBlocked
353+
354+ SNotFound findProblem ->
355+ return (RProblem (Problem.BadFind findProblem))
356+
357+ SNotValid syntaxProblem ->
358+ return (RProblem (Problem.BadSyntax syntaxProblem))
359+
360+ SForeign home ->
361+ case foreigns ! ModuleName.Canonical home name of
362+ I.Public iface -> return (RForeign iface)
363+ I.Private _ _ _ -> error "loading private interface in Build"
364+
365+ SKernel ->
366+ return RKernel
367+
368+
369+
370+-- CHECK DEPS
371+
372+
373+data DepsStatus
374+ = DepsChange (Map.Map ModuleName.Raw I.Interface)
375+ | DepsSame [Dep] [CDep]
376+ | DepsBlock
377+
378+
379+checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
380+checkDeps root results deps =
381+ checkDepsHelp root results deps [] [] []
382+
383+
384+type Dep = (ModuleName.Raw, I.Interface)
385+type CDep = (ModuleName.Raw, MVar CachedInterface)
386+
387+
388+checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> IO DepsStatus
389+checkDepsHelp root results deps new same cached =
390+ case deps of
391+ [] ->
392+ if null new
393+ then return (DepsSame same cached)
394+ else
395+ do maybeLoaded <- checkCachedInterfaces root cached
396+ case maybeLoaded of
397+ Nothing ->
398+ return DepsBlock
399+
400+ Just loaded ->
401+ return $ DepsChange $
402+ Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
403+
404+ dep:otherDeps ->
405+ do result <- readMVar (results ! dep)
406+ case result of
407+ RNew _ iface _ ->
408+ checkDepsHelp root results otherDeps ((dep,iface) : new) same cached
409+
410+ RSame _ iface _ ->
411+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached
412+
413+ RCached _ mvar ->
414+ checkDepsHelp root results otherDeps new same ((dep,mvar) : cached)
415+
416+ RProblem _ ->
417+ return DepsBlock
418+
419+ RBlocked ->
420+ return DepsBlock
421+
422+ RForeign iface ->
423+ checkDepsHelp root results otherDeps new ((dep,iface) : same) cached
424+
425+ RKernel ->
426+ checkDepsHelp root results otherDeps new same cached
427+
428+
429+
430+-- CACHED INTERFACE
431+
432+
433+checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
434+checkCachedInterfaces root deps =
435+ do loading <- traverse (fork . checkCache root) deps
436+ loaded <- traverse readMVar loading
437+ return $ Map.fromList <$> sequence loaded
438+
439+
440+checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
441+checkCache root (name, ciMvar) =
442+ do cachedInterface <- takeMVar ciMvar
443+ case cachedInterface of
444+ Corrupted ->
445+ do putMVar ciMvar cachedInterface
446+ return Nothing
447+
448+ Loaded iface ->
449+ do putMVar ciMvar cachedInterface
450+ return (Just (name, iface))
451+
452+ Unneeded ->
453+ do maybeIface <- File.readBinary (Stuff.elmi root name)
454+ case maybeIface of
455+ Nothing ->
456+ do putMVar ciMvar Corrupted
457+ return Nothing
458+
459+ Just iface ->
460+ do putMVar ciMvar (Loaded iface)
461+ return (Just (name, iface))
462+
463+
464+
465+-- CHECK PROJECT
466+
467+
468+checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
469+checkExposedMidpoint dmvar statuses =
470+ case checkForCycles statuses of
471+ Nothing ->
472+ do maybeForeigns <- readMVar dmvar
473+ case maybeForeigns of
474+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)
475+ Just fs -> return (Right fs)
476+
477+ Just (NE.List name names) ->
478+ do _ <- readMVar dmvar
479+ return (Left (Exit.BP_Cycle name names))
480+
481+
482+checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
483+checkMainsMidpoint dmvar statuses smains =
484+ case checkForCycles statuses of
485+ Nothing ->
486+ case checkUniqueMains statuses smains of
487+ Nothing ->
488+ do maybeForeigns <- readMVar dmvar
489+ case maybeForeigns of
490+ Nothing -> return (Left Exit.BP_CannotLoadDependencies)
491+ Just fs -> return (Right fs)
492+
493+ Just problem ->
494+ do _ <- readMVar dmvar
495+ return (Left problem)
496+
497+ Just (NE.List name names) ->
498+ do _ <- readMVar dmvar
499+ return (Left (Exit.BP_Cycle name names))
500+
501+
502+
503+-- CHECK FOR CYCLES
504+
505+
506+checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
507+checkForCycles modules =
508+ let
509+ !graph = Map.foldrWithKey addToGraph [] modules
510+ !sccs = Graph.stronglyConnComp graph
511+ in
512+ checkForCyclesHelp sccs
513+
514+
515+checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
516+checkForCyclesHelp sccs =
517+ case sccs of
518+ [] ->
519+ Nothing
520+
521+ scc:otherSccs ->
522+ case scc of
523+ Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
524+ Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
525+ Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
526+
527+
528+type Node =
529+ ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
530+
531+
532+addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
533+addToGraph name status graph =
534+ let
535+ dependencies =
536+ case status of
537+ SCached (Details.Local _ _ deps _) -> deps
538+ SChanged (Details.Local _ _ deps _) _ -> deps
539+ SNotFound _ -> []
540+ SNotValid _ -> []
541+ SForeign _ -> []
542+ SKernel -> []
543+ in
544+ (name, name, dependencies) : graph
545+
546+
547+
548+-- CHECK UNIQUE MAINS
549+
550+
551+checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
552+checkUniqueMains insides smains =
553+ let
554+ outsidesDict =
555+ Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
556+ in
557+ case Map.traverseWithKey checkOutside outsidesDict of
558+ Left problem ->
559+ Just problem
560+
561+ Right outsides ->
562+ case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
563+ Right () -> Nothing
564+ Left problem -> Just problem
565+
566+
567+mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
568+mainStatusToNamePathPair smain =
569+ case smain of
570+ SInside _ -> Nothing
571+ SOutsideOk (Details.Local path _ _ _) modul -> Just (Src.getName modul, OneOrMore.one path)
572+ SOutsideErr _ -> Nothing
573+
574+
575+checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
576+checkOutside name paths =
577+ case OneOrMore.destruct NE.List paths of
578+ NE.List p [] -> Right p
579+ NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
580+
581+
582+checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
583+checkInside name p1 status =
584+ case status of
585+ SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
586+ SChanged (Details.Local p2 _ _ _) _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
587+ SNotFound _ -> Right ()
588+ SNotValid _ -> Right ()
589+ SForeign _ -> Right ()
590+ SKernel -> Right ()
591+
592+
593+
594+-- COMPILE MODULE
595+
596+
597+compile :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
598+compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) ifaces modul =
599+ case Compile.compile pkg ifaces modul of
600+ Right (Compile.Artifacts canonical annotations objects) ->
601+ do let name = Src.getName modul
602+ let iface = I.fromModule pkg canonical annotations
603+ File.writeBinary (Stuff.elmo root name) objects
604+ maybeOldi <- File.readBinary (Stuff.elmi root name)
605+ case maybeOldi of
606+ Just oldi | oldi == iface ->
607+ do -- iface should be fully forced by equality check
608+ Reporting.report key Reporting.BDone
609+ return (RSame local iface objects)
610+
611+ _ ->
612+ do -- iface may be lazy still
613+ -- TODO try adding forkIO here
614+ File.writeBinary (Stuff.elmi root name) iface
615+ Reporting.report key Reporting.BDone
616+ return (RNew local iface objects)
617+
618+ Left errors ->
619+ do Reporting.report key Reporting.BDone
620+ return $ RProblem $ Problem.BadContent $
621+ Problem.Module (Src.getName modul) path time errors (Localizer.fromModule modul)
622+
623+
624+
625+-- WRITE DETAILS
626+
627+
628+writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
629+writeDetails root (Details.Details time outline locals foreigns) results =
630+ File.writeBinary (Stuff.details root) $
631+ Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns
632+
633+
634+addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
635+addNewLocal name result locals =
636+ case result of
637+ RNew local _ _ -> Map.insert name local locals
638+ RSame local _ _ -> Map.insert name local locals
639+ RCached _ _ -> locals
640+ RProblem _ -> locals
641+ RBlocked -> locals
642+ RForeign _ -> locals
643+ RKernel -> locals
644+
645+
646+
647+-- DETECT PROBLEMS
648+
649+
650+detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
651+detectProblems results =
652+ case Map.foldr addProblem [] results of
653+ [] -> Right ()
654+ p:ps -> Left (Exit.BuildModuleProblems p ps)
655+
656+
657+addProblem :: Result -> [Problem.Problem] -> [Problem.Problem]
658+addProblem result problems =
659+ case result of
660+ RNew _ _ _ -> problems
661+ RSame _ _ _ -> problems
662+ RCached _ _ -> problems
663+ RProblem p -> p:problems
664+ RBlocked -> problems
665+ RForeign _ -> problems
666+ RKernel -> problems
667+
668+
669+
670+--------------------------------------------------------------------------------
671+--------------------------------------------------------------------------------
672+------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
673+--------------------------------------------------------------------------------
674+--------------------------------------------------------------------------------
675+
676+
677+
678+-- FIND MAIN
679+
680+
681+data MainLocation
682+ = LInside ModuleName.Raw
683+ | LOutside FilePath
684+
685+
686+findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
687+findMains env paths =
688+ do mvars <- traverse (fork . findLocation env) paths
689+ elocs <- traverse readMVar mvars
690+ return $ checkLocations =<< sequence elocs
691+
692+
693+checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
694+checkLocations locations =
695+ let
696+ toOneOrMore loc@(Location absolute _ _) =
697+ (absolute, OneOrMore.one loc)
698+
699+ fromOneOrMore loc locs =
700+ case locs of
701+ [] -> Right ()
702+ loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
703+ in
704+ fmap (\_ -> fmap _location locations) $
705+ traverse (OneOrMore.destruct fromOneOrMore) $
706+ Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
707+
708+
709+
710+-- LOCATIONS
711+
712+
713+data Location =
714+ Location
715+ { _absolute :: FilePath
716+ , _relative :: FilePath
717+ , _location :: MainLocation
718+ }
719+
720+
721+findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
722+findLocation env path =
723+ do exists <- File.exists path
724+ if exists
725+ then isInsideSrcDirs env path <$> Dir.canonicalizePath path
726+ else return (Left (Exit.BP_PathUnknown path))
727+
728+
729+isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
730+isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
731+ let
732+ (dirs, file) = FP.splitFileName absolutePath
733+ (final, ext) = break (=='.') file
734+ in
735+ if ext /= ".elm"
736+ then Left (Exit.BP_WithBadExtension path)
737+ else
738+ let
739+ roots = FP.splitDirectories root
740+ segments = FP.splitDirectories dirs ++ [final]
741+ in
742+ case dropPrefix roots segments of
743+ Nothing ->
744+ Right (Location absolutePath path (LOutside path))
745+
746+ Just relativeSegments ->
747+ let
748+ (exits, maybes) =
749+ Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
750+ in
751+ case (exits, Maybe.catMaybes maybes) of
752+ (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
753+ ([], []) -> Right (Location absolutePath path (LOutside path))
754+ (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
755+ (exit:_, _) -> Left exit
756+
757+
758+isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
759+isInsideSrcDirsHelp segments srcDir =
760+ case dropPrefix (FP.splitDirectories srcDir) segments of
761+ Nothing ->
762+ Right Nothing
763+
764+ Just names ->
765+ if all isGoodName names
766+ then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
767+ else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
768+
769+
770+isGoodName :: [Char] -> Bool
771+isGoodName name =
772+ case name of
773+ [] ->
774+ False
775+
776+ char:chars ->
777+ Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
778+
779+
780+dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
781+dropPrefix roots paths =
782+ case roots of
783+ [] ->
784+ Just paths
785+
786+ r:rs ->
787+ case paths of
788+ [] -> Nothing
789+ p:ps -> if r == p then dropPrefix rs ps else Nothing
790+
791+
792+
793+-- CRAWL MAINS
794+
795+
796+data MainStatus
797+ = SInside ModuleName.Raw
798+ | SOutsideOk Details.Local Src.Module
799+ | SOutsideErr Problem.Syntax
800+
801+
802+crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
803+crawlMain env@(Env _ _ pkg _ _ _) mvar given =
804+ case given of
805+ LInside name ->
806+ do statusMVar <- newEmptyMVar
807+ statusDict <- takeMVar mvar
808+ putMVar mvar (Map.insert name statusMVar statusDict)
809+ putMVar statusMVar =<< crawlModule env mvar name
810+ return (SInside name)
811+
812+ LOutside path ->
813+ do time <- File.getTime path
814+ result <- Parse.fromFile pkg path
815+ case result of
816+ Right modul@(Src.Module _ _ imports values _ _ _ _) ->
817+ do let deps = map Src.getImportName imports
818+ let local = Details.Local path time deps (any isMain values)
819+ crawlDeps env mvar deps (SOutsideOk local modul)
820+
821+ Left syntaxError ->
822+ return (SOutsideErr (Problem.SyntaxProblem path time syntaxError))
823+
824+
825+
826+-- CHECK MAINS
827+
828+
829+data MainResult
830+ = RInside ModuleName.Raw
831+ | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
832+ | ROutsideErr Problem.Problem
833+ | ROutsideBlocked
834+
835+
836+checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
837+checkMain env@(Env _ root _ _ _ _) results pendingMain =
838+ case pendingMain of
839+ SInside name ->
840+ return (RInside name)
841+
842+ SOutsideErr syntaxProblem ->
843+ return (ROutsideErr (Problem.BadSyntax syntaxProblem))
844+
845+ SOutsideOk local@(Details.Local _ _ deps _) modul ->
846+ do depsStatus <- checkDeps root results deps
847+ case depsStatus of
848+ DepsChange ifaces ->
849+ return $ compileOutside env local ifaces modul
850+
851+ DepsSame same cached ->
852+ do maybeLoaded <- checkCachedInterfaces root cached
853+ case maybeLoaded of
854+ Nothing ->
855+ return ROutsideBlocked
856+
857+ Just loaded ->
858+ do let ifaces = Map.union loaded (Map.fromList same)
859+ return $ compileOutside env local ifaces modul
860+
861+ DepsBlock ->
862+ return ROutsideBlocked
863+
864+
865+compileOutside :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
866+compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) ifaces modul =
867+ let
868+ name = Src.getName modul
869+ in
870+ case Compile.compile pkg ifaces modul of
871+ Right (Compile.Artifacts canonical annotations objects) ->
872+ ROutsideOk name (I.fromModule pkg canonical annotations) objects
873+
874+ Left errors ->
875+ ROutsideErr $ Problem.BadContent $
876+ Problem.Module name path time errors (Localizer.fromModule modul)
877+
878+
879+
880+-- TO ARTIFACTS
881+
882+
883+data Main
884+ = Inside ModuleName.Raw
885+ | Outside ModuleName.Raw I.Interface Opt.LocalGraph
886+
887+
888+toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
889+toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
890+ case gatherProblemsOrMains results mainResults of
891+ Left (NE.List p ps) ->
892+ Left (Exit.BuildModuleProblems p ps)
893+
894+ Right mains ->
895+ Right $ Artifacts pkg foreigns mains $
896+ Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
897+
898+
899+gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Problem.Problem) (NE.List Main)
900+gatherProblemsOrMains results (NE.List mainResult mainResults) =
901+ let
902+ sortMain result (ps, mains) =
903+ case result of
904+ RInside n -> ( ps, Inside n : mains)
905+ ROutsideOk n i o -> ( ps, Outside n i o : mains)
906+ ROutsideErr p -> (p:ps, mains)
907+ ROutsideBlocked -> ( ps, mains)
908+
909+ problems = Map.foldr addProblem [] results
910+ in
911+ case (mainResult, foldr sortMain (problems, []) mainResults) of
912+ (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
913+ (RInside _ , (p:ps, _ )) -> Left (NE.List p ps)
914+ (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
915+ (ROutsideOk _ _ _, (p:ps, _ )) -> Left (NE.List p ps)
916+ (ROutsideErr p , ( ps, _ )) -> Left (NE.List p ps)
917+ (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
918+ (ROutsideBlocked , (p:ps, _ )) -> Left (NE.List p ps)
919+
920+
921+addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
922+addInside name result modules =
923+ case result of
924+ RNew _ iface objs -> Fresh name iface objs : modules
925+ RSame _ iface objs -> Fresh name iface objs : modules
926+ RCached main mvar -> Cached name main mvar : modules
927+ RProblem _ -> error ("I missed the error in `" ++ Name.toChars name ++ "` module.")
928+ RBlocked -> error ("I missed the error in `" ++ Name.toChars name ++ "` module.")
929+ RForeign _ -> modules
930+ RKernel -> modules
931+
932+
933+addOutside :: MainResult -> [Module] -> [Module]
934+addOutside main modules =
935+ case main of
936+ RInside _ -> modules
937+ ROutsideOk name iface objs -> Fresh name iface objs : modules
938+ ROutsideErr _ -> modules
939+ ROutsideBlocked -> modules