git.iko.soy/elk
on f71818d help sign in
elk/builder/src/Build.hs
996 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 (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 (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) -- TODO error if "exposed-modules" are not found
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 PROBLEMS
694detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
695detectProblems results =
696 case Map.foldr addErrors [] results of
697 [] -> Right ()
698 e:es -> Left (Exit.BuildModuleProblems e es)
701addErrors :: Result -> [Error.Module] -> [Error.Module]
702addErrors result errors =
703 case result of
704 RNew _ _ _ -> errors
705 RSame _ _ _ -> errors
706 RCached _ _ -> errors
707 RNotFound _ -> errors
708 RProblem e -> e:errors
709 RBlocked -> errors
710 RForeign _ -> errors
711 RKernel -> errors
715--------------------------------------------------------------------------------
716--------------------------------------------------------------------------------
717------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
718--------------------------------------------------------------------------------
719--------------------------------------------------------------------------------
723-- FIND MAIN
726data MainLocation
727 = LInside ModuleName.Raw
728 | LOutside FilePath
731findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
732findMains env paths =
733 do mvars <- traverse (fork . findLocation env) paths
734 elocs <- traverse readMVar mvars
735 return $ checkLocations =<< sequence elocs
738checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
739checkLocations locations =
740 let
741 toOneOrMore loc@(Location absolute _ _) =
742 (absolute, OneOrMore.one loc)
744 fromOneOrMore loc locs =
745 case locs of
746 [] -> Right ()
747 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
748 in
749 fmap (\_ -> fmap _location locations) $
750 traverse (OneOrMore.destruct fromOneOrMore) $
751 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
755-- LOCATIONS
758data Location =
759 Location
760 { _absolute :: FilePath
761 , _relative :: FilePath
762 , _location :: MainLocation
763 }
766findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
767findLocation env path =
768 do exists <- File.exists path
769 if exists
770 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
771 else return (Left (Exit.BP_PathUnknown path))
774isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
775isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
776 let
777 (dirs, file) = FP.splitFileName absolutePath
778 (final, ext) = break (=='.') file
779 in
780 if ext /= ".elm"
781 then Left (Exit.BP_WithBadExtension path)
782 else
783 let
784 roots = FP.splitDirectories root
785 segments = FP.splitDirectories dirs ++ [final]
786 in
787 case dropPrefix roots segments of
788 Nothing ->
789 Right (Location absolutePath path (LOutside path))
791 Just relativeSegments ->
792 let
793 (exits, maybes) =
794 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
795 in
796 -- TODO make sure this is all correct
797 case (exits, Maybe.catMaybes maybes) of
798 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
799 ([], []) -> Right (Location absolutePath path (LOutside path))
800 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
801 (exit:_, _) -> Left exit
804isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
805isInsideSrcDirsHelp segments srcDir =
806 case dropPrefix (FP.splitDirectories srcDir) segments of
807 Nothing ->
808 Right Nothing
810 Just names ->
811 if all isGoodName names
812 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
813 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
816isGoodName :: [Char] -> Bool
817isGoodName name =
818 case name of
819 [] ->
820 False
822 char:chars ->
823 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
826dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
827dropPrefix roots paths =
828 case roots of
829 [] ->
830 Just paths
832 r:rs ->
833 case paths of
834 [] -> Nothing
835 p:ps -> if r == p then dropPrefix rs ps else Nothing
839-- CRAWL MAINS
842data MainStatus
843 = SInside ModuleName.Raw
844 | SOutsideOk Details.Local B.ByteString Src.Module
845 | SOutsideErr Error.Module
848crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
849crawlMain env@(Env _ _ pkg _ _ _) mvar given =
850 case given of
851 LInside name ->
852 do statusMVar <- newEmptyMVar
853 statusDict <- takeMVar mvar
854 putMVar mvar (Map.insert name statusMVar statusDict)
855 putMVar statusMVar =<< crawlModule env mvar name
856 return (SInside name)
858 LOutside path ->
859 do time <- File.getTime path
860 source <- File.readUtf8 path
861 case Parse.fromByteString pkg source of
862 Right modul@(Src.Module _ _ imports values _ _ _ _) ->
863 do let deps = map Src.getImportName imports
864 let local = Details.Local path time deps (any isMain values)
865 crawlDeps env mvar deps (SOutsideOk local source modul)
867 Left syntaxError ->
868 return $ SOutsideErr $
869 Error.Module "???" path time source (Error.BadSyntax syntaxError)
873-- CHECK MAINS
876data MainResult
877 = RInside ModuleName.Raw
878 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
879 | ROutsideErr Error.Module
880 | ROutsideBlocked
883checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
884checkMain env@(Env _ root _ _ _ _) results pendingMain =
885 case pendingMain of
886 SInside name ->
887 return (RInside name)
889 SOutsideErr err ->
890 return (ROutsideErr err)
892 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ imports _ _ _ _ _) ->
893 do depsStatus <- checkDeps root results deps
894 case depsStatus of
895 DepsChange ifaces ->
896 return $ compileOutside env local source ifaces modul
898 DepsSame same cached ->
899 do maybeLoaded <- checkCachedInterfaces root cached
900 case maybeLoaded of
901 Nothing ->
902 return ROutsideBlocked
904 Just loaded ->
905 do let ifaces = Map.union loaded (Map.fromList same)
906 return $ compileOutside env local source ifaces modul
908 DepsBlock ->
909 return ROutsideBlocked
911 DepsNotFound problems ->
912 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
913 Error.BadImports (toImportErrors env results imports problems)
916compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
917compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
918 let
919 name = Src.getName modul
920 in
921 case Compile.compile pkg ifaces modul of
922 Right (Compile.Artifacts canonical annotations objects) ->
923 ROutsideOk name (I.fromModule pkg canonical annotations) objects
925 Left errors ->
926 ROutsideErr $
927 Error.Module name path time source errors
931-- TO ARTIFACTS
934data Main
935 = Inside ModuleName.Raw
936 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
939toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
940toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
941 case gatherProblemsOrMains results mainResults of
942 Left (NE.List e es) ->
943 Left (Exit.BuildModuleProblems e es)
945 Right mains ->
946 Right $ Artifacts pkg foreigns mains $
947 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
950gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
951gatherProblemsOrMains results (NE.List mainResult mainResults) =
952 let
953 sortMain result (es, mains) =
954 case result of
955 RInside n -> ( es, Inside n : mains)
956 ROutsideOk n i o -> ( es, Outside n i o : mains)
957 ROutsideErr e -> (e:es, mains)
958 ROutsideBlocked -> ( es, mains)
960 errors = Map.foldr addErrors [] results
961 in
962 case (mainResult, foldr sortMain (errors, []) mainResults) of
963 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
964 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
965 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
966 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
967 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
968 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
969 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
972addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
973addInside name result modules =
974 case result of
975 RNew _ iface objs -> Fresh name iface objs : modules
976 RSame _ iface objs -> Fresh name iface objs : modules
977 RCached main mvar -> Cached name main mvar : modules
978 RNotFound _ -> error (badInside name)
979 RProblem _ -> error (badInside name)
980 RBlocked -> error (badInside name)
981 RForeign _ -> modules
982 RKernel -> modules
985badInside :: ModuleName.Raw -> [Char]
986badInside name =
987 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
990addOutside :: MainResult -> [Module] -> [Module]
991addOutside main modules =
992 case main of
993 RInside _ -> modules
994 ROutsideOk name iface objs -> Fresh name iface objs : modules
995 ROutsideErr _ -> modules
996 ROutsideBlocked -> modules