git.iko.soy/elk
on e35fa44 help sign in
elk/builder/src/Build.hs
1078 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.Outline as Outline
44import qualified Elm.Package as Pkg
45import qualified File
46import qualified Json.Encode as E
47import qualified Parse.Module as Parse
48import qualified Reporting
49import qualified Reporting.Annotation as A
50import qualified Reporting.Error as Error
51import qualified Reporting.Error.Syntax as Syntax
52import qualified Reporting.Error.Import as Import
53import qualified Reporting.Exit as Exit
54import qualified Stuff
58-- ENVIRONMENT
61data Env =
62 Env
63 { _key :: Reporting.BKey
64 , _root :: FilePath
65 , _pkg :: Pkg.Name
66 , _srcDirs :: [FilePath]
67 , _locals :: Map.Map ModuleName.Raw Details.Local
68 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
69 }
72makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
73makeEnv key root (Details.Details _ validOutline locals foreigns _) =
74 case validOutline of
75 Details.ValidApp srcDirs ->
76 Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
78 Details.ValidPkg pkg _ ->
79 Env key root pkg ["src"] locals foreigns
83-- FORK
86fork :: IO a -> IO (MVar a)
87fork work =
88 do mvar <- newEmptyMVar
89 _ <- forkIO $ putMVar mvar =<< work
90 return mvar
93{-# INLINE forkWithKey #-}
94forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
95forkWithKey func dict =
96 Map.traverseWithKey (\k v -> fork (func k v)) dict
100-- FROM EXPOSED
103fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
104fromExposed style root details docsGoal exposed@(NE.List e es) =
105 Reporting.trackBuild style $ \key ->
106 do let env = makeEnv key root details
107 dmvar <- Details.loadInterfaces root details
109 -- crawl
110 mvar <- newEmptyMVar
111 let docsNeed = toDocsNeed docsGoal
112 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
113 putMVar mvar roots
114 mapM_ readMVar roots
115 statuses <- traverse readMVar =<< readMVar mvar
117 -- compile
118 midpoint <- checkExposedMidpoint dmvar statuses
119 case midpoint of
120 Left problem ->
121 return (Left (Exit.BuildProjectProblem problem))
123 Right foreigns ->
124 do rmvar <- newEmptyMVar
125 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
126 putMVar rmvar resultMVars
127 results <- traverse readMVar resultMVars
128 writeDetails root details results
129 finalizeExposed docsGoal exposed results
133-- FROM MAINS
136data Artifacts =
137 Artifacts
138 { _name :: Pkg.Name
139 , _deps :: Dependencies
140 , _mains :: NE.List Main
141 , _modules :: [Module]
142 }
145data Module
146 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
147 | Cached ModuleName.Raw Bool (MVar CachedInterface)
150type Dependencies =
151 Map.Map ModuleName.Canonical I.DependencyInterface
154fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
155fromMains style root details paths =
156 Reporting.trackBuild style $ \key ->
157 do let env = makeEnv key root details
159 elmains <- findMains env paths
160 case elmains of
161 Left problem ->
162 return (Left (Exit.BuildProjectProblem problem))
164 Right lmains ->
165 do -- crawl
166 dmvar <- Details.loadInterfaces root details
167 smvar <- newMVar Map.empty
168 smainMVars <- traverse (fork . crawlMain env smvar) lmains
169 smains <- traverse readMVar smainMVars
170 statuses <- traverse readMVar =<< readMVar smvar
172 midpoint <- checkMainsMidpoint dmvar statuses smains
173 case midpoint of
174 Left problem ->
175 return (Left (Exit.BuildProjectProblem problem))
177 Right foreigns ->
178 do -- compile
179 rmvar <- newEmptyMVar
180 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
181 putMVar rmvar resultsMVars
182 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
183 results <- traverse readMVar resultsMVars
184 writeDetails root details results
185 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
189-- CRAWL
192type StatusDict =
193 Map.Map ModuleName.Raw (MVar Status)
196data Status
197 = SCached Details.Local
198 | SChanged Details.Local B.ByteString Src.Module DocsNeed
199 | SBadImport Import.Problem
200 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
201 | SForeign Pkg.Name
202 | SKernel
205crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
206crawlDeps env mvar deps blockedValue =
207 do statusDict <- takeMVar mvar
208 let depsDict = Map.fromKeys (\_ -> ()) deps
209 let newsDict = Map.difference depsDict statusDict
210 statuses <- Map.traverseWithKey crawlNew newsDict
211 putMVar mvar (Map.union statuses statusDict)
212 mapM_ readMVar statuses
213 return blockedValue
214 where
215 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
218crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
219crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
220 do let fileName = ModuleName.toFilePath name <.> "elm"
221 let inRoot path = File.exists (root </> path)
223 paths <- filterM inRoot (map (</> fileName) srcDirs)
225 case paths of
226 [path] ->
227 case Map.lookup name foreigns of
228 Just (Details.Foreign dep deps) ->
229 return $ SBadImport $ Import.Ambiguous path [] dep deps
231 Nothing ->
232 case Map.lookup name locals of
233 Nothing ->
234 crawlFile env mvar docsNeed name path
236 Just local@(Details.Local oldPath oldTime deps _) ->
237 if path /= oldPath
238 then crawlFile env mvar docsNeed name path
239 else
240 do newTime <- File.getTime path
241 if oldTime < newTime || needsDocs docsNeed
242 then crawlFile env mvar docsNeed name path
243 else crawlDeps env mvar deps (SCached local)
245 p1:p2:ps ->
246 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
248 [] ->
249 case Map.lookup name foreigns of
250 Just (Details.Foreign dep deps) ->
251 case deps of
252 [] ->
253 return $ SForeign dep
255 d:ds ->
256 return $ SBadImport $ Import.AmbiguousForeign dep d ds
258 Nothing ->
259 if Name.isKernel name && Pkg.isKernel pkg then
260 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
261 return $ if exists then SKernel else SBadImport Import.NotFound
262 else
263 return $ SBadImport Import.NotFound
266crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
267crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
268 do time <- File.getTime path
269 source <- File.readUtf8 (root </> path)
271 case Parse.fromByteString pkg source of
272 Left err ->
273 return $ SBadSyntax path time source err
275 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
276 case maybeActualName of
277 Nothing ->
278 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
280 Just name@(A.At _ actualName) ->
281 if expectedName == actualName then
282 let
283 deps = map Src.getImportName imports
284 local = Details.Local path time deps (any isMain values)
285 in
286 crawlDeps env mvar deps (SChanged local source modul docsNeed)
287 else
288 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
291isMain :: A.Located Src.Value -> Bool
292isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
293 name == Name._main
297-- CHECK MODULE
300type ResultDict =
301 Map.Map ModuleName.Raw (MVar Result)
304data Result
305 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
306 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
307 | RCached Bool (MVar CachedInterface)
308 | RNotFound Import.Problem
309 | RProblem Error.Module
310 | RBlocked
311 | RForeign I.Interface
312 | RKernel
315data CachedInterface
316 = Unneeded
317 | Loaded I.Interface
318 | Corrupted
321checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
322checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
323 case status of
324 SCached local@(Details.Local path time deps hasMain) ->
325 do results <- readMVar resultsMVar
326 depsStatus <- checkDeps root results deps
327 case depsStatus of
328 DepsChange ifaces ->
329 do source <- File.readUtf8 path
330 case Parse.fromByteString pkg source of
331 Right modul -> compile env (DocsNeed False) local source ifaces modul
332 Left err ->
333 return $ RProblem $
334 Error.Module name path time source (Error.BadSyntax err)
336 DepsSame _ _ ->
337 do mvar <- newMVar Unneeded
338 return (RCached hasMain mvar)
340 DepsBlock ->
341 return RBlocked
343 DepsNotFound problems ->
344 do source <- File.readUtf8 path
345 return $ RProblem $ Error.Module name path time source $
346 case Parse.fromByteString pkg source of
347 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
348 Error.BadImports (toImportErrors env results imports problems)
350 Left err ->
351 Error.BadSyntax err
353 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
354 do results <- readMVar resultsMVar
355 depsStatus <- checkDeps root results deps
356 case depsStatus of
357 DepsChange ifaces ->
358 compile env docsNeed local source ifaces modul
360 DepsSame same cached ->
361 do maybeLoaded <- checkCachedInterfaces root cached
362 case maybeLoaded of
363 Nothing ->
364 return RBlocked
366 Just loaded ->
367 do let ifaces = Map.union loaded (Map.fromList same)
368 compile env docsNeed local source ifaces modul
370 DepsBlock ->
371 return RBlocked
373 DepsNotFound problems ->
374 return $ RProblem $ Error.Module name path time source $
375 Error.BadImports (toImportErrors env results imports problems)
377 SBadImport importProblem ->
378 return (RNotFound importProblem)
380 SBadSyntax path time source err ->
381 return $ RProblem $ Error.Module name path time source $
382 Error.BadSyntax err
384 SForeign home ->
385 case foreigns ! ModuleName.Canonical home name of
386 I.Public iface -> return (RForeign iface)
387 I.Private _ _ _ -> error "loading private interface in Build"
389 SKernel ->
390 return RKernel
394-- CHECK DEPS
397data DepsStatus
398 = DepsChange (Map.Map ModuleName.Raw I.Interface)
399 | DepsSame [Dep] [CDep]
400 | DepsBlock
401 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
404checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
405checkDeps root results deps =
406 checkDepsHelp root results deps [] [] [] [] False
409type Dep = (ModuleName.Raw, I.Interface)
410type CDep = (ModuleName.Raw, MVar CachedInterface)
413checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
414checkDepsHelp root results deps new same cached importProblems isBlocked =
415 case deps of
416 dep:otherDeps ->
417 do result <- readMVar (results ! dep)
418 case result of
419 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
420 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
421 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
422 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
423 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
424 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
425 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
426 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
428 [] ->
429 case importProblems of
430 p:ps ->
431 return $ DepsNotFound (NE.List p ps)
433 [] ->
434 if isBlocked then
435 return $ DepsBlock
437 else if null new then
438 return $ DepsSame same cached
440 else
441 do maybeLoaded <- checkCachedInterfaces root cached
442 case maybeLoaded of
443 Nothing ->
444 return DepsBlock
446 Just loaded ->
447 return $ DepsChange $
448 Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
452-- TO IMPORT ERROR
455toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
456toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
457 let
458 knownModules =
459 Set.unions
460 [ Map.keysSet foreigns
461 , Map.keysSet locals
462 , Map.keysSet results
463 ]
465 unimportedModules =
466 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
468 regionDict =
469 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
471 toError (name, problem) =
472 Import.Error (regionDict ! name) name unimportedModules problem
473 in
474 fmap toError problems
478-- CACHED INTERFACE
481checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
482checkCachedInterfaces root deps =
483 do loading <- traverse (fork . checkCache root) deps
484 loaded <- traverse readMVar loading
485 return $ Map.fromList <$> sequence loaded
488checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
489checkCache root (name, ciMvar) =
490 do cachedInterface <- takeMVar ciMvar
491 case cachedInterface of
492 Corrupted ->
493 do putMVar ciMvar cachedInterface
494 return Nothing
496 Loaded iface ->
497 do putMVar ciMvar cachedInterface
498 return (Just (name, iface))
500 Unneeded ->
501 do maybeIface <- File.readBinary (Stuff.elmi root name)
502 case maybeIface of
503 Nothing ->
504 do putMVar ciMvar Corrupted
505 return Nothing
507 Just iface ->
508 do putMVar ciMvar (Loaded iface)
509 return (Just (name, iface))
513-- CHECK PROJECT
516checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
517checkExposedMidpoint dmvar statuses =
518 case checkForCycles statuses of
519 Nothing ->
520 do maybeForeigns <- readMVar dmvar
521 case maybeForeigns of
522 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
523 Just fs -> return (Right fs)
525 Just (NE.List name names) ->
526 do _ <- readMVar dmvar
527 return (Left (Exit.BP_Cycle name names))
530checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
531checkMainsMidpoint dmvar statuses smains =
532 case checkForCycles statuses of
533 Nothing ->
534 case checkUniqueMains statuses smains of
535 Nothing ->
536 do maybeForeigns <- readMVar dmvar
537 case maybeForeigns of
538 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
539 Just fs -> return (Right fs)
541 Just problem ->
542 do _ <- readMVar dmvar
543 return (Left problem)
545 Just (NE.List name names) ->
546 do _ <- readMVar dmvar
547 return (Left (Exit.BP_Cycle name names))
551-- CHECK FOR CYCLES
554checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
555checkForCycles modules =
556 let
557 !graph = Map.foldrWithKey addToGraph [] modules
558 !sccs = Graph.stronglyConnComp graph
559 in
560 checkForCyclesHelp sccs
563checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
564checkForCyclesHelp sccs =
565 case sccs of
566 [] ->
567 Nothing
569 scc:otherSccs ->
570 case scc of
571 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
572 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
573 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
576type Node =
577 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
580addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
581addToGraph name status graph =
582 let
583 dependencies =
584 case status of
585 SCached (Details.Local _ _ deps _) -> deps
586 SChanged (Details.Local _ _ deps _) _ _ _ -> deps
587 SBadImport _ -> []
588 SBadSyntax _ _ _ _ -> []
589 SForeign _ -> []
590 SKernel -> []
591 in
592 (name, name, dependencies) : graph
596-- CHECK UNIQUE MAINS
599checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
600checkUniqueMains insides smains =
601 let
602 outsidesDict =
603 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
604 in
605 case Map.traverseWithKey checkOutside outsidesDict of
606 Left problem ->
607 Just problem
609 Right outsides ->
610 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
611 Right () -> Nothing
612 Left problem -> Just problem
615mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
616mainStatusToNamePathPair smain =
617 case smain of
618 SInside _ -> Nothing
619 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
620 SOutsideErr _ -> Nothing
623checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
624checkOutside name paths =
625 case OneOrMore.destruct NE.List paths of
626 NE.List p [] -> Right p
627 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
630checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
631checkInside name p1 status =
632 case status of
633 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
634 SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
635 SBadImport _ -> Right ()
636 SBadSyntax _ _ _ _ -> Right ()
637 SForeign _ -> Right ()
638 SKernel -> Right ()
642-- COMPILE MODULE
645compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
646compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
647 case Compile.compile pkg ifaces modul of
648 Right (Compile.Artifacts canonical annotations objects) ->
649 do let name = Src.getName modul
650 let iface = I.fromModule pkg canonical annotations
651 let docs = makeDocs docsNeed canonical
652 File.writeBinary (Stuff.elmo root name) objects
653 maybeOldi <- File.readBinary (Stuff.elmi root name)
654 case maybeOldi of
655 Just oldi | oldi == iface ->
656 do -- iface should be fully forced by equality check
657 Reporting.report key Reporting.BDone
658 return (RSame local iface objects docs)
660 _ ->
661 do -- iface may be lazy still
662 -- TODO try adding forkIO here
663 File.writeBinary (Stuff.elmi root name) iface
664 Reporting.report key Reporting.BDone
665 return (RNew local iface objects docs)
667 Left err ->
668 do Reporting.report key Reporting.BDone
669 return $ RProblem $
670 Error.Module (Src.getName modul) path time source err
674-- WRITE DETAILS
677writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
678writeDetails root (Details.Details time outline locals foreigns extras) results =
679 File.writeBinary (Stuff.details root) $
680 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
683addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
684addNewLocal name result locals =
685 case result of
686 RNew local _ _ _ -> Map.insert name local locals
687 RSame local _ _ _ -> Map.insert name local locals
688 RCached _ _ -> locals
689 RNotFound _ -> locals
690 RProblem _ -> locals
691 RBlocked -> locals
692 RForeign _ -> locals
693 RKernel -> locals
697-- FINALIZE EXPOSED
700finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
701finalizeExposed docsGoal exposed results =
702 case foldr (addImportProblems results) [] (NE.toList exposed) of
703 p:ps ->
704 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
706 [] ->
707 case Map.foldr addErrors [] results of
708 [] -> Right <$> finalizeDocs docsGoal results
709 e:es -> return $ Left $ Exit.BuildModuleProblems e es
712addErrors :: Result -> [Error.Module] -> [Error.Module]
713addErrors result errors =
714 case result of
715 RNew _ _ _ _ -> errors
716 RSame _ _ _ _ -> errors
717 RCached _ _ -> errors
718 RNotFound _ -> errors
719 RProblem e -> e:errors
720 RBlocked -> errors
721 RForeign _ -> errors
722 RKernel -> errors
725addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
726addImportProblems results name problems =
727 case results ! name of
728 RNew _ _ _ _ -> problems
729 RSame _ _ _ _ -> problems
730 RCached _ _ -> problems
731 RNotFound p -> (name, p) : problems
732 RProblem _ -> problems
733 RBlocked -> problems
734 RForeign _ -> problems
735 RKernel -> problems
739-- DOCS
742data DocsGoal a where
743 KeepDocs :: DocsGoal Docs.Documentation
744 WriteDocs :: FilePath -> DocsGoal ()
745 IgnoreDocs :: DocsGoal ()
748newtype DocsNeed =
749 DocsNeed { needsDocs :: Bool }
752toDocsNeed :: DocsGoal a -> DocsNeed
753toDocsNeed goal =
754 case goal of
755 IgnoreDocs -> DocsNeed False
756 WriteDocs _ -> DocsNeed True
757 KeepDocs -> DocsNeed True
760makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
761makeDocs (DocsNeed isNeeded) modul =
762 if isNeeded then
763 case Docs.fromModule modul of
764 Right docs -> Just docs
765 Left _ -> Nothing
766 else
767 Nothing
770finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
771finalizeDocs goal results =
772 case goal of
773 KeepDocs ->
774 return $ Map.mapMaybe toDocs results
776 WriteDocs path ->
777 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
779 IgnoreDocs ->
780 return ()
783toDocs :: Result -> Maybe Docs.Module
784toDocs result =
785 case result of
786 RNew _ _ _ d -> d
787 RSame _ _ _ d -> d
788 RCached _ _ -> Nothing
789 RNotFound _ -> Nothing
790 RProblem _ -> Nothing
791 RBlocked -> Nothing
792 RForeign _ -> Nothing
793 RKernel -> Nothing
797--------------------------------------------------------------------------------
798--------------------------------------------------------------------------------
799------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
800--------------------------------------------------------------------------------
801--------------------------------------------------------------------------------
805-- FIND MAIN
808data MainLocation
809 = LInside ModuleName.Raw
810 | LOutside FilePath
813findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
814findMains env paths =
815 do mvars <- traverse (fork . findLocation env) paths
816 elocs <- traverse readMVar mvars
817 return $ checkLocations =<< sequence elocs
820checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
821checkLocations locations =
822 let
823 toOneOrMore loc@(Location absolute _ _) =
824 (absolute, OneOrMore.one loc)
826 fromOneOrMore loc locs =
827 case locs of
828 [] -> Right ()
829 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
830 in
831 fmap (\_ -> fmap _location locations) $
832 traverse (OneOrMore.destruct fromOneOrMore) $
833 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
837-- LOCATIONS
840data Location =
841 Location
842 { _absolute :: FilePath
843 , _relative :: FilePath
844 , _location :: MainLocation
845 }
848findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
849findLocation env path =
850 do exists <- File.exists path
851 if exists
852 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
853 else return (Left (Exit.BP_PathUnknown path))
856isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
857isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
858 let
859 (dirs, file) = FP.splitFileName absolutePath
860 (final, ext) = break (=='.') file
861 in
862 if ext /= ".elm"
863 then Left (Exit.BP_WithBadExtension path)
864 else
865 let
866 roots = FP.splitDirectories root
867 segments = FP.splitDirectories dirs ++ [final]
868 in
869 case dropPrefix roots segments of
870 Nothing ->
871 Right (Location absolutePath path (LOutside path))
873 Just relativeSegments ->
874 let
875 (exits, maybes) =
876 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
877 in
878 -- TODO make sure this is all correct
879 case (exits, Maybe.catMaybes maybes) of
880 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
881 ([], []) -> Right (Location absolutePath path (LOutside path))
882 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
883 (exit:_, _) -> Left exit
886isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
887isInsideSrcDirsHelp segments srcDir =
888 case dropPrefix (FP.splitDirectories srcDir) segments of
889 Nothing ->
890 Right Nothing
892 Just names ->
893 if all isGoodName names
894 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
895 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
898isGoodName :: [Char] -> Bool
899isGoodName name =
900 case name of
901 [] ->
902 False
904 char:chars ->
905 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
908dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
909dropPrefix roots paths =
910 case roots of
911 [] ->
912 Just paths
914 r:rs ->
915 case paths of
916 [] -> Nothing
917 p:ps -> if r == p then dropPrefix rs ps else Nothing
921-- CRAWL MAINS
924data MainStatus
925 = SInside ModuleName.Raw
926 | SOutsideOk Details.Local B.ByteString Src.Module
927 | SOutsideErr Error.Module
930crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
931crawlMain env@(Env _ _ pkg _ _ _) mvar given =
932 case given of
933 LInside name ->
934 do statusMVar <- newEmptyMVar
935 statusDict <- takeMVar mvar
936 putMVar mvar (Map.insert name statusMVar statusDict)
937 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
938 return (SInside name)
940 LOutside path ->
941 do time <- File.getTime path
942 source <- File.readUtf8 path
943 case Parse.fromByteString pkg source of
944 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
945 do let deps = map Src.getImportName imports
946 let local = Details.Local path time deps (any isMain values)
947 crawlDeps env mvar deps (SOutsideOk local source modul)
949 Left syntaxError ->
950 return $ SOutsideErr $
951 Error.Module "???" path time source (Error.BadSyntax syntaxError)
955-- CHECK MAINS
958data MainResult
959 = RInside ModuleName.Raw
960 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
961 | ROutsideErr Error.Module
962 | ROutsideBlocked
965checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
966checkMain env@(Env _ root _ _ _ _) results pendingMain =
967 case pendingMain of
968 SInside name ->
969 return (RInside name)
971 SOutsideErr err ->
972 return (ROutsideErr err)
974 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
975 do depsStatus <- checkDeps root results deps
976 case depsStatus of
977 DepsChange ifaces ->
978 return $ compileOutside env local source ifaces modul
980 DepsSame same cached ->
981 do maybeLoaded <- checkCachedInterfaces root cached
982 case maybeLoaded of
983 Nothing ->
984 return ROutsideBlocked
986 Just loaded ->
987 do let ifaces = Map.union loaded (Map.fromList same)
988 return $ compileOutside env local source ifaces modul
990 DepsBlock ->
991 return ROutsideBlocked
993 DepsNotFound problems ->
994 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
995 Error.BadImports (toImportErrors env results imports problems)
998compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
999compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1000 let
1001 name = Src.getName modul
1002 in
1003 case Compile.compile pkg ifaces modul of
1004 Right (Compile.Artifacts canonical annotations objects) ->
1005 ROutsideOk name (I.fromModule pkg canonical annotations) objects
1007 Left errors ->
1008 ROutsideErr $
1009 Error.Module name path time source errors
1013-- TO ARTIFACTS
1016data Main
1017 = Inside ModuleName.Raw
1018 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1021toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1022toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1023 case gatherProblemsOrMains results mainResults of
1024 Left (NE.List e es) ->
1025 Left (Exit.BuildModuleProblems e es)
1027 Right mains ->
1028 Right $ Artifacts pkg foreigns mains $
1029 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1032gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1033gatherProblemsOrMains results (NE.List mainResult mainResults) =
1034 let
1035 sortMain result (es, mains) =
1036 case result of
1037 RInside n -> ( es, Inside n : mains)
1038 ROutsideOk n i o -> ( es, Outside n i o : mains)
1039 ROutsideErr e -> (e:es, mains)
1040 ROutsideBlocked -> ( es, mains)
1042 errors = Map.foldr addErrors [] results
1043 in
1044 case (mainResult, foldr sortMain (errors, []) mainResults) of
1045 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1046 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1047 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1048 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1049 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1050 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1051 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1054addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1055addInside name result modules =
1056 case result of
1057 RNew _ iface objs _ -> Fresh name iface objs : modules
1058 RSame _ iface objs _ -> Fresh name iface objs : modules
1059 RCached main mvar -> Cached name main mvar : modules
1060 RNotFound _ -> error (badInside name)
1061 RProblem _ -> error (badInside name)
1062 RBlocked -> error (badInside name)
1063 RForeign _ -> modules
1064 RKernel -> modules
1067badInside :: ModuleName.Raw -> [Char]
1068badInside name =
1069 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1072addOutside :: MainResult -> [Module] -> [Module]
1073addOutside main modules =
1074 case main of
1075 RInside _ -> modules
1076 ROutsideOk name iface objs -> Fresh name iface objs : modules
1077 ROutsideErr _ -> modules
1078 ROutsideBlocked -> modules