git.iko.soy/elk
on 978ed5d help sign in
elk/builder/src/Build.hs
939 lines 30 kB history raw
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2{-# LANGUAGE BangPatterns #-}
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.Char as Char
18import qualified Data.Either as Either
19import qualified Data.Graph as Graph
20import qualified Data.List as List
21import qualified Data.Map.Utils as Map
22import qualified Data.Map.Strict as Map
23import Data.Map.Strict ((!))
24import qualified Data.Maybe as Maybe
25import qualified Data.Name as Name
26import qualified Data.NonEmptyList as NE
27import qualified Data.OneOrMore as OneOrMore
28import qualified System.Directory as Dir
29import qualified System.FilePath as FP
30import System.FilePath ((</>), (<.>))
32import qualified AST.Source as Src
33import qualified AST.Optimized as Opt
34import qualified Compile
35import qualified Elm.Details as Details
36import qualified Elm.Interface as I
37import qualified Elm.ModuleName as ModuleName
38import qualified Elm.Outline as Outline
39import qualified Elm.Package as Pkg
40import qualified File
41import qualified Parse.Module as Parse
42import qualified Reporting
43import qualified Reporting.Annotation as A
44import qualified Reporting.Exit as Exit
45import qualified Reporting.Problem as Problem
46import qualified Reporting.Render.Type.Localizer as Localizer
47import qualified Stuff
51-- ENVIRONMENT
54data 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 }
65makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
66makeEnv 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
71 Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
72 Env key root pkg ["src"] locals foreigns
76-- FORK
79fork :: IO a -> IO (MVar a)
80fork work =
81 do mvar <- newEmptyMVar
82 _ <- forkIO $ putMVar mvar =<< work
83 return mvar
86{-# INLINE forkWithKey #-}
87forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
88forkWithKey func dict =
89 Map.traverseWithKey (\k v -> fork (func k v)) dict
93-- FROM EXPOSED
96fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
97fromExposed 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
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
109 -- compile
110 midpoint <- checkExposedMidpoint dmvar statuses
111 case midpoint of
112 Left problem ->
113 return (Left (Exit.BuildProjectProblem problem))
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)
125-- FROM MAINS
128data Artifacts =
129 Artifacts
130 { _name :: Pkg.Name
131 , _deps :: Dependencies
132 , _mains :: NE.List Main
133 , _modules :: [Module]
134 }
137data Module
138 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
139 | Cached ModuleName.Raw Bool (MVar CachedInterface)
142type Dependencies =
143 Map.Map ModuleName.Canonical I.DependencyInterface
146fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
147fromMains style root details paths =
148 Reporting.trackBuild style $ \key ->
149 do let env = makeEnv key root details
151 elmains <- findMains env paths
152 case elmains of
153 Left problem ->
154 return (Left (Exit.BuildProjectProblem problem))
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
164 midpoint <- checkMainsMidpoint dmvar statuses smains
165 case midpoint of
166 Left problem ->
167 return (Left (Exit.BuildProjectProblem problem))
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
181-- CRAWL
184type StatusDict =
185 Map.Map ModuleName.Raw (MVar Status)
188data 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
197crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
198crawlDeps 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)
210crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
211crawlModule 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)
215 paths <- filterM inRoot (map (</> fileName) srcDirs)
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
223 Nothing ->
224 case Map.lookup name locals of
225 Nothing ->
226 crawlFile env mvar name path
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)
237 p1:p2:ps ->
238 return $ SNotFound $ Problem.AmbiguousLocal p1 p2 ps
240 [] ->
241 case Map.lookup name foreigns of
242 Just (Details.Foreign dep deps) ->
243 case deps of
244 [] ->
245 return $ SForeign dep
247 d:ds ->
248 return $ SNotFound $ Problem.AmbiguousForeign dep d ds
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
258crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
259crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
260 do time <- File.getTime path
261 bytes <- File.readUtf8 (root </> path)
263 case Parse.fromByteString pkg bytes 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
276 Nothing ->
277 return $ SNotValid $ Problem.BadModuleName_Unspecified expectedName
279 Left syntaxError ->
280 return $ SNotValid $ Problem.SyntaxProblem path time syntaxError
283isMain :: A.Located Src.Value -> Bool
284isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
285 name == Name.main
289-- CHECK MODULE
292type ResultDict =
293 Map.Map ModuleName.Raw (MVar Result)
296data 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
306data CachedInterface
307 = Unneeded
308 | Loaded I.Interface
309 | Corrupted
312checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
313checkModule 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 bytes <- File.readUtf8 path
321 case Parse.fromByteString pkg bytes of
322 Right modul -> compile env local ifaces modul
323 Left syntaxError ->
324 return $ RProblem $ Problem.BadSyntax $
325 Problem.SyntaxProblem path time syntaxError
327 DepsSame _ _ ->
328 do mvar <- newMVar Unneeded
329 return (RCached hasMain mvar)
331 DepsBlock ->
332 return RBlocked
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
341 DepsSame same cached ->
342 do maybeLoaded <- checkCachedInterfaces root cached
343 case maybeLoaded of
344 Nothing ->
345 return RBlocked
347 Just loaded ->
348 do let ifaces = Map.union loaded (Map.fromList same)
349 compile env local ifaces modul
351 DepsBlock ->
352 return RBlocked
354 SNotFound findProblem ->
355 return (RProblem (Problem.BadFind findProblem))
357 SNotValid syntaxProblem ->
358 return (RProblem (Problem.BadSyntax syntaxProblem))
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"
365 SKernel ->
366 return RKernel
370-- CHECK DEPS
373data DepsStatus
374 = DepsChange (Map.Map ModuleName.Raw I.Interface)
375 | DepsSame [Dep] [CDep]
376 | DepsBlock
379checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
380checkDeps root results deps =
381 checkDepsHelp root results deps [] [] []
384type Dep = (ModuleName.Raw, I.Interface)
385type CDep = (ModuleName.Raw, MVar CachedInterface)
388checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> IO DepsStatus
389checkDepsHelp 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
400 Just loaded ->
401 return $ DepsChange $
402 Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
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
410 RSame _ iface _ ->
411 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached
413 RCached _ mvar ->
414 checkDepsHelp root results otherDeps new same ((dep,mvar) : cached)
416 RProblem _ ->
417 return DepsBlock
419 RBlocked ->
420 return DepsBlock
422 RForeign iface ->
423 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached
425 RKernel ->
426 checkDepsHelp root results otherDeps new same cached
430-- CACHED INTERFACE
433checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
434checkCachedInterfaces root deps =
435 do loading <- traverse (fork . checkCache root) deps
436 loaded <- traverse readMVar loading
437 return $ Map.fromList <$> sequence loaded
440checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
441checkCache root (name, ciMvar) =
442 do cachedInterface <- takeMVar ciMvar
443 case cachedInterface of
444 Corrupted ->
445 do putMVar ciMvar cachedInterface
446 return Nothing
448 Loaded iface ->
449 do putMVar ciMvar cachedInterface
450 return (Just (name, iface))
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
459 Just iface ->
460 do putMVar ciMvar (Loaded iface)
461 return (Just (name, iface))
465-- CHECK PROJECT
468checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
469checkExposedMidpoint 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)
477 Just (NE.List name names) ->
478 do _ <- readMVar dmvar
479 return (Left (Exit.BP_Cycle name names))
482checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
483checkMainsMidpoint 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)
493 Just problem ->
494 do _ <- readMVar dmvar
495 return (Left problem)
497 Just (NE.List name names) ->
498 do _ <- readMVar dmvar
499 return (Left (Exit.BP_Cycle name names))
503-- CHECK FOR CYCLES
506checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
507checkForCycles modules =
508 let
509 !graph = Map.foldrWithKey addToGraph [] modules
510 !sccs = Graph.stronglyConnComp graph
511 in
512 checkForCyclesHelp sccs
515checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
516checkForCyclesHelp sccs =
517 case sccs of
518 [] ->
519 Nothing
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)
528type Node =
529 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
532addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
533addToGraph 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
548-- CHECK UNIQUE MAINS
551checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
552checkUniqueMains 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
561 Right outsides ->
562 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
563 Right () -> Nothing
564 Left problem -> Just problem
567mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
568mainStatusToNamePathPair smain =
569 case smain of
570 SInside _ -> Nothing
571 SOutsideOk (Details.Local path _ _ _) modul -> Just (Src.getName modul, OneOrMore.one path)
572 SOutsideErr _ -> Nothing
575checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
576checkOutside 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)
582checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
583checkInside 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 ()
594-- COMPILE MODULE
597compile :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
598compile (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)
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)
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)
625-- WRITE DETAILS
628writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
629writeDetails root (Details.Details time outline locals foreigns extras) results =
630 File.writeBinary (Stuff.details root) $
631 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
634addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
635addNewLocal 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
647-- DETECT PROBLEMS
650detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
651detectProblems results =
652 case Map.foldr addProblem [] results of
653 [] -> Right ()
654 p:ps -> Left (Exit.BuildModuleProblems p ps)
657addProblem :: Result -> [Problem.Problem] -> [Problem.Problem]
658addProblem 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
670--------------------------------------------------------------------------------
671--------------------------------------------------------------------------------
672------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
673--------------------------------------------------------------------------------
674--------------------------------------------------------------------------------
678-- FIND MAIN
681data MainLocation
682 = LInside ModuleName.Raw
683 | LOutside FilePath
686findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
687findMains env paths =
688 do mvars <- traverse (fork . findLocation env) paths
689 elocs <- traverse readMVar mvars
690 return $ checkLocations =<< sequence elocs
693checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
694checkLocations locations =
695 let
696 toOneOrMore loc@(Location absolute _ _) =
697 (absolute, OneOrMore.one loc)
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)
710-- LOCATIONS
713data Location =
714 Location
715 { _absolute :: FilePath
716 , _relative :: FilePath
717 , _location :: MainLocation
718 }
721findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
722findLocation 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))
729isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
730isInsideSrcDirs (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))
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
758isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
759isInsideSrcDirsHelp segments srcDir =
760 case dropPrefix (FP.splitDirectories srcDir) segments of
761 Nothing ->
762 Right Nothing
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)
770isGoodName :: [Char] -> Bool
771isGoodName name =
772 case name of
773 [] ->
774 False
776 char:chars ->
777 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
780dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
781dropPrefix roots paths =
782 case roots of
783 [] ->
784 Just paths
786 r:rs ->
787 case paths of
788 [] -> Nothing
789 p:ps -> if r == p then dropPrefix rs ps else Nothing
793-- CRAWL MAINS
796data MainStatus
797 = SInside ModuleName.Raw
798 | SOutsideOk Details.Local Src.Module
799 | SOutsideErr Problem.Syntax
802crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
803crawlMain 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)
812 LOutside path ->
813 do time <- File.getTime path
814 bytes <- File.readUtf8 path
815 case Parse.fromByteString pkg bytes 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)
821 Left syntaxError ->
822 return (SOutsideErr (Problem.SyntaxProblem path time syntaxError))
826-- CHECK MAINS
829data MainResult
830 = RInside ModuleName.Raw
831 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
832 | ROutsideErr Problem.Problem
833 | ROutsideBlocked
836checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
837checkMain env@(Env _ root _ _ _ _) results pendingMain =
838 case pendingMain of
839 SInside name ->
840 return (RInside name)
842 SOutsideErr syntaxProblem ->
843 return (ROutsideErr (Problem.BadSyntax syntaxProblem))
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
851 DepsSame same cached ->
852 do maybeLoaded <- checkCachedInterfaces root cached
853 case maybeLoaded of
854 Nothing ->
855 return ROutsideBlocked
857 Just loaded ->
858 do let ifaces = Map.union loaded (Map.fromList same)
859 return $ compileOutside env local ifaces modul
861 DepsBlock ->
862 return ROutsideBlocked
865compileOutside :: Env -> Details.Local -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
866compileOutside (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
874 Left errors ->
875 ROutsideErr $ Problem.BadContent $
876 Problem.Module name path time errors (Localizer.fromModule modul)
880-- TO ARTIFACTS
883data Main
884 = Inside ModuleName.Raw
885 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
888toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
889toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
890 case gatherProblemsOrMains results mainResults of
891 Left (NE.List p ps) ->
892 Left (Exit.BuildModuleProblems p ps)
894 Right mains ->
895 Right $ Artifacts pkg foreigns mains $
896 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
899gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Problem.Problem) (NE.List Main)
900gatherProblemsOrMains 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)
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)
921addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
922addInside 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
933addOutside :: MainResult -> [Module] -> [Module]
934addOutside 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