git.iko.soy/elk
on 7b60982 help sign in
elk/builder/src/Build.hs
990 lines 32 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 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 (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 (detectProblems 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 foreigns 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 foreigns 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 foreigns 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 :: Dependencies -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
451toImportErrors foreigns results imports problems =
452 let
453 knownModules =
454 Set.union
455 (Set.fromList (map ModuleName._module (Map.keys foreigns)))
456 (Map.keysSet results)
458 regionDict =
459 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
461 toError (name, problem) =
462 Import.Error (regionDict ! name) name knownModules problem
463 in
464 fmap toError problems
468-- CACHED INTERFACE
471checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
472checkCachedInterfaces root deps =
473 do loading <- traverse (fork . checkCache root) deps
474 loaded <- traverse readMVar loading
475 return $ Map.fromList <$> sequence loaded
478checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
479checkCache root (name, ciMvar) =
480 do cachedInterface <- takeMVar ciMvar
481 case cachedInterface of
482 Corrupted ->
483 do putMVar ciMvar cachedInterface
484 return Nothing
486 Loaded iface ->
487 do putMVar ciMvar cachedInterface
488 return (Just (name, iface))
490 Unneeded ->
491 do maybeIface <- File.readBinary (Stuff.elmi root name)
492 case maybeIface of
493 Nothing ->
494 do putMVar ciMvar Corrupted
495 return Nothing
497 Just iface ->
498 do putMVar ciMvar (Loaded iface)
499 return (Just (name, iface))
503-- CHECK PROJECT
506checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
507checkExposedMidpoint dmvar statuses =
508 case checkForCycles statuses of
509 Nothing ->
510 do maybeForeigns <- readMVar dmvar
511 case maybeForeigns of
512 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
513 Just fs -> return (Right fs)
515 Just (NE.List name names) ->
516 do _ <- readMVar dmvar
517 return (Left (Exit.BP_Cycle name names))
520checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
521checkMainsMidpoint dmvar statuses smains =
522 case checkForCycles statuses of
523 Nothing ->
524 case checkUniqueMains statuses smains of
525 Nothing ->
526 do maybeForeigns <- readMVar dmvar
527 case maybeForeigns of
528 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
529 Just fs -> return (Right fs)
531 Just problem ->
532 do _ <- readMVar dmvar
533 return (Left problem)
535 Just (NE.List name names) ->
536 do _ <- readMVar dmvar
537 return (Left (Exit.BP_Cycle name names))
541-- CHECK FOR CYCLES
544checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
545checkForCycles modules =
546 let
547 !graph = Map.foldrWithKey addToGraph [] modules
548 !sccs = Graph.stronglyConnComp graph
549 in
550 checkForCyclesHelp sccs
553checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
554checkForCyclesHelp sccs =
555 case sccs of
556 [] ->
557 Nothing
559 scc:otherSccs ->
560 case scc of
561 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
562 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
563 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
566type Node =
567 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
570addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
571addToGraph name status graph =
572 let
573 dependencies =
574 case status of
575 SCached (Details.Local _ _ deps _) -> deps
576 SChanged (Details.Local _ _ deps _) _ _ -> deps
577 SBadImport _ -> []
578 SBadSyntax _ _ _ _ -> []
579 SForeign _ -> []
580 SKernel -> []
581 in
582 (name, name, dependencies) : graph
586-- CHECK UNIQUE MAINS
589checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
590checkUniqueMains insides smains =
591 let
592 outsidesDict =
593 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
594 in
595 case Map.traverseWithKey checkOutside outsidesDict of
596 Left problem ->
597 Just problem
599 Right outsides ->
600 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
601 Right () -> Nothing
602 Left problem -> Just problem
605mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
606mainStatusToNamePathPair smain =
607 case smain of
608 SInside _ -> Nothing
609 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
610 SOutsideErr _ -> Nothing
613checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
614checkOutside name paths =
615 case OneOrMore.destruct NE.List paths of
616 NE.List p [] -> Right p
617 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
620checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
621checkInside name p1 status =
622 case status of
623 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
624 SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
625 SBadImport _ -> Right ()
626 SBadSyntax _ _ _ _ -> Right ()
627 SForeign _ -> Right ()
628 SKernel -> Right ()
632-- COMPILE MODULE
635compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
636compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifaces modul =
637 case Compile.compile pkg ifaces modul of
638 Right (Compile.Artifacts canonical annotations objects) ->
639 do let name = Src.getName modul
640 let iface = I.fromModule pkg canonical annotations
641 File.writeBinary (Stuff.elmo root name) objects
642 maybeOldi <- File.readBinary (Stuff.elmi root name)
643 case maybeOldi of
644 Just oldi | oldi == iface ->
645 do -- iface should be fully forced by equality check
646 Reporting.report key Reporting.BDone
647 return (RSame local iface objects)
649 _ ->
650 do -- iface may be lazy still
651 -- TODO try adding forkIO here
652 File.writeBinary (Stuff.elmi root name) iface
653 Reporting.report key Reporting.BDone
654 return (RNew local iface objects)
656 Left err ->
657 do Reporting.report key Reporting.BDone
658 return $ RProblem $
659 Error.Module (Src.getName modul) path time source err
663-- WRITE DETAILS
666writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
667writeDetails root (Details.Details time outline locals foreigns extras) results =
668 File.writeBinary (Stuff.details root) $
669 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
672addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
673addNewLocal name result locals =
674 case result of
675 RNew local _ _ -> Map.insert name local locals
676 RSame local _ _ -> Map.insert name local locals
677 RCached _ _ -> locals
678 RNotFound _ -> locals
679 RProblem _ -> locals
680 RBlocked -> locals
681 RForeign _ -> locals
682 RKernel -> locals
686-- DETECT PROBLEMS
689detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
690detectProblems results =
691 case Map.foldr addErrors [] results of
692 [] -> Right ()
693 e:es -> Left (Exit.BuildModuleProblems e es)
696addErrors :: Result -> [Error.Module] -> [Error.Module]
697addErrors result errors =
698 case result of
699 RNew _ _ _ -> errors
700 RSame _ _ _ -> errors
701 RCached _ _ -> errors
702 RNotFound _ -> errors
703 RProblem e -> e:errors
704 RBlocked -> errors
705 RForeign _ -> errors
706 RKernel -> errors
710--------------------------------------------------------------------------------
711--------------------------------------------------------------------------------
712------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
713--------------------------------------------------------------------------------
714--------------------------------------------------------------------------------
718-- FIND MAIN
721data MainLocation
722 = LInside ModuleName.Raw
723 | LOutside FilePath
726findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
727findMains env paths =
728 do mvars <- traverse (fork . findLocation env) paths
729 elocs <- traverse readMVar mvars
730 return $ checkLocations =<< sequence elocs
733checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
734checkLocations locations =
735 let
736 toOneOrMore loc@(Location absolute _ _) =
737 (absolute, OneOrMore.one loc)
739 fromOneOrMore loc locs =
740 case locs of
741 [] -> Right ()
742 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
743 in
744 fmap (\_ -> fmap _location locations) $
745 traverse (OneOrMore.destruct fromOneOrMore) $
746 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
750-- LOCATIONS
753data Location =
754 Location
755 { _absolute :: FilePath
756 , _relative :: FilePath
757 , _location :: MainLocation
758 }
761findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
762findLocation env path =
763 do exists <- File.exists path
764 if exists
765 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
766 else return (Left (Exit.BP_PathUnknown path))
769isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
770isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
771 let
772 (dirs, file) = FP.splitFileName absolutePath
773 (final, ext) = break (=='.') file
774 in
775 if ext /= ".elm"
776 then Left (Exit.BP_WithBadExtension path)
777 else
778 let
779 roots = FP.splitDirectories root
780 segments = FP.splitDirectories dirs ++ [final]
781 in
782 case dropPrefix roots segments of
783 Nothing ->
784 Right (Location absolutePath path (LOutside path))
786 Just relativeSegments ->
787 let
788 (exits, maybes) =
789 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
790 in
791 case (exits, Maybe.catMaybes maybes) of
792 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
793 ([], []) -> Right (Location absolutePath path (LOutside path))
794 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
795 (exit:_, _) -> Left exit
798isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
799isInsideSrcDirsHelp segments srcDir =
800 case dropPrefix (FP.splitDirectories srcDir) segments of
801 Nothing ->
802 Right Nothing
804 Just names ->
805 if all isGoodName names
806 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
807 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
810isGoodName :: [Char] -> Bool
811isGoodName name =
812 case name of
813 [] ->
814 False
816 char:chars ->
817 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
820dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
821dropPrefix roots paths =
822 case roots of
823 [] ->
824 Just paths
826 r:rs ->
827 case paths of
828 [] -> Nothing
829 p:ps -> if r == p then dropPrefix rs ps else Nothing
833-- CRAWL MAINS
836data MainStatus
837 = SInside ModuleName.Raw
838 | SOutsideOk Details.Local B.ByteString Src.Module
839 | SOutsideErr Error.Module
842crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
843crawlMain env@(Env _ _ pkg _ _ _) mvar given =
844 case given of
845 LInside name ->
846 do statusMVar <- newEmptyMVar
847 statusDict <- takeMVar mvar
848 putMVar mvar (Map.insert name statusMVar statusDict)
849 putMVar statusMVar =<< crawlModule env mvar name
850 return (SInside name)
852 LOutside path ->
853 do time <- File.getTime path
854 source <- File.readUtf8 path
855 case Parse.fromByteString pkg source of
856 Right modul@(Src.Module _ _ imports values _ _ _ _) ->
857 do let deps = map Src.getImportName imports
858 let local = Details.Local path time deps (any isMain values)
859 crawlDeps env mvar deps (SOutsideOk local source modul)
861 Left syntaxError ->
862 return $ SOutsideErr $
863 Error.Module "???" path time source (Error.BadSyntax syntaxError)
867-- CHECK MAINS
870data MainResult
871 = RInside ModuleName.Raw
872 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
873 | ROutsideErr Error.Module
874 | ROutsideBlocked
877checkMain :: Env -> Dependencies -> ResultDict -> MainStatus -> IO MainResult
878checkMain env@(Env _ root _ _ _ _) foreigns results pendingMain =
879 case pendingMain of
880 SInside name ->
881 return (RInside name)
883 SOutsideErr err ->
884 return (ROutsideErr err)
886 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ imports _ _ _ _ _) ->
887 do depsStatus <- checkDeps root results deps
888 case depsStatus of
889 DepsChange ifaces ->
890 return $ compileOutside env local source ifaces modul
892 DepsSame same cached ->
893 do maybeLoaded <- checkCachedInterfaces root cached
894 case maybeLoaded of
895 Nothing ->
896 return ROutsideBlocked
898 Just loaded ->
899 do let ifaces = Map.union loaded (Map.fromList same)
900 return $ compileOutside env local source ifaces modul
902 DepsBlock ->
903 return ROutsideBlocked
905 DepsNotFound problems ->
906 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
907 Error.BadImports (toImportErrors foreigns results imports problems)
910compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
911compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
912 let
913 name = Src.getName modul
914 in
915 case Compile.compile pkg ifaces modul of
916 Right (Compile.Artifacts canonical annotations objects) ->
917 ROutsideOk name (I.fromModule pkg canonical annotations) objects
919 Left errors ->
920 ROutsideErr $
921 Error.Module name path time source errors
925-- TO ARTIFACTS
928data Main
929 = Inside ModuleName.Raw
930 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
933toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
934toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
935 case gatherProblemsOrMains results mainResults of
936 Left (NE.List e es) ->
937 Left (Exit.BuildModuleProblems e es)
939 Right mains ->
940 Right $ Artifacts pkg foreigns mains $
941 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
944gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
945gatherProblemsOrMains results (NE.List mainResult mainResults) =
946 let
947 sortMain result (es, mains) =
948 case result of
949 RInside n -> ( es, Inside n : mains)
950 ROutsideOk n i o -> ( es, Outside n i o : mains)
951 ROutsideErr e -> (e:es, mains)
952 ROutsideBlocked -> ( es, mains)
954 errors = Map.foldr addErrors [] results
955 in
956 case (mainResult, foldr sortMain (errors, []) mainResults) of
957 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
958 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
959 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
960 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
961 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
962 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
963 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
966addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
967addInside name result modules =
968 case result of
969 RNew _ iface objs -> Fresh name iface objs : modules
970 RSame _ iface objs -> Fresh name iface objs : modules
971 RCached main mvar -> Cached name main mvar : modules
972 RNotFound _ -> error (badInside name)
973 RProblem _ -> error (badInside name)
974 RBlocked -> error (badInside name)
975 RForeign _ -> modules
976 RKernel -> modules
979badInside :: ModuleName.Raw -> [Char]
980badInside name =
981 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
984addOutside :: MainResult -> [Module] -> [Module]
985addOutside main modules =
986 case main of
987 RInside _ -> modules
988 ROutsideOk name iface objs -> Fresh name iface objs : modules
989 ROutsideErr _ -> modules
990 ROutsideBlocked -> modules