git.iko.soy/elk
on ef0a3da help sign in
elk/builder/src/Build.hs
1094 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 , getMainNames
12 )
13 where
16import Control.Concurrent (forkIO)
17import Control.Concurrent.MVar
18import Control.Monad (filterM, mapM_, sequence_)
19import qualified Data.ByteString as B
20import qualified Data.Char as Char
21import qualified Data.Either as Either
22import qualified Data.Graph as Graph
23import qualified Data.List as List
24import qualified Data.Map.Utils as Map
25import qualified Data.Map.Strict as Map
26import Data.Map.Strict ((!))
27import qualified Data.Maybe as Maybe
28import qualified Data.Name as Name
29import qualified Data.NonEmptyList as NE
30import qualified Data.OneOrMore as OneOrMore
31import qualified Data.Set as Set
32import qualified System.Directory as Dir
33import qualified System.FilePath as FP
34import System.FilePath ((</>), (<.>))
36import qualified AST.Canonical as Can
37import qualified AST.Source as Src
38import qualified AST.Optimized as Opt
39import qualified Compile
40import qualified Elm.Details as Details
41import qualified Elm.Docs as Docs
42import qualified Elm.Interface as I
43import qualified Elm.ModuleName as ModuleName
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-- GET MAIN NAMES
192getMainNames :: Artifacts -> NE.List ModuleName.Raw
193getMainNames (Artifacts _ _ mains _) =
194 fmap getMainName mains
197getMainName :: Main -> ModuleName.Raw
198getMainName main =
199 case main of
200 Inside name -> name
201 Outside name _ _ -> name
205-- CRAWL
208type StatusDict =
209 Map.Map ModuleName.Raw (MVar Status)
212data Status
213 = SCached Details.Local
214 | SChanged Details.Local B.ByteString Src.Module DocsNeed
215 | SBadImport Import.Problem
216 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
217 | SForeign Pkg.Name
218 | SKernel
221crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
222crawlDeps env mvar deps blockedValue =
223 do statusDict <- takeMVar mvar
224 let depsDict = Map.fromKeys (\_ -> ()) deps
225 let newsDict = Map.difference depsDict statusDict
226 statuses <- Map.traverseWithKey crawlNew newsDict
227 putMVar mvar (Map.union statuses statusDict)
228 mapM_ readMVar statuses
229 return blockedValue
230 where
231 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
234crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
235crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
236 do let fileName = ModuleName.toFilePath name <.> "elm"
237 let inRoot path = File.exists (root </> path)
239 paths <- filterM inRoot (map (</> fileName) srcDirs)
241 case paths of
242 [path] ->
243 case Map.lookup name foreigns of
244 Just (Details.Foreign dep deps) ->
245 return $ SBadImport $ Import.Ambiguous path [] dep deps
247 Nothing ->
248 case Map.lookup name locals of
249 Nothing ->
250 crawlFile env mvar docsNeed name path
252 Just local@(Details.Local oldPath oldTime deps _) ->
253 if path /= oldPath
254 then crawlFile env mvar docsNeed name path
255 else
256 do newTime <- File.getTime path
257 if oldTime < newTime || needsDocs docsNeed
258 then crawlFile env mvar docsNeed name path
259 else crawlDeps env mvar deps (SCached local)
261 p1:p2:ps ->
262 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
264 [] ->
265 case Map.lookup name foreigns of
266 Just (Details.Foreign dep deps) ->
267 case deps of
268 [] ->
269 return $ SForeign dep
271 d:ds ->
272 return $ SBadImport $ Import.AmbiguousForeign dep d ds
274 Nothing ->
275 if Name.isKernel name && Pkg.isKernel pkg then
276 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
277 return $ if exists then SKernel else SBadImport Import.NotFound
278 else
279 return $ SBadImport Import.NotFound
282crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
283crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
284 do time <- File.getTime path
285 source <- File.readUtf8 (root </> path)
287 case Parse.fromByteString pkg source of
288 Left err ->
289 return $ SBadSyntax path time source err
291 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
292 case maybeActualName of
293 Nothing ->
294 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
296 Just name@(A.At _ actualName) ->
297 if expectedName == actualName then
298 let
299 deps = map Src.getImportName imports
300 local = Details.Local path time deps (any isMain values)
301 in
302 crawlDeps env mvar deps (SChanged local source modul docsNeed)
303 else
304 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
307isMain :: A.Located Src.Value -> Bool
308isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
309 name == Name._main
313-- CHECK MODULE
316type ResultDict =
317 Map.Map ModuleName.Raw (MVar Result)
320data Result
321 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
322 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
323 | RCached Bool (MVar CachedInterface)
324 | RNotFound Import.Problem
325 | RProblem Error.Module
326 | RBlocked
327 | RForeign I.Interface
328 | RKernel
331data CachedInterface
332 = Unneeded
333 | Loaded I.Interface
334 | Corrupted
337checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
338checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
339 case status of
340 SCached local@(Details.Local path time deps hasMain) ->
341 do results <- readMVar resultsMVar
342 depsStatus <- checkDeps root results deps
343 case depsStatus of
344 DepsChange ifaces ->
345 do source <- File.readUtf8 path
346 case Parse.fromByteString pkg source of
347 Right modul -> compile env (DocsNeed False) local source ifaces modul
348 Left err ->
349 return $ RProblem $
350 Error.Module name path time source (Error.BadSyntax err)
352 DepsSame _ _ ->
353 do mvar <- newMVar Unneeded
354 return (RCached hasMain mvar)
356 DepsBlock ->
357 return RBlocked
359 DepsNotFound problems ->
360 do source <- File.readUtf8 path
361 return $ RProblem $ Error.Module name path time source $
362 case Parse.fromByteString pkg source of
363 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
364 Error.BadImports (toImportErrors env results imports problems)
366 Left err ->
367 Error.BadSyntax err
369 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
370 do results <- readMVar resultsMVar
371 depsStatus <- checkDeps root results deps
372 case depsStatus of
373 DepsChange ifaces ->
374 compile env docsNeed local source ifaces modul
376 DepsSame same cached ->
377 do maybeLoaded <- checkCachedInterfaces root cached
378 case maybeLoaded of
379 Nothing ->
380 return RBlocked
382 Just loaded ->
383 do let ifaces = Map.union loaded (Map.fromList same)
384 compile env docsNeed local source ifaces modul
386 DepsBlock ->
387 return RBlocked
389 DepsNotFound problems ->
390 return $ RProblem $ Error.Module name path time source $
391 Error.BadImports (toImportErrors env results imports problems)
393 SBadImport importProblem ->
394 return (RNotFound importProblem)
396 SBadSyntax path time source err ->
397 return $ RProblem $ Error.Module name path time source $
398 Error.BadSyntax err
400 SForeign home ->
401 case foreigns ! ModuleName.Canonical home name of
402 I.Public iface -> return (RForeign iface)
403 I.Private _ _ _ -> error "loading private interface in Build"
405 SKernel ->
406 return RKernel
410-- CHECK DEPS
413data DepsStatus
414 = DepsChange (Map.Map ModuleName.Raw I.Interface)
415 | DepsSame [Dep] [CDep]
416 | DepsBlock
417 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
420checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
421checkDeps root results deps =
422 checkDepsHelp root results deps [] [] [] [] False
425type Dep = (ModuleName.Raw, I.Interface)
426type CDep = (ModuleName.Raw, MVar CachedInterface)
429checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
430checkDepsHelp root results deps new same cached importProblems isBlocked =
431 case deps of
432 dep:otherDeps ->
433 do result <- readMVar (results ! dep)
434 case result of
435 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
436 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
437 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
438 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
439 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
440 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
441 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
442 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
444 [] ->
445 case importProblems of
446 p:ps ->
447 return $ DepsNotFound (NE.List p ps)
449 [] ->
450 if isBlocked then
451 return $ DepsBlock
453 else if null new then
454 return $ DepsSame same cached
456 else
457 do maybeLoaded <- checkCachedInterfaces root cached
458 case maybeLoaded of
459 Nothing ->
460 return DepsBlock
462 Just loaded ->
463 return $ DepsChange $
464 Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
468-- TO IMPORT ERROR
471toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
472toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
473 let
474 knownModules =
475 Set.unions
476 [ Map.keysSet foreigns
477 , Map.keysSet locals
478 , Map.keysSet results
479 ]
481 unimportedModules =
482 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
484 regionDict =
485 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
487 toError (name, problem) =
488 Import.Error (regionDict ! name) name unimportedModules problem
489 in
490 fmap toError problems
494-- CACHED INTERFACE
497checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
498checkCachedInterfaces root deps =
499 do loading <- traverse (fork . checkCache root) deps
500 loaded <- traverse readMVar loading
501 return $ Map.fromList <$> sequence loaded
504checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
505checkCache root (name, ciMvar) =
506 do cachedInterface <- takeMVar ciMvar
507 case cachedInterface of
508 Corrupted ->
509 do putMVar ciMvar cachedInterface
510 return Nothing
512 Loaded iface ->
513 do putMVar ciMvar cachedInterface
514 return (Just (name, iface))
516 Unneeded ->
517 do maybeIface <- File.readBinary (Stuff.elmi root name)
518 case maybeIface of
519 Nothing ->
520 do putMVar ciMvar Corrupted
521 return Nothing
523 Just iface ->
524 do putMVar ciMvar (Loaded iface)
525 return (Just (name, iface))
529-- CHECK PROJECT
532checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
533checkExposedMidpoint dmvar statuses =
534 case checkForCycles statuses 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 (NE.List name names) ->
542 do _ <- readMVar dmvar
543 return (Left (Exit.BP_Cycle name names))
546checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
547checkMainsMidpoint dmvar statuses smains =
548 case checkForCycles statuses of
549 Nothing ->
550 case checkUniqueMains statuses smains of
551 Nothing ->
552 do maybeForeigns <- readMVar dmvar
553 case maybeForeigns of
554 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
555 Just fs -> return (Right fs)
557 Just problem ->
558 do _ <- readMVar dmvar
559 return (Left problem)
561 Just (NE.List name names) ->
562 do _ <- readMVar dmvar
563 return (Left (Exit.BP_Cycle name names))
567-- CHECK FOR CYCLES
570checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
571checkForCycles modules =
572 let
573 !graph = Map.foldrWithKey addToGraph [] modules
574 !sccs = Graph.stronglyConnComp graph
575 in
576 checkForCyclesHelp sccs
579checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
580checkForCyclesHelp sccs =
581 case sccs of
582 [] ->
583 Nothing
585 scc:otherSccs ->
586 case scc of
587 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
588 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
589 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
592type Node =
593 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
596addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
597addToGraph name status graph =
598 let
599 dependencies =
600 case status of
601 SCached (Details.Local _ _ deps _) -> deps
602 SChanged (Details.Local _ _ deps _) _ _ _ -> deps
603 SBadImport _ -> []
604 SBadSyntax _ _ _ _ -> []
605 SForeign _ -> []
606 SKernel -> []
607 in
608 (name, name, dependencies) : graph
612-- CHECK UNIQUE MAINS
615checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
616checkUniqueMains insides smains =
617 let
618 outsidesDict =
619 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
620 in
621 case Map.traverseWithKey checkOutside outsidesDict of
622 Left problem ->
623 Just problem
625 Right outsides ->
626 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
627 Right () -> Nothing
628 Left problem -> Just problem
631mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
632mainStatusToNamePathPair smain =
633 case smain of
634 SInside _ -> Nothing
635 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
636 SOutsideErr _ -> Nothing
639checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
640checkOutside name paths =
641 case OneOrMore.destruct NE.List paths of
642 NE.List p [] -> Right p
643 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
646checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
647checkInside name p1 status =
648 case status of
649 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
650 SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
651 SBadImport _ -> Right ()
652 SBadSyntax _ _ _ _ -> Right ()
653 SForeign _ -> Right ()
654 SKernel -> Right ()
658-- COMPILE MODULE
661compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
662compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
663 case Compile.compile pkg ifaces modul of
664 Right (Compile.Artifacts canonical annotations objects) ->
665 do let name = Src.getName modul
666 let iface = I.fromModule pkg canonical annotations
667 let docs = makeDocs docsNeed canonical
668 File.writeBinary (Stuff.elmo root name) objects
669 maybeOldi <- File.readBinary (Stuff.elmi root name)
670 case maybeOldi of
671 Just oldi | oldi == iface ->
672 do -- iface should be fully forced by equality check
673 Reporting.report key Reporting.BDone
674 return (RSame local iface objects docs)
676 _ ->
677 do -- iface may be lazy still
678 -- TODO try adding forkIO here
679 File.writeBinary (Stuff.elmi root name) iface
680 Reporting.report key Reporting.BDone
681 return (RNew local iface objects docs)
683 Left err ->
684 do Reporting.report key Reporting.BDone
685 return $ RProblem $
686 Error.Module (Src.getName modul) path time source err
690-- WRITE DETAILS
693writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
694writeDetails root (Details.Details time outline locals foreigns extras) results =
695 File.writeBinary (Stuff.details root) $
696 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
699addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
700addNewLocal name result locals =
701 case result of
702 RNew local _ _ _ -> Map.insert name local locals
703 RSame local _ _ _ -> Map.insert name local locals
704 RCached _ _ -> locals
705 RNotFound _ -> locals
706 RProblem _ -> locals
707 RBlocked -> locals
708 RForeign _ -> locals
709 RKernel -> locals
713-- FINALIZE EXPOSED
716finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
717finalizeExposed docsGoal exposed results =
718 case foldr (addImportProblems results) [] (NE.toList exposed) of
719 p:ps ->
720 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
722 [] ->
723 case Map.foldr addErrors [] results of
724 [] -> Right <$> finalizeDocs docsGoal results
725 e:es -> return $ Left $ Exit.BuildModuleProblems e es
728addErrors :: Result -> [Error.Module] -> [Error.Module]
729addErrors result errors =
730 case result of
731 RNew _ _ _ _ -> errors
732 RSame _ _ _ _ -> errors
733 RCached _ _ -> errors
734 RNotFound _ -> errors
735 RProblem e -> e:errors
736 RBlocked -> errors
737 RForeign _ -> errors
738 RKernel -> errors
741addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
742addImportProblems results name problems =
743 case results ! name of
744 RNew _ _ _ _ -> problems
745 RSame _ _ _ _ -> problems
746 RCached _ _ -> problems
747 RNotFound p -> (name, p) : problems
748 RProblem _ -> problems
749 RBlocked -> problems
750 RForeign _ -> problems
751 RKernel -> problems
755-- DOCS
758data DocsGoal a where
759 KeepDocs :: DocsGoal Docs.Documentation
760 WriteDocs :: FilePath -> DocsGoal ()
761 IgnoreDocs :: DocsGoal ()
764newtype DocsNeed =
765 DocsNeed { needsDocs :: Bool }
768toDocsNeed :: DocsGoal a -> DocsNeed
769toDocsNeed goal =
770 case goal of
771 IgnoreDocs -> DocsNeed False
772 WriteDocs _ -> DocsNeed True
773 KeepDocs -> DocsNeed True
776makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
777makeDocs (DocsNeed isNeeded) modul =
778 if isNeeded then
779 case Docs.fromModule modul of
780 Right docs -> Just docs
781 Left _ -> Nothing
782 else
783 Nothing
786finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
787finalizeDocs goal results =
788 case goal of
789 KeepDocs ->
790 return $ Map.mapMaybe toDocs results
792 WriteDocs path ->
793 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
795 IgnoreDocs ->
796 return ()
799toDocs :: Result -> Maybe Docs.Module
800toDocs result =
801 case result of
802 RNew _ _ _ d -> d
803 RSame _ _ _ d -> d
804 RCached _ _ -> Nothing
805 RNotFound _ -> Nothing
806 RProblem _ -> Nothing
807 RBlocked -> Nothing
808 RForeign _ -> Nothing
809 RKernel -> Nothing
813--------------------------------------------------------------------------------
814--------------------------------------------------------------------------------
815------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
816--------------------------------------------------------------------------------
817--------------------------------------------------------------------------------
821-- FIND MAIN
824data MainLocation
825 = LInside ModuleName.Raw
826 | LOutside FilePath
829findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
830findMains env paths =
831 do mvars <- traverse (fork . findLocation env) paths
832 elocs <- traverse readMVar mvars
833 return $ checkLocations =<< sequence elocs
836checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
837checkLocations locations =
838 let
839 toOneOrMore loc@(Location absolute _ _) =
840 (absolute, OneOrMore.one loc)
842 fromOneOrMore loc locs =
843 case locs of
844 [] -> Right ()
845 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
846 in
847 fmap (\_ -> fmap _location locations) $
848 traverse (OneOrMore.destruct fromOneOrMore) $
849 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
853-- LOCATIONS
856data Location =
857 Location
858 { _absolute :: FilePath
859 , _relative :: FilePath
860 , _location :: MainLocation
861 }
864findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
865findLocation env path =
866 do exists <- File.exists path
867 if exists
868 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
869 else return (Left (Exit.BP_PathUnknown path))
872isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
873isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
874 let
875 (dirs, file) = FP.splitFileName absolutePath
876 (final, ext) = break (=='.') file
877 in
878 if ext /= ".elm"
879 then Left (Exit.BP_WithBadExtension path)
880 else
881 let
882 roots = FP.splitDirectories root
883 segments = FP.splitDirectories dirs ++ [final]
884 in
885 case dropPrefix roots segments of
886 Nothing ->
887 Right (Location absolutePath path (LOutside path))
889 Just relativeSegments ->
890 let
891 (exits, maybes) =
892 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
893 in
894 -- TODO make sure this is all correct
895 case (exits, Maybe.catMaybes maybes) of
896 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
897 ([], []) -> Right (Location absolutePath path (LOutside path))
898 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir path s1 s2)
899 (exit:_, _) -> Left exit
902isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
903isInsideSrcDirsHelp segments srcDir =
904 case dropPrefix (FP.splitDirectories srcDir) segments of
905 Nothing ->
906 Right Nothing
908 Just names ->
909 if all isGoodName names
910 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
911 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
914isGoodName :: [Char] -> Bool
915isGoodName name =
916 case name of
917 [] ->
918 False
920 char:chars ->
921 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
924dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
925dropPrefix roots paths =
926 case roots of
927 [] ->
928 Just paths
930 r:rs ->
931 case paths of
932 [] -> Nothing
933 p:ps -> if r == p then dropPrefix rs ps else Nothing
937-- CRAWL MAINS
940data MainStatus
941 = SInside ModuleName.Raw
942 | SOutsideOk Details.Local B.ByteString Src.Module
943 | SOutsideErr Error.Module
946crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
947crawlMain env@(Env _ _ pkg _ _ _) mvar given =
948 case given of
949 LInside name ->
950 do statusMVar <- newEmptyMVar
951 statusDict <- takeMVar mvar
952 putMVar mvar (Map.insert name statusMVar statusDict)
953 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
954 return (SInside name)
956 LOutside path ->
957 do time <- File.getTime path
958 source <- File.readUtf8 path
959 case Parse.fromByteString pkg source of
960 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
961 do let deps = map Src.getImportName imports
962 let local = Details.Local path time deps (any isMain values)
963 crawlDeps env mvar deps (SOutsideOk local source modul)
965 Left syntaxError ->
966 return $ SOutsideErr $
967 Error.Module "???" path time source (Error.BadSyntax syntaxError)
971-- CHECK MAINS
974data MainResult
975 = RInside ModuleName.Raw
976 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
977 | ROutsideErr Error.Module
978 | ROutsideBlocked
981checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
982checkMain env@(Env _ root _ _ _ _) results pendingMain =
983 case pendingMain of
984 SInside name ->
985 return (RInside name)
987 SOutsideErr err ->
988 return (ROutsideErr err)
990 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
991 do depsStatus <- checkDeps root results deps
992 case depsStatus of
993 DepsChange ifaces ->
994 return $ compileOutside env local source ifaces modul
996 DepsSame same cached ->
997 do maybeLoaded <- checkCachedInterfaces root cached
998 case maybeLoaded of
999 Nothing ->
1000 return ROutsideBlocked
1002 Just loaded ->
1003 do let ifaces = Map.union loaded (Map.fromList same)
1004 return $ compileOutside env local source ifaces modul
1006 DepsBlock ->
1007 return ROutsideBlocked
1009 DepsNotFound problems ->
1010 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1011 Error.BadImports (toImportErrors env results imports problems)
1014compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
1015compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1016 let
1017 name = Src.getName modul
1018 in
1019 case Compile.compile pkg ifaces modul of
1020 Right (Compile.Artifacts canonical annotations objects) ->
1021 ROutsideOk name (I.fromModule pkg canonical annotations) objects
1023 Left errors ->
1024 ROutsideErr $
1025 Error.Module name path time source errors
1029-- TO ARTIFACTS
1032data Main
1033 = Inside ModuleName.Raw
1034 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1037toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1038toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1039 case gatherProblemsOrMains results mainResults of
1040 Left (NE.List e es) ->
1041 Left (Exit.BuildModuleProblems e es)
1043 Right mains ->
1044 Right $ Artifacts pkg foreigns mains $
1045 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1048gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1049gatherProblemsOrMains results (NE.List mainResult mainResults) =
1050 let
1051 sortMain result (es, mains) =
1052 case result of
1053 RInside n -> ( es, Inside n : mains)
1054 ROutsideOk n i o -> ( es, Outside n i o : mains)
1055 ROutsideErr e -> (e:es, mains)
1056 ROutsideBlocked -> ( es, mains)
1058 errors = Map.foldr addErrors [] results
1059 in
1060 case (mainResult, foldr sortMain (errors, []) mainResults) of
1061 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1062 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1063 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1064 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1065 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1066 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1067 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1070addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1071addInside name result modules =
1072 case result of
1073 RNew _ iface objs _ -> Fresh name iface objs : modules
1074 RSame _ iface objs _ -> Fresh name iface objs : modules
1075 RCached main mvar -> Cached name main mvar : modules
1076 RNotFound _ -> error (badInside name)
1077 RProblem _ -> error (badInside name)
1078 RBlocked -> error (badInside name)
1079 RForeign _ -> modules
1080 RKernel -> modules
1083badInside :: ModuleName.Raw -> [Char]
1084badInside name =
1085 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1088addOutside :: MainResult -> [Module] -> [Module]
1089addOutside main modules =
1090 case main of
1091 RInside _ -> modules
1092 ROutsideOk name iface objs -> Fresh name iface objs : modules
1093 ROutsideErr _ -> modules
1094 ROutsideBlocked -> modules