git.iko.soy/elk
on efb63ca help sign in
elk/builder/src/Build.hs
1176 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
89-- PERF try using IORef semephore on file crawl phase?
90-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
91-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
92--
93fork :: IO a -> IO (MVar a)
94fork work =
95 do mvar <- newEmptyMVar
96 _ <- forkIO $ putMVar mvar =<< work
97 return mvar
100{-# INLINE forkWithKey #-}
101forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
102forkWithKey func dict =
103 Map.traverseWithKey (\k v -> fork (func k v)) dict
107-- FROM EXPOSED
110fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
111fromExposed style root details docsGoal exposed@(NE.List e es) =
112 Reporting.trackBuild style $ \key ->
113 do let env = makeEnv key root details
114 dmvar <- Details.loadInterfaces root details
116 -- crawl
117 mvar <- newEmptyMVar
118 let docsNeed = toDocsNeed docsGoal
119 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
120 putMVar mvar roots
121 mapM_ readMVar roots
122 statuses <- traverse readMVar =<< readMVar mvar
124 -- compile
125 midpoint <- checkMidpoint dmvar statuses
126 case midpoint of
127 Left problem ->
128 return (Left (Exit.BuildProjectProblem problem))
130 Right foreigns ->
131 do rmvar <- newEmptyMVar
132 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
133 putMVar rmvar resultMVars
134 results <- traverse readMVar resultMVars
135 writeDetails root details results
136 finalizeExposed docsGoal exposed results
140-- FROM MAINS
143data Artifacts =
144 Artifacts
145 { _name :: Pkg.Name
146 , _deps :: Dependencies
147 , _mains :: NE.List Main
148 , _modules :: [Module]
149 }
152data Module
153 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
154 | Cached ModuleName.Raw Bool (MVar CachedInterface)
157type Dependencies =
158 Map.Map ModuleName.Canonical I.DependencyInterface
161fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
162fromMains style root details paths =
163 Reporting.trackBuild style $ \key ->
164 do let env = makeEnv key root details
166 elmains <- findMains env paths
167 case elmains of
168 Left problem ->
169 return (Left (Exit.BuildProjectProblem problem))
171 Right lmains ->
172 do -- crawl
173 dmvar <- Details.loadInterfaces root details
174 smvar <- newMVar Map.empty
175 smainMVars <- traverse (fork . crawlMain env smvar) lmains
176 smains <- traverse readMVar smainMVars
177 statuses <- traverse readMVar =<< readMVar smvar
179 midpoint <- checkMainsMidpoint dmvar statuses smains
180 case midpoint of
181 Left problem ->
182 return (Left (Exit.BuildProjectProblem problem))
184 Right foreigns ->
185 do -- compile
186 rmvar <- newEmptyMVar
187 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
188 putMVar rmvar resultsMVars
189 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
190 results <- traverse readMVar resultsMVars
191 writeDetails root details results
192 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
196-- GET MAIN NAMES
199getMainNames :: Artifacts -> NE.List ModuleName.Raw
200getMainNames (Artifacts _ _ mains _) =
201 fmap getMainName mains
204getMainName :: Main -> ModuleName.Raw
205getMainName main =
206 case main of
207 Inside name -> name
208 Outside name _ _ -> name
212-- CRAWL
215type StatusDict =
216 Map.Map ModuleName.Raw (MVar Status)
219data Status
220 = SCached Details.Local
221 | SChanged Details.Local B.ByteString Src.Module DocsNeed
222 | SBadImport Import.Problem
223 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
224 | SForeign Pkg.Name
225 | SKernel
228crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
229crawlDeps env mvar deps blockedValue =
230 do statusDict <- takeMVar mvar
231 let depsDict = Map.fromKeys (\_ -> ()) deps
232 let newsDict = Map.difference depsDict statusDict
233 statuses <- Map.traverseWithKey crawlNew newsDict
234 putMVar mvar (Map.union statuses statusDict)
235 mapM_ readMVar statuses
236 return blockedValue
237 where
238 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
241crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
242crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
243 do let fileName = ModuleName.toFilePath name <.> "elm"
244 let inRoot path = File.exists (root </> path)
246 paths <- filterM inRoot (map (</> fileName) srcDirs)
248 case paths of
249 [path] ->
250 case Map.lookup name foreigns of
251 Just (Details.Foreign dep deps) ->
252 return $ SBadImport $ Import.Ambiguous path [] dep deps
254 Nothing ->
255 case Map.lookup name locals of
256 Nothing ->
257 crawlFile env mvar docsNeed name path
259 Just local@(Details.Local oldPath oldTime deps _) ->
260 if path /= oldPath
261 then crawlFile env mvar docsNeed name path
262 else
263 do newTime <- File.getTime path
264 if oldTime < newTime || needsDocs docsNeed
265 then crawlFile env mvar docsNeed name path
266 else crawlDeps env mvar deps (SCached local)
268 p1:p2:ps ->
269 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
271 [] ->
272 case Map.lookup name foreigns of
273 Just (Details.Foreign dep deps) ->
274 case deps of
275 [] ->
276 return $ SForeign dep
278 d:ds ->
279 return $ SBadImport $ Import.AmbiguousForeign dep d ds
281 Nothing ->
282 if Name.isKernel name && Pkg.isKernel pkg then
283 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
284 return $ if exists then SKernel else SBadImport Import.NotFound
285 else
286 return $ SBadImport Import.NotFound
289crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
290crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
291 do time <- File.getTime path
292 source <- File.readUtf8 (root </> path)
294 case Parse.fromByteString pkg source of
295 Left err ->
296 return $ SBadSyntax path time source err
298 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
299 case maybeActualName of
300 Nothing ->
301 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
303 Just name@(A.At _ actualName) ->
304 if expectedName == actualName then
305 let
306 deps = map Src.getImportName imports
307 local = Details.Local path time deps (any isMain values)
308 in
309 crawlDeps env mvar deps (SChanged local source modul docsNeed)
310 else
311 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
314isMain :: A.Located Src.Value -> Bool
315isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
316 name == Name._main
320-- CHECK MODULE
323type ResultDict =
324 Map.Map ModuleName.Raw (MVar Result)
327data Result
328 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
329 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
330 | RCached Bool (MVar CachedInterface)
331 | RNotFound Import.Problem
332 | RProblem Error.Module
333 | RBlocked
334 | RForeign I.Interface
335 | RKernel
338data CachedInterface
339 = Unneeded
340 | Loaded I.Interface
341 | Corrupted
344checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
345checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
346 case status of
347 SCached local@(Details.Local path time deps hasMain) ->
348 do results <- readMVar resultsMVar
349 depsStatus <- checkDeps root results deps
350 case depsStatus of
351 DepsChange ifaces ->
352 do source <- File.readUtf8 path
353 case Parse.fromByteString pkg source of
354 Right modul -> compile env (DocsNeed False) local source ifaces modul
355 Left err ->
356 return $ RProblem $
357 Error.Module name path time source (Error.BadSyntax err)
359 DepsSame _ _ ->
360 do mvar <- newMVar Unneeded
361 return (RCached hasMain mvar)
363 DepsBlock ->
364 return RBlocked
366 DepsNotFound problems ->
367 do source <- File.readUtf8 path
368 return $ RProblem $ Error.Module name path time source $
369 case Parse.fromByteString pkg source of
370 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
371 Error.BadImports (toImportErrors env results imports problems)
373 Left err ->
374 Error.BadSyntax err
376 SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
377 do results <- readMVar resultsMVar
378 depsStatus <- checkDeps root results deps
379 case depsStatus of
380 DepsChange ifaces ->
381 compile env docsNeed local source ifaces modul
383 DepsSame same cached ->
384 do maybeLoaded <- loadInterfaces root same cached
385 case maybeLoaded of
386 Nothing -> return RBlocked
387 Just ifaces -> compile env docsNeed local source ifaces modul
389 DepsBlock ->
390 return RBlocked
392 DepsNotFound problems ->
393 return $ RProblem $ Error.Module name path time source $
394 Error.BadImports (toImportErrors env results imports problems)
396 SBadImport importProblem ->
397 return (RNotFound importProblem)
399 SBadSyntax path time source err ->
400 return $ RProblem $ Error.Module name path time source $
401 Error.BadSyntax err
403 SForeign home ->
404 case foreigns ! ModuleName.Canonical home name of
405 I.Public iface -> return (RForeign iface)
406 I.Private _ _ _ -> error "loading private interface in Build"
408 SKernel ->
409 return RKernel
413-- CHECK DEPS
416data DepsStatus
417 = DepsChange (Map.Map ModuleName.Raw I.Interface)
418 | DepsSame [Dep] [CDep]
419 | DepsBlock
420 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
423checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
424checkDeps root results deps =
425 checkDepsHelp root results deps [] [] [] [] False
428type Dep = (ModuleName.Raw, I.Interface)
429type CDep = (ModuleName.Raw, MVar CachedInterface)
432checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> IO DepsStatus
433checkDepsHelp root results deps new same cached importProblems isBlocked =
434 case deps of
435 dep:otherDeps ->
436 do result <- readMVar (results ! dep)
437 case result of
438 RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
439 RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
440 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
441 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
442 RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
443 RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
444 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
445 RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
447 [] ->
448 case importProblems of
449 p:ps ->
450 return $ DepsNotFound (NE.List p ps)
452 [] ->
453 if isBlocked then
454 return $ DepsBlock
456 else if null new then
457 return $ DepsSame same cached
459 else
460 do maybeLoaded <- loadInterfaces root same cached
461 case maybeLoaded of
462 Nothing -> return DepsBlock
463 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
467-- TO IMPORT ERROR
470toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
471toImportErrors (Env _ _ _ _ locals foreigns) results imports problems =
472 let
473 knownModules =
474 Set.unions
475 [ Map.keysSet foreigns
476 , Map.keysSet locals
477 , Map.keysSet results
478 ]
480 unimportedModules =
481 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
483 regionDict =
484 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
486 toError (name, problem) =
487 Import.Error (regionDict ! name) name unimportedModules problem
488 in
489 fmap toError problems
493-- LOAD CACHED INTERFACES
496loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
497loadInterfaces root same cached =
498 do loading <- traverse (fork . loadInterface root) cached
499 maybeLoaded <- traverse readMVar loading
500 case sequence maybeLoaded of
501 Nothing ->
502 return Nothing
504 Just loaded ->
505 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
508loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
509loadInterface root (name, ciMvar) =
510 do cachedInterface <- takeMVar ciMvar
511 case cachedInterface of
512 Corrupted ->
513 do putMVar ciMvar cachedInterface
514 return Nothing
516 Loaded iface ->
517 do putMVar ciMvar cachedInterface
518 return (Just (name, iface))
520 Unneeded ->
521 do maybeIface <- File.readBinary (Stuff.elmi root name)
522 case maybeIface of
523 Nothing ->
524 do putMVar ciMvar Corrupted
525 return Nothing
527 Just iface ->
528 do putMVar ciMvar (Loaded iface)
529 return (Just (name, iface))
533-- CHECK PROJECT
536checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
537checkMidpoint dmvar statuses =
538 case checkForCycles statuses of
539 Nothing ->
540 do maybeForeigns <- readMVar dmvar
541 case maybeForeigns of
542 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
543 Just fs -> return (Right fs)
545 Just (NE.List name names) ->
546 do _ <- readMVar dmvar
547 return (Left (Exit.BP_Cycle name names))
550checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
551checkMainsMidpoint dmvar statuses smains =
552 case checkForCycles statuses of
553 Nothing ->
554 case checkUniqueMains statuses smains of
555 Nothing ->
556 do maybeForeigns <- readMVar dmvar
557 case maybeForeigns of
558 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
559 Just fs -> return (Right fs)
561 Just problem ->
562 do _ <- readMVar dmvar
563 return (Left problem)
565 Just (NE.List name names) ->
566 do _ <- readMVar dmvar
567 return (Left (Exit.BP_Cycle name names))
571-- CHECK FOR CYCLES
574checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
575checkForCycles modules =
576 let
577 !graph = Map.foldrWithKey addToGraph [] modules
578 !sccs = Graph.stronglyConnComp graph
579 in
580 checkForCyclesHelp sccs
583checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
584checkForCyclesHelp sccs =
585 case sccs of
586 [] ->
587 Nothing
589 scc:otherSccs ->
590 case scc of
591 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
592 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
593 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
596type Node =
597 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
600addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
601addToGraph name status graph =
602 let
603 dependencies =
604 case status of
605 SCached (Details.Local _ _ deps _) -> deps
606 SChanged (Details.Local _ _ deps _) _ _ _ -> deps
607 SBadImport _ -> []
608 SBadSyntax _ _ _ _ -> []
609 SForeign _ -> []
610 SKernel -> []
611 in
612 (name, name, dependencies) : graph
616-- CHECK UNIQUE MAINS
619checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
620checkUniqueMains insides smains =
621 let
622 outsidesDict =
623 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
624 in
625 case Map.traverseWithKey checkOutside outsidesDict of
626 Left problem ->
627 Just problem
629 Right outsides ->
630 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
631 Right () -> Nothing
632 Left problem -> Just problem
635mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
636mainStatusToNamePathPair smain =
637 case smain of
638 SInside _ -> Nothing
639 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
640 SOutsideErr _ -> Nothing
643checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
644checkOutside name paths =
645 case OneOrMore.destruct NE.List paths of
646 NE.List p [] -> Right p
647 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
650checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
651checkInside name p1 status =
652 case status of
653 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
654 SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
655 SBadImport _ -> Right ()
656 SBadSyntax _ _ _ _ -> Right ()
657 SForeign _ -> Right ()
658 SKernel -> Right ()
662-- COMPILE MODULE
665compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
666compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
667 case Compile.compile pkg ifaces modul of
668 Right (Compile.Artifacts canonical annotations objects) ->
669 do let name = Src.getName modul
670 let iface = I.fromModule pkg canonical annotations
671 let docs = makeDocs docsNeed canonical
672 let path = Stuff.elmi root name
673 File.writeBinary (Stuff.elmo root name) objects
674 maybeOldi <- File.readBinary path
675 case maybeOldi of
676 Just oldi | oldi == iface ->
677 do -- iface should be fully forced by equality check
678 Reporting.report key Reporting.BDone
679 return (RSame local iface objects docs)
681 _ ->
682 do -- iface may be lazy still
683 File.writeBinary path iface
684 Reporting.report key Reporting.BDone
685 return (RNew local iface objects docs)
687 Left err ->
688 do Reporting.report key Reporting.BDone
689 return $ RProblem $
690 Error.Module (Src.getName modul) path time source err
694-- WRITE DETAILS
697writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
698writeDetails root (Details.Details time outline locals foreigns extras) results =
699 File.writeBinary (Stuff.details root) $
700 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
703addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
704addNewLocal name result locals =
705 case result of
706 RNew local _ _ _ -> Map.insert name local locals
707 RSame local _ _ _ -> Map.insert name local locals
708 RCached _ _ -> locals
709 RNotFound _ -> locals
710 RProblem _ -> locals
711 RBlocked -> locals
712 RForeign _ -> locals
713 RKernel -> locals
717-- FINALIZE EXPOSED
720finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
721finalizeExposed docsGoal exposed results =
722 case foldr (addImportProblems results) [] (NE.toList exposed) of
723 p:ps ->
724 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
726 [] ->
727 case Map.foldr addErrors [] results of
728 [] -> Right <$> finalizeDocs docsGoal results
729 e:es -> return $ Left $ Exit.BuildBadModules e es
732addErrors :: Result -> [Error.Module] -> [Error.Module]
733addErrors result errors =
734 case result of
735 RNew _ _ _ _ -> errors
736 RSame _ _ _ _ -> errors
737 RCached _ _ -> errors
738 RNotFound _ -> errors
739 RProblem e -> e:errors
740 RBlocked -> errors
741 RForeign _ -> errors
742 RKernel -> errors
745addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
746addImportProblems results name problems =
747 case results ! name of
748 RNew _ _ _ _ -> problems
749 RSame _ _ _ _ -> problems
750 RCached _ _ -> problems
751 RNotFound p -> (name, p) : problems
752 RProblem _ -> problems
753 RBlocked -> problems
754 RForeign _ -> problems
755 RKernel -> problems
759-- DOCS
762data DocsGoal a where
763 KeepDocs :: DocsGoal Docs.Documentation
764 WriteDocs :: FilePath -> DocsGoal ()
765 IgnoreDocs :: DocsGoal ()
768newtype DocsNeed =
769 DocsNeed { needsDocs :: Bool }
772toDocsNeed :: DocsGoal a -> DocsNeed
773toDocsNeed goal =
774 case goal of
775 IgnoreDocs -> DocsNeed False
776 WriteDocs _ -> DocsNeed True
777 KeepDocs -> DocsNeed True
780makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
781makeDocs (DocsNeed isNeeded) modul =
782 if isNeeded then
783 case Docs.fromModule modul of
784 Right docs -> Just docs
785 Left _ -> Nothing
786 else
787 Nothing
790finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
791finalizeDocs goal results =
792 case goal of
793 KeepDocs ->
794 return $ Map.mapMaybe toDocs results
796 WriteDocs path ->
797 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
799 IgnoreDocs ->
800 return ()
803toDocs :: Result -> Maybe Docs.Module
804toDocs result =
805 case result of
806 RNew _ _ _ d -> d
807 RSame _ _ _ d -> d
808 RCached _ _ -> Nothing
809 RNotFound _ -> Nothing
810 RProblem _ -> Nothing
811 RBlocked -> Nothing
812 RForeign _ -> Nothing
813 RKernel -> Nothing
817--------------------------------------------------------------------------------
818------ NOW FOR SOME REPL STUFF -------------------------------------------------
819--------------------------------------------------------------------------------
822-- FROM REPL
825data ReplArtifacts =
826 ReplArtifacts
827 { _repl_home :: ModuleName.Canonical
828 , _repl_modules :: [Module]
829 , _repl_localizer :: L.Localizer
830 , _repl_annotations :: Map.Map Name.Name Can.Annotation
831 }
834fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
835fromRepl root details source =
836 let
837 env@(Env _ _ pkg _ _ _) = makeEnv Reporting.ignorer root details
838 in
839 case Parse.fromByteString pkg source of
840 Left syntaxError ->
841 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
843 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
844 do dmvar <- Details.loadInterfaces root details
846 let deps = map Src.getImportName imports
847 mvar <- newMVar Map.empty
848 crawlDeps env mvar deps ()
850 statuses <- traverse readMVar =<< readMVar mvar
851 midpoint <- checkMidpoint dmvar statuses
853 case midpoint of
854 Left problem ->
855 return $ Left $ Exit.ReplProjectProblem problem
857 Right foreigns ->
858 do rmvar <- newEmptyMVar
859 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
860 putMVar rmvar resultMVars
861 results <- traverse readMVar resultMVars
862 writeDetails root details results
863 depsStatus <- checkDeps root resultMVars deps
864 finalizeReplArtifacts env source modul depsStatus resultMVars results
867finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
868finalizeReplArtifacts env@(Env _ root pkg _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
869 let
870 compileInput ifaces =
871 case Compile.compile pkg ifaces modul of
872 Right (Compile.Artifacts canonical annotations objects) ->
873 let
874 h = Can._name canonical
875 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
876 ms = Map.foldrWithKey addInside [] results
877 in
878 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
880 Left errors ->
881 return $ Left $ Exit.ReplBadInput source errors
882 in
883 case depsStatus of
884 DepsChange ifaces ->
885 compileInput ifaces
887 DepsSame same cached ->
888 do maybeLoaded <- loadInterfaces root same cached
889 case maybeLoaded of
890 Just ifaces -> compileInput ifaces
891 Nothing -> return $ Left $ Exit.ReplBadCache
893 DepsBlock ->
894 case Map.foldr addErrors [] results of
895 [] -> return $ Left $ Exit.ReplBlocked
896 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
898 DepsNotFound problems ->
899 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
900 toImportErrors env resultMVars imports problems
904--------------------------------------------------------------------------------
905--------------------------------------------------------------------------------
906------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
907--------------------------------------------------------------------------------
908--------------------------------------------------------------------------------
912-- FIND MAIN
915data MainLocation
916 = LInside ModuleName.Raw
917 | LOutside FilePath
920findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
921findMains env paths =
922 do mvars <- traverse (fork . findLocation env) paths
923 elocs <- traverse readMVar mvars
924 return $ checkLocations =<< sequence elocs
927checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
928checkLocations locations =
929 let
930 toOneOrMore loc@(Location absolute _ _) =
931 (absolute, OneOrMore.one loc)
933 fromOneOrMore loc locs =
934 case locs of
935 [] -> Right ()
936 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
937 in
938 fmap (\_ -> fmap _location locations) $
939 traverse (OneOrMore.destruct fromOneOrMore) $
940 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
944-- LOCATIONS
947data Location =
948 Location
949 { _absolute :: FilePath
950 , _relative :: FilePath
951 , _location :: MainLocation
952 }
955findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
956findLocation env path =
957 do exists <- File.exists path
958 if exists
959 then findLoc env path <$> Dir.canonicalizePath path
960 else return (Left (Exit.BP_PathUnknown path))
963findLoc :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
964findLoc (Env _ root _ srcDirs _ _) path absolutePath =
965 let
966 (dirs, file) = FP.splitFileName absolutePath
967 (final, ext) = break (=='.') file
968 in
969 if ext /= ".elm"
970 then Left (Exit.BP_WithBadExtension path)
971 else
972 let
973 roots = FP.splitDirectories root
974 segments = FP.splitDirectories dirs ++ [final]
975 in
976 case dropPrefix roots segments of
977 Nothing ->
978 Right (Location absolutePath path (LOutside path))
980 Just relativeSegments ->
981 case Maybe.mapMaybe (isInsideSrcDir relativeSegments) srcDirs of
982 [] -> Right $ Location absolutePath path (LOutside path)
983 [(_, Right name)] -> Right $ Location absolutePath path (LInside name)
984 [(s, Left names)] -> Left $ Exit.BP_MainNameInvalid path s names
985 (s1,_):(s2,_):_ -> Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
988isInsideSrcDir :: [String] -> FilePath -> Maybe (FilePath, Either [String] ModuleName.Raw)
989isInsideSrcDir segments srcDir =
990 case dropPrefix (FP.splitDirectories srcDir) segments of
991 Nothing ->
992 Nothing
994 Just names ->
995 if all isGoodName names
996 then Just (srcDir, Right (Name.fromChars (List.intercalate "." names)))
997 else Just (srcDir, Left names)
1000isGoodName :: [Char] -> Bool
1001isGoodName name =
1002 case name of
1003 [] ->
1004 False
1006 char:chars ->
1007 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1010dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1011dropPrefix roots paths =
1012 case roots of
1013 [] ->
1014 Just paths
1016 r:rs ->
1017 case paths of
1018 [] -> Nothing
1019 p:ps -> if r == p then dropPrefix rs ps else Nothing
1023-- CRAWL MAINS
1026data MainStatus
1027 = SInside ModuleName.Raw
1028 | SOutsideOk Details.Local B.ByteString Src.Module
1029 | SOutsideErr Error.Module
1032crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1033crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1034 case given of
1035 LInside name ->
1036 do statusMVar <- newEmptyMVar
1037 statusDict <- takeMVar mvar
1038 putMVar mvar (Map.insert name statusMVar statusDict)
1039 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1040 return (SInside name)
1042 LOutside path ->
1043 do time <- File.getTime path
1044 source <- File.readUtf8 path
1045 case Parse.fromByteString pkg source of
1046 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1047 do let deps = map Src.getImportName imports
1048 let local = Details.Local path time deps (any isMain values)
1049 crawlDeps env mvar deps (SOutsideOk local source modul)
1051 Left syntaxError ->
1052 return $ SOutsideErr $
1053 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1057-- CHECK MAINS
1060data MainResult
1061 = RInside ModuleName.Raw
1062 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1063 | ROutsideErr Error.Module
1064 | ROutsideBlocked
1067checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1068checkMain env@(Env _ root _ _ _ _) results pendingMain =
1069 case pendingMain of
1070 SInside name ->
1071 return (RInside name)
1073 SOutsideErr err ->
1074 return (ROutsideErr err)
1076 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1077 do depsStatus <- checkDeps root results deps
1078 case depsStatus of
1079 DepsChange ifaces ->
1080 return $ compileOutside env local source ifaces modul
1082 DepsSame same cached ->
1083 do maybeLoaded <- loadInterfaces root same cached
1084 case maybeLoaded of
1085 Nothing -> return ROutsideBlocked
1086 Just ifaces -> return $ compileOutside env local source ifaces modul
1088 DepsBlock ->
1089 return ROutsideBlocked
1091 DepsNotFound problems ->
1092 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1093 Error.BadImports (toImportErrors env results imports problems)
1096compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
1097compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1098 let
1099 name = Src.getName modul
1100 in
1101 case Compile.compile pkg ifaces modul of
1102 Right (Compile.Artifacts canonical annotations objects) ->
1103 ROutsideOk name (I.fromModule pkg canonical annotations) objects
1105 Left errors ->
1106 ROutsideErr $
1107 Error.Module name path time source errors
1111-- TO ARTIFACTS
1114data Main
1115 = Inside ModuleName.Raw
1116 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1119toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1120toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1121 case gatherProblemsOrMains results mainResults of
1122 Left (NE.List e es) ->
1123 Left (Exit.BuildBadModules e es)
1125 Right mains ->
1126 Right $ Artifacts pkg foreigns mains $
1127 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1130gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1131gatherProblemsOrMains results (NE.List mainResult mainResults) =
1132 let
1133 sortMain result (es, mains) =
1134 case result of
1135 RInside n -> ( es, Inside n : mains)
1136 ROutsideOk n i o -> ( es, Outside n i o : mains)
1137 ROutsideErr e -> (e:es, mains)
1138 ROutsideBlocked -> ( es, mains)
1140 errors = Map.foldr addErrors [] results
1141 in
1142 case (mainResult, foldr sortMain (errors, []) mainResults) of
1143 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1144 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1145 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1146 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1147 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1148 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1149 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1152addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1153addInside name result modules =
1154 case result of
1155 RNew _ iface objs _ -> Fresh name iface objs : modules
1156 RSame _ iface objs _ -> Fresh name iface objs : modules
1157 RCached main mvar -> Cached name main mvar : modules
1158 RNotFound _ -> error (badInside name)
1159 RProblem _ -> error (badInside name)
1160 RBlocked -> error (badInside name)
1161 RForeign _ -> modules
1162 RKernel -> modules
1165badInside :: ModuleName.Raw -> [Char]
1166badInside name =
1167 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1170addOutside :: MainResult -> [Module] -> [Module]
1171addOutside main modules =
1172 case main of
1173 RInside _ -> modules
1174 ROutsideOk name iface objs -> Fresh name iface objs : modules
1175 ROutsideErr _ -> modules
1176 ROutsideBlocked -> modules