git.iko.soy/elk
on 6c19c6e help sign in
elk/builder/src/Build.hs
1174 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.Graph as Graph
24import qualified Data.List as List
25import qualified Data.Map.Utils as Map
26import qualified Data.Map.Strict as Map
27import Data.Map.Strict ((!))
28import qualified Data.Maybe as Maybe
29import qualified Data.Name as Name
30import qualified Data.NonEmptyList as NE
31import qualified Data.OneOrMore as OneOrMore
32import qualified Data.Set as Set
33import qualified System.Directory as Dir
34import qualified System.FilePath as FP
35import System.FilePath ((</>), (<.>))
37import qualified AST.Canonical as Can
38import qualified AST.Source as Src
39import qualified AST.Optimized as Opt
40import qualified Compile
41import qualified Elm.Details as Details
42import qualified Elm.Docs as Docs
43import qualified Elm.Interface as I
44import qualified Elm.ModuleName as ModuleName
45import qualified Elm.Package as Pkg
46import qualified File
47import qualified Json.Encode as E
48import qualified Parse.Module as Parse
49import qualified Reporting
50import qualified Reporting.Annotation as A
51import qualified Reporting.Error as Error
52import qualified Reporting.Error.Syntax as Syntax
53import qualified Reporting.Error.Import as Import
54import qualified Reporting.Exit as Exit
55import qualified Reporting.Render.Type.Localizer as L
56import qualified Stuff
60-- ENVIRONMENT
63data Env =
64 Env
65 { _key :: Reporting.BKey
66 , _root :: FilePath
67 , _pkg :: Pkg.Name
68 , _srcDirs :: [FilePath]
69 , _locals :: Map.Map ModuleName.Raw Details.Local
70 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
71 }
74makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
75makeEnv key root (Details.Details _ validOutline locals foreigns _) =
76 case validOutline of
77 Details.ValidApp srcDirs ->
78 Env key root Pkg.dummyName (NE.toList srcDirs) locals foreigns
80 Details.ValidPkg pkg _ _ ->
81 Env key root pkg ["src"] locals foreigns
85-- FORK
88-- PERF try using IORef semephore on file crawl phase?
89-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
90-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
91--
92fork :: IO a -> IO (MVar a)
93fork work =
94 do mvar <- newEmptyMVar
95 _ <- forkIO $ putMVar mvar =<< work
96 return mvar
99{-# INLINE forkWithKey #-}
100forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
101forkWithKey func dict =
102 Map.traverseWithKey (\k v -> fork (func k v)) dict
106-- FROM EXPOSED
109fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
110fromExposed style root details docsGoal exposed@(NE.List e es) =
111 Reporting.trackBuild style $ \key ->
112 do let env = makeEnv key root details
113 dmvar <- Details.loadInterfaces root details
115 -- crawl
116 mvar <- newEmptyMVar
117 let docsNeed = toDocsNeed docsGoal
118 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
119 putMVar mvar roots
120 mapM_ readMVar roots
121 statuses <- traverse readMVar =<< readMVar mvar
123 -- compile
124 midpoint <- checkMidpoint dmvar statuses
125 case midpoint of
126 Left problem ->
127 return (Left (Exit.BuildProjectProblem problem))
129 Right foreigns ->
130 do rmvar <- newEmptyMVar
131 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
132 putMVar rmvar resultMVars
133 results <- traverse readMVar resultMVars
134 writeDetails root details results
135 finalizeExposed docsGoal exposed results
139-- FROM MAINS
142data Artifacts =
143 Artifacts
144 { _name :: Pkg.Name
145 , _deps :: Dependencies
146 , _mains :: NE.List Main
147 , _modules :: [Module]
148 }
151data Module
152 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
153 | Cached ModuleName.Raw Bool (MVar CachedInterface)
156type Dependencies =
157 Map.Map ModuleName.Canonical I.DependencyInterface
160fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
161fromMains style root details paths =
162 Reporting.trackBuild style $ \key ->
163 do let env = makeEnv key root details
165 elmains <- findMains env paths
166 case elmains of
167 Left problem ->
168 return (Left (Exit.BuildProjectProblem problem))
170 Right lmains ->
171 do -- crawl
172 dmvar <- Details.loadInterfaces root details
173 smvar <- newMVar Map.empty
174 smainMVars <- traverse (fork . crawlMain env smvar) lmains
175 smains <- traverse readMVar smainMVars
176 statuses <- traverse readMVar =<< readMVar smvar
178 midpoint <- checkMainsMidpoint dmvar statuses smains
179 case midpoint of
180 Left problem ->
181 return (Left (Exit.BuildProjectProblem problem))
183 Right foreigns ->
184 do -- compile
185 rmvar <- newEmptyMVar
186 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
187 putMVar rmvar resultsMVars
188 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
189 results <- traverse readMVar resultsMVars
190 writeDetails root details results
191 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
195-- GET MAIN NAMES
198getMainNames :: Artifacts -> NE.List ModuleName.Raw
199getMainNames (Artifacts _ _ mains _) =
200 fmap getMainName mains
203getMainName :: Main -> ModuleName.Raw
204getMainName main =
205 case main of
206 Inside name -> name
207 Outside name _ _ -> name
211-- CRAWL
214type StatusDict =
215 Map.Map ModuleName.Raw (MVar Status)
218data Status
219 = SCached Details.Local
220 | SChanged Details.Local B.ByteString Src.Module DocsNeed
221 | SBadImport Import.Problem
222 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
223 | SForeign Pkg.Name
224 | SKernel
227crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
228crawlDeps env mvar deps blockedValue =
229 do statusDict <- takeMVar mvar
230 let depsDict = Map.fromKeys (\_ -> ()) deps
231 let newsDict = Map.difference depsDict statusDict
232 statuses <- Map.traverseWithKey crawlNew newsDict
233 putMVar mvar (Map.union statuses statusDict)
234 mapM_ readMVar statuses
235 return blockedValue
236 where
237 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
240crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
241crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
242 do let fileName = ModuleName.toFilePath name <.> "elm"
243 let inRoot path = File.exists (root </> path)
245 paths <- filterM inRoot (map (</> fileName) srcDirs)
247 case paths of
248 [path] ->
249 case Map.lookup name foreigns of
250 Just (Details.Foreign dep deps) ->
251 return $ SBadImport $ Import.Ambiguous path [] dep deps
253 Nothing ->
254 case Map.lookup name locals of
255 Nothing ->
256 crawlFile env mvar docsNeed name path
258 Just local@(Details.Local oldPath oldTime deps _) ->
259 if path /= oldPath
260 then crawlFile env mvar docsNeed name path
261 else
262 do newTime <- File.getTime path
263 if oldTime < newTime || needsDocs docsNeed
264 then crawlFile env mvar docsNeed name path
265 else crawlDeps env mvar deps (SCached local)
267 p1:p2:ps ->
268 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
270 [] ->
271 case Map.lookup name foreigns of
272 Just (Details.Foreign dep deps) ->
273 case deps of
274 [] ->
275 return $ SForeign dep
277 d:ds ->
278 return $ SBadImport $ Import.AmbiguousForeign dep d ds
280 Nothing ->
281 if Name.isKernel name && Pkg.isKernel pkg then
282 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
283 return $ if exists then SKernel else SBadImport Import.NotFound
284 else
285 return $ SBadImport Import.NotFound
288crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
289crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
290 do time <- File.getTime path
291 source <- File.readUtf8 (root </> path)
293 case Parse.fromByteString pkg source of
294 Left err ->
295 return $ SBadSyntax path time source err
297 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
298 case maybeActualName of
299 Nothing ->
300 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
302 Just name@(A.At _ actualName) ->
303 if expectedName == actualName then
304 let
305 deps = map Src.getImportName imports
306 local = Details.Local path time deps (any isMain values)
307 in
308 crawlDeps env mvar deps (SChanged local source modul docsNeed)
309 else
310 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
313isMain :: A.Located Src.Value -> Bool
314isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
315 name == Name._main
319-- CHECK MODULE
322type ResultDict =
323 Map.Map ModuleName.Raw (MVar Result)
326data Result
327 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
328 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
329 | RCached Bool (MVar CachedInterface)
330 | RNotFound Import.Problem
331 | RProblem Error.Module
332 | RBlocked
333 | RForeign I.Interface
334 | RKernel
337data CachedInterface
338 = Unneeded
339 | Loaded I.Interface
340 | Corrupted
343checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
344checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
345 case status of
346 SCached local@(Details.Local path time deps hasMain) ->
347 do results <- readMVar resultsMVar
348 depsStatus <- checkDeps root results deps
349 case depsStatus of
350 DepsChange ifaces ->
351 do source <- File.readUtf8 path
352 case Parse.fromByteString pkg source of
353 Right modul -> compile env (DocsNeed False) local source ifaces modul
354 Left err ->
355 return $ RProblem $
356 Error.Module name path time source (Error.BadSyntax err)
358 DepsSame _ _ ->
359 do mvar <- newMVar Unneeded
360 return (RCached hasMain mvar)
362 DepsBlock ->
363 return RBlocked
365 DepsNotFound problems ->
366 do source <- File.readUtf8 path
367 return $ RProblem $ Error.Module name path time source $
368 case Parse.fromByteString pkg source of
369 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
370 Error.BadImports (toImportErrors env results imports problems)
372 Left err ->
373 Error.BadSyntax err
375 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
376 do results <- readMVar resultsMVar
377 depsStatus <- checkDeps root results deps
378 case depsStatus of
379 DepsChange ifaces ->
380 compile env docsNeed local source ifaces modul
382 DepsSame same cached ->
383 do maybeLoaded <- loadInterfaces root same cached
384 case maybeLoaded of
385 Nothing -> return RBlocked
386 Just ifaces -> compile env docsNeed local source ifaces modul
388 DepsBlock ->
389 return RBlocked
391 DepsNotFound problems ->
392 return $ RProblem $ Error.Module name path time source $
393 Error.BadImports (toImportErrors env results imports problems)
395 SBadImport importProblem ->
396 return (RNotFound importProblem)
398 SBadSyntax path time source err ->
399 return $ RProblem $ Error.Module name path time source $
400 Error.BadSyntax err
402 SForeign home ->
403 case foreigns ! ModuleName.Canonical home name of
404 I.Public iface -> return (RForeign iface)
405 I.Private _ _ _ -> error "loading private interface in Build"
407 SKernel ->
408 return RKernel
412-- CHECK DEPS
415data DepsStatus
416 = DepsChange (Map.Map ModuleName.Raw I.Interface)
417 | DepsSame [Dep] [CDep]
418 | DepsBlock
419 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
422checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
423checkDeps root results deps =
424 checkDepsHelp root results deps [] [] [] [] False
427type Dep = (ModuleName.Raw, I.Interface)
428type CDep = (ModuleName.Raw, MVar CachedInterface)
431checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
432checkDepsHelp root results deps new same cached importProblems isBlocked =
433 case deps of
434 dep:otherDeps ->
435 do result <- readMVar (results ! dep)
436 case result of
437 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
438 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
439 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
440 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
441 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
442 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
443 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
444 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
446 [] ->
447 case importProblems of
448 p:ps ->
449 return $ DepsNotFound (NE.List p ps)
451 [] ->
452 if isBlocked then
453 return $ DepsBlock
455 else if null new then
456 return $ DepsSame same cached
458 else
459 do maybeLoaded <- loadInterfaces root same cached
460 case maybeLoaded of
461 Nothing -> return DepsBlock
462 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
466-- TO IMPORT ERROR
469toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
470toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
471 let
472 knownModules =
473 Set.unions
474 [ Map.keysSet foreigns
475 , Map.keysSet locals
476 , Map.keysSet results
477 ]
479 unimportedModules =
480 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
482 regionDict =
483 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
485 toError (name, problem) =
486 Import.Error (regionDict ! name) name unimportedModules problem
487 in
488 fmap toError problems
492-- LOAD CACHED INTERFACES
495loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
496loadInterfaces root same cached =
497 do loading <- traverse (fork . loadInterface root) cached
498 maybeLoaded <- traverse readMVar loading
499 case sequence maybeLoaded of
500 Nothing ->
501 return Nothing
503 Just loaded ->
504 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
507loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
508loadInterface root (name, ciMvar) =
509 do cachedInterface <- takeMVar ciMvar
510 case cachedInterface of
511 Corrupted ->
512 do putMVar ciMvar cachedInterface
513 return Nothing
515 Loaded iface ->
516 do putMVar ciMvar cachedInterface
517 return (Just (name, iface))
519 Unneeded ->
520 do maybeIface <- File.readBinary (Stuff.elmi root name)
521 case maybeIface of
522 Nothing ->
523 do putMVar ciMvar Corrupted
524 return Nothing
526 Just iface ->
527 do putMVar ciMvar (Loaded iface)
528 return (Just (name, iface))
532-- CHECK PROJECT
535checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
536checkMidpoint dmvar statuses =
537 case checkForCycles statuses of
538 Nothing ->
539 do maybeForeigns <- readMVar dmvar
540 case maybeForeigns of
541 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
542 Just fs -> return (Right fs)
544 Just (NE.List name names) ->
545 do _ <- readMVar dmvar
546 return (Left (Exit.BP_Cycle name names))
549checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
550checkMainsMidpoint dmvar statuses smains =
551 case checkForCycles statuses of
552 Nothing ->
553 case checkUniqueMains statuses smains of
554 Nothing ->
555 do maybeForeigns <- readMVar dmvar
556 case maybeForeigns of
557 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
558 Just fs -> return (Right fs)
560 Just problem ->
561 do _ <- readMVar dmvar
562 return (Left problem)
564 Just (NE.List name names) ->
565 do _ <- readMVar dmvar
566 return (Left (Exit.BP_Cycle name names))
570-- CHECK FOR CYCLES
573checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
574checkForCycles modules =
575 let
576 !graph = Map.foldrWithKey addToGraph [] modules
577 !sccs = Graph.stronglyConnComp graph
578 in
579 checkForCyclesHelp sccs
582checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
583checkForCyclesHelp sccs =
584 case sccs of
585 [] ->
586 Nothing
588 scc:otherSccs ->
589 case scc of
590 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
591 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
592 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
595type Node =
596 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
599addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
600addToGraph name status graph =
601 let
602 dependencies =
603 case status of
604 SCached (Details.Local _ _ deps _) -> deps
605 SChanged (Details.Local _ _ deps _) _ _ _ -> deps
606 SBadImport _ -> []
607 SBadSyntax _ _ _ _ -> []
608 SForeign _ -> []
609 SKernel -> []
610 in
611 (name, name, dependencies) : graph
615-- CHECK UNIQUE MAINS
618checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
619checkUniqueMains insides smains =
620 let
621 outsidesDict =
622 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
623 in
624 case Map.traverseWithKey checkOutside outsidesDict of
625 Left problem ->
626 Just problem
628 Right outsides ->
629 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
630 Right () -> Nothing
631 Left problem -> Just problem
634mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
635mainStatusToNamePathPair smain =
636 case smain of
637 SInside _ -> Nothing
638 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
639 SOutsideErr _ -> Nothing
642checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
643checkOutside name paths =
644 case OneOrMore.destruct NE.List paths of
645 NE.List p [] -> Right p
646 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
649checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
650checkInside name p1 status =
651 case status of
652 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
653 SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
654 SBadImport _ -> Right ()
655 SBadSyntax _ _ _ _ -> Right ()
656 SForeign _ -> Right ()
657 SKernel -> Right ()
661-- COMPILE MODULE
664compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
665compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
666 case Compile.compile pkg ifaces modul of
667 Right (Compile.Artifacts canonical annotations objects) ->
668 do let name = Src.getName modul
669 let iface = I.fromModule pkg canonical annotations
670 let docs = makeDocs docsNeed canonical
671 let elmi = Stuff.elmi root name
672 File.writeBinary (Stuff.elmo root name) objects
673 maybeOldi <- File.readBinary elmi
674 case maybeOldi of
675 Just oldi | oldi == iface ->
676 do -- iface should be fully forced by equality check
677 Reporting.report key Reporting.BDone
678 return (RSame local iface objects docs)
680 _ ->
681 do -- iface may be lazy still
682 File.writeBinary elmi iface
683 Reporting.report key Reporting.BDone
684 return (RNew local iface objects docs)
686 Left err ->
687 return $ RProblem $
688 Error.Module (Src.getName modul) path time source err
692-- WRITE DETAILS
695writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
696writeDetails root (Details.Details time outline locals foreigns extras) results =
697 File.writeBinary (Stuff.details root) $
698 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
701addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
702addNewLocal name result locals =
703 case result of
704 RNew local _ _ _ -> Map.insert name local locals
705 RSame local _ _ _ -> Map.insert name local locals
706 RCached _ _ -> locals
707 RNotFound _ -> locals
708 RProblem _ -> locals
709 RBlocked -> locals
710 RForeign _ -> locals
711 RKernel -> locals
715-- FINALIZE EXPOSED
718finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
719finalizeExposed docsGoal exposed results =
720 case foldr (addImportProblems results) [] (NE.toList exposed) of
721 p:ps ->
722 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
724 [] ->
725 case Map.foldr addErrors [] results of
726 [] -> Right <$> finalizeDocs docsGoal results
727 e:es -> return $ Left $ Exit.BuildBadModules e es
730addErrors :: Result -> [Error.Module] -> [Error.Module]
731addErrors result errors =
732 case result of
733 RNew _ _ _ _ -> errors
734 RSame _ _ _ _ -> errors
735 RCached _ _ -> errors
736 RNotFound _ -> errors
737 RProblem e -> e:errors
738 RBlocked -> errors
739 RForeign _ -> errors
740 RKernel -> errors
743addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
744addImportProblems results name problems =
745 case results ! name of
746 RNew _ _ _ _ -> problems
747 RSame _ _ _ _ -> problems
748 RCached _ _ -> problems
749 RNotFound p -> (name, p) : problems
750 RProblem _ -> problems
751 RBlocked -> problems
752 RForeign _ -> problems
753 RKernel -> problems
757-- DOCS
760data DocsGoal a where
761 KeepDocs :: DocsGoal Docs.Documentation
762 WriteDocs :: FilePath -> DocsGoal ()
763 IgnoreDocs :: DocsGoal ()
766newtype DocsNeed =
767 DocsNeed { needsDocs :: Bool }
770toDocsNeed :: DocsGoal a -> DocsNeed
771toDocsNeed goal =
772 case goal of
773 IgnoreDocs -> DocsNeed False
774 WriteDocs _ -> DocsNeed True
775 KeepDocs -> DocsNeed True
778makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
779makeDocs (DocsNeed isNeeded) modul =
780 if isNeeded then
781 case Docs.fromModule modul of
782 Right docs -> Just docs
783 Left _ -> Nothing
784 else
785 Nothing
788finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
789finalizeDocs goal results =
790 case goal of
791 KeepDocs ->
792 return $ Map.mapMaybe toDocs results
794 WriteDocs path ->
795 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
797 IgnoreDocs ->
798 return ()
801toDocs :: Result -> Maybe Docs.Module
802toDocs result =
803 case result of
804 RNew _ _ _ d -> d
805 RSame _ _ _ d -> d
806 RCached _ _ -> Nothing
807 RNotFound _ -> Nothing
808 RProblem _ -> Nothing
809 RBlocked -> Nothing
810 RForeign _ -> Nothing
811 RKernel -> Nothing
815--------------------------------------------------------------------------------
816------ NOW FOR SOME REPL STUFF -------------------------------------------------
817--------------------------------------------------------------------------------
820-- FROM REPL
823data ReplArtifacts =
824 ReplArtifacts
825 { _repl_home :: ModuleName.Canonical
826 , _repl_modules :: [Module]
827 , _repl_localizer :: L.Localizer
828 , _repl_annotations :: Map.Map Name.Name Can.Annotation
829 }
832fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
833fromRepl root details source =
834 let
835 env@(Env _ _ pkg _ _ _) = makeEnv Reporting.ignorer root details
836 in
837 case Parse.fromByteString pkg source of
838 Left syntaxError ->
839 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
841 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
842 do dmvar <- Details.loadInterfaces root details
844 let deps = map Src.getImportName imports
845 mvar <- newMVar Map.empty
846 crawlDeps env mvar deps ()
848 statuses <- traverse readMVar =<< readMVar mvar
849 midpoint <- checkMidpoint dmvar statuses
851 case midpoint of
852 Left problem ->
853 return $ Left $ Exit.ReplProjectProblem problem
855 Right foreigns ->
856 do rmvar <- newEmptyMVar
857 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
858 putMVar rmvar resultMVars
859 results <- traverse readMVar resultMVars
860 writeDetails root details results
861 depsStatus <- checkDeps root resultMVars deps
862 finalizeReplArtifacts env source modul depsStatus resultMVars results
865finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
866finalizeReplArtifacts env@(Env _ root pkg _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
867 let
868 compileInput ifaces =
869 case Compile.compile pkg ifaces modul of
870 Right (Compile.Artifacts canonical annotations objects) ->
871 let
872 h = Can._name canonical
873 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
874 ms = Map.foldrWithKey addInside [] results
875 in
876 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
878 Left errors ->
879 return $ Left $ Exit.ReplBadInput source errors
880 in
881 case depsStatus of
882 DepsChange ifaces ->
883 compileInput ifaces
885 DepsSame same cached ->
886 do maybeLoaded <- loadInterfaces root same cached
887 case maybeLoaded of
888 Just ifaces -> compileInput ifaces
889 Nothing -> return $ Left $ Exit.ReplBadCache
891 DepsBlock ->
892 case Map.foldr addErrors [] results of
893 [] -> return $ Left $ Exit.ReplBlocked
894 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
896 DepsNotFound problems ->
897 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
898 toImportErrors env resultMVars imports problems
902--------------------------------------------------------------------------------
903--------------------------------------------------------------------------------
904------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
905--------------------------------------------------------------------------------
906--------------------------------------------------------------------------------
910-- FIND MAIN
913data MainLocation
914 = LInside ModuleName.Raw
915 | LOutside FilePath
918findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
919findMains env paths =
920 do mvars <- traverse (fork . findLocation env) paths
921 elocs <- traverse readMVar mvars
922 return $ checkLocations =<< sequence elocs
925checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
926checkLocations locations =
927 let
928 toOneOrMore loc@(Location absolute _ _) =
929 (absolute, OneOrMore.one loc)
931 fromOneOrMore loc locs =
932 case locs of
933 [] -> Right ()
934 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
935 in
936 fmap (\_ -> fmap _location locations) $
937 traverse (OneOrMore.destruct fromOneOrMore) $
938 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
942-- LOCATIONS
945data Location =
946 Location
947 { _absolute :: FilePath
948 , _relative :: FilePath
949 , _location :: MainLocation
950 }
953findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
954findLocation env path =
955 do exists <- File.exists path
956 if exists
957 then findLoc env path <$> Dir.canonicalizePath path
958 else return (Left (Exit.BP_PathUnknown path))
961findLoc :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
962findLoc (Env _ root _ srcDirs _ _) path absolutePath =
963 let
964 (dirs, file) = FP.splitFileName absolutePath
965 (final, ext) = FP.splitExtension file
966 in
967 if ext /= ".elm"
968 then Left (Exit.BP_WithBadExtension path)
969 else
970 let
971 roots = FP.splitDirectories root
972 segments = FP.splitDirectories dirs ++ [final]
973 in
974 case dropPrefix roots segments of
975 Nothing ->
976 Right (Location absolutePath path (LOutside path))
978 Just relativeSegments ->
979 case Maybe.mapMaybe (isInsideSrcDir relativeSegments) srcDirs of
980 [] -> Right $ Location absolutePath path (LOutside path)
981 [(_, Right name)] -> Right $ Location absolutePath path (LInside name)
982 [(s, Left names)] -> Left $ Exit.BP_MainNameInvalid path s names
983 (s1,_):(s2,_):_ -> Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
986isInsideSrcDir :: [String] -> FilePath -> Maybe (FilePath, Either [String] ModuleName.Raw)
987isInsideSrcDir segments srcDir =
988 case dropPrefix (FP.splitDirectories srcDir) segments of
989 Nothing ->
990 Nothing
992 Just names ->
993 if all isGoodName names
994 then Just (srcDir, Right (Name.fromChars (List.intercalate "." names)))
995 else Just (srcDir, Left names)
998isGoodName :: [Char] -> Bool
999isGoodName name =
1000 case name of
1001 [] ->
1002 False
1004 char:chars ->
1005 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1008dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1009dropPrefix roots paths =
1010 case roots of
1011 [] ->
1012 Just paths
1014 r:rs ->
1015 case paths of
1016 [] -> Nothing
1017 p:ps -> if r == p then dropPrefix rs ps else Nothing
1021-- CRAWL MAINS
1024data MainStatus
1025 = SInside ModuleName.Raw
1026 | SOutsideOk Details.Local B.ByteString Src.Module
1027 | SOutsideErr Error.Module
1030crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1031crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1032 case given of
1033 LInside name ->
1034 do statusMVar <- newEmptyMVar
1035 statusDict <- takeMVar mvar
1036 putMVar mvar (Map.insert name statusMVar statusDict)
1037 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1038 return (SInside name)
1040 LOutside path ->
1041 do time <- File.getTime path
1042 source <- File.readUtf8 path
1043 case Parse.fromByteString pkg source of
1044 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1045 do let deps = map Src.getImportName imports
1046 let local = Details.Local path time deps (any isMain values)
1047 crawlDeps env mvar deps (SOutsideOk local source modul)
1049 Left syntaxError ->
1050 return $ SOutsideErr $
1051 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1055-- CHECK MAINS
1058data MainResult
1059 = RInside ModuleName.Raw
1060 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1061 | ROutsideErr Error.Module
1062 | ROutsideBlocked
1065checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1066checkMain env@(Env _ root _ _ _ _) results pendingMain =
1067 case pendingMain of
1068 SInside name ->
1069 return (RInside name)
1071 SOutsideErr err ->
1072 return (ROutsideErr err)
1074 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1075 do depsStatus <- checkDeps root results deps
1076 case depsStatus of
1077 DepsChange ifaces ->
1078 compileOutside env local source ifaces modul
1080 DepsSame same cached ->
1081 do maybeLoaded <- loadInterfaces root same cached
1082 case maybeLoaded of
1083 Nothing -> return ROutsideBlocked
1084 Just ifaces -> compileOutside env local source ifaces modul
1086 DepsBlock ->
1087 return ROutsideBlocked
1089 DepsNotFound problems ->
1090 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1091 Error.BadImports (toImportErrors env results imports problems)
1094compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO MainResult
1095compileOutside (Env key _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1096 let
1097 name = Src.getName modul
1098 in
1099 case Compile.compile pkg ifaces modul of
1100 Right (Compile.Artifacts canonical annotations objects) ->
1101 do Reporting.report key Reporting.BDone
1102 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1104 Left errors ->
1105 return $ ROutsideErr $ Error.Module name path time source errors
1109-- TO ARTIFACTS
1112data Main
1113 = Inside ModuleName.Raw
1114 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1117toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1118toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1119 case gatherProblemsOrMains results mainResults of
1120 Left (NE.List e es) ->
1121 Left (Exit.BuildBadModules e es)
1123 Right mains ->
1124 Right $ Artifacts pkg foreigns mains $
1125 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1128gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1129gatherProblemsOrMains results (NE.List mainResult mainResults) =
1130 let
1131 sortMain result (es, mains) =
1132 case result of
1133 RInside n -> ( es, Inside n : mains)
1134 ROutsideOk n i o -> ( es, Outside n i o : mains)
1135 ROutsideErr e -> (e:es, mains)
1136 ROutsideBlocked -> ( es, mains)
1138 errors = Map.foldr addErrors [] results
1139 in
1140 case (mainResult, foldr sortMain (errors, []) mainResults) of
1141 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1142 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1143 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1144 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1145 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1146 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1147 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1150addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1151addInside name result modules =
1152 case result of
1153 RNew _ iface objs _ -> Fresh name iface objs : modules
1154 RSame _ iface objs _ -> Fresh name iface objs : modules
1155 RCached main mvar -> Cached name main mvar : modules
1156 RNotFound _ -> error (badInside name)
1157 RProblem _ -> error (badInside name)
1158 RBlocked -> error (badInside name)
1159 RForeign _ -> modules
1160 RKernel -> modules
1163badInside :: ModuleName.Raw -> [Char]
1164badInside name =
1165 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1168addOutside :: MainResult -> [Module] -> [Module]
1169addOutside main modules =
1170 case main of
1171 RInside _ -> modules
1172 ROutsideOk name iface objs -> Fresh name iface objs : modules
1173 ROutsideErr _ -> modules
1174 ROutsideBlocked -> modules