git.iko.soy/elk
on 047a256 help sign in
elk/builder/src/Build.hs
1230 lines 41 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 , _project :: Parse.ProjectType
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 Parse.Application (NE.toList srcDirs) buildID locals foreigns
81 Details.ValidPkg pkg _ _ ->
82 Env key root (Parse.Package 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 projectType 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 && Parse.isKernel projectType 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 projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
288 do source <- File.readUtf8 (root </> path)
290 case Parse.fromByteString projectType 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 projectType _ _ _ _) 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 projectType 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 projectType 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 projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
679 let
680 pkg = projectTypeToPkg projectType
681 in
682 case Compile.compile pkg ifaces modul of
683 Right (Compile.Artifacts canonical annotations objects) ->
684 do let name = Src.getName modul
685 let iface = I.fromModule pkg canonical annotations
686 let docs = makeDocs docsNeed canonical
687 let elmi = Stuff.elmi root name
688 File.writeBinary (Stuff.elmo root name) objects
689 maybeOldi <- File.readBinary elmi
690 case maybeOldi of
691 Just oldi | oldi == iface ->
692 do -- iface should be fully forced by equality check
693 Reporting.report key Reporting.BDone
694 let local = Details.Local path time deps main lastChange buildID
695 return (RSame local iface objects docs)
697 _ ->
698 do -- iface may be lazy still
699 File.writeBinary elmi iface
700 Reporting.report key Reporting.BDone
701 let local = Details.Local path time deps main buildID buildID
702 return (RNew local iface objects docs)
704 Left err ->
705 return $ RProblem $
706 Error.Module (Src.getName modul) path time source err
709projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
710projectTypeToPkg projectType =
711 case projectType of
712 Parse.Package pkg -> pkg
713 Parse.Application -> Pkg.dummyName
717-- WRITE DETAILS
720writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
721writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
722 File.writeBinary (Stuff.details root) $
723 Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
726addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
727addNewLocal name result locals =
728 case result of
729 RNew local _ _ _ -> Map.insert name local locals
730 RSame local _ _ _ -> Map.insert name local locals
731 RCached _ _ _ -> locals
732 RNotFound _ -> locals
733 RProblem _ -> locals
734 RBlocked -> locals
735 RForeign _ -> locals
736 RKernel -> locals
740-- FINALIZE EXPOSED
743finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
744finalizeExposed docsGoal exposed results =
745 case foldr (addImportProblems results) [] (NE.toList exposed) of
746 p:ps ->
747 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
749 [] ->
750 case Map.foldr addErrors [] results of
751 [] -> Right <$> finalizeDocs docsGoal results
752 e:es -> return $ Left $ Exit.BuildBadModules e es
755addErrors :: Result -> [Error.Module] -> [Error.Module]
756addErrors result errors =
757 case result of
758 RNew _ _ _ _ -> errors
759 RSame _ _ _ _ -> errors
760 RCached _ _ _ -> errors
761 RNotFound _ -> errors
762 RProblem e -> e:errors
763 RBlocked -> errors
764 RForeign _ -> errors
765 RKernel -> errors
768addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
769addImportProblems results name problems =
770 case results ! name of
771 RNew _ _ _ _ -> problems
772 RSame _ _ _ _ -> problems
773 RCached _ _ _ -> problems
774 RNotFound p -> (name, p) : problems
775 RProblem _ -> problems
776 RBlocked -> problems
777 RForeign _ -> problems
778 RKernel -> problems
782-- DOCS
785data DocsGoal a where
786 KeepDocs :: DocsGoal Docs.Documentation
787 WriteDocs :: FilePath -> DocsGoal ()
788 IgnoreDocs :: DocsGoal ()
791newtype DocsNeed =
792 DocsNeed { needsDocs :: Bool }
795toDocsNeed :: DocsGoal a -> DocsNeed
796toDocsNeed goal =
797 case goal of
798 IgnoreDocs -> DocsNeed False
799 WriteDocs _ -> DocsNeed True
800 KeepDocs -> DocsNeed True
803makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
804makeDocs (DocsNeed isNeeded) modul =
805 if isNeeded then
806 case Docs.fromModule modul of
807 Right docs -> Just docs
808 Left _ -> Nothing
809 else
810 Nothing
813finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
814finalizeDocs goal results =
815 case goal of
816 KeepDocs ->
817 return $ Map.mapMaybe toDocs results
819 WriteDocs path ->
820 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
822 IgnoreDocs ->
823 return ()
826toDocs :: Result -> Maybe Docs.Module
827toDocs result =
828 case result of
829 RNew _ _ _ d -> d
830 RSame _ _ _ d -> d
831 RCached _ _ _ -> Nothing
832 RNotFound _ -> Nothing
833 RProblem _ -> Nothing
834 RBlocked -> Nothing
835 RForeign _ -> Nothing
836 RKernel -> Nothing
840--------------------------------------------------------------------------------
841------ NOW FOR SOME REPL STUFF -------------------------------------------------
842--------------------------------------------------------------------------------
845-- FROM REPL
848data ReplArtifacts =
849 ReplArtifacts
850 { _repl_home :: ModuleName.Canonical
851 , _repl_modules :: [Module]
852 , _repl_localizer :: L.Localizer
853 , _repl_annotations :: Map.Map Name.Name Can.Annotation
854 }
857fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
858fromRepl root details source =
859 let
860 env@(Env _ _ projectType _ _ _ _) = makeEnv Reporting.ignorer root details
861 in
862 case Parse.fromByteString projectType source of
863 Left syntaxError ->
864 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
866 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
867 do dmvar <- Details.loadInterfaces root details
869 let deps = map Src.getImportName imports
870 mvar <- newMVar Map.empty
871 crawlDeps env mvar deps ()
873 statuses <- traverse readMVar =<< readMVar mvar
874 midpoint <- checkMidpoint dmvar statuses
876 case midpoint of
877 Left problem ->
878 return $ Left $ Exit.ReplProjectProblem problem
880 Right foreigns ->
881 do rmvar <- newEmptyMVar
882 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
883 putMVar rmvar resultMVars
884 results <- traverse readMVar resultMVars
885 writeDetails root details results
886 depsStatus <- checkDeps root resultMVars deps 0
887 finalizeReplArtifacts env source modul depsStatus resultMVars results
890finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
891finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
892 let
893 pkg =
894 projectTypeToPkg projectType
896 compileInput ifaces =
897 case Compile.compile pkg ifaces modul of
898 Right (Compile.Artifacts canonical annotations objects) ->
899 let
900 h = Can._name canonical
901 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
902 ms = Map.foldrWithKey addInside [] results
903 in
904 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
906 Left errors ->
907 return $ Left $ Exit.ReplBadInput source errors
908 in
909 case depsStatus of
910 DepsChange ifaces ->
911 compileInput ifaces
913 DepsSame same cached ->
914 do maybeLoaded <- loadInterfaces root same cached
915 case maybeLoaded of
916 Just ifaces -> compileInput ifaces
917 Nothing -> return $ Left $ Exit.ReplBadCache
919 DepsBlock ->
920 case Map.foldr addErrors [] results of
921 [] -> return $ Left $ Exit.ReplBlocked
922 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
924 DepsNotFound problems ->
925 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
926 toImportErrors env resultMVars imports problems
930--------------------------------------------------------------------------------
931--------------------------------------------------------------------------------
932------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
933--------------------------------------------------------------------------------
934--------------------------------------------------------------------------------
938-- FIND MAIN
941data MainLocation
942 = LInside ModuleName.Raw
943 | LOutside FilePath
946findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
947findMains env paths =
948 do mvars <- traverse (fork . findLocation env) paths
949 elocs <- traverse readMVar mvars
950 return $ checkLocations =<< sequence elocs
953checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
954checkLocations locations =
955 let
956 toOneOrMore loc@(Location absolute _ _) =
957 (absolute, OneOrMore.one loc)
959 fromOneOrMore loc locs =
960 case locs of
961 [] -> Right ()
962 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
963 in
964 fmap (\_ -> fmap _location locations) $
965 traverse (OneOrMore.destruct fromOneOrMore) $
966 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
970-- LOCATIONS
973data Location =
974 Location
975 { _absolute :: FilePath
976 , _relative :: FilePath
977 , _location :: MainLocation
978 }
981findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
982findLocation env path =
983 do exists <- File.exists path
984 if exists
985 then findLoc env path =<< Dir.canonicalizePath path
986 else return (Left (Exit.BP_PathUnknown path))
989findLoc :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
990findLoc (Env _ root _ srcDirs _ _ _) path absolutePath =
991 let
992 (dirs, file) = FP.splitFileName absolutePath
993 (final, ext) = FP.splitExtension file
994 in
995 if ext /= ".elm"
996 then
997 return $ Left $ Exit.BP_WithBadExtension path
998 else
999 let
1000 roots = FP.splitDirectories root
1001 segments = FP.splitDirectories dirs ++ [final]
1002 in
1003 case dropPrefix roots segments of
1004 Nothing ->
1005 return $ Right $ Location absolutePath path (LOutside path)
1007 Just relativeSegments ->
1008 case Maybe.mapMaybe (isInsideSrcDirByPath relativeSegments) srcDirs of
1009 [] ->
1010 return $ Right $ Location absolutePath path (LOutside path)
1012 [(_, Right names)] ->
1013 do let name = Name.fromChars (List.intercalate "." names)
1014 matchingDirs <- filterM (isInsideSrcDirByName root names) srcDirs
1015 case matchingDirs of
1016 d1:d2:_ ->
1017 do let p1 = d1 </> FP.joinPath names <.> "elm"
1018 let p2 = d2 </> FP.joinPath names <.> "elm"
1019 return $ Left $ Exit.BP_MainNameDuplicate name p1 p2
1021 _ ->
1022 return $ Right $ Location absolutePath path (LInside name)
1024 [(s, Left names)] ->
1025 return $ Left $ Exit.BP_MainNameInvalid path s names
1027 (s1,_):(s2,_):_ ->
1028 return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1032isInsideSrcDirByName :: FilePath -> [String] -> FilePath -> IO Bool
1033isInsideSrcDirByName root names srcDir =
1034 File.exists (root </> srcDir </> FP.joinPath names <.> "elm")
1037isInsideSrcDirByPath :: [String] -> FilePath -> Maybe (FilePath, Either [String] [String])
1038isInsideSrcDirByPath segments srcDir =
1039 case dropPrefix (FP.splitDirectories srcDir) segments of
1040 Nothing ->
1041 Nothing
1043 Just names ->
1044 if all isGoodName names
1045 then Just (srcDir, Right names)
1046 else Just (srcDir, Left names)
1049isGoodName :: [Char] -> Bool
1050isGoodName name =
1051 case name of
1052 [] ->
1053 False
1055 char:chars ->
1056 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1059dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1060dropPrefix roots paths =
1061 case roots of
1062 [] ->
1063 Just paths
1065 ".":rs ->
1066 dropPrefix rs paths
1068 r:rs ->
1069 case paths of
1070 [] -> Nothing
1071 ".":ps -> dropPrefix roots ps
1072 p:ps -> if r == p then dropPrefix rs ps else Nothing
1076-- CRAWL MAINS
1079data MainStatus
1080 = SInside ModuleName.Raw
1081 | SOutsideOk Details.Local B.ByteString Src.Module
1082 | SOutsideErr Error.Module
1085crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1086crawlMain env@(Env _ _ projectType _ buildID _ _) mvar given =
1087 case given of
1088 LInside name ->
1089 do statusMVar <- newEmptyMVar
1090 statusDict <- takeMVar mvar
1091 putMVar mvar (Map.insert name statusMVar statusDict)
1092 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1093 return (SInside name)
1095 LOutside path ->
1096 do time <- File.getTime path
1097 source <- File.readUtf8 path
1098 case Parse.fromByteString projectType source of
1099 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1100 do let deps = map Src.getImportName imports
1101 let local = Details.Local path time deps (any isMain values) buildID buildID
1102 crawlDeps env mvar deps (SOutsideOk local source modul)
1104 Left syntaxError ->
1105 return $ SOutsideErr $
1106 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1110-- CHECK MAINS
1113data MainResult
1114 = RInside ModuleName.Raw
1115 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1116 | ROutsideErr Error.Module
1117 | ROutsideBlocked
1120checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1121checkMain env@(Env _ root _ _ _ _ _) results pendingMain =
1122 case pendingMain of
1123 SInside name ->
1124 return (RInside name)
1126 SOutsideErr err ->
1127 return (ROutsideErr err)
1129 SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1130 do depsStatus <- checkDeps root results deps lastCompile
1131 case depsStatus of
1132 DepsChange ifaces ->
1133 compileOutside env local source ifaces modul
1135 DepsSame same cached ->
1136 do maybeLoaded <- loadInterfaces root same cached
1137 case maybeLoaded of
1138 Nothing -> return ROutsideBlocked
1139 Just ifaces -> compileOutside env local source ifaces modul
1141 DepsBlock ->
1142 return ROutsideBlocked
1144 DepsNotFound problems ->
1145 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1146 Error.BadImports (toImportErrors env results imports problems)
1149compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO MainResult
1150compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1151 let
1152 pkg = projectTypeToPkg projectType
1153 name = Src.getName modul
1154 in
1155 case Compile.compile pkg ifaces modul of
1156 Right (Compile.Artifacts canonical annotations objects) ->
1157 do Reporting.report key Reporting.BDone
1158 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1160 Left errors ->
1161 return $ ROutsideErr $ Error.Module name path time source errors
1165-- TO ARTIFACTS
1168data Main
1169 = Inside ModuleName.Raw
1170 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1173toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1174toArtifacts (Env _ _ projectType _ _ _ _) foreigns results mainResults =
1175 case gatherProblemsOrMains results mainResults of
1176 Left (NE.List e es) ->
1177 Left (Exit.BuildBadModules e es)
1179 Right mains ->
1180 Right $ Artifacts (projectTypeToPkg projectType) foreigns mains $
1181 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1184gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1185gatherProblemsOrMains results (NE.List mainResult mainResults) =
1186 let
1187 sortMain result (es, mains) =
1188 case result of
1189 RInside n -> ( es, Inside n : mains)
1190 ROutsideOk n i o -> ( es, Outside n i o : mains)
1191 ROutsideErr e -> (e:es, mains)
1192 ROutsideBlocked -> ( es, mains)
1194 errors = Map.foldr addErrors [] results
1195 in
1196 case (mainResult, foldr sortMain (errors, []) mainResults) of
1197 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1198 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1199 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1200 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1201 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1202 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1203 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1206addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1207addInside name result modules =
1208 case result of
1209 RNew _ iface objs _ -> Fresh name iface objs : modules
1210 RSame _ iface objs _ -> Fresh name iface objs : modules
1211 RCached main _ mvar -> Cached name main mvar : modules
1212 RNotFound _ -> error (badInside name)
1213 RProblem _ -> error (badInside name)
1214 RBlocked -> error (badInside name)
1215 RForeign _ -> modules
1216 RKernel -> modules
1219badInside :: ModuleName.Raw -> [Char]
1220badInside name =
1221 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1224addOutside :: MainResult -> [Module] -> [Module]
1225addOutside main modules =
1226 case main of
1227 RInside _ -> modules
1228 ROutsideOk name iface objs -> Fresh name iface objs : modules
1229 ROutsideErr _ -> modules
1230 ROutsideBlocked -> modules