git.iko.soy/elk
on aa5d9fe help sign in
elk/builder/src/Build.hs
1077 lines 35 kB history raw
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3module Build
4 ( fromExposed
5 , fromMains
6 , Artifacts(..)
7 , Main(..)
8 , Module(..)
9 , CachedInterface(..)
10 , DocsGoal(..)
11 )
12 where
15import Control.Concurrent (forkIO)
16import Control.Concurrent.MVar
17import Control.Monad (filterM, mapM_, sequence_)
18import qualified Data.ByteString as B
19import qualified Data.Char as Char
20import qualified Data.Either as Either
21import qualified Data.Graph as Graph
22import qualified Data.List as List
23import qualified Data.Map.Utils as Map
24import qualified Data.Map.Strict as Map
25import Data.Map.Strict ((!))
26import qualified Data.Maybe as Maybe
27import qualified Data.Name as Name
28import qualified Data.NonEmptyList as NE
29import qualified Data.OneOrMore as OneOrMore
30import qualified Data.Set as Set
31import qualified System.Directory as Dir
32import qualified System.FilePath as FP
33import System.FilePath ((</>), (<.>))
35import qualified AST.Canonical as Can
36import qualified AST.Source as Src
37import qualified AST.Optimized as Opt
38import qualified Compile
39import qualified Elm.Details as Details
40import qualified Elm.Docs as Docs
41import qualified Elm.Interface as I
42import qualified Elm.ModuleName as ModuleName
43import qualified Elm.Package as Pkg
44import qualified File
45import qualified Json.Encode as E
46import qualified Parse.Module as Parse
47import qualified Reporting
48import qualified Reporting.Annotation as A
49import qualified Reporting.Error as Error
50import qualified Reporting.Error.Syntax as Syntax
51import qualified Reporting.Error.Import as Import
52import qualified Reporting.Exit as Exit
53import qualified Stuff
57-- ENVIRONMENT
60data Env =
61 Env
62 { _key :: Reporting.BKey
63 , _root :: FilePath
64 , _pkg :: Pkg.Name
65 , _srcDirs :: [FilePath]
66 , _locals :: Map.Map ModuleName.Raw Details.Local
67 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
68 }
71makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
72makeEnv key root (Details.Details _ validOutline locals foreigns _) =
73 case validOutline of
74 Details.ValidApp srcDirs ->
75 Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
77 Details.ValidPkg pkg _ ->
78 Env key root pkg ["src"] locals foreigns
82-- FORK
85fork :: IO a -> IO (MVar a)
86fork work =
87 do mvar <- newEmptyMVar
88 _ <- forkIO $ putMVar mvar =<< work
89 return mvar
92{-# INLINE forkWithKey #-}
93forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
94forkWithKey func dict =
95 Map.traverseWithKey (\k v -> fork (func k v)) dict
99-- FROM EXPOSED
102fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
103fromExposed style root details docsGoal exposed@(NE.List e es) =
104 Reporting.trackBuild style $ \key ->
105 do let env = makeEnv key root details
106 dmvar <- Details.loadInterfaces root details
108 -- crawl
109 mvar <- newEmptyMVar
110 let docsNeed = toDocsNeed docsGoal
111 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
112 putMVar mvar roots
113 mapM_ readMVar roots
114 statuses <- traverse readMVar =<< readMVar mvar
116 -- compile
117 midpoint <- checkExposedMidpoint dmvar statuses
118 case midpoint of
119 Left problem ->
120 return (Left (Exit.BuildProjectProblem problem))
122 Right foreigns ->
123 do rmvar <- newEmptyMVar
124 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
125 putMVar rmvar resultMVars
126 results <- traverse readMVar resultMVars
127 writeDetails root details results
128 finalizeExposed docsGoal exposed results
132-- FROM MAINS
135data Artifacts =
136 Artifacts
137 { _name :: Pkg.Name
138 , _deps :: Dependencies
139 , _mains :: NE.List Main
140 , _modules :: [Module]
141 }
144data Module
145 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
146 | Cached ModuleName.Raw Bool (MVar CachedInterface)
149type Dependencies =
150 Map.Map ModuleName.Canonical I.DependencyInterface
153fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
154fromMains style root details paths =
155 Reporting.trackBuild style $ \key ->
156 do let env = makeEnv key root details
158 elmains <- findMains env paths
159 case elmains of
160 Left problem ->
161 return (Left (Exit.BuildProjectProblem problem))
163 Right lmains ->
164 do -- crawl
165 dmvar <- Details.loadInterfaces root details
166 smvar <- newMVar Map.empty
167 smainMVars <- traverse (fork . crawlMain env smvar) lmains
168 smains <- traverse readMVar smainMVars
169 statuses <- traverse readMVar =<< readMVar smvar
171 midpoint <- checkMainsMidpoint dmvar statuses smains
172 case midpoint of
173 Left problem ->
174 return (Left (Exit.BuildProjectProblem problem))
176 Right foreigns ->
177 do -- compile
178 rmvar <- newEmptyMVar
179 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
180 putMVar rmvar resultsMVars
181 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
182 results <- traverse readMVar resultsMVars
183 writeDetails root details results
184 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
188-- CRAWL
191type StatusDict =
192 Map.Map ModuleName.Raw (MVar Status)
195data Status
196 = SCached Details.Local
197 | SChanged Details.Local B.ByteString Src.Module DocsNeed
198 | SBadImport Import.Problem
199 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
200 | SForeign Pkg.Name
201 | SKernel
204crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
205crawlDeps env mvar deps blockedValue =
206 do statusDict <- takeMVar mvar
207 let depsDict = Map.fromKeys (\_ -> ()) deps
208 let newsDict = Map.difference depsDict statusDict
209 statuses <- Map.traverseWithKey crawlNew newsDict
210 putMVar mvar (Map.union statuses statusDict)
211 mapM_ readMVar statuses
212 return blockedValue
213 where
214 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
217crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
218crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
219 do let fileName = ModuleName.toFilePath name <.> "elm"
220 let inRoot path = File.exists (root </> path)
222 paths <- filterM inRoot (map (</> fileName) srcDirs)
224 case paths of
225 [path] ->
226 case Map.lookup name foreigns of
227 Just (Details.Foreign dep deps) ->
228 return $ SBadImport $ Import.Ambiguous path [] dep deps
230 Nothing ->
231 case Map.lookup name locals of
232 Nothing ->
233 crawlFile env mvar docsNeed name path
235 Just local@(Details.Local oldPath oldTime deps _) ->
236 if path /= oldPath
237 then crawlFile env mvar docsNeed name path
238 else
239 do newTime <- File.getTime path
240 if oldTime < newTime || needsDocs docsNeed
241 then crawlFile env mvar docsNeed name path
242 else crawlDeps env mvar deps (SCached local)
244 p1:p2:ps ->
245 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
247 [] ->
248 case Map.lookup name foreigns of
249 Just (Details.Foreign dep deps) ->
250 case deps of
251 [] ->
252 return $ SForeign dep
254 d:ds ->
255 return $ SBadImport $ Import.AmbiguousForeign dep d ds
257 Nothing ->
258 if Name.isKernel name && Pkg.isKernel pkg then
259 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
260 return $ if exists then SKernel else SBadImport Import.NotFound
261 else
262 return $ SBadImport Import.NotFound
265crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
266crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
267 do time <- File.getTime path
268 source <- File.readUtf8 (root </> path)
270 case Parse.fromByteString pkg source of
271 Left err ->
272 return $ SBadSyntax path time source err
274 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
275 case maybeActualName of
276 Nothing ->
277 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
279 Just name@(A.At _ actualName) ->
280 if expectedName == actualName then
281 let
282 deps = map Src.getImportName imports
283 local = Details.Local path time deps (any isMain values)
284 in
285 crawlDeps env mvar deps (SChanged local source modul docsNeed)
286 else
287 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
290isMain :: A.Located Src.Value -> Bool
291isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
292 name == Name._main
296-- CHECK MODULE
299type ResultDict =
300 Map.Map ModuleName.Raw (MVar Result)
303data Result
304 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
305 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
306 | RCached Bool (MVar CachedInterface)
307 | RNotFound Import.Problem
308 | RProblem Error.Module
309 | RBlocked
310 | RForeign I.Interface
311 | RKernel
314data CachedInterface
315 = Unneeded
316 | Loaded I.Interface
317 | Corrupted
320checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
321checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
322 case status of
323 SCached local@(Details.Local path time deps hasMain) ->
324 do results <- readMVar resultsMVar
325 depsStatus <- checkDeps root results deps
326 case depsStatus of
327 DepsChange ifaces ->
328 do source <- File.readUtf8 path
329 case Parse.fromByteString pkg source of
330 Right modul -> compile env (DocsNeed False) local source ifaces modul
331 Left err ->
332 return $ RProblem $
333 Error.Module name path time source (Error.BadSyntax err)
335 DepsSame _ _ ->
336 do mvar <- newMVar Unneeded
337 return (RCached hasMain mvar)
339 DepsBlock ->
340 return RBlocked
342 DepsNotFound problems ->
343 do source <- File.readUtf8 path
344 return $ RProblem $ Error.Module name path time source $
345 case Parse.fromByteString pkg source of
346 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
347 Error.BadImports (toImportErrors env results imports problems)
349 Left err ->
350 Error.BadSyntax err
352 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
353 do results <- readMVar resultsMVar
354 depsStatus <- checkDeps root results deps
355 case depsStatus of
356 DepsChange ifaces ->
357 compile env docsNeed local source ifaces modul
359 DepsSame same cached ->
360 do maybeLoaded <- checkCachedInterfaces root cached
361 case maybeLoaded of
362 Nothing ->
363 return RBlocked
365 Just loaded ->
366 do let ifaces = Map.union loaded (Map.fromList same)
367 compile env docsNeed local source ifaces modul
369 DepsBlock ->
370 return RBlocked
372 DepsNotFound problems ->
373 return $ RProblem $ Error.Module name path time source $
374 Error.BadImports (toImportErrors env results imports problems)
376 SBadImport importProblem ->
377 return (RNotFound importProblem)
379 SBadSyntax path time source err ->
380 return $ RProblem $ Error.Module name path time source $
381 Error.BadSyntax err
383 SForeign home ->
384 case foreigns ! ModuleName.Canonical home name of
385 I.Public iface -> return (RForeign iface)
386 I.Private _ _ _ -> error "loading private interface in Build"
388 SKernel ->
389 return RKernel
393-- CHECK DEPS
396data DepsStatus
397 = DepsChange (Map.Map ModuleName.Raw I.Interface)
398 | DepsSame [Dep] [CDep]
399 | DepsBlock
400 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
403checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
404checkDeps root results deps =
405 checkDepsHelp root results deps [] [] [] [] False
408type Dep = (ModuleName.Raw, I.Interface)
409type CDep = (ModuleName.Raw, MVar CachedInterface)
412checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
413checkDepsHelp root results deps new same cached importProblems isBlocked =
414 case deps of
415 dep:otherDeps ->
416 do result <- readMVar (results ! dep)
417 case result of
418 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
419 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
420 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
421 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
422 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
423 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
424 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
425 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
427 [] ->
428 case importProblems of
429 p:ps ->
430 return $ DepsNotFound (NE.List p ps)
432 [] ->
433 if isBlocked then
434 return $ DepsBlock
436 else if null new then
437 return $ DepsSame same cached
439 else
440 do maybeLoaded <- checkCachedInterfaces root cached
441 case maybeLoaded of
442 Nothing ->
443 return DepsBlock
445 Just loaded ->
446 return $ DepsChange $
447 Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
451-- TO IMPORT ERROR
454toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
455toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
456 let
457 knownModules =
458 Set.unions
459 [ Map.keysSet foreigns
460 , Map.keysSet locals
461 , Map.keysSet results
462 ]
464 unimportedModules =
465 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
467 regionDict =
468 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
470 toError (name, problem) =
471 Import.Error (regionDict ! name) name unimportedModules problem
472 in
473 fmap toError problems
477-- CACHED INTERFACE
480checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
481checkCachedInterfaces root deps =
482 do loading <- traverse (fork . checkCache root) deps
483 loaded <- traverse readMVar loading
484 return $ Map.fromList <$> sequence loaded
487checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
488checkCache root (name, ciMvar) =
489 do cachedInterface <- takeMVar ciMvar
490 case cachedInterface of
491 Corrupted ->
492 do putMVar ciMvar cachedInterface
493 return Nothing
495 Loaded iface ->
496 do putMVar ciMvar cachedInterface
497 return (Just (name, iface))
499 Unneeded ->
500 do maybeIface <- File.readBinary (Stuff.elmi root name)
501 case maybeIface of
502 Nothing ->
503 do putMVar ciMvar Corrupted
504 return Nothing
506 Just iface ->
507 do putMVar ciMvar (Loaded iface)
508 return (Just (name, iface))
512-- CHECK PROJECT
515checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
516checkExposedMidpoint dmvar statuses =
517 case checkForCycles statuses of
518 Nothing ->
519 do maybeForeigns <- readMVar dmvar
520 case maybeForeigns of
521 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
522 Just fs -> return (Right fs)
524 Just (NE.List name names) ->
525 do _ <- readMVar dmvar
526 return (Left (Exit.BP_Cycle name names))
529checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
530checkMainsMidpoint dmvar statuses smains =
531 case checkForCycles statuses of
532 Nothing ->
533 case checkUniqueMains statuses smains of
534 Nothing ->
535 do maybeForeigns <- readMVar dmvar
536 case maybeForeigns of
537 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
538 Just fs -> return (Right fs)
540 Just problem ->
541 do _ <- readMVar dmvar
542 return (Left problem)
544 Just (NE.List name names) ->
545 do _ <- readMVar dmvar
546 return (Left (Exit.BP_Cycle name names))
550-- CHECK FOR CYCLES
553checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
554checkForCycles modules =
555 let
556 !graph = Map.foldrWithKey addToGraph [] modules
557 !sccs = Graph.stronglyConnComp graph
558 in
559 checkForCyclesHelp sccs
562checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
563checkForCyclesHelp sccs =
564 case sccs of
565 [] ->
566 Nothing
568 scc:otherSccs ->
569 case scc of
570 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
571 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
572 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
575type Node =
576 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
579addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
580addToGraph name status graph =
581 let
582 dependencies =
583 case status of
584 SCached (Details.Local _ _ deps _) -> deps
585 SChanged (Details.Local _ _ deps _) _ _ _ -> deps
586 SBadImport _ -> []
587 SBadSyntax _ _ _ _ -> []
588 SForeign _ -> []
589 SKernel -> []
590 in
591 (name, name, dependencies) : graph
595-- CHECK UNIQUE MAINS
598checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
599checkUniqueMains insides smains =
600 let
601 outsidesDict =
602 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
603 in
604 case Map.traverseWithKey checkOutside outsidesDict of
605 Left problem ->
606 Just problem
608 Right outsides ->
609 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
610 Right () -> Nothing
611 Left problem -> Just problem
614mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
615mainStatusToNamePathPair smain =
616 case smain of
617 SInside _ -> Nothing
618 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
619 SOutsideErr _ -> Nothing
622checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
623checkOutside name paths =
624 case OneOrMore.destruct NE.List paths of
625 NE.List p [] -> Right p
626 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
629checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
630checkInside name p1 status =
631 case status of
632 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
633 SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
634 SBadImport _ -> Right ()
635 SBadSyntax _ _ _ _ -> Right ()
636 SForeign _ -> Right ()
637 SKernel -> Right ()
641-- COMPILE MODULE
644compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
645compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
646 case Compile.compile pkg ifaces modul of
647 Right (Compile.Artifacts canonical annotations objects) ->
648 do let name = Src.getName modul
649 let iface = I.fromModule pkg canonical annotations
650 let docs = makeDocs docsNeed canonical
651 File.writeBinary (Stuff.elmo root name) objects
652 maybeOldi <- File.readBinary (Stuff.elmi root name)
653 case maybeOldi of
654 Just oldi | oldi == iface ->
655 do -- iface should be fully forced by equality check
656 Reporting.report key Reporting.BDone
657 return (RSame local iface objects docs)
659 _ ->
660 do -- iface may be lazy still
661 -- TODO try adding forkIO here
662 File.writeBinary (Stuff.elmi root name) iface
663 Reporting.report key Reporting.BDone
664 return (RNew local iface objects docs)
666 Left err ->
667 do Reporting.report key Reporting.BDone
668 return $ RProblem $
669 Error.Module (Src.getName modul) path time source err
673-- WRITE DETAILS
676writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
677writeDetails root (Details.Details time outline locals foreigns extras) results =
678 File.writeBinary (Stuff.details root) $
679 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
682addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
683addNewLocal name result locals =
684 case result of
685 RNew local _ _ _ -> Map.insert name local locals
686 RSame local _ _ _ -> Map.insert name local locals
687 RCached _ _ -> locals
688 RNotFound _ -> locals
689 RProblem _ -> locals
690 RBlocked -> locals
691 RForeign _ -> locals
692 RKernel -> locals
696-- FINALIZE EXPOSED
699finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
700finalizeExposed docsGoal exposed results =
701 case foldr (addImportProblems results) [] (NE.toList exposed) of
702 p:ps ->
703 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
705 [] ->
706 case Map.foldr addErrors [] results of
707 [] -> Right <$> finalizeDocs docsGoal results
708 e:es -> return $ Left $ Exit.BuildModuleProblems e es
711addErrors :: Result -> [Error.Module] -> [Error.Module]
712addErrors result errors =
713 case result of
714 RNew _ _ _ _ -> errors
715 RSame _ _ _ _ -> errors
716 RCached _ _ -> errors
717 RNotFound _ -> errors
718 RProblem e -> e:errors
719 RBlocked -> errors
720 RForeign _ -> errors
721 RKernel -> errors
724addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
725addImportProblems results name problems =
726 case results ! name of
727 RNew _ _ _ _ -> problems
728 RSame _ _ _ _ -> problems
729 RCached _ _ -> problems
730 RNotFound p -> (name, p) : problems
731 RProblem _ -> problems
732 RBlocked -> problems
733 RForeign _ -> problems
734 RKernel -> problems
738-- DOCS
741data DocsGoal a where
742 KeepDocs :: DocsGoal Docs.Documentation
743 WriteDocs :: FilePath -> DocsGoal ()
744 IgnoreDocs :: DocsGoal ()
747newtype DocsNeed =
748 DocsNeed { needsDocs :: Bool }
751toDocsNeed :: DocsGoal a -> DocsNeed
752toDocsNeed goal =
753 case goal of
754 IgnoreDocs -> DocsNeed False
755 WriteDocs _ -> DocsNeed True
756 KeepDocs -> DocsNeed True
759makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
760makeDocs (DocsNeed isNeeded) modul =
761 if isNeeded then
762 case Docs.fromModule modul of
763 Right docs -> Just docs
764 Left _ -> Nothing
765 else
766 Nothing
769finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
770finalizeDocs goal results =
771 case goal of
772 KeepDocs ->
773 return $ Map.mapMaybe toDocs results
775 WriteDocs path ->
776 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
778 IgnoreDocs ->
779 return ()
782toDocs :: Result -> Maybe Docs.Module
783toDocs result =
784 case result of
785 RNew _ _ _ d -> d
786 RSame _ _ _ d -> d
787 RCached _ _ -> Nothing
788 RNotFound _ -> Nothing
789 RProblem _ -> Nothing
790 RBlocked -> Nothing
791 RForeign _ -> Nothing
792 RKernel -> Nothing
796--------------------------------------------------------------------------------
797--------------------------------------------------------------------------------
798------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
799--------------------------------------------------------------------------------
800--------------------------------------------------------------------------------
804-- FIND MAIN
807data MainLocation
808 = LInside ModuleName.Raw
809 | LOutside FilePath
812findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
813findMains env paths =
814 do mvars <- traverse (fork . findLocation env) paths
815 elocs <- traverse readMVar mvars
816 return $ checkLocations =<< sequence elocs
819checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
820checkLocations locations =
821 let
822 toOneOrMore loc@(Location absolute _ _) =
823 (absolute, OneOrMore.one loc)
825 fromOneOrMore loc locs =
826 case locs of
827 [] -> Right ()
828 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
829 in
830 fmap (\_ -> fmap _location locations) $
831 traverse (OneOrMore.destruct fromOneOrMore) $
832 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
836-- LOCATIONS
839data Location =
840 Location
841 { _absolute :: FilePath
842 , _relative :: FilePath
843 , _location :: MainLocation
844 }
847findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
848findLocation env path =
849 do exists <- File.exists path
850 if exists
851 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
852 else return (Left (Exit.BP_PathUnknown path))
855isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
856isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
857 let
858 (dirs, file) = FP.splitFileName absolutePath
859 (final, ext) = break (=='.') file
860 in
861 if ext /= ".elm"
862 then Left (Exit.BP_WithBadExtension path)
863 else
864 let
865 roots = FP.splitDirectories root
866 segments = FP.splitDirectories dirs ++ [final]
867 in
868 case dropPrefix roots segments of
869 Nothing ->
870 Right (Location absolutePath path (LOutside path))
872 Just relativeSegments ->
873 let
874 (exits, maybes) =
875 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
876 in
877 -- TODO make sure this is all correct
878 case (exits, Maybe.catMaybes maybes) of
879 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
880 ([], []) -> Right (Location absolutePath path (LOutside path))
881 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
882 (exit:_, _) -> Left exit
885isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
886isInsideSrcDirsHelp segments srcDir =
887 case dropPrefix (FP.splitDirectories srcDir) segments of
888 Nothing ->
889 Right Nothing
891 Just names ->
892 if all isGoodName names
893 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
894 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
897isGoodName :: [Char] -> Bool
898isGoodName name =
899 case name of
900 [] ->
901 False
903 char:chars ->
904 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
907dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
908dropPrefix roots paths =
909 case roots of
910 [] ->
911 Just paths
913 r:rs ->
914 case paths of
915 [] -> Nothing
916 p:ps -> if r == p then dropPrefix rs ps else Nothing
920-- CRAWL MAINS
923data MainStatus
924 = SInside ModuleName.Raw
925 | SOutsideOk Details.Local B.ByteString Src.Module
926 | SOutsideErr Error.Module
929crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
930crawlMain env@(Env _ _ pkg _ _ _) mvar given =
931 case given of
932 LInside name ->
933 do statusMVar <- newEmptyMVar
934 statusDict <- takeMVar mvar
935 putMVar mvar (Map.insert name statusMVar statusDict)
936 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
937 return (SInside name)
939 LOutside path ->
940 do time <- File.getTime path
941 source <- File.readUtf8 path
942 case Parse.fromByteString pkg source of
943 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
944 do let deps = map Src.getImportName imports
945 let local = Details.Local path time deps (any isMain values)
946 crawlDeps env mvar deps (SOutsideOk local source modul)
948 Left syntaxError ->
949 return $ SOutsideErr $
950 Error.Module "???" path time source (Error.BadSyntax syntaxError)
954-- CHECK MAINS
957data MainResult
958 = RInside ModuleName.Raw
959 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
960 | ROutsideErr Error.Module
961 | ROutsideBlocked
964checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
965checkMain env@(Env _ root _ _ _ _) results pendingMain =
966 case pendingMain of
967 SInside name ->
968 return (RInside name)
970 SOutsideErr err ->
971 return (ROutsideErr err)
973 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
974 do depsStatus <- checkDeps root results deps
975 case depsStatus of
976 DepsChange ifaces ->
977 return $ compileOutside env local source ifaces modul
979 DepsSame same cached ->
980 do maybeLoaded <- checkCachedInterfaces root cached
981 case maybeLoaded of
982 Nothing ->
983 return ROutsideBlocked
985 Just loaded ->
986 do let ifaces = Map.union loaded (Map.fromList same)
987 return $ compileOutside env local source ifaces modul
989 DepsBlock ->
990 return ROutsideBlocked
992 DepsNotFound problems ->
993 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
994 Error.BadImports (toImportErrors env results imports problems)
997compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
998compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
999 let
1000 name = Src.getName modul
1001 in
1002 case Compile.compile pkg ifaces modul of
1003 Right (Compile.Artifacts canonical annotations objects) ->
1004 ROutsideOk name (I.fromModule pkg canonical annotations) objects
1006 Left errors ->
1007 ROutsideErr $
1008 Error.Module name path time source errors
1012-- TO ARTIFACTS
1015data Main
1016 = Inside ModuleName.Raw
1017 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1020toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1021toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1022 case gatherProblemsOrMains results mainResults of
1023 Left (NE.List e es) ->
1024 Left (Exit.BuildModuleProblems e es)
1026 Right mains ->
1027 Right $ Artifacts pkg foreigns mains $
1028 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1031gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1032gatherProblemsOrMains results (NE.List mainResult mainResults) =
1033 let
1034 sortMain result (es, mains) =
1035 case result of
1036 RInside n -> ( es, Inside n : mains)
1037 ROutsideOk n i o -> ( es, Outside n i o : mains)
1038 ROutsideErr e -> (e:es, mains)
1039 ROutsideBlocked -> ( es, mains)
1041 errors = Map.foldr addErrors [] results
1042 in
1043 case (mainResult, foldr sortMain (errors, []) mainResults) of
1044 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1045 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1046 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1047 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1048 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1049 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1050 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1053addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1054addInside name result modules =
1055 case result of
1056 RNew _ iface objs _ -> Fresh name iface objs : modules
1057 RSame _ iface objs _ -> Fresh name iface objs : modules
1058 RCached main mvar -> Cached name main mvar : modules
1059 RNotFound _ -> error (badInside name)
1060 RProblem _ -> error (badInside name)
1061 RBlocked -> error (badInside name)
1062 RForeign _ -> modules
1063 RKernel -> modules
1066badInside :: ModuleName.Raw -> [Char]
1067badInside name =
1068 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1071addOutside :: MainResult -> [Module] -> [Module]
1072addOutside main modules =
1073 case main of
1074 RInside _ -> modules
1075 ROutsideOk name iface objs -> Fresh name iface objs : modules
1076 ROutsideErr _ -> modules
1077 ROutsideBlocked -> modules