git.iko.soy/elk
on ef457e7 help sign in
elk/builder/src/Build.hs
1216 lines 40 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 , _buildID :: Details.BuildID
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 buildID locals foreigns _) =
77 case validOutline of
78 Details.ValidApp srcDirs ->
79 Env key root Pkg.dummyName (NE.toList srcDirs) buildID locals foreigns
81 Details.ValidPkg pkg _ _ ->
82 Env key root pkg ["src"] buildID 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 buildID 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 do newTime <- File.getTime path
256 case Map.lookup name locals of
257 Nothing ->
258 crawlFile env mvar docsNeed name path newTime buildID
260 Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
261 if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
262 then crawlFile env mvar docsNeed name path newTime lastChange
263 else crawlDeps env mvar deps (SCached local)
265 p1:p2:ps ->
266 return $ SBadImport $ Import.AmbiguousLocal p1 p2 ps
268 [] ->
269 case Map.lookup name foreigns of
270 Just (Details.Foreign dep deps) ->
271 case deps of
272 [] ->
273 return $ SForeign dep
275 d:ds ->
276 return $ SBadImport $ Import.AmbiguousForeign dep d ds
278 Nothing ->
279 if Name.isKernel name && Pkg.isKernel pkg then
280 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
281 return $ if exists then SKernel else SBadImport Import.NotFound
282 else
283 return $ SBadImport Import.NotFound
286crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
287crawlFile env@(Env _ root pkg _ buildID _ _) mvar docsNeed expectedName path time lastChange =
288 do source <- File.readUtf8 (root </> path)
290 case Parse.fromByteString pkg source of
291 Left err ->
292 return $ SBadSyntax path time source err
294 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
295 case maybeActualName of
296 Nothing ->
297 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
299 Just name@(A.At _ actualName) ->
300 if expectedName == actualName then
301 let
302 deps = map Src.getImportName imports
303 local = Details.Local path time deps (any isMain values) lastChange buildID
304 in
305 crawlDeps env mvar deps (SChanged local source modul docsNeed)
306 else
307 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
310isMain :: A.Located Src.Value -> Bool
311isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
312 name == Name._main
316-- CHECK MODULE
319type ResultDict =
320 Map.Map ModuleName.Raw (MVar Result)
323data Result
324 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
325 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
326 | RCached Bool Details.BuildID (MVar CachedInterface)
327 | RNotFound Import.Problem
328 | RProblem Error.Module
329 | RBlocked
330 | RForeign I.Interface
331 | RKernel
334data CachedInterface
335 = Unneeded
336 | Loaded I.Interface
337 | Corrupted
340checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
341checkModule env@(Env _ root pkg _ _ _ _) foreigns resultsMVar name status =
342 case status of
343 SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
344 do results <- readMVar resultsMVar
345 depsStatus <- checkDeps root results deps lastCompile
346 case depsStatus of
347 DepsChange ifaces ->
348 do source <- File.readUtf8 path
349 case Parse.fromByteString pkg source of
350 Right modul -> compile env (DocsNeed False) local source ifaces modul
351 Left err ->
352 return $ RProblem $
353 Error.Module name path time source (Error.BadSyntax err)
355 DepsSame _ _ ->
356 do mvar <- newMVar Unneeded
357 return (RCached hasMain lastChange mvar)
359 DepsBlock ->
360 return RBlocked
362 DepsNotFound problems ->
363 do source <- File.readUtf8 path
364 return $ RProblem $ Error.Module name path time source $
365 case Parse.fromByteString pkg source of
366 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
367 Error.BadImports (toImportErrors env results imports problems)
369 Left err ->
370 Error.BadSyntax err
372 SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
373 do results <- readMVar resultsMVar
374 depsStatus <- checkDeps root results deps lastCompile
375 case depsStatus of
376 DepsChange ifaces ->
377 compile env docsNeed local source ifaces modul
379 DepsSame same cached ->
380 do maybeLoaded <- loadInterfaces root same cached
381 case maybeLoaded of
382 Nothing -> return RBlocked
383 Just ifaces -> compile env docsNeed local source ifaces modul
385 DepsBlock ->
386 return RBlocked
388 DepsNotFound problems ->
389 return $ RProblem $ Error.Module name path time source $
390 Error.BadImports (toImportErrors env results imports problems)
392 SBadImport importProblem ->
393 return (RNotFound importProblem)
395 SBadSyntax path time source err ->
396 return $ RProblem $ Error.Module name path time source $
397 Error.BadSyntax err
399 SForeign home ->
400 case foreigns ! ModuleName.Canonical home name of
401 I.Public iface -> return (RForeign iface)
402 I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
404 SKernel ->
405 return RKernel
409-- CHECK DEPS
412data DepsStatus
413 = DepsChange (Map.Map ModuleName.Raw I.Interface)
414 | DepsSame [Dep] [CDep]
415 | DepsBlock
416 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
419checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
420checkDeps root results deps lastCompile =
421 checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
424type Dep = (ModuleName.Raw, I.Interface)
425type CDep = (ModuleName.Raw, MVar CachedInterface)
428checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
429checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
430 case deps of
431 dep:otherDeps ->
432 do result <- readMVar (results ! dep)
433 case result of
434 RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
435 checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
437 RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
438 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
440 RCached _ lastChange mvar ->
441 checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
443 RNotFound prob ->
444 checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
446 RProblem _ ->
447 checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
449 RBlocked ->
450 checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
452 RForeign iface ->
453 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
455 RKernel ->
456 checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
459 [] ->
460 case reverse importProblems of
461 p:ps ->
462 return $ DepsNotFound (NE.List p ps)
464 [] ->
465 if isBlocked then
466 return $ DepsBlock
468 else if null new && lastDepChange <= lastCompile then
469 return $ DepsSame same cached
471 else
472 do maybeLoaded <- loadInterfaces root same cached
473 case maybeLoaded of
474 Nothing -> return DepsBlock
475 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
479-- TO IMPORT ERROR
482toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
483toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
484 let
485 knownModules =
486 Set.unions
487 [ Map.keysSet foreigns
488 , Map.keysSet locals
489 , Map.keysSet results
490 ]
492 unimportedModules =
493 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
495 regionDict =
496 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
498 toError (name, problem) =
499 Import.Error (regionDict ! name) name unimportedModules problem
500 in
501 fmap toError problems
505-- LOAD CACHED INTERFACES
508loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
509loadInterfaces root same cached =
510 do loading <- traverse (fork . loadInterface root) cached
511 maybeLoaded <- traverse readMVar loading
512 case sequence maybeLoaded of
513 Nothing ->
514 return Nothing
516 Just loaded ->
517 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
520loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
521loadInterface root (name, ciMvar) =
522 do cachedInterface <- takeMVar ciMvar
523 case cachedInterface of
524 Corrupted ->
525 do putMVar ciMvar cachedInterface
526 return Nothing
528 Loaded iface ->
529 do putMVar ciMvar cachedInterface
530 return (Just (name, iface))
532 Unneeded ->
533 do maybeIface <- File.readBinary (Stuff.elmi root name)
534 case maybeIface of
535 Nothing ->
536 do putMVar ciMvar Corrupted
537 return Nothing
539 Just iface ->
540 do putMVar ciMvar (Loaded iface)
541 return (Just (name, iface))
545-- CHECK PROJECT
548checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
549checkMidpoint dmvar statuses =
550 case checkForCycles statuses of
551 Nothing ->
552 do maybeForeigns <- readMVar dmvar
553 case maybeForeigns of
554 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
555 Just fs -> return (Right fs)
557 Just (NE.List name names) ->
558 do _ <- readMVar dmvar
559 return (Left (Exit.BP_Cycle name names))
562checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
563checkMainsMidpoint dmvar statuses smains =
564 case checkForCycles statuses of
565 Nothing ->
566 case checkUniqueMains statuses smains of
567 Nothing ->
568 do maybeForeigns <- readMVar dmvar
569 case maybeForeigns of
570 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
571 Just fs -> return (Right fs)
573 Just problem ->
574 do _ <- readMVar dmvar
575 return (Left problem)
577 Just (NE.List name names) ->
578 do _ <- readMVar dmvar
579 return (Left (Exit.BP_Cycle name names))
583-- CHECK FOR CYCLES
586checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
587checkForCycles modules =
588 let
589 !graph = Map.foldrWithKey addToGraph [] modules
590 !sccs = Graph.stronglyConnComp graph
591 in
592 checkForCyclesHelp sccs
595checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
596checkForCyclesHelp sccs =
597 case sccs of
598 [] ->
599 Nothing
601 scc:otherSccs ->
602 case scc of
603 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
604 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
605 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
608type Node =
609 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
612addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
613addToGraph name status graph =
614 let
615 dependencies =
616 case status of
617 SCached (Details.Local _ _ deps _ _ _) -> deps
618 SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
619 SBadImport _ -> []
620 SBadSyntax _ _ _ _ -> []
621 SForeign _ -> []
622 SKernel -> []
623 in
624 (name, name, dependencies) : graph
628-- CHECK UNIQUE MAINS
631checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
632checkUniqueMains insides smains =
633 let
634 outsidesDict =
635 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
636 in
637 case Map.traverseWithKey checkOutside outsidesDict of
638 Left problem ->
639 Just problem
641 Right outsides ->
642 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
643 Right () -> Nothing
644 Left problem -> Just problem
647mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
648mainStatusToNamePathPair smain =
649 case smain of
650 SInside _ -> Nothing
651 SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
652 SOutsideErr _ -> Nothing
655checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
656checkOutside name paths =
657 case OneOrMore.destruct NE.List paths of
658 NE.List p [] -> Right p
659 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
662checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
663checkInside name p1 status =
664 case status of
665 SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
666 SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
667 SBadImport _ -> Right ()
668 SBadSyntax _ _ _ _ -> Right ()
669 SForeign _ -> Right ()
670 SKernel -> Right ()
674-- COMPILE MODULE
677compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
678compile (Env key root pkg _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
679 case Compile.compile pkg ifaces modul of
680 Right (Compile.Artifacts canonical annotations objects) ->
681 do let name = Src.getName modul
682 let iface = I.fromModule pkg canonical annotations
683 let docs = makeDocs docsNeed canonical
684 let elmi = Stuff.elmi root name
685 File.writeBinary (Stuff.elmo root name) objects
686 maybeOldi <- File.readBinary elmi
687 case maybeOldi of
688 Just oldi | oldi == iface ->
689 do -- iface should be fully forced by equality check
690 Reporting.report key Reporting.BDone
691 let local = Details.Local path time deps main lastChange buildID
692 return (RSame local iface objects docs)
694 _ ->
695 do -- iface may be lazy still
696 File.writeBinary elmi iface
697 Reporting.report key Reporting.BDone
698 let local = Details.Local path time deps main buildID buildID
699 return (RNew local iface objects docs)
701 Left err ->
702 return $ RProblem $
703 Error.Module (Src.getName modul) path time source err
707-- WRITE DETAILS
710writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
711writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
712 File.writeBinary (Stuff.details root) $
713 Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
716addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
717addNewLocal name result locals =
718 case result of
719 RNew local _ _ _ -> Map.insert name local locals
720 RSame local _ _ _ -> Map.insert name local locals
721 RCached _ _ _ -> locals
722 RNotFound _ -> locals
723 RProblem _ -> locals
724 RBlocked -> locals
725 RForeign _ -> locals
726 RKernel -> locals
730-- FINALIZE EXPOSED
733finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
734finalizeExposed docsGoal exposed results =
735 case foldr (addImportProblems results) [] (NE.toList exposed) of
736 p:ps ->
737 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
739 [] ->
740 case Map.foldr addErrors [] results of
741 [] -> Right <$> finalizeDocs docsGoal results
742 e:es -> return $ Left $ Exit.BuildBadModules e es
745addErrors :: Result -> [Error.Module] -> [Error.Module]
746addErrors result errors =
747 case result of
748 RNew _ _ _ _ -> errors
749 RSame _ _ _ _ -> errors
750 RCached _ _ _ -> errors
751 RNotFound _ -> errors
752 RProblem e -> e:errors
753 RBlocked -> errors
754 RForeign _ -> errors
755 RKernel -> errors
758addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
759addImportProblems results name problems =
760 case results ! name of
761 RNew _ _ _ _ -> problems
762 RSame _ _ _ _ -> problems
763 RCached _ _ _ -> problems
764 RNotFound p -> (name, p) : problems
765 RProblem _ -> problems
766 RBlocked -> problems
767 RForeign _ -> problems
768 RKernel -> problems
772-- DOCS
775data DocsGoal a where
776 KeepDocs :: DocsGoal Docs.Documentation
777 WriteDocs :: FilePath -> DocsGoal ()
778 IgnoreDocs :: DocsGoal ()
781newtype DocsNeed =
782 DocsNeed { needsDocs :: Bool }
785toDocsNeed :: DocsGoal a -> DocsNeed
786toDocsNeed goal =
787 case goal of
788 IgnoreDocs -> DocsNeed False
789 WriteDocs _ -> DocsNeed True
790 KeepDocs -> DocsNeed True
793makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
794makeDocs (DocsNeed isNeeded) modul =
795 if isNeeded then
796 case Docs.fromModule modul of
797 Right docs -> Just docs
798 Left _ -> Nothing
799 else
800 Nothing
803finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
804finalizeDocs goal results =
805 case goal of
806 KeepDocs ->
807 return $ Map.mapMaybe toDocs results
809 WriteDocs path ->
810 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
812 IgnoreDocs ->
813 return ()
816toDocs :: Result -> Maybe Docs.Module
817toDocs result =
818 case result of
819 RNew _ _ _ d -> d
820 RSame _ _ _ d -> d
821 RCached _ _ _ -> Nothing
822 RNotFound _ -> Nothing
823 RProblem _ -> Nothing
824 RBlocked -> Nothing
825 RForeign _ -> Nothing
826 RKernel -> Nothing
830--------------------------------------------------------------------------------
831------ NOW FOR SOME REPL STUFF -------------------------------------------------
832--------------------------------------------------------------------------------
835-- FROM REPL
838data ReplArtifacts =
839 ReplArtifacts
840 { _repl_home :: ModuleName.Canonical
841 , _repl_modules :: [Module]
842 , _repl_localizer :: L.Localizer
843 , _repl_annotations :: Map.Map Name.Name Can.Annotation
844 }
847fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
848fromRepl root details source =
849 let
850 env@(Env _ _ pkg _ _ _ _) = makeEnv Reporting.ignorer root details
851 in
852 case Parse.fromByteString pkg source of
853 Left syntaxError ->
854 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
856 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
857 do dmvar <- Details.loadInterfaces root details
859 let deps = map Src.getImportName imports
860 mvar <- newMVar Map.empty
861 crawlDeps env mvar deps ()
863 statuses <- traverse readMVar =<< readMVar mvar
864 midpoint <- checkMidpoint dmvar statuses
866 case midpoint of
867 Left problem ->
868 return $ Left $ Exit.ReplProjectProblem problem
870 Right foreigns ->
871 do rmvar <- newEmptyMVar
872 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
873 putMVar rmvar resultMVars
874 results <- traverse readMVar resultMVars
875 writeDetails root details results
876 depsStatus <- checkDeps root resultMVars deps 0
877 finalizeReplArtifacts env source modul depsStatus resultMVars results
880finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
881finalizeReplArtifacts env@(Env _ root pkg _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
882 let
883 compileInput ifaces =
884 case Compile.compile pkg ifaces modul of
885 Right (Compile.Artifacts canonical annotations objects) ->
886 let
887 h = Can._name canonical
888 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
889 ms = Map.foldrWithKey addInside [] results
890 in
891 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
893 Left errors ->
894 return $ Left $ Exit.ReplBadInput source errors
895 in
896 case depsStatus of
897 DepsChange ifaces ->
898 compileInput ifaces
900 DepsSame same cached ->
901 do maybeLoaded <- loadInterfaces root same cached
902 case maybeLoaded of
903 Just ifaces -> compileInput ifaces
904 Nothing -> return $ Left $ Exit.ReplBadCache
906 DepsBlock ->
907 case Map.foldr addErrors [] results of
908 [] -> return $ Left $ Exit.ReplBlocked
909 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
911 DepsNotFound problems ->
912 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
913 toImportErrors env resultMVars imports problems
917--------------------------------------------------------------------------------
918--------------------------------------------------------------------------------
919------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
920--------------------------------------------------------------------------------
921--------------------------------------------------------------------------------
925-- FIND MAIN
928data MainLocation
929 = LInside ModuleName.Raw
930 | LOutside FilePath
933findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
934findMains env paths =
935 do mvars <- traverse (fork . findLocation env) paths
936 elocs <- traverse readMVar mvars
937 return $ checkLocations =<< sequence elocs
940checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
941checkLocations locations =
942 let
943 toOneOrMore loc@(Location absolute _ _) =
944 (absolute, OneOrMore.one loc)
946 fromOneOrMore loc locs =
947 case locs of
948 [] -> Right ()
949 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
950 in
951 fmap (\_ -> fmap _location locations) $
952 traverse (OneOrMore.destruct fromOneOrMore) $
953 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
957-- LOCATIONS
960data Location =
961 Location
962 { _absolute :: FilePath
963 , _relative :: FilePath
964 , _location :: MainLocation
965 }
968findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
969findLocation env path =
970 do exists <- File.exists path
971 if exists
972 then findLoc env path =<< Dir.canonicalizePath path
973 else return (Left (Exit.BP_PathUnknown path))
976findLoc :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
977findLoc (Env _ root _ srcDirs _ _ _) path absolutePath =
978 let
979 (dirs, file) = FP.splitFileName absolutePath
980 (final, ext) = FP.splitExtension file
981 in
982 if ext /= ".elm"
983 then
984 return $ Left $ Exit.BP_WithBadExtension path
985 else
986 let
987 roots = FP.splitDirectories root
988 segments = FP.splitDirectories dirs ++ [final]
989 in
990 case dropPrefix roots segments of
991 Nothing ->
992 return $ Right $ Location absolutePath path (LOutside path)
994 Just relativeSegments ->
995 case Maybe.mapMaybe (isInsideSrcDirByPath relativeSegments) srcDirs of
996 [] ->
997 return $ Right $ Location absolutePath path (LOutside path)
999 [(_, Right names)] ->
1000 do let name = Name.fromChars (List.intercalate "." names)
1001 matchingDirs <- filterM (isInsideSrcDirByName root names) srcDirs
1002 case matchingDirs of
1003 d1:d2:_ ->
1004 do let p1 = d1 </> FP.joinPath names <.> "elm"
1005 let p2 = d2 </> FP.joinPath names <.> "elm"
1006 return $ Left $ Exit.BP_MainNameDuplicate name p1 p2
1008 _ ->
1009 return $ Right $ Location absolutePath path (LInside name)
1011 [(s, Left names)] ->
1012 return $ Left $ Exit.BP_MainNameInvalid path s names
1014 (s1,_):(s2,_):_ ->
1015 return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1019isInsideSrcDirByName :: FilePath -> [String] -> FilePath -> IO Bool
1020isInsideSrcDirByName root names srcDir =
1021 File.exists (root </> srcDir </> FP.joinPath names <.> "elm")
1024isInsideSrcDirByPath :: [String] -> FilePath -> Maybe (FilePath, Either [String] [String])
1025isInsideSrcDirByPath segments srcDir =
1026 case dropPrefix (FP.splitDirectories srcDir) segments of
1027 Nothing ->
1028 Nothing
1030 Just names ->
1031 if all isGoodName names
1032 then Just (srcDir, Right names)
1033 else Just (srcDir, Left names)
1036isGoodName :: [Char] -> Bool
1037isGoodName name =
1038 case name of
1039 [] ->
1040 False
1042 char:chars ->
1043 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1046dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1047dropPrefix roots paths =
1048 case roots of
1049 [] ->
1050 Just paths
1052 ".":rs ->
1053 dropPrefix rs paths
1055 r:rs ->
1056 case paths of
1057 [] -> Nothing
1058 ".":ps -> dropPrefix roots ps
1059 p:ps -> if r == p then dropPrefix rs ps else Nothing
1063-- CRAWL MAINS
1066data MainStatus
1067 = SInside ModuleName.Raw
1068 | SOutsideOk Details.Local B.ByteString Src.Module
1069 | SOutsideErr Error.Module
1072crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1073crawlMain env@(Env _ _ pkg _ buildID _ _) mvar given =
1074 case given of
1075 LInside name ->
1076 do statusMVar <- newEmptyMVar
1077 statusDict <- takeMVar mvar
1078 putMVar mvar (Map.insert name statusMVar statusDict)
1079 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1080 return (SInside name)
1082 LOutside path ->
1083 do time <- File.getTime path
1084 source <- File.readUtf8 path
1085 case Parse.fromByteString pkg source of
1086 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1087 do let deps = map Src.getImportName imports
1088 let local = Details.Local path time deps (any isMain values) buildID buildID
1089 crawlDeps env mvar deps (SOutsideOk local source modul)
1091 Left syntaxError ->
1092 return $ SOutsideErr $
1093 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1097-- CHECK MAINS
1100data MainResult
1101 = RInside ModuleName.Raw
1102 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1103 | ROutsideErr Error.Module
1104 | ROutsideBlocked
1107checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1108checkMain env@(Env _ root _ _ _ _ _) results pendingMain =
1109 case pendingMain of
1110 SInside name ->
1111 return (RInside name)
1113 SOutsideErr err ->
1114 return (ROutsideErr err)
1116 SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1117 do depsStatus <- checkDeps root results deps lastCompile
1118 case depsStatus of
1119 DepsChange ifaces ->
1120 compileOutside env local source ifaces modul
1122 DepsSame same cached ->
1123 do maybeLoaded <- loadInterfaces root same cached
1124 case maybeLoaded of
1125 Nothing -> return ROutsideBlocked
1126 Just ifaces -> compileOutside env local source ifaces modul
1128 DepsBlock ->
1129 return ROutsideBlocked
1131 DepsNotFound problems ->
1132 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1133 Error.BadImports (toImportErrors env results imports problems)
1136compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO MainResult
1137compileOutside (Env key _ pkg _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1138 let
1139 name = Src.getName modul
1140 in
1141 case Compile.compile pkg ifaces modul of
1142 Right (Compile.Artifacts canonical annotations objects) ->
1143 do Reporting.report key Reporting.BDone
1144 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1146 Left errors ->
1147 return $ ROutsideErr $ Error.Module name path time source errors
1151-- TO ARTIFACTS
1154data Main
1155 = Inside ModuleName.Raw
1156 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1159toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1160toArtifacts (Env _ _ pkg _ _ _ _) foreigns results mainResults =
1161 case gatherProblemsOrMains results mainResults of
1162 Left (NE.List e es) ->
1163 Left (Exit.BuildBadModules e es)
1165 Right mains ->
1166 Right $ Artifacts pkg foreigns mains $
1167 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1170gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1171gatherProblemsOrMains results (NE.List mainResult mainResults) =
1172 let
1173 sortMain result (es, mains) =
1174 case result of
1175 RInside n -> ( es, Inside n : mains)
1176 ROutsideOk n i o -> ( es, Outside n i o : mains)
1177 ROutsideErr e -> (e:es, mains)
1178 ROutsideBlocked -> ( es, mains)
1180 errors = Map.foldr addErrors [] results
1181 in
1182 case (mainResult, foldr sortMain (errors, []) mainResults) of
1183 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1184 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1185 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1186 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1187 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1188 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1189 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1192addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1193addInside name result modules =
1194 case result of
1195 RNew _ iface objs _ -> Fresh name iface objs : modules
1196 RSame _ iface objs _ -> Fresh name iface objs : modules
1197 RCached main _ mvar -> Cached name main mvar : modules
1198 RNotFound _ -> error (badInside name)
1199 RProblem _ -> error (badInside name)
1200 RBlocked -> error (badInside name)
1201 RForeign _ -> modules
1202 RKernel -> modules
1205badInside :: ModuleName.Raw -> [Char]
1206badInside name =
1207 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1210addOutside :: MainResult -> [Module] -> [Module]
1211addOutside main modules =
1212 case main of
1213 RInside _ -> modules
1214 ROutsideOk name iface objs -> Fresh name iface objs : modules
1215 ROutsideErr _ -> modules
1216 ROutsideBlocked -> modules