git.iko.soy/elk
on 5e73421 help sign in
elk/builder/src/Build.hs
1175 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 return $ RProblem $
689 Error.Module (Src.getName modul) path time source err
693-- WRITE DETAILS
696writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
697writeDetails root (Details.Details time outline locals foreigns extras) results =
698 File.writeBinary (Stuff.details root) $
699 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
702addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
703addNewLocal name result locals =
704 case result of
705 RNew local _ _ _ -> Map.insert name local locals
706 RSame local _ _ _ -> Map.insert name local locals
707 RCached _ _ -> locals
708 RNotFound _ -> locals
709 RProblem _ -> locals
710 RBlocked -> locals
711 RForeign _ -> locals
712 RKernel -> locals
716-- FINALIZE EXPOSED
719finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
720finalizeExposed docsGoal exposed results =
721 case foldr (addImportProblems results) [] (NE.toList exposed) of
722 p:ps ->
723 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
725 [] ->
726 case Map.foldr addErrors [] results of
727 [] -> Right <$> finalizeDocs docsGoal results
728 e:es -> return $ Left $ Exit.BuildBadModules e es
731addErrors :: Result -> [Error.Module] -> [Error.Module]
732addErrors result errors =
733 case result of
734 RNew _ _ _ _ -> errors
735 RSame _ _ _ _ -> errors
736 RCached _ _ -> errors
737 RNotFound _ -> errors
738 RProblem e -> e:errors
739 RBlocked -> errors
740 RForeign _ -> errors
741 RKernel -> errors
744addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
745addImportProblems results name problems =
746 case results ! name of
747 RNew _ _ _ _ -> problems
748 RSame _ _ _ _ -> problems
749 RCached _ _ -> problems
750 RNotFound p -> (name, p) : problems
751 RProblem _ -> problems
752 RBlocked -> problems
753 RForeign _ -> problems
754 RKernel -> problems
758-- DOCS
761data DocsGoal a where
762 KeepDocs :: DocsGoal Docs.Documentation
763 WriteDocs :: FilePath -> DocsGoal ()
764 IgnoreDocs :: DocsGoal ()
767newtype DocsNeed =
768 DocsNeed { needsDocs :: Bool }
771toDocsNeed :: DocsGoal a -> DocsNeed
772toDocsNeed goal =
773 case goal of
774 IgnoreDocs -> DocsNeed False
775 WriteDocs _ -> DocsNeed True
776 KeepDocs -> DocsNeed True
779makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
780makeDocs (DocsNeed isNeeded) modul =
781 if isNeeded then
782 case Docs.fromModule modul of
783 Right docs -> Just docs
784 Left _ -> Nothing
785 else
786 Nothing
789finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
790finalizeDocs goal results =
791 case goal of
792 KeepDocs ->
793 return $ Map.mapMaybe toDocs results
795 WriteDocs path ->
796 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
798 IgnoreDocs ->
799 return ()
802toDocs :: Result -> Maybe Docs.Module
803toDocs result =
804 case result of
805 RNew _ _ _ d -> d
806 RSame _ _ _ d -> d
807 RCached _ _ -> Nothing
808 RNotFound _ -> Nothing
809 RProblem _ -> Nothing
810 RBlocked -> Nothing
811 RForeign _ -> Nothing
812 RKernel -> Nothing
816--------------------------------------------------------------------------------
817------ NOW FOR SOME REPL STUFF -------------------------------------------------
818--------------------------------------------------------------------------------
821-- FROM REPL
824data ReplArtifacts =
825 ReplArtifacts
826 { _repl_home :: ModuleName.Canonical
827 , _repl_modules :: [Module]
828 , _repl_localizer :: L.Localizer
829 , _repl_annotations :: Map.Map Name.Name Can.Annotation
830 }
833fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
834fromRepl root details source =
835 let
836 env@(Env _ _ pkg _ _ _) = makeEnv Reporting.ignorer root details
837 in
838 case Parse.fromByteString pkg source of
839 Left syntaxError ->
840 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
842 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
843 do dmvar <- Details.loadInterfaces root details
845 let deps = map Src.getImportName imports
846 mvar <- newMVar Map.empty
847 crawlDeps env mvar deps ()
849 statuses <- traverse readMVar =<< readMVar mvar
850 midpoint <- checkMidpoint dmvar statuses
852 case midpoint of
853 Left problem ->
854 return $ Left $ Exit.ReplProjectProblem problem
856 Right foreigns ->
857 do rmvar <- newEmptyMVar
858 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
859 putMVar rmvar resultMVars
860 results <- traverse readMVar resultMVars
861 writeDetails root details results
862 depsStatus <- checkDeps root resultMVars deps
863 finalizeReplArtifacts env source modul depsStatus resultMVars results
866finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
867finalizeReplArtifacts env@(Env _ root pkg _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
868 let
869 compileInput ifaces =
870 case Compile.compile pkg ifaces modul of
871 Right (Compile.Artifacts canonical annotations objects) ->
872 let
873 h = Can._name canonical
874 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
875 ms = Map.foldrWithKey addInside [] results
876 in
877 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
879 Left errors ->
880 return $ Left $ Exit.ReplBadInput source errors
881 in
882 case depsStatus of
883 DepsChange ifaces ->
884 compileInput ifaces
886 DepsSame same cached ->
887 do maybeLoaded <- loadInterfaces root same cached
888 case maybeLoaded of
889 Just ifaces -> compileInput ifaces
890 Nothing -> return $ Left $ Exit.ReplBadCache
892 DepsBlock ->
893 case Map.foldr addErrors [] results of
894 [] -> return $ Left $ Exit.ReplBlocked
895 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
897 DepsNotFound problems ->
898 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
899 toImportErrors env resultMVars imports problems
903--------------------------------------------------------------------------------
904--------------------------------------------------------------------------------
905------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
906--------------------------------------------------------------------------------
907--------------------------------------------------------------------------------
911-- FIND MAIN
914data MainLocation
915 = LInside ModuleName.Raw
916 | LOutside FilePath
919findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
920findMains env paths =
921 do mvars <- traverse (fork . findLocation env) paths
922 elocs <- traverse readMVar mvars
923 return $ checkLocations =<< sequence elocs
926checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
927checkLocations locations =
928 let
929 toOneOrMore loc@(Location absolute _ _) =
930 (absolute, OneOrMore.one loc)
932 fromOneOrMore loc locs =
933 case locs of
934 [] -> Right ()
935 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
936 in
937 fmap (\_ -> fmap _location locations) $
938 traverse (OneOrMore.destruct fromOneOrMore) $
939 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
943-- LOCATIONS
946data Location =
947 Location
948 { _absolute :: FilePath
949 , _relative :: FilePath
950 , _location :: MainLocation
951 }
954findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
955findLocation env path =
956 do exists <- File.exists path
957 if exists
958 then findLoc env path <$> Dir.canonicalizePath path
959 else return (Left (Exit.BP_PathUnknown path))
962findLoc :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
963findLoc (Env _ root _ srcDirs _ _) path absolutePath =
964 let
965 (dirs, file) = FP.splitFileName absolutePath
966 (final, ext) = break (=='.') file
967 in
968 if ext /= ".elm"
969 then Left (Exit.BP_WithBadExtension path)
970 else
971 let
972 roots = FP.splitDirectories root
973 segments = FP.splitDirectories dirs ++ [final]
974 in
975 case dropPrefix roots segments of
976 Nothing ->
977 Right (Location absolutePath path (LOutside path))
979 Just relativeSegments ->
980 case Maybe.mapMaybe (isInsideSrcDir relativeSegments) srcDirs of
981 [] -> Right $ Location absolutePath path (LOutside path)
982 [(_, Right name)] -> Right $ Location absolutePath path (LInside name)
983 [(s, Left names)] -> Left $ Exit.BP_MainNameInvalid path s names
984 (s1,_):(s2,_):_ -> Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
987isInsideSrcDir :: [String] -> FilePath -> Maybe (FilePath, Either [String] ModuleName.Raw)
988isInsideSrcDir segments srcDir =
989 case dropPrefix (FP.splitDirectories srcDir) segments of
990 Nothing ->
991 Nothing
993 Just names ->
994 if all isGoodName names
995 then Just (srcDir, Right (Name.fromChars (List.intercalate "." names)))
996 else Just (srcDir, Left names)
999isGoodName :: [Char] -> Bool
1000isGoodName name =
1001 case name of
1002 [] ->
1003 False
1005 char:chars ->
1006 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1009dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1010dropPrefix roots paths =
1011 case roots of
1012 [] ->
1013 Just paths
1015 r:rs ->
1016 case paths of
1017 [] -> Nothing
1018 p:ps -> if r == p then dropPrefix rs ps else Nothing
1022-- CRAWL MAINS
1025data MainStatus
1026 = SInside ModuleName.Raw
1027 | SOutsideOk Details.Local B.ByteString Src.Module
1028 | SOutsideErr Error.Module
1031crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1032crawlMain env@(Env _ _ pkg _ _ _) mvar given =
1033 case given of
1034 LInside name ->
1035 do statusMVar <- newEmptyMVar
1036 statusDict <- takeMVar mvar
1037 putMVar mvar (Map.insert name statusMVar statusDict)
1038 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1039 return (SInside name)
1041 LOutside path ->
1042 do time <- File.getTime path
1043 source <- File.readUtf8 path
1044 case Parse.fromByteString pkg source of
1045 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1046 do let deps = map Src.getImportName imports
1047 let local = Details.Local path time deps (any isMain values)
1048 crawlDeps env mvar deps (SOutsideOk local source modul)
1050 Left syntaxError ->
1051 return $ SOutsideErr $
1052 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1056-- CHECK MAINS
1059data MainResult
1060 = RInside ModuleName.Raw
1061 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1062 | ROutsideErr Error.Module
1063 | ROutsideBlocked
1066checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1067checkMain env@(Env _ root _ _ _ _) results pendingMain =
1068 case pendingMain of
1069 SInside name ->
1070 return (RInside name)
1072 SOutsideErr err ->
1073 return (ROutsideErr err)
1075 SOutsideOk local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1076 do depsStatus <- checkDeps root results deps
1077 case depsStatus of
1078 DepsChange ifaces ->
1079 compileOutside env local source ifaces modul
1081 DepsSame same cached ->
1082 do maybeLoaded <- loadInterfaces root same cached
1083 case maybeLoaded of
1084 Nothing -> return ROutsideBlocked
1085 Just ifaces -> compileOutside env local source ifaces modul
1087 DepsBlock ->
1088 return ROutsideBlocked
1090 DepsNotFound problems ->
1091 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1092 Error.BadImports (toImportErrors env results imports problems)
1095compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO MainResult
1096compileOutside (Env key _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
1097 let
1098 name = Src.getName modul
1099 in
1100 case Compile.compile pkg ifaces modul of
1101 Right (Compile.Artifacts canonical annotations objects) ->
1102 do Reporting.report key Reporting.BDone
1103 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1105 Left errors ->
1106 return $ ROutsideErr $ Error.Module name path time source errors
1110-- TO ARTIFACTS
1113data Main
1114 = Inside ModuleName.Raw
1115 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1118toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1119toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
1120 case gatherProblemsOrMains results mainResults of
1121 Left (NE.List e es) ->
1122 Left (Exit.BuildBadModules e es)
1124 Right mains ->
1125 Right $ Artifacts pkg foreigns mains $
1126 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1129gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1130gatherProblemsOrMains results (NE.List mainResult mainResults) =
1131 let
1132 sortMain result (es, mains) =
1133 case result of
1134 RInside n -> ( es, Inside n : mains)
1135 ROutsideOk n i o -> ( es, Outside n i o : mains)
1136 ROutsideErr e -> (e:es, mains)
1137 ROutsideBlocked -> ( es, mains)
1139 errors = Map.foldr addErrors [] results
1140 in
1141 case (mainResult, foldr sortMain (errors, []) mainResults) of
1142 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1143 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1144 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1145 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1146 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1147 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1148 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1151addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1152addInside name result modules =
1153 case result of
1154 RNew _ iface objs _ -> Fresh name iface objs : modules
1155 RSame _ iface objs _ -> Fresh name iface objs : modules
1156 RCached main mvar -> Cached name main mvar : modules
1157 RNotFound _ -> error (badInside name)
1158 RProblem _ -> error (badInside name)
1159 RBlocked -> error (badInside name)
1160 RForeign _ -> modules
1161 RKernel -> modules
1164badInside :: ModuleName.Raw -> [Char]
1165badInside name =
1166 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1169addOutside :: MainResult -> [Module] -> [Module]
1170addOutside main modules =
1171 case main of
1172 RInside _ -> modules
1173 ROutsideOk name iface objs -> Fresh name iface objs : modules
1174 ROutsideErr _ -> modules
1175 ROutsideBlocked -> modules