git.iko.soy/elk
on a74201c help sign in
elk/builder/src/Build.hs
1200 lines 39 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 =<< File.getTime path
258 Just local@(Details.Local oldPath oldTime deps _) ->
259 if path /= oldPath
260 then crawlFile env mvar docsNeed name path =<< File.getTime path
261 else
262 do newTime <- File.getTime path
263 if oldTime /= newTime || needsDocs docsNeed
264 then crawlFile env mvar docsNeed name path newTime
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 -> File.Time -> IO Status
289crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path time =
290 do source <- File.readUtf8 (root </> path)
292 case Parse.fromByteString pkg source of
293 Left err ->
294 return $ SBadSyntax path time source err
296 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
297 case maybeActualName of
298 Nothing ->
299 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
301 Just name@(A.At _ actualName) ->
302 if expectedName == actualName then
303 let
304 deps = map Src.getImportName imports
305 local = Details.Local path time deps (any isMain values)
306 in
307 crawlDeps env mvar deps (SChanged local source modul docsNeed)
308 else
309 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
312isMain :: A.Located Src.Value -> Bool
313isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
314 name == Name._main
318-- CHECK MODULE
321type ResultDict =
322 Map.Map ModuleName.Raw (MVar Result)
325data Result
326 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
327 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
328 | RCached Bool (MVar CachedInterface)
329 | RNotFound Import.Problem
330 | RProblem Error.Module
331 | RBlocked
332 | RForeign I.Interface
333 | RKernel
336data CachedInterface
337 = Unneeded
338 | Loaded I.Interface
339 | Corrupted
342checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
343checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
344 case status of
345 SCached local@(Details.Local path time deps hasMain) ->
346 do results <- readMVar resultsMVar
347 depsStatus <- checkDeps root results deps
348 case depsStatus of
349 DepsChange ifaces ->
350 do source <- File.readUtf8 path
351 case Parse.fromByteString pkg source of
352 Right modul -> compile env (DocsNeed False) local source ifaces modul
353 Left err ->
354 return $ RProblem $
355 Error.Module name path time source (Error.BadSyntax err)
357 DepsSame _ _ ->
358 do mvar <- newMVar Unneeded
359 return (RCached hasMain mvar)
361 DepsBlock ->
362 return RBlocked
364 DepsNotFound problems ->
365 do source <- File.readUtf8 path
366 return $ RProblem $ Error.Module name path time source $
367 case Parse.fromByteString pkg source of
368 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
369 Error.BadImports (toImportErrors env results imports problems)
371 Left err ->
372 Error.BadSyntax err
374 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
375 do results <- readMVar resultsMVar
376 depsStatus <- checkDeps root results deps
377 case depsStatus of
378 DepsChange ifaces ->
379 compile env docsNeed local source ifaces modul
381 DepsSame same cached ->
382 do maybeLoaded <- loadInterfaces root same cached
383 case maybeLoaded of
384 Nothing -> return RBlocked
385 Just ifaces -> compile env docsNeed local source ifaces modul
387 DepsBlock ->
388 return RBlocked
390 DepsNotFound problems ->
391 return $ RProblem $ Error.Module name path time source $
392 Error.BadImports (toImportErrors env results imports problems)
394 SBadImport importProblem ->
395 return (RNotFound importProblem)
397 SBadSyntax path time source err ->
398 return $ RProblem $ Error.Module name path time source $
399 Error.BadSyntax err
401 SForeign home ->
402 case foreigns ! ModuleName.Canonical home name of
403 I.Public iface -> return (RForeign iface)
404 I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
406 SKernel ->
407 return RKernel
411-- CHECK DEPS
414data DepsStatus
415 = DepsChange (Map.Map ModuleName.Raw I.Interface)
416 | DepsSame [Dep] [CDep]
417 | DepsBlock
418 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
421checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
422checkDeps root results deps =
423 checkDepsHelp root results deps [] [] [] [] False
426type Dep = (ModuleName.Raw, I.Interface)
427type CDep = (ModuleName.Raw, MVar CachedInterface)
430checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
431checkDepsHelp root results deps new same cached importProblems isBlocked =
432 case deps of
433 dep:otherDeps ->
434 do result <- readMVar (results ! dep)
435 case result of
436 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
437 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
438 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
439 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
440 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
441 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
442 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
443 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
445 [] ->
446 case reverse importProblems of
447 p:ps ->
448 return $ DepsNotFound (NE.List p ps)
450 [] ->
451 if isBlocked then
452 return $ DepsBlock
454 else if null new then
455 return $ DepsSame same cached
457 else
458 do maybeLoaded <- loadInterfaces root same cached
459 case maybeLoaded of
460 Nothing -> return DepsBlock
461 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
465-- TO IMPORT ERROR
468toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
469toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
470 let
471 knownModules =
472 Set.unions
473 [ Map.keysSet foreigns
474 , Map.keysSet locals
475 , Map.keysSet results
476 ]
478 unimportedModules =
479 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
481 regionDict =
482 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
484 toError (name, problem) =
485 Import.Error (regionDict ! name) name unimportedModules problem
486 in
487 fmap toError problems
491-- LOAD CACHED INTERFACES
494loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
495loadInterfaces root same cached =
496 do loading <- traverse (fork . loadInterface root) cached
497 maybeLoaded <- traverse readMVar loading
498 case sequence maybeLoaded of
499 Nothing ->
500 return Nothing
502 Just loaded ->
503 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
506loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
507loadInterface root (name, ciMvar) =
508 do cachedInterface <- takeMVar ciMvar
509 case cachedInterface of
510 Corrupted ->
511 do putMVar ciMvar cachedInterface
512 return Nothing
514 Loaded iface ->
515 do putMVar ciMvar cachedInterface
516 return (Just (name, iface))
518 Unneeded ->
519 do maybeIface <- File.readBinary (Stuff.elmi root name)
520 case maybeIface of
521 Nothing ->
522 do putMVar ciMvar Corrupted
523 return Nothing
525 Just iface ->
526 do putMVar ciMvar (Loaded iface)
527 return (Just (name, iface))
531-- CHECK PROJECT
534checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
535checkMidpoint dmvar statuses =
536 case checkForCycles statuses of
537 Nothing ->
538 do maybeForeigns <- readMVar dmvar
539 case maybeForeigns of
540 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
541 Just fs -> return (Right fs)
543 Just (NE.List name names) ->
544 do _ <- readMVar dmvar
545 return (Left (Exit.BP_Cycle name names))
548checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
549checkMainsMidpoint dmvar statuses smains =
550 case checkForCycles statuses of
551 Nothing ->
552 case checkUniqueMains statuses smains of
553 Nothing ->
554 do maybeForeigns <- readMVar dmvar
555 case maybeForeigns of
556 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
557 Just fs -> return (Right fs)
559 Just problem ->
560 do _ <- readMVar dmvar
561 return (Left problem)
563 Just (NE.List name names) ->
564 do _ <- readMVar dmvar
565 return (Left (Exit.BP_Cycle name names))
569-- CHECK FOR CYCLES
572checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
573checkForCycles modules =
574 let
575 !graph = Map.foldrWithKey addToGraph [] modules
576 !sccs = Graph.stronglyConnComp graph
577 in
578 checkForCyclesHelp sccs
581checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
582checkForCyclesHelp sccs =
583 case sccs of
584 [] ->
585 Nothing
587 scc:otherSccs ->
588 case scc of
589 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
590 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
591 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
594type Node =
595 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
598addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
599addToGraph name status graph =
600 let
601 dependencies =
602 case status of
603 SCached (Details.Local _ _ deps _) -> deps
604 SChanged (Details.Local _ _ deps _) _ _ _ -> deps
605 SBadImport _ -> []
606 SBadSyntax _ _ _ _ -> []
607 SForeign _ -> []
608 SKernel -> []
609 in
610 (name, name, dependencies) : graph
614-- CHECK UNIQUE MAINS
617checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
618checkUniqueMains insides smains =
619 let
620 outsidesDict =
621 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
622 in
623 case Map.traverseWithKey checkOutside outsidesDict of
624 Left problem ->
625 Just problem
627 Right outsides ->
628 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
629 Right () -> Nothing
630 Left problem -> Just problem
633mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
634mainStatusToNamePathPair smain =
635 case smain of
636 SInside _ -> Nothing
637 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
638 SOutsideErr _ -> Nothing
641checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
642checkOutside name paths =
643 case OneOrMore.destruct NE.List paths of
644 NE.List p [] -> Right p
645 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
648checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
649checkInside name p1 status =
650 case status of
651 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
652 SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
653 SBadImport _ -> Right ()
654 SBadSyntax _ _ _ _ -> Right ()
655 SForeign _ -> Right ()
656 SKernel -> Right ()
660-- COMPILE MODULE
663compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
664compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
665 case Compile.compile pkg ifaces modul of
666 Right (Compile.Artifacts canonical annotations objects) ->
667 do let name = Src.getName modul
668 let iface = I.fromModule pkg canonical annotations
669 let docs = makeDocs docsNeed canonical
670 let elmi = Stuff.elmi root name
671 File.writeBinary (Stuff.elmo root name) objects
672 maybeOldi <- File.readBinary elmi
673 case maybeOldi of
674 Just oldi | oldi == iface ->
675 do -- iface should be fully forced by equality check
676 Reporting.report key Reporting.BDone
677 return (RSame local iface objects docs)
679 _ ->
680 do -- iface may be lazy still
681 File.writeBinary elmi iface
682 Reporting.report key Reporting.BDone
683 return (RNew local iface objects docs)
685 Left err ->
686 return $ RProblem $
687 Error.Module (Src.getName modul) path time source err
691-- WRITE DETAILS
694writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
695writeDetails root (Details.Details time outline locals foreigns extras) results =
696 File.writeBinary (Stuff.details root) $
697 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
700addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
701addNewLocal name result locals =
702 case result of
703 RNew local _ _ _ -> Map.insert name local locals
704 RSame local _ _ _ -> Map.insert name local locals
705 RCached _ _ -> locals
706 RNotFound _ -> locals
707 RProblem _ -> locals
708 RBlocked -> locals
709 RForeign _ -> locals
710 RKernel -> locals
714-- FINALIZE EXPOSED
717finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
718finalizeExposed docsGoal exposed results =
719 case foldr (addImportProblems results) [] (NE.toList exposed) of
720 p:ps ->
721 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
723 [] ->
724 case Map.foldr addErrors [] results of
725 [] -> Right <$> finalizeDocs docsGoal results
726 e:es -> return $ Left $ Exit.BuildBadModules e es
729addErrors :: Result -> [Error.Module] -> [Error.Module]
730addErrors result errors =
731 case result of
732 RNew _ _ _ _ -> errors
733 RSame _ _ _ _ -> errors
734 RCached _ _ -> errors
735 RNotFound _ -> errors
736 RProblem e -> e:errors
737 RBlocked -> errors
738 RForeign _ -> errors
739 RKernel -> errors
742addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
743addImportProblems results name problems =
744 case results ! name of
745 RNew _ _ _ _ -> problems
746 RSame _ _ _ _ -> problems
747 RCached _ _ -> problems
748 RNotFound p -> (name, p) : problems
749 RProblem _ -> problems
750 RBlocked -> problems
751 RForeign _ -> problems
752 RKernel -> problems
756-- DOCS
759data DocsGoal a where
760 KeepDocs :: DocsGoal Docs.Documentation
761 WriteDocs :: FilePath -> DocsGoal ()
762 IgnoreDocs :: DocsGoal ()
765newtype DocsNeed =
766 DocsNeed { needsDocs :: Bool }
769toDocsNeed :: DocsGoal a -> DocsNeed
770toDocsNeed goal =
771 case goal of
772 IgnoreDocs -> DocsNeed False
773 WriteDocs _ -> DocsNeed True
774 KeepDocs -> DocsNeed True
777makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
778makeDocs (DocsNeed isNeeded) modul =
779 if isNeeded then
780 case Docs.fromModule modul of
781 Right docs -> Just docs
782 Left _ -> Nothing
783 else
784 Nothing
787finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
788finalizeDocs goal results =
789 case goal of
790 KeepDocs ->
791 return $ Map.mapMaybe toDocs results
793 WriteDocs path ->
794 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
796 IgnoreDocs ->
797 return ()
800toDocs :: Result -> Maybe Docs.Module
801toDocs result =
802 case result of
803 RNew _ _ _ d -> d
804 RSame _ _ _ d -> d
805 RCached _ _ -> Nothing
806 RNotFound _ -> Nothing
807 RProblem _ -> Nothing
808 RBlocked -> Nothing
809 RForeign _ -> Nothing
810 RKernel -> Nothing
814--------------------------------------------------------------------------------
815------ NOW FOR SOME REPL STUFF -------------------------------------------------
816--------------------------------------------------------------------------------
819-- FROM REPL
822data ReplArtifacts =
823 ReplArtifacts
824 { _repl_home :: ModuleName.Canonical
825 , _repl_modules :: [Module]
826 , _repl_localizer :: L.Localizer
827 , _repl_annotations :: Map.Map Name.Name Can.Annotation
828 }
831fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
832fromRepl root details source =
833 let
834 env@(Env _ _ pkg _ _ _) = makeEnv Reporting.ignorer root details
835 in
836 case Parse.fromByteString pkg source of
837 Left syntaxError ->
838 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
840 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
841 do dmvar <- Details.loadInterfaces root details
843 let deps = map Src.getImportName imports
844 mvar <- newMVar Map.empty
845 crawlDeps env mvar deps ()
847 statuses <- traverse readMVar =<< readMVar mvar
848 midpoint <- checkMidpoint dmvar statuses
850 case midpoint of
851 Left problem ->
852 return $ Left $ Exit.ReplProjectProblem problem
854 Right foreigns ->
855 do rmvar <- newEmptyMVar
856 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
857 putMVar rmvar resultMVars
858 results <- traverse readMVar resultMVars
859 writeDetails root details results
860 depsStatus <- checkDeps root resultMVars deps
861 finalizeReplArtifacts env source modul depsStatus resultMVars results
864finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
865finalizeReplArtifacts env@(Env _ root pkg _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
866 let
867 compileInput ifaces =
868 case Compile.compile pkg ifaces modul of
869 Right (Compile.Artifacts canonical annotations objects) ->
870 let
871 h = Can._name canonical
872 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
873 ms = Map.foldrWithKey addInside [] results
874 in
875 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
877 Left errors ->
878 return $ Left $ Exit.ReplBadInput source errors
879 in
880 case depsStatus of
881 DepsChange ifaces ->
882 compileInput ifaces
884 DepsSame same cached ->
885 do maybeLoaded <- loadInterfaces root same cached
886 case maybeLoaded of
887 Just ifaces -> compileInput ifaces
888 Nothing -> return $ Left $ Exit.ReplBadCache
890 DepsBlock ->
891 case Map.foldr addErrors [] results of
892 [] -> return $ Left $ Exit.ReplBlocked
893 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
895 DepsNotFound problems ->
896 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
897 toImportErrors env resultMVars imports problems
901--------------------------------------------------------------------------------
902--------------------------------------------------------------------------------
903------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
904--------------------------------------------------------------------------------
905--------------------------------------------------------------------------------
909-- FIND MAIN
912data MainLocation
913 = LInside ModuleName.Raw
914 | LOutside FilePath
917findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
918findMains env paths =
919 do mvars <- traverse (fork . findLocation env) paths
920 elocs <- traverse readMVar mvars
921 return $ checkLocations =<< sequence elocs
924checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
925checkLocations locations =
926 let
927 toOneOrMore loc@(Location absolute _ _) =
928 (absolute, OneOrMore.one loc)
930 fromOneOrMore loc locs =
931 case locs of
932 [] -> Right ()
933 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
934 in
935 fmap (\_ -> fmap _location locations) $
936 traverse (OneOrMore.destruct fromOneOrMore) $
937 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
941-- LOCATIONS
944data Location =
945 Location
946 { _absolute :: FilePath
947 , _relative :: FilePath
948 , _location :: MainLocation
949 }
952findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
953findLocation env path =
954 do exists <- File.exists path
955 if exists
956 then findLoc env path =<< Dir.canonicalizePath path
957 else return (Left (Exit.BP_PathUnknown path))
960findLoc :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
961findLoc (Env _ root _ srcDirs _ _) path absolutePath =
962 let
963 (dirs, file) = FP.splitFileName absolutePath
964 (final, ext) = FP.splitExtension file
965 in
966 if ext /= ".elm"
967 then
968 return $ 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 return $ Right $ Location absolutePath path (LOutside path)
978 Just relativeSegments ->
979 case Maybe.mapMaybe (isInsideSrcDirByPath relativeSegments) srcDirs of
980 [] ->
981 return $ Right $ Location absolutePath path (LOutside path)
983 [(_, Right names)] ->
984 do let name = Name.fromChars (List.intercalate "." names)
985 matchingDirs <- filterM (isInsideSrcDirByName root names) srcDirs
986 case matchingDirs of
987 d1:d2:_ ->
988 do let p1 = d1 </> FP.joinPath names <.> "elm"
989 let p2 = d2 </> FP.joinPath names <.> "elm"
990 return $ Left $ Exit.BP_MainNameDuplicate name p1 p2
992 _ ->
993 return $ Right $ Location absolutePath path (LInside name)
995 [(s, Left names)] ->
996 return $ Left $ Exit.BP_MainNameInvalid path s names
998 (s1,_):(s2,_):_ ->
999 return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1003isInsideSrcDirByName :: FilePath -> [String] -> FilePath -> IO Bool
1004isInsideSrcDirByName root names srcDir =
1005 File.exists (root </> srcDir </> FP.joinPath names <.> "elm")
1008isInsideSrcDirByPath :: [String] -> FilePath -> Maybe (FilePath, Either [String] [String])
1009isInsideSrcDirByPath segments srcDir =
1010 case dropPrefix (FP.splitDirectories srcDir) segments of
1011 Nothing ->
1012 Nothing
1014 Just names ->
1015 if all isGoodName names
1016 then Just (srcDir, Right names)
1017 else Just (srcDir, Left names)
1020isGoodName :: [Char] -> Bool
1021isGoodName name =
1022 case name of
1023 [] ->
1024 False
1026 char:chars ->
1027 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1030dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1031dropPrefix roots paths =
1032 case roots of
1033 [] ->
1034 Just paths
1036 ".":rs ->
1037 dropPrefix rs paths
1039 r:rs ->
1040 case paths of
1041 [] -> Nothing
1042 ".":ps -> dropPrefix roots ps
1043 p:ps -> if r == p then dropPrefix rs ps else Nothing
1047-- CRAWL MAINS
1050data MainStatus
1051 = SInside ModuleName.Raw
1052 | SOutsideOk Details.Local B.ByteString Src.Module
1053 | SOutsideErr Error.Module
1056crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1057crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1058 case given of
1059 LInside name ->
1060 do statusMVar <- newEmptyMVar
1061 statusDict <- takeMVar mvar
1062 putMVar mvar (Map.insert name statusMVar statusDict)
1063 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1064 return (SInside name)
1066 LOutside path ->
1067 do time <- File.getTime path
1068 source <- File.readUtf8 path
1069 case Parse.fromByteString pkg source of
1070 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1071 do let deps = map Src.getImportName imports
1072 let local = Details.Local path time deps (any isMain values)
1073 crawlDeps env mvar deps (SOutsideOk local source modul)
1075 Left syntaxError ->
1076 return $ SOutsideErr $
1077 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1081-- CHECK MAINS
1084data MainResult
1085 = RInside ModuleName.Raw
1086 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1087 | ROutsideErr Error.Module
1088 | ROutsideBlocked
1091checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1092checkMain env@(Env _ root _ _ _ _) results pendingMain =
1093 case pendingMain of
1094 SInside name ->
1095 return (RInside name)
1097 SOutsideErr err ->
1098 return (ROutsideErr err)
1100 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1101 do depsStatus <- checkDeps root results deps
1102 case depsStatus of
1103 DepsChange ifaces ->
1104 compileOutside env local source ifaces modul
1106 DepsSame same cached ->
1107 do maybeLoaded <- loadInterfaces root same cached
1108 case maybeLoaded of
1109 Nothing -> return ROutsideBlocked
1110 Just ifaces -> compileOutside env local source ifaces modul
1112 DepsBlock ->
1113 return ROutsideBlocked
1115 DepsNotFound problems ->
1116 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1117 Error.BadImports (toImportErrors env results imports problems)
1120compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO MainResult
1121compileOutside (Env key _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1122 let
1123 name = Src.getName modul
1124 in
1125 case Compile.compile pkg ifaces modul of
1126 Right (Compile.Artifacts canonical annotations objects) ->
1127 do Reporting.report key Reporting.BDone
1128 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1130 Left errors ->
1131 return $ ROutsideErr $ Error.Module name path time source errors
1135-- TO ARTIFACTS
1138data Main
1139 = Inside ModuleName.Raw
1140 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1143toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1144toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1145 case gatherProblemsOrMains results mainResults of
1146 Left (NE.List e es) ->
1147 Left (Exit.BuildBadModules e es)
1149 Right mains ->
1150 Right $ Artifacts pkg foreigns mains $
1151 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1154gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1155gatherProblemsOrMains results (NE.List mainResult mainResults) =
1156 let
1157 sortMain result (es, mains) =
1158 case result of
1159 RInside n -> ( es, Inside n : mains)
1160 ROutsideOk n i o -> ( es, Outside n i o : mains)
1161 ROutsideErr e -> (e:es, mains)
1162 ROutsideBlocked -> ( es, mains)
1164 errors = Map.foldr addErrors [] results
1165 in
1166 case (mainResult, foldr sortMain (errors, []) mainResults) of
1167 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1168 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1169 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1170 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1171 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1172 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1173 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1176addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1177addInside name result modules =
1178 case result of
1179 RNew _ iface objs _ -> Fresh name iface objs : modules
1180 RSame _ iface objs _ -> Fresh name iface objs : modules
1181 RCached main mvar -> Cached name main mvar : modules
1182 RNotFound _ -> error (badInside name)
1183 RProblem _ -> error (badInside name)
1184 RBlocked -> error (badInside name)
1185 RForeign _ -> modules
1186 RKernel -> modules
1189badInside :: ModuleName.Raw -> [Char]
1190badInside name =
1191 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1194addOutside :: MainResult -> [Module] -> [Module]
1195addOutside main modules =
1196 case main of
1197 RInside _ -> modules
1198 ROutsideOk name iface objs -> Fresh name iface objs : modules
1199 ROutsideErr _ -> modules
1200 ROutsideBlocked -> modules