git.iko.soy/elk
on 7a87f08 help sign in
elk/builder/src/Build.hs
1014 lines 33 kB history raw
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3module Build
4 ( fromExposed
5 , fromMains
6 , Artifacts(..)
7 , Main(..)
8 , Module(..)
9 , CachedInterface(..)
10 )
11 where
14import Control.Concurrent (forkIO)
15import Control.Concurrent.MVar
16import Control.Monad (filterM, mapM_, sequence_)
17import qualified Data.ByteString as B
18import qualified Data.Char as Char
19import qualified Data.Either as Either
20import qualified Data.Graph as Graph
21import qualified Data.List as List
22import qualified Data.Map.Utils as Map
23import qualified Data.Map.Strict as Map
24import Data.Map.Strict ((!))
25import qualified Data.Maybe as Maybe
26import qualified Data.Name as Name
27import qualified Data.NonEmptyList as NE
28import qualified Data.OneOrMore as OneOrMore
29import qualified Data.Set as Set
30import qualified System.Directory as Dir
31import qualified System.FilePath as FP
32import System.FilePath ((</>), (<.>))
34import qualified AST.Source as Src
35import qualified AST.Optimized as Opt
36import qualified Compile
37import qualified Elm.Details as Details
38import qualified Elm.Interface as I
39import qualified Elm.ModuleName as ModuleName
40import qualified Elm.Outline as Outline
41import qualified Elm.Package as Pkg
42import qualified File
43import qualified Parse.Module as Parse
44import qualified Reporting
45import qualified Reporting.Annotation as A
46import qualified Reporting.Error as Error
47import qualified Reporting.Error.Syntax as Syntax
48import qualified Reporting.Error.Import as Import
49import qualified Reporting.Exit as Exit
50import qualified Stuff
54-- ENVIRONMENT
57data Env =
58 Env
59 { _key :: Reporting.BKey
60 , _root :: FilePath
61 , _pkg :: Pkg.Name
62 , _srcDirs :: [FilePath]
63 , _locals :: Map.Map ModuleName.Raw Details.Local
64 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
65 }
68makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
69makeEnv key root (Details.Details _ validOutline locals foreigns _) =
70 case validOutline of
71 Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->
72 Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
74 Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
75 Env key root pkg ["src"] locals foreigns
79-- FORK
82fork :: IO a -> IO (MVar a)
83fork work =
84 do mvar <- newEmptyMVar
85 _ <- forkIO $ putMVar mvar =<< work
86 return mvar
89{-# INLINE forkWithKey #-}
90forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
91forkWithKey func dict =
92 Map.traverseWithKey (\k v -> fork (func k v)) dict
96-- FROM EXPOSED
99fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
100fromExposed style root details exposed@(NE.List e es) =
101 Reporting.trackBuild style $ \key ->
102 do let env = makeEnv key root details
103 dmvar <- Details.loadInterfaces root details
105 -- crawl
106 mvar <- newEmptyMVar
107 roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
108 putMVar mvar roots
109 mapM_ readMVar roots
110 statuses <- traverse readMVar =<< readMVar mvar
112 -- compile
113 midpoint <- checkExposedMidpoint dmvar statuses
114 case midpoint of
115 Left problem ->
116 return (Left (Exit.BuildProjectProblem problem))
118 Right foreigns ->
119 do rmvar <- newEmptyMVar
120 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
121 putMVar rmvar resultMVars
122 results <- traverse readMVar resultMVars
123 writeDetails root details results
124 return (detectExposedProblems exposed results)
128-- FROM MAINS
131data Artifacts =
132 Artifacts
133 { _name :: Pkg.Name
134 , _deps :: Dependencies
135 , _mains :: NE.List Main
136 , _modules :: [Module]
137 }
140data Module
141 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
142 | Cached ModuleName.Raw Bool (MVar CachedInterface)
145type Dependencies =
146 Map.Map ModuleName.Canonical I.DependencyInterface
149fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
150fromMains style root details paths =
151 Reporting.trackBuild style $ \key ->
152 do let env = makeEnv key root details
154 elmains <- findMains env paths
155 case elmains of
156 Left problem ->
157 return (Left (Exit.BuildProjectProblem problem))
159 Right lmains ->
160 do -- crawl
161 dmvar <- Details.loadInterfaces root details
162 smvar <- newMVar Map.empty
163 smainMVars <- traverse (fork . crawlMain env smvar) lmains
164 smains <- traverse readMVar smainMVars
165 statuses <- traverse readMVar =<< readMVar smvar
167 midpoint <- checkMainsMidpoint dmvar statuses smains
168 case midpoint of
169 Left problem ->
170 return (Left (Exit.BuildProjectProblem problem))
172 Right foreigns ->
173 do -- compile
174 rmvar <- newEmptyMVar
175 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
176 putMVar rmvar resultsMVars
177 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
178 results <- traverse readMVar resultsMVars
179 writeDetails root details results
180 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
184-- CRAWL
187type StatusDict =
188 Map.Map ModuleName.Raw (MVar Status)
191data Status
192 = SCached Details.Local
193 | SChanged Details.Local B.ByteString Src.Module
194 | SBadImport Import.Problem
195 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
196 | SForeign Pkg.Name
197 | SKernel
200crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
201crawlDeps env mvar deps blockedValue =
202 do statusDict <- takeMVar mvar
203 let depsDict = Map.fromKeys (\_ -> ()) deps
204 let newsDict = Map.difference depsDict statusDict
205 statuses <- Map.traverseWithKey crawlNew newsDict
206 putMVar mvar (Map.union statuses statusDict)
207 mapM_ readMVar statuses
208 return blockedValue
209 where
210 crawlNew name () = fork (crawlModule env mvar name)
213crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
214crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
215 do let fileName = ModuleName.toFilePath name <.> "elm"
216 let inRoot path = File.exists (root </> path)
218 paths <- filterM inRoot (map (</> fileName) srcDirs)
220 case paths of
221 [path] ->
222 case Map.lookup name foreigns of
223 Just (Details.Foreign dep deps) ->
224 return $ SBadImport $ Import.Ambiguous path [] dep deps
226 Nothing ->
227 case Map.lookup name locals of
228 Nothing ->
229 crawlFile env mvar name path
231 Just local@(Details.Local oldPath oldTime deps _) ->
232 if path /= oldPath
233 then crawlFile env mvar name path
234 else
235 do newTime <- File.getTime path
236 if oldTime < newTime
237 then crawlFile env mvar name path
238 else crawlDeps env mvar deps (SCached local)
240 p1:p2:ps ->
241 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
243 [] ->
244 case Map.lookup name foreigns of
245 Just (Details.Foreign dep deps) ->
246 case deps of
247 [] ->
248 return $ SForeign dep
250 d:ds ->
251 return $ SBadImport $ Import.AmbiguousForeign dep d ds
253 Nothing ->
254 if Name.isKernel name && Pkg.isKernel pkg then
255 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
256 return $ if exists then SKernel else SBadImport Import.NotFound
257 else
258 return $ SBadImport Import.NotFound
261crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
262crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
263 do time <- File.getTime path
264 source <- File.readUtf8 (root </> path)
266 case Parse.fromByteString pkg source of
267 Left err ->
268 return $ SBadSyntax path time source err
270 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
271 case maybeActualName of
272 Nothing ->
273 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
275 Just name@(A.At _ actualName) ->
276 if expectedName == actualName then
277 let
278 deps = map Src.getImportName imports
279 local = Details.Local path time deps (any isMain values)
280 in
281 crawlDeps env mvar deps (SChanged local source modul)
282 else
283 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
286isMain :: A.Located Src.Value -> Bool
287isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
288 name == Name.main
292-- CHECK MODULE
295type ResultDict =
296 Map.Map ModuleName.Raw (MVar Result)
299data Result
300 = RNew Details.Local I.Interface Opt.LocalGraph
301 | RSame Details.Local I.Interface Opt.LocalGraph
302 | RCached Bool (MVar CachedInterface)
303 | RNotFound Import.Problem
304 | RProblem Error.Module
305 | RBlocked
306 | RForeign I.Interface
307 | RKernel
310data CachedInterface
311 = Unneeded
312 | Loaded I.Interface
313 | Corrupted
316checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
317checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
318 case status of
319 SCached local@(Details.Local path time deps hasMain) ->
320 do results <- readMVar resultsMVar
321 depsStatus <- checkDeps root results deps
322 case depsStatus of
323 DepsChange ifaces ->
324 do source <- File.readUtf8 path
325 case Parse.fromByteString pkg source of
326 Right modul -> compile env local source ifaces modul
327 Left err ->
328 return $ RProblem $
329 Error.Module name path time source (Error.BadSyntax err)
331 DepsSame _ _ ->
332 do mvar <- newMVar Unneeded
333 return (RCached hasMain mvar)
335 DepsBlock ->
336 return RBlocked
338 DepsNotFound problems ->
339 do source <- File.readUtf8 path
340 return $ RProblem $ Error.Module name path time source $
341 case Parse.fromByteString pkg source of
342 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
343 Error.BadImports (toImportErrors env results imports problems)
345 Left err ->
346 Error.BadSyntax err
348 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
349 do results <- readMVar resultsMVar
350 depsStatus <- checkDeps root results deps
351 case depsStatus of
352 DepsChange ifaces ->
353 compile env local source ifaces modul
355 DepsSame same cached ->
356 do maybeLoaded <- checkCachedInterfaces root cached
357 case maybeLoaded of
358 Nothing ->
359 return RBlocked
361 Just loaded ->
362 do let ifaces = Map.union loaded (Map.fromList same)
363 compile env local source ifaces modul
365 DepsBlock ->
366 return RBlocked
368 DepsNotFound problems ->
369 return $ RProblem $ Error.Module name path time source $
370 Error.BadImports (toImportErrors env results imports problems)
372 SBadImport importProblem ->
373 return (RNotFound importProblem)
375 SBadSyntax path time source err ->
376 return $ RProblem $ Error.Module name path time source $
377 Error.BadSyntax err
379 SForeign home ->
380 case foreigns ! ModuleName.Canonical home name of
381 I.Public iface -> return (RForeign iface)
382 I.Private _ _ _ -> error "loading private interface in Build"
384 SKernel ->
385 return RKernel
389-- CHECK DEPS
392data DepsStatus
393 = DepsChange (Map.Map ModuleName.Raw I.Interface)
394 | DepsSame [Dep] [CDep]
395 | DepsBlock
396 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
399checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
400checkDeps root results deps =
401 checkDepsHelp root results deps [] [] [] [] False
404type Dep = (ModuleName.Raw, I.Interface)
405type CDep = (ModuleName.Raw, MVar CachedInterface)
408checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
409checkDepsHelp root results deps new same cached importProblems isBlocked =
410 case deps of
411 dep:otherDeps ->
412 do result <- readMVar (results ! dep)
413 case result of
414 RNew _ iface _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
415 RSame _ iface _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
416 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
417 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
418 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
419 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
420 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
421 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
423 [] ->
424 case importProblems of
425 p:ps ->
426 return $ DepsNotFound (NE.List p ps)
428 [] ->
429 if isBlocked then
430 return $ DepsBlock
432 else if null new then
433 return $ DepsSame same cached
435 else
436 do maybeLoaded <- checkCachedInterfaces root cached
437 case maybeLoaded of
438 Nothing ->
439 return DepsBlock
441 Just loaded ->
442 return $ DepsChange $
443 Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
447-- TO IMPORT ERROR
450toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
451toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
452 let
453 knownModules =
454 Set.unions
455 [ Map.keysSet foreigns
456 , Map.keysSet locals
457 , Map.keysSet results
458 ]
460 unimportedModules =
461 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
463 regionDict =
464 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
466 toError (name, problem) =
467 Import.Error (regionDict ! name) name unimportedModules problem
468 in
469 fmap toError problems
473-- CACHED INTERFACE
476checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
477checkCachedInterfaces root deps =
478 do loading <- traverse (fork . checkCache root) deps
479 loaded <- traverse readMVar loading
480 return $ Map.fromList <$> sequence loaded
483checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
484checkCache root (name, ciMvar) =
485 do cachedInterface <- takeMVar ciMvar
486 case cachedInterface of
487 Corrupted ->
488 do putMVar ciMvar cachedInterface
489 return Nothing
491 Loaded iface ->
492 do putMVar ciMvar cachedInterface
493 return (Just (name, iface))
495 Unneeded ->
496 do maybeIface <- File.readBinary (Stuff.elmi root name)
497 case maybeIface of
498 Nothing ->
499 do putMVar ciMvar Corrupted
500 return Nothing
502 Just iface ->
503 do putMVar ciMvar (Loaded iface)
504 return (Just (name, iface))
508-- CHECK PROJECT
511checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
512checkExposedMidpoint dmvar statuses =
513 case checkForCycles statuses of
514 Nothing ->
515 do maybeForeigns <- readMVar dmvar
516 case maybeForeigns of
517 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
518 Just fs -> return (Right fs)
520 Just (NE.List name names) ->
521 do _ <- readMVar dmvar
522 return (Left (Exit.BP_Cycle name names))
525checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
526checkMainsMidpoint dmvar statuses smains =
527 case checkForCycles statuses of
528 Nothing ->
529 case checkUniqueMains statuses smains of
530 Nothing ->
531 do maybeForeigns <- readMVar dmvar
532 case maybeForeigns of
533 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
534 Just fs -> return (Right fs)
536 Just problem ->
537 do _ <- readMVar dmvar
538 return (Left problem)
540 Just (NE.List name names) ->
541 do _ <- readMVar dmvar
542 return (Left (Exit.BP_Cycle name names))
546-- CHECK FOR CYCLES
549checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
550checkForCycles modules =
551 let
552 !graph = Map.foldrWithKey addToGraph [] modules
553 !sccs = Graph.stronglyConnComp graph
554 in
555 checkForCyclesHelp sccs
558checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
559checkForCyclesHelp sccs =
560 case sccs of
561 [] ->
562 Nothing
564 scc:otherSccs ->
565 case scc of
566 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
567 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
568 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
571type Node =
572 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
575addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
576addToGraph name status graph =
577 let
578 dependencies =
579 case status of
580 SCached (Details.Local _ _ deps _) -> deps
581 SChanged (Details.Local _ _ deps _) _ _ -> deps
582 SBadImport _ -> []
583 SBadSyntax _ _ _ _ -> []
584 SForeign _ -> []
585 SKernel -> []
586 in
587 (name, name, dependencies) : graph
591-- CHECK UNIQUE MAINS
594checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
595checkUniqueMains insides smains =
596 let
597 outsidesDict =
598 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
599 in
600 case Map.traverseWithKey checkOutside outsidesDict of
601 Left problem ->
602 Just problem
604 Right outsides ->
605 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
606 Right () -> Nothing
607 Left problem -> Just problem
610mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
611mainStatusToNamePathPair smain =
612 case smain of
613 SInside _ -> Nothing
614 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
615 SOutsideErr _ -> Nothing
618checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
619checkOutside name paths =
620 case OneOrMore.destruct NE.List paths of
621 NE.List p [] -> Right p
622 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
625checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
626checkInside name p1 status =
627 case status of
628 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
629 SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
630 SBadImport _ -> Right ()
631 SBadSyntax _ _ _ _ -> Right ()
632 SForeign _ -> Right ()
633 SKernel -> Right ()
637-- COMPILE MODULE
640compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
641compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifaces modul =
642 case Compile.compile pkg ifaces modul of
643 Right (Compile.Artifacts canonical annotations objects) ->
644 do let name = Src.getName modul
645 let iface = I.fromModule pkg canonical annotations
646 File.writeBinary (Stuff.elmo root name) objects
647 maybeOldi <- File.readBinary (Stuff.elmi root name)
648 case maybeOldi of
649 Just oldi | oldi == iface ->
650 do -- iface should be fully forced by equality check
651 Reporting.report key Reporting.BDone
652 return (RSame local iface objects)
654 _ ->
655 do -- iface may be lazy still
656 -- TODO try adding forkIO here
657 File.writeBinary (Stuff.elmi root name) iface
658 Reporting.report key Reporting.BDone
659 return (RNew local iface objects)
661 Left err ->
662 do Reporting.report key Reporting.BDone
663 return $ RProblem $
664 Error.Module (Src.getName modul) path time source err
668-- WRITE DETAILS
671writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
672writeDetails root (Details.Details time outline locals foreigns extras) results =
673 File.writeBinary (Stuff.details root) $
674 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
677addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
678addNewLocal name result locals =
679 case result of
680 RNew local _ _ -> Map.insert name local locals
681 RSame local _ _ -> Map.insert name local locals
682 RCached _ _ -> locals
683 RNotFound _ -> locals
684 RProblem _ -> locals
685 RBlocked -> locals
686 RForeign _ -> locals
687 RKernel -> locals
691-- DETECT EXPOSED PROBLEMS
694detectExposedProblems :: NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
695detectExposedProblems exposed results =
696 case foldr (addImportProblems results) [] (NE.toList exposed) of
697 p:ps ->
698 Left (Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps)))
700 [] ->
701 case Map.foldr addErrors [] results of
702 [] -> Right ()
703 e:es -> Left (Exit.BuildModuleProblems e es)
706addErrors :: Result -> [Error.Module] -> [Error.Module]
707addErrors result errors =
708 case result of
709 RNew _ _ _ -> errors
710 RSame _ _ _ -> errors
711 RCached _ _ -> errors
712 RNotFound _ -> errors
713 RProblem e -> e:errors
714 RBlocked -> errors
715 RForeign _ -> errors
716 RKernel -> errors
719addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
720addImportProblems results name problems =
721 case results ! name of
722 RNew _ _ _ -> problems
723 RSame _ _ _ -> problems
724 RCached _ _ -> problems
725 RNotFound p -> (name, p) : problems
726 RProblem _ -> problems
727 RBlocked -> problems
728 RForeign _ -> problems
729 RKernel -> problems
733--------------------------------------------------------------------------------
734--------------------------------------------------------------------------------
735------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
736--------------------------------------------------------------------------------
737--------------------------------------------------------------------------------
741-- FIND MAIN
744data MainLocation
745 = LInside ModuleName.Raw
746 | LOutside FilePath
749findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
750findMains env paths =
751 do mvars <- traverse (fork . findLocation env) paths
752 elocs <- traverse readMVar mvars
753 return $ checkLocations =<< sequence elocs
756checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
757checkLocations locations =
758 let
759 toOneOrMore loc@(Location absolute _ _) =
760 (absolute, OneOrMore.one loc)
762 fromOneOrMore loc locs =
763 case locs of
764 [] -> Right ()
765 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
766 in
767 fmap (\_ -> fmap _location locations) $
768 traverse (OneOrMore.destruct fromOneOrMore) $
769 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
773-- LOCATIONS
776data Location =
777 Location
778 { _absolute :: FilePath
779 , _relative :: FilePath
780 , _location :: MainLocation
781 }
784findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
785findLocation env path =
786 do exists <- File.exists path
787 if exists
788 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
789 else return (Left (Exit.BP_PathUnknown path))
792isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
793isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
794 let
795 (dirs, file) = FP.splitFileName absolutePath
796 (final, ext) = break (=='.') file
797 in
798 if ext /= ".elm"
799 then Left (Exit.BP_WithBadExtension path)
800 else
801 let
802 roots = FP.splitDirectories root
803 segments = FP.splitDirectories dirs ++ [final]
804 in
805 case dropPrefix roots segments of
806 Nothing ->
807 Right (Location absolutePath path (LOutside path))
809 Just relativeSegments ->
810 let
811 (exits, maybes) =
812 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
813 in
814 -- TODO make sure this is all correct
815 case (exits, Maybe.catMaybes maybes) of
816 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
817 ([], []) -> Right (Location absolutePath path (LOutside path))
818 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
819 (exit:_, _) -> Left exit
822isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
823isInsideSrcDirsHelp segments srcDir =
824 case dropPrefix (FP.splitDirectories srcDir) segments of
825 Nothing ->
826 Right Nothing
828 Just names ->
829 if all isGoodName names
830 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
831 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
834isGoodName :: [Char] -> Bool
835isGoodName name =
836 case name of
837 [] ->
838 False
840 char:chars ->
841 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
844dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
845dropPrefix roots paths =
846 case roots of
847 [] ->
848 Just paths
850 r:rs ->
851 case paths of
852 [] -> Nothing
853 p:ps -> if r == p then dropPrefix rs ps else Nothing
857-- CRAWL MAINS
860data MainStatus
861 = SInside ModuleName.Raw
862 | SOutsideOk Details.Local B.ByteString Src.Module
863 | SOutsideErr Error.Module
866crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
867crawlMain env@(Env _ _ pkg _ _ _) mvar given =
868 case given of
869 LInside name ->
870 do statusMVar <- newEmptyMVar
871 statusDict <- takeMVar mvar
872 putMVar mvar (Map.insert name statusMVar statusDict)
873 putMVar statusMVar =<< crawlModule env mvar name
874 return (SInside name)
876 LOutside path ->
877 do time <- File.getTime path
878 source <- File.readUtf8 path
879 case Parse.fromByteString pkg source of
880 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
881 do let deps = map Src.getImportName imports
882 let local = Details.Local path time deps (any isMain values)
883 crawlDeps env mvar deps (SOutsideOk local source modul)
885 Left syntaxError ->
886 return $ SOutsideErr $
887 Error.Module "???" path time source (Error.BadSyntax syntaxError)
891-- CHECK MAINS
894data MainResult
895 = RInside ModuleName.Raw
896 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
897 | ROutsideErr Error.Module
898 | ROutsideBlocked
901checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
902checkMain env@(Env _ root _ _ _ _) results pendingMain =
903 case pendingMain of
904 SInside name ->
905 return (RInside name)
907 SOutsideErr err ->
908 return (ROutsideErr err)
910 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
911 do depsStatus <- checkDeps root results deps
912 case depsStatus of
913 DepsChange ifaces ->
914 return $ compileOutside env local source ifaces modul
916 DepsSame same cached ->
917 do maybeLoaded <- checkCachedInterfaces root cached
918 case maybeLoaded of
919 Nothing ->
920 return ROutsideBlocked
922 Just loaded ->
923 do let ifaces = Map.union loaded (Map.fromList same)
924 return $ compileOutside env local source ifaces modul
926 DepsBlock ->
927 return ROutsideBlocked
929 DepsNotFound problems ->
930 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
931 Error.BadImports (toImportErrors env results imports problems)
934compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
935compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
936 let
937 name = Src.getName modul
938 in
939 case Compile.compile pkg ifaces modul of
940 Right (Compile.Artifacts canonical annotations objects) ->
941 ROutsideOk name (I.fromModule pkg canonical annotations) objects
943 Left errors ->
944 ROutsideErr $
945 Error.Module name path time source errors
949-- TO ARTIFACTS
952data Main
953 = Inside ModuleName.Raw
954 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
957toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
958toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
959 case gatherProblemsOrMains results mainResults of
960 Left (NE.List e es) ->
961 Left (Exit.BuildModuleProblems e es)
963 Right mains ->
964 Right $ Artifacts pkg foreigns mains $
965 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
968gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
969gatherProblemsOrMains results (NE.List mainResult mainResults) =
970 let
971 sortMain result (es, mains) =
972 case result of
973 RInside n -> ( es, Inside n : mains)
974 ROutsideOk n i o -> ( es, Outside n i o : mains)
975 ROutsideErr e -> (e:es, mains)
976 ROutsideBlocked -> ( es, mains)
978 errors = Map.foldr addErrors [] results
979 in
980 case (mainResult, foldr sortMain (errors, []) mainResults) of
981 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
982 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
983 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
984 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
985 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
986 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
987 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
990addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
991addInside name result modules =
992 case result of
993 RNew _ iface objs -> Fresh name iface objs : modules
994 RSame _ iface objs -> Fresh name iface objs : modules
995 RCached main mvar -> Cached name main mvar : modules
996 RNotFound _ -> error (badInside name)
997 RProblem _ -> error (badInside name)
998 RBlocked -> error (badInside name)
999 RForeign _ -> modules
1000 RKernel -> modules
1003badInside :: ModuleName.Raw -> [Char]
1004badInside name =
1005 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1008addOutside :: MainResult -> [Module] -> [Module]
1009addOutside main modules =
1010 case main of
1011 RInside _ -> modules
1012 ROutsideOk name iface objs -> Fresh name iface objs : modules
1013 ROutsideErr _ -> modules
1014 ROutsideBlocked -> modules