git.iko.soy/elk
on dcbe51f help sign in
elk/builder/src/Build.hs
1177 lines 38 kB history raw
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3module Build
4 ( fromExposed
5 , fromMains
6 , fromRepl
7 , Artifacts(..)
8 , Main(..)
9 , Module(..)
10 , CachedInterface(..)
11 , ReplArtifacts(..)
12 , DocsGoal(..)
13 , getMainNames
14 )
15 where
18import Control.Concurrent (forkIO)
19import Control.Concurrent.MVar
20import Control.Monad (filterM, mapM_, sequence_)
21import qualified Data.ByteString as B
22import qualified Data.Char as Char
23import qualified Data.Either as Either
24import qualified Data.Graph as Graph
25import qualified Data.List as List
26import qualified Data.Map.Utils as Map
27import qualified Data.Map.Strict as Map
28import Data.Map.Strict ((!))
29import qualified Data.Maybe as Maybe
30import qualified Data.Name as Name
31import qualified Data.NonEmptyList as NE
32import qualified Data.OneOrMore as OneOrMore
33import qualified Data.Set as Set
34import qualified System.Directory as Dir
35import qualified System.FilePath as FP
36import System.FilePath ((</>), (<.>))
38import qualified AST.Canonical as Can
39import qualified AST.Source as Src
40import qualified AST.Optimized as Opt
41import qualified Compile
42import qualified Elm.Details as Details
43import qualified Elm.Docs as Docs
44import qualified Elm.Interface as I
45import qualified Elm.ModuleName as ModuleName
46import qualified Elm.Package as Pkg
47import qualified File
48import qualified Json.Encode as E
49import qualified Parse.Module as Parse
50import qualified Reporting
51import qualified Reporting.Annotation as A
52import qualified Reporting.Error as Error
53import qualified Reporting.Error.Syntax as Syntax
54import qualified Reporting.Error.Import as Import
55import qualified Reporting.Exit as Exit
56import qualified Reporting.Render.Type.Localizer as L
57import qualified Stuff
61-- ENVIRONMENT
64data Env =
65 Env
66 { _key :: Reporting.BKey
67 , _root :: FilePath
68 , _pkg :: Pkg.Name
69 , _srcDirs :: [FilePath]
70 , _locals :: Map.Map ModuleName.Raw Details.Local
71 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
72 }
75makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
76makeEnv key root (Details.Details _ validOutline locals foreigns _) =
77 case validOutline of
78 Details.ValidApp srcDirs ->
79 Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
81 Details.ValidPkg pkg _ ->
82 Env key root pkg ["src"] locals foreigns
86-- FORK
89fork :: IO a -> IO (MVar a)
90fork work =
91 do mvar <- newEmptyMVar
92 _ <- forkIO $ putMVar mvar =<< work
93 return mvar
96{-# INLINE forkWithKey #-}
97forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
98forkWithKey func dict =
99 Map.traverseWithKey (\k v -> fork (func k v)) dict
103-- FROM EXPOSED
106fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
107fromExposed style root details docsGoal exposed@(NE.List e es) =
108 Reporting.trackBuild style $ \key ->
109 do let env = makeEnv key root details
110 dmvar <- Details.loadInterfaces root details
112 -- crawl
113 mvar <- newEmptyMVar
114 let docsNeed = toDocsNeed docsGoal
115 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
116 putMVar mvar roots
117 mapM_ readMVar roots
118 statuses <- traverse readMVar =<< readMVar mvar
120 -- compile
121 midpoint <- checkMidpoint dmvar statuses
122 case midpoint of
123 Left problem ->
124 return (Left (Exit.BuildProjectProblem problem))
126 Right foreigns ->
127 do rmvar <- newEmptyMVar
128 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
129 putMVar rmvar resultMVars
130 results <- traverse readMVar resultMVars
131 writeDetails root details results
132 finalizeExposed docsGoal exposed results
136-- FROM MAINS
139data Artifacts =
140 Artifacts
141 { _name :: Pkg.Name
142 , _deps :: Dependencies
143 , _mains :: NE.List Main
144 , _modules :: [Module]
145 }
148data Module
149 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
150 | Cached ModuleName.Raw Bool (MVar CachedInterface)
153type Dependencies =
154 Map.Map ModuleName.Canonical I.DependencyInterface
157fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
158fromMains style root details paths =
159 Reporting.trackBuild style $ \key ->
160 do let env = makeEnv key root details
162 elmains <- findMains env paths
163 case elmains of
164 Left problem ->
165 return (Left (Exit.BuildProjectProblem problem))
167 Right lmains ->
168 do -- crawl
169 dmvar <- Details.loadInterfaces root details
170 smvar <- newMVar Map.empty
171 smainMVars <- traverse (fork . crawlMain env smvar) lmains
172 smains <- traverse readMVar smainMVars
173 statuses <- traverse readMVar =<< readMVar smvar
175 midpoint <- checkMainsMidpoint dmvar statuses smains
176 case midpoint of
177 Left problem ->
178 return (Left (Exit.BuildProjectProblem problem))
180 Right foreigns ->
181 do -- compile
182 rmvar <- newEmptyMVar
183 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
184 putMVar rmvar resultsMVars
185 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
186 results <- traverse readMVar resultsMVars
187 writeDetails root details results
188 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
192-- GET MAIN NAMES
195getMainNames :: Artifacts -> NE.List ModuleName.Raw
196getMainNames (Artifacts _ _ mains _) =
197 fmap getMainName mains
200getMainName :: Main -> ModuleName.Raw
201getMainName main =
202 case main of
203 Inside name -> name
204 Outside name _ _ -> name
208-- CRAWL
211type StatusDict =
212 Map.Map ModuleName.Raw (MVar Status)
215data Status
216 = SCached Details.Local
217 | SChanged Details.Local B.ByteString Src.Module DocsNeed
218 | SBadImport Import.Problem
219 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
220 | SForeign Pkg.Name
221 | SKernel
224crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
225crawlDeps env mvar deps blockedValue =
226 do statusDict <- takeMVar mvar
227 let depsDict = Map.fromKeys (\_ -> ()) deps
228 let newsDict = Map.difference depsDict statusDict
229 statuses <- Map.traverseWithKey crawlNew newsDict
230 putMVar mvar (Map.union statuses statusDict)
231 mapM_ readMVar statuses
232 return blockedValue
233 where
234 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
237crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
238crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
239 do let fileName = ModuleName.toFilePath name <.> "elm"
240 let inRoot path = File.exists (root </> path)
242 paths <- filterM inRoot (map (</> fileName) srcDirs)
244 case paths of
245 [path] ->
246 case Map.lookup name foreigns of
247 Just (Details.Foreign dep deps) ->
248 return $ SBadImport $ Import.Ambiguous path [] dep deps
250 Nothing ->
251 case Map.lookup name locals of
252 Nothing ->
253 crawlFile env mvar docsNeed name path
255 Just local@(Details.Local oldPath oldTime deps _) ->
256 if path /= oldPath
257 then crawlFile env mvar docsNeed name path
258 else
259 do newTime <- File.getTime path
260 if oldTime < newTime || needsDocs docsNeed
261 then crawlFile env mvar docsNeed name path
262 else crawlDeps env mvar deps (SCached local)
264 p1:p2:ps ->
265 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
267 [] ->
268 case Map.lookup name foreigns of
269 Just (Details.Foreign dep deps) ->
270 case deps of
271 [] ->
272 return $ SForeign dep
274 d:ds ->
275 return $ SBadImport $ Import.AmbiguousForeign dep d ds
277 Nothing ->
278 if Name.isKernel name && Pkg.isKernel pkg then
279 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
280 return $ if exists then SKernel else SBadImport Import.NotFound
281 else
282 return $ SBadImport Import.NotFound
285crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
286crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
287 do time <- File.getTime path
288 source <- File.readUtf8 (root </> path)
290 case Parse.fromByteString pkg source of
291 Left err ->
292 return $ SBadSyntax path time source err
294 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
295 case maybeActualName of
296 Nothing ->
297 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
299 Just name@(A.At _ actualName) ->
300 if expectedName == actualName then
301 let
302 deps = map Src.getImportName imports
303 local = Details.Local path time deps (any isMain values)
304 in
305 crawlDeps env mvar deps (SChanged local source modul docsNeed)
306 else
307 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
310isMain :: A.Located Src.Value -> Bool
311isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
312 name == Name._main
316-- CHECK MODULE
319type ResultDict =
320 Map.Map ModuleName.Raw (MVar Result)
323data Result
324 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
325 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
326 | RCached Bool (MVar CachedInterface)
327 | RNotFound Import.Problem
328 | RProblem Error.Module
329 | RBlocked
330 | RForeign I.Interface
331 | RKernel
334data CachedInterface
335 = Unneeded
336 | Loaded I.Interface
337 | Corrupted
340checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
341checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
342 case status of
343 SCached local@(Details.Local path time deps hasMain) ->
344 do results <- readMVar resultsMVar
345 depsStatus <- checkDeps root results deps
346 case depsStatus of
347 DepsChange ifaces ->
348 do source <- File.readUtf8 path
349 case Parse.fromByteString pkg source of
350 Right modul -> compile env (DocsNeed False) local source ifaces modul
351 Left err ->
352 return $ RProblem $
353 Error.Module name path time source (Error.BadSyntax err)
355 DepsSame _ _ ->
356 do mvar <- newMVar Unneeded
357 return (RCached hasMain mvar)
359 DepsBlock ->
360 return RBlocked
362 DepsNotFound problems ->
363 do source <- File.readUtf8 path
364 return $ RProblem $ Error.Module name path time source $
365 case Parse.fromByteString pkg source of
366 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
367 Error.BadImports (toImportErrors env results imports problems)
369 Left err ->
370 Error.BadSyntax err
372 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
373 do results <- readMVar resultsMVar
374 depsStatus <- checkDeps root results deps
375 case depsStatus of
376 DepsChange ifaces ->
377 compile env docsNeed local source ifaces modul
379 DepsSame same cached ->
380 do maybeLoaded <- loadInterfaces root same cached
381 case maybeLoaded of
382 Nothing -> return RBlocked
383 Just ifaces -> compile env docsNeed local source ifaces modul
385 DepsBlock ->
386 return RBlocked
388 DepsNotFound problems ->
389 return $ RProblem $ Error.Module name path time source $
390 Error.BadImports (toImportErrors env results imports problems)
392 SBadImport importProblem ->
393 return (RNotFound importProblem)
395 SBadSyntax path time source err ->
396 return $ RProblem $ Error.Module name path time source $
397 Error.BadSyntax err
399 SForeign home ->
400 case foreigns ! ModuleName.Canonical home name of
401 I.Public iface -> return (RForeign iface)
402 I.Private _ _ _ -> error "loading private interface in Build"
404 SKernel ->
405 return RKernel
409-- CHECK DEPS
412data DepsStatus
413 = DepsChange (Map.Map ModuleName.Raw I.Interface)
414 | DepsSame [Dep] [CDep]
415 | DepsBlock
416 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
419checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
420checkDeps root results deps =
421 checkDepsHelp root results deps [] [] [] [] False
424type Dep = (ModuleName.Raw, I.Interface)
425type CDep = (ModuleName.Raw, MVar CachedInterface)
428checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
429checkDepsHelp root results deps new same cached importProblems isBlocked =
430 case deps of
431 dep:otherDeps ->
432 do result <- readMVar (results ! dep)
433 case result of
434 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
435 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
436 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
437 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
438 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
439 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
440 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
441 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
443 [] ->
444 case importProblems of
445 p:ps ->
446 return $ DepsNotFound (NE.List p ps)
448 [] ->
449 if isBlocked then
450 return $ DepsBlock
452 else if null new then
453 return $ DepsSame same cached
455 else
456 do maybeLoaded <- loadInterfaces root same cached
457 case maybeLoaded of
458 Nothing -> return DepsBlock
459 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
463-- TO IMPORT ERROR
466toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
467toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
468 let
469 knownModules =
470 Set.unions
471 [ Map.keysSet foreigns
472 , Map.keysSet locals
473 , Map.keysSet results
474 ]
476 unimportedModules =
477 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
479 regionDict =
480 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
482 toError (name, problem) =
483 Import.Error (regionDict ! name) name unimportedModules problem
484 in
485 fmap toError problems
489-- LOAD CACHED INTERFACES
492loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
493loadInterfaces root same cached =
494 do loading <- traverse (fork . loadInterface root) cached
495 maybeLoaded <- traverse readMVar loading
496 case sequence maybeLoaded of
497 Nothing ->
498 return Nothing
500 Just loaded ->
501 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
504loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
505loadInterface 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
532checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
533checkMidpoint 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 let path = Stuff.elmi root name
669 File.writeBinary (Stuff.elmo root name) objects
670 maybeOldi <- File.readBinary path
671 case maybeOldi of
672 Just oldi | oldi == iface ->
673 do -- iface should be fully forced by equality check
674 Reporting.report key Reporting.BDone
675 return (RSame local iface objects docs)
677 _ ->
678 do -- iface may be lazy still
679 File.writeBinary path 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.BuildBadModules 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------ NOW FOR SOME REPL STUFF -------------------------------------------------
815--------------------------------------------------------------------------------
818-- FROM REPL
821data ReplArtifacts =
822 ReplArtifacts
823 { _repl_home :: ModuleName.Canonical
824 , _repl_modules :: [Module]
825 , _repl_localizer :: L.Localizer
826 , _repl_annotations :: Map.Map Name.Name Can.Annotation
827 }
830fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
831fromRepl root details source =
832 let
833 env@(Env _ _ pkg _ _ _) = makeEnv Reporting.ignorer root details
834 in
835 case Parse.fromByteString pkg source of
836 Left syntaxError ->
837 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
839 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
840 do dmvar <- Details.loadInterfaces root details
842 let deps = map Src.getImportName imports
843 mvar <- newMVar Map.empty
844 crawlDeps env mvar deps ()
846 statuses <- traverse readMVar =<< readMVar mvar
847 midpoint <- checkMidpoint dmvar statuses
849 case midpoint of
850 Left problem ->
851 return $ Left $ Exit.ReplProjectProblem problem
853 Right foreigns ->
854 do rmvar <- newEmptyMVar
855 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
856 putMVar rmvar resultMVars
857 results <- traverse readMVar resultMVars
858 writeDetails root details results
859 depsStatus <- checkDeps root resultMVars deps
860 finalizeReplArtifacts env source modul depsStatus resultMVars results
863finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
864finalizeReplArtifacts env@(Env _ root pkg _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
865 let
866 compileInput ifaces =
867 case Compile.compile pkg ifaces modul of
868 Right (Compile.Artifacts canonical annotations objects) ->
869 let
870 h = Can._name canonical
871 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
872 ms = Map.foldrWithKey addInside [] results
873 in
874 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
876 Left errors ->
877 return $ Left $ Exit.ReplBadInput source errors
878 in
879 case depsStatus of
880 DepsChange ifaces ->
881 compileInput ifaces
883 DepsSame same cached ->
884 do maybeLoaded <- loadInterfaces root same cached
885 case maybeLoaded of
886 Just ifaces -> compileInput ifaces
887 Nothing -> return $ Left $ Exit.ReplBadCache
889 DepsBlock ->
890 case Map.foldr addErrors [] results of
891 [] -> return $ Left $ Exit.ReplBlocked
892 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
894 DepsNotFound problems ->
895 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
896 toImportErrors env resultMVars imports problems
900--------------------------------------------------------------------------------
901--------------------------------------------------------------------------------
902------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
903--------------------------------------------------------------------------------
904--------------------------------------------------------------------------------
908-- FIND MAIN
911data MainLocation
912 = LInside ModuleName.Raw
913 | LOutside FilePath
916findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
917findMains env paths =
918 do mvars <- traverse (fork . findLocation env) paths
919 elocs <- traverse readMVar mvars
920 return $ checkLocations =<< sequence elocs
923checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
924checkLocations locations =
925 let
926 toOneOrMore loc@(Location absolute _ _) =
927 (absolute, OneOrMore.one loc)
929 fromOneOrMore loc locs =
930 case locs of
931 [] -> Right ()
932 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
933 in
934 fmap (\_ -> fmap _location locations) $
935 traverse (OneOrMore.destruct fromOneOrMore) $
936 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
940-- LOCATIONS
943data Location =
944 Location
945 { _absolute :: FilePath
946 , _relative :: FilePath
947 , _location :: MainLocation
948 }
951findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
952findLocation env path =
953 do exists <- File.exists path
954 if exists
955 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
956 else return (Left (Exit.BP_PathUnknown path))
959isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
960isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
961 let
962 (dirs, file) = FP.splitFileName absolutePath
963 (final, ext) = break (=='.') file
964 in
965 if ext /= ".elm"
966 then Left (Exit.BP_WithBadExtension path)
967 else
968 let
969 roots = FP.splitDirectories root
970 segments = FP.splitDirectories dirs ++ [final]
971 in
972 case dropPrefix roots segments of
973 Nothing ->
974 Right (Location absolutePath path (LOutside path))
976 Just relativeSegments ->
977 let
978 (exits, maybes) =
979 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
980 in
981 -- TODO make sure this is all correct
982 case (exits, Maybe.catMaybes maybes) of
983 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
984 ([], []) -> Right (Location absolutePath path (LOutside path))
985 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir path s1 s2)
986 (exit:_, _) -> Left exit
989isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
990isInsideSrcDirsHelp segments srcDir =
991 case dropPrefix (FP.splitDirectories srcDir) segments of
992 Nothing ->
993 Right Nothing
995 Just names ->
996 if all isGoodName names
997 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
998 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
1001isGoodName :: [Char] -> Bool
1002isGoodName name =
1003 case name of
1004 [] ->
1005 False
1007 char:chars ->
1008 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1011dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1012dropPrefix roots paths =
1013 case roots of
1014 [] ->
1015 Just paths
1017 r:rs ->
1018 case paths of
1019 [] -> Nothing
1020 p:ps -> if r == p then dropPrefix rs ps else Nothing
1024-- CRAWL MAINS
1027data MainStatus
1028 = SInside ModuleName.Raw
1029 | SOutsideOk Details.Local B.ByteString Src.Module
1030 | SOutsideErr Error.Module
1033crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1034crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1035 case given of
1036 LInside name ->
1037 do statusMVar <- newEmptyMVar
1038 statusDict <- takeMVar mvar
1039 putMVar mvar (Map.insert name statusMVar statusDict)
1040 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1041 return (SInside name)
1043 LOutside path ->
1044 do time <- File.getTime path
1045 source <- File.readUtf8 path
1046 case Parse.fromByteString pkg source of
1047 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1048 do let deps = map Src.getImportName imports
1049 let local = Details.Local path time deps (any isMain values)
1050 crawlDeps env mvar deps (SOutsideOk local source modul)
1052 Left syntaxError ->
1053 return $ SOutsideErr $
1054 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1058-- CHECK MAINS
1061data MainResult
1062 = RInside ModuleName.Raw
1063 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1064 | ROutsideErr Error.Module
1065 | ROutsideBlocked
1068checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1069checkMain env@(Env _ root _ _ _ _) results pendingMain =
1070 case pendingMain of
1071 SInside name ->
1072 return (RInside name)
1074 SOutsideErr err ->
1075 return (ROutsideErr err)
1077 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1078 do depsStatus <- checkDeps root results deps
1079 case depsStatus of
1080 DepsChange ifaces ->
1081 return $ compileOutside env local source ifaces modul
1083 DepsSame same cached ->
1084 do maybeLoaded <- loadInterfaces root same cached
1085 case maybeLoaded of
1086 Nothing -> return ROutsideBlocked
1087 Just ifaces -> return $ compileOutside env local source ifaces modul
1089 DepsBlock ->
1090 return ROutsideBlocked
1092 DepsNotFound problems ->
1093 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1094 Error.BadImports (toImportErrors env results imports problems)
1097compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
1098compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1099 let
1100 name = Src.getName modul
1101 in
1102 case Compile.compile pkg ifaces modul of
1103 Right (Compile.Artifacts canonical annotations objects) ->
1104 ROutsideOk name (I.fromModule pkg canonical annotations) objects
1106 Left errors ->
1107 ROutsideErr $
1108 Error.Module name path time source errors
1112-- TO ARTIFACTS
1115data Main
1116 = Inside ModuleName.Raw
1117 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1120toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1121toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1122 case gatherProblemsOrMains results mainResults of
1123 Left (NE.List e es) ->
1124 Left (Exit.BuildBadModules e es)
1126 Right mains ->
1127 Right $ Artifacts pkg foreigns mains $
1128 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1131gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1132gatherProblemsOrMains results (NE.List mainResult mainResults) =
1133 let
1134 sortMain result (es, mains) =
1135 case result of
1136 RInside n -> ( es, Inside n : mains)
1137 ROutsideOk n i o -> ( es, Outside n i o : mains)
1138 ROutsideErr e -> (e:es, mains)
1139 ROutsideBlocked -> ( es, mains)
1141 errors = Map.foldr addErrors [] results
1142 in
1143 case (mainResult, foldr sortMain (errors, []) mainResults) of
1144 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1145 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1146 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1147 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1148 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1149 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1150 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1153addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1154addInside name result modules =
1155 case result of
1156 RNew _ iface objs _ -> Fresh name iface objs : modules
1157 RSame _ iface objs _ -> Fresh name iface objs : modules
1158 RCached main mvar -> Cached name main mvar : modules
1159 RNotFound _ -> error (badInside name)
1160 RProblem _ -> error (badInside name)
1161 RBlocked -> error (badInside name)
1162 RForeign _ -> modules
1163 RKernel -> modules
1166badInside :: ModuleName.Raw -> [Char]
1167badInside name =
1168 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1171addOutside :: MainResult -> [Module] -> [Module]
1172addOutside main modules =
1173 case main of
1174 RInside _ -> modules
1175 ROutsideOk name iface objs -> Fresh name iface objs : modules
1176 ROutsideErr _ -> modules
1177 ROutsideBlocked -> modules