git.iko.soy/elk
on db1d374 help sign in
elk/builder/src/Build.hs
1245 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.Outline as Outline
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 , _project :: Parse.ProjectType
69 , _srcDirs :: [AbsoluteSrcDir]
70 , _buildID :: Details.BuildID
71 , _locals :: Map.Map ModuleName.Raw Details.Local
72 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
73 }
76makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
77makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
78 case validOutline of
79 Details.ValidApp givenSrcDirs ->
80 do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
81 return $ Env key root Parse.Application srcDirs buildID locals foreigns
83 Details.ValidPkg pkg _ _ ->
84 do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
85 return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
89-- SOURCE DIRECTORY
92newtype AbsoluteSrcDir =
93 AbsoluteSrcDir FilePath
96toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
97toAbsoluteSrcDir root srcDir =
98 AbsoluteSrcDir <$> Dir.canonicalizePath
99 (
100 case srcDir of
101 Outline.AbsoluteSrcDir dir -> dir
102 Outline.RelativeSrcDir dir -> root </> dir
103 )
106addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
107addRelative (AbsoluteSrcDir srcDir) path =
108 srcDir </> path
112-- FORK
115-- PERF try using IORef semephore on file crawl phase?
116-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
117-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
118--
119fork :: IO a -> IO (MVar a)
120fork work =
121 do mvar <- newEmptyMVar
122 _ <- forkIO $ putMVar mvar =<< work
123 return mvar
126{-# INLINE forkWithKey #-}
127forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
128forkWithKey func dict =
129 Map.traverseWithKey (\k v -> fork (func k v)) dict
133-- FROM EXPOSED
136fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
137fromExposed style root details docsGoal exposed@(NE.List e es) =
138 Reporting.trackBuild style $ \key ->
139 do env <- makeEnv key root details
140 dmvar <- Details.loadInterfaces root details
142 -- crawl
143 mvar <- newEmptyMVar
144 let docsNeed = toDocsNeed docsGoal
145 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
146 putMVar mvar roots
147 mapM_ readMVar roots
148 statuses <- traverse readMVar =<< readMVar mvar
150 -- compile
151 midpoint <- checkMidpoint dmvar statuses
152 case midpoint of
153 Left problem ->
154 return (Left (Exit.BuildProjectProblem problem))
156 Right foreigns ->
157 do rmvar <- newEmptyMVar
158 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
159 putMVar rmvar resultMVars
160 results <- traverse readMVar resultMVars
161 writeDetails root details results
162 finalizeExposed docsGoal exposed results
166-- FROM MAINS
169data Artifacts =
170 Artifacts
171 { _name :: Pkg.Name
172 , _deps :: Dependencies
173 , _mains :: NE.List Main
174 , _modules :: [Module]
175 }
178data Module
179 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
180 | Cached ModuleName.Raw Bool (MVar CachedInterface)
183type Dependencies =
184 Map.Map ModuleName.Canonical I.DependencyInterface
187fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
188fromMains style root details paths =
189 Reporting.trackBuild style $ \key ->
190 do env <- makeEnv key root details
192 elmains <- findMains env paths
193 case elmains of
194 Left problem ->
195 return (Left (Exit.BuildProjectProblem problem))
197 Right lmains ->
198 do -- crawl
199 dmvar <- Details.loadInterfaces root details
200 smvar <- newMVar Map.empty
201 smainMVars <- traverse (fork . crawlMain env smvar) lmains
202 smains <- traverse readMVar smainMVars
203 statuses <- traverse readMVar =<< readMVar smvar
205 midpoint <- checkMainsMidpoint dmvar statuses smains
206 case midpoint of
207 Left problem ->
208 return (Left (Exit.BuildProjectProblem problem))
210 Right foreigns ->
211 do -- compile
212 rmvar <- newEmptyMVar
213 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
214 putMVar rmvar resultsMVars
215 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
216 results <- traverse readMVar resultsMVars
217 writeDetails root details results
218 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
222-- GET MAIN NAMES
225getMainNames :: Artifacts -> NE.List ModuleName.Raw
226getMainNames (Artifacts _ _ mains _) =
227 fmap getMainName mains
230getMainName :: Main -> ModuleName.Raw
231getMainName main =
232 case main of
233 Inside name -> name
234 Outside name _ _ -> name
238-- CRAWL
241type StatusDict =
242 Map.Map ModuleName.Raw (MVar Status)
245data Status
246 = SCached Details.Local
247 | SChanged Details.Local B.ByteString Src.Module DocsNeed
248 | SBadImport Import.Problem
249 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
250 | SForeign Pkg.Name
251 | SKernel
254crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
255crawlDeps env mvar deps blockedValue =
256 do statusDict <- takeMVar mvar
257 let depsDict = Map.fromKeys (\_ -> ()) deps
258 let newsDict = Map.difference depsDict statusDict
259 statuses <- Map.traverseWithKey crawlNew newsDict
260 putMVar mvar (Map.union statuses statusDict)
261 mapM_ readMVar statuses
262 return blockedValue
263 where
264 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
267crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
268crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
269 do let fileName = ModuleName.toFilePath name <.> "elm"
271 paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
273 case paths of
274 [path] ->
275 case Map.lookup name foreigns of
276 Just (Details.Foreign dep deps) ->
277 return $ SBadImport $ Import.Ambiguous path [] dep deps
279 Nothing ->
280 do newTime <- File.getTime path
281 case Map.lookup name locals of
282 Nothing ->
283 crawlFile env mvar docsNeed name path newTime buildID
285 Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
286 if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
287 then crawlFile env mvar docsNeed name path newTime lastChange
288 else crawlDeps env mvar deps (SCached local)
290 p1:p2:ps ->
291 return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
293 [] ->
294 case Map.lookup name foreigns of
295 Just (Details.Foreign dep deps) ->
296 case deps of
297 [] ->
298 return $ SForeign dep
300 d:ds ->
301 return $ SBadImport $ Import.AmbiguousForeign dep d ds
303 Nothing ->
304 if Name.isKernel name && Parse.isKernel projectType then
305 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
306 return $ if exists then SKernel else SBadImport Import.NotFound
307 else
308 return $ SBadImport Import.NotFound
311crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
312crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
313 do source <- File.readUtf8 (root </> path)
315 case Parse.fromByteString projectType source of
316 Left err ->
317 return $ SBadSyntax path time source err
319 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
320 case maybeActualName of
321 Nothing ->
322 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
324 Just name@(A.At _ actualName) ->
325 if expectedName == actualName then
326 let
327 deps = map Src.getImportName imports
328 local = Details.Local path time deps (any isMain values) lastChange buildID
329 in
330 crawlDeps env mvar deps (SChanged local source modul docsNeed)
331 else
332 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
335isMain :: A.Located Src.Value -> Bool
336isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
337 name == Name._main
341-- CHECK MODULE
344type ResultDict =
345 Map.Map ModuleName.Raw (MVar Result)
348data Result
349 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
350 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
351 | RCached Bool Details.BuildID (MVar CachedInterface)
352 | RNotFound Import.Problem
353 | RProblem Error.Module
354 | RBlocked
355 | RForeign I.Interface
356 | RKernel
359data CachedInterface
360 = Unneeded
361 | Loaded I.Interface
362 | Corrupted
365checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
366checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
367 case status of
368 SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
369 do results <- readMVar resultsMVar
370 depsStatus <- checkDeps root results deps lastCompile
371 case depsStatus of
372 DepsChange ifaces ->
373 do source <- File.readUtf8 path
374 case Parse.fromByteString projectType source of
375 Right modul -> compile env (DocsNeed False) local source ifaces modul
376 Left err ->
377 return $ RProblem $
378 Error.Module name path time source (Error.BadSyntax err)
380 DepsSame _ _ ->
381 do mvar <- newMVar Unneeded
382 return (RCached hasMain lastChange mvar)
384 DepsBlock ->
385 return RBlocked
387 DepsNotFound problems ->
388 do source <- File.readUtf8 path
389 return $ RProblem $ Error.Module name path time source $
390 case Parse.fromByteString projectType source of
391 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
392 Error.BadImports (toImportErrors env results imports problems)
394 Left err ->
395 Error.BadSyntax err
397 SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
398 do results <- readMVar resultsMVar
399 depsStatus <- checkDeps root results deps lastCompile
400 case depsStatus of
401 DepsChange ifaces ->
402 compile env docsNeed local source ifaces modul
404 DepsSame same cached ->
405 do maybeLoaded <- loadInterfaces root same cached
406 case maybeLoaded of
407 Nothing -> return RBlocked
408 Just ifaces -> compile env docsNeed local source ifaces modul
410 DepsBlock ->
411 return RBlocked
413 DepsNotFound problems ->
414 return $ RProblem $ Error.Module name path time source $
415 Error.BadImports (toImportErrors env results imports problems)
417 SBadImport importProblem ->
418 return (RNotFound importProblem)
420 SBadSyntax path time source err ->
421 return $ RProblem $ Error.Module name path time source $
422 Error.BadSyntax err
424 SForeign home ->
425 case foreigns ! ModuleName.Canonical home name of
426 I.Public iface -> return (RForeign iface)
427 I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
429 SKernel ->
430 return RKernel
434-- CHECK DEPS
437data DepsStatus
438 = DepsChange (Map.Map ModuleName.Raw I.Interface)
439 | DepsSame [Dep] [CDep]
440 | DepsBlock
441 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
444checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
445checkDeps root results deps lastCompile =
446 checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
449type Dep = (ModuleName.Raw, I.Interface)
450type CDep = (ModuleName.Raw, MVar CachedInterface)
453checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
454checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
455 case deps of
456 dep:otherDeps ->
457 do result <- readMVar (results ! dep)
458 case result of
459 RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
460 checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
462 RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
463 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
465 RCached _ lastChange mvar ->
466 checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
468 RNotFound prob ->
469 checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
471 RProblem _ ->
472 checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
474 RBlocked ->
475 checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
477 RForeign iface ->
478 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
480 RKernel ->
481 checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
484 [] ->
485 case reverse importProblems of
486 p:ps ->
487 return $ DepsNotFound (NE.List p ps)
489 [] ->
490 if isBlocked then
491 return $ DepsBlock
493 else if null new && lastDepChange <= lastCompile then
494 return $ DepsSame same cached
496 else
497 do maybeLoaded <- loadInterfaces root same cached
498 case maybeLoaded of
499 Nothing -> return DepsBlock
500 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
504-- TO IMPORT ERROR
507toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
508toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
509 let
510 knownModules =
511 Set.unions
512 [ Map.keysSet foreigns
513 , Map.keysSet locals
514 , Map.keysSet results
515 ]
517 unimportedModules =
518 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
520 regionDict =
521 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
523 toError (name, problem) =
524 Import.Error (regionDict ! name) name unimportedModules problem
525 in
526 fmap toError problems
530-- LOAD CACHED INTERFACES
533loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
534loadInterfaces root same cached =
535 do loading <- traverse (fork . loadInterface root) cached
536 maybeLoaded <- traverse readMVar loading
537 case sequence maybeLoaded of
538 Nothing ->
539 return Nothing
541 Just loaded ->
542 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
545loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
546loadInterface root (name, ciMvar) =
547 do cachedInterface <- takeMVar ciMvar
548 case cachedInterface of
549 Corrupted ->
550 do putMVar ciMvar cachedInterface
551 return Nothing
553 Loaded iface ->
554 do putMVar ciMvar cachedInterface
555 return (Just (name, iface))
557 Unneeded ->
558 do maybeIface <- File.readBinary (Stuff.elmi root name)
559 case maybeIface of
560 Nothing ->
561 do putMVar ciMvar Corrupted
562 return Nothing
564 Just iface ->
565 do putMVar ciMvar (Loaded iface)
566 return (Just (name, iface))
570-- CHECK PROJECT
573checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
574checkMidpoint dmvar statuses =
575 case checkForCycles statuses of
576 Nothing ->
577 do maybeForeigns <- readMVar dmvar
578 case maybeForeigns of
579 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
580 Just fs -> return (Right fs)
582 Just (NE.List name names) ->
583 do _ <- readMVar dmvar
584 return (Left (Exit.BP_Cycle name names))
587checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
588checkMainsMidpoint dmvar statuses smains =
589 case checkForCycles statuses of
590 Nothing ->
591 case checkUniqueMains statuses smains of
592 Nothing ->
593 do maybeForeigns <- readMVar dmvar
594 case maybeForeigns of
595 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
596 Just fs -> return (Right fs)
598 Just problem ->
599 do _ <- readMVar dmvar
600 return (Left problem)
602 Just (NE.List name names) ->
603 do _ <- readMVar dmvar
604 return (Left (Exit.BP_Cycle name names))
608-- CHECK FOR CYCLES
611checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
612checkForCycles modules =
613 let
614 !graph = Map.foldrWithKey addToGraph [] modules
615 !sccs = Graph.stronglyConnComp graph
616 in
617 checkForCyclesHelp sccs
620checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
621checkForCyclesHelp sccs =
622 case sccs of
623 [] ->
624 Nothing
626 scc:otherSccs ->
627 case scc of
628 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
629 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
630 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
633type Node =
634 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
637addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
638addToGraph name status graph =
639 let
640 dependencies =
641 case status of
642 SCached (Details.Local _ _ deps _ _ _) -> deps
643 SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
644 SBadImport _ -> []
645 SBadSyntax _ _ _ _ -> []
646 SForeign _ -> []
647 SKernel -> []
648 in
649 (name, name, dependencies) : graph
653-- CHECK UNIQUE MAINS
656checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
657checkUniqueMains insides smains =
658 let
659 outsidesDict =
660 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
661 in
662 case Map.traverseWithKey checkOutside outsidesDict of
663 Left problem ->
664 Just problem
666 Right outsides ->
667 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
668 Right () -> Nothing
669 Left problem -> Just problem
672mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
673mainStatusToNamePathPair smain =
674 case smain of
675 SInside _ -> Nothing
676 SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
677 SOutsideErr _ -> Nothing
680checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
681checkOutside name paths =
682 case OneOrMore.destruct NE.List paths of
683 NE.List p [] -> Right p
684 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
687checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
688checkInside name p1 status =
689 case status of
690 SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
691 SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
692 SBadImport _ -> Right ()
693 SBadSyntax _ _ _ _ -> Right ()
694 SForeign _ -> Right ()
695 SKernel -> Right ()
699-- COMPILE MODULE
702compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
703compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
704 let
705 pkg = projectTypeToPkg projectType
706 in
707 case Compile.compile pkg ifaces modul of
708 Right (Compile.Artifacts canonical annotations objects) ->
709 do let name = Src.getName modul
710 let iface = I.fromModule pkg canonical annotations
711 let docs = makeDocs docsNeed canonical
712 let elmi = Stuff.elmi root name
713 File.writeBinary (Stuff.elmo root name) objects
714 maybeOldi <- File.readBinary elmi
715 case maybeOldi of
716 Just oldi | oldi == iface ->
717 do -- iface should be fully forced by equality check
718 Reporting.report key Reporting.BDone
719 let local = Details.Local path time deps main lastChange buildID
720 return (RSame local iface objects docs)
722 _ ->
723 do -- iface may be lazy still
724 File.writeBinary elmi iface
725 Reporting.report key Reporting.BDone
726 let local = Details.Local path time deps main buildID buildID
727 return (RNew local iface objects docs)
729 Left err ->
730 return $ RProblem $
731 Error.Module (Src.getName modul) path time source err
734projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
735projectTypeToPkg projectType =
736 case projectType of
737 Parse.Package pkg -> pkg
738 Parse.Application -> Pkg.dummyName
742-- WRITE DETAILS
745writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
746writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
747 File.writeBinary (Stuff.details root) $
748 Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
751addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
752addNewLocal name result locals =
753 case result of
754 RNew local _ _ _ -> Map.insert name local locals
755 RSame local _ _ _ -> Map.insert name local locals
756 RCached _ _ _ -> locals
757 RNotFound _ -> locals
758 RProblem _ -> locals
759 RBlocked -> locals
760 RForeign _ -> locals
761 RKernel -> locals
765-- FINALIZE EXPOSED
768finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
769finalizeExposed docsGoal exposed results =
770 case foldr (addImportProblems results) [] (NE.toList exposed) of
771 p:ps ->
772 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
774 [] ->
775 case Map.foldr addErrors [] results of
776 [] -> Right <$> finalizeDocs docsGoal results
777 e:es -> return $ Left $ Exit.BuildBadModules e es
780addErrors :: Result -> [Error.Module] -> [Error.Module]
781addErrors result errors =
782 case result of
783 RNew _ _ _ _ -> errors
784 RSame _ _ _ _ -> errors
785 RCached _ _ _ -> errors
786 RNotFound _ -> errors
787 RProblem e -> e:errors
788 RBlocked -> errors
789 RForeign _ -> errors
790 RKernel -> errors
793addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
794addImportProblems results name problems =
795 case results ! name of
796 RNew _ _ _ _ -> problems
797 RSame _ _ _ _ -> problems
798 RCached _ _ _ -> problems
799 RNotFound p -> (name, p) : problems
800 RProblem _ -> problems
801 RBlocked -> problems
802 RForeign _ -> problems
803 RKernel -> problems
807-- DOCS
810data DocsGoal a where
811 KeepDocs :: DocsGoal Docs.Documentation
812 WriteDocs :: FilePath -> DocsGoal ()
813 IgnoreDocs :: DocsGoal ()
816newtype DocsNeed =
817 DocsNeed { needsDocs :: Bool }
820toDocsNeed :: DocsGoal a -> DocsNeed
821toDocsNeed goal =
822 case goal of
823 IgnoreDocs -> DocsNeed False
824 WriteDocs _ -> DocsNeed True
825 KeepDocs -> DocsNeed True
828makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
829makeDocs (DocsNeed isNeeded) modul =
830 if isNeeded then
831 case Docs.fromModule modul of
832 Right docs -> Just docs
833 Left _ -> Nothing
834 else
835 Nothing
838finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
839finalizeDocs goal results =
840 case goal of
841 KeepDocs ->
842 return $ Map.mapMaybe toDocs results
844 WriteDocs path ->
845 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
847 IgnoreDocs ->
848 return ()
851toDocs :: Result -> Maybe Docs.Module
852toDocs result =
853 case result of
854 RNew _ _ _ d -> d
855 RSame _ _ _ d -> d
856 RCached _ _ _ -> Nothing
857 RNotFound _ -> Nothing
858 RProblem _ -> Nothing
859 RBlocked -> Nothing
860 RForeign _ -> Nothing
861 RKernel -> Nothing
865--------------------------------------------------------------------------------
866------ NOW FOR SOME REPL STUFF -------------------------------------------------
867--------------------------------------------------------------------------------
870-- FROM REPL
873data ReplArtifacts =
874 ReplArtifacts
875 { _repl_home :: ModuleName.Canonical
876 , _repl_modules :: [Module]
877 , _repl_localizer :: L.Localizer
878 , _repl_annotations :: Map.Map Name.Name Can.Annotation
879 }
882fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
883fromRepl root details source =
884 do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
885 case Parse.fromByteString projectType source of
886 Left syntaxError ->
887 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
889 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
890 do dmvar <- Details.loadInterfaces root details
892 let deps = map Src.getImportName imports
893 mvar <- newMVar Map.empty
894 crawlDeps env mvar deps ()
896 statuses <- traverse readMVar =<< readMVar mvar
897 midpoint <- checkMidpoint dmvar statuses
899 case midpoint of
900 Left problem ->
901 return $ Left $ Exit.ReplProjectProblem problem
903 Right foreigns ->
904 do rmvar <- newEmptyMVar
905 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
906 putMVar rmvar resultMVars
907 results <- traverse readMVar resultMVars
908 writeDetails root details results
909 depsStatus <- checkDeps root resultMVars deps 0
910 finalizeReplArtifacts env source modul depsStatus resultMVars results
913finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
914finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
915 let
916 pkg =
917 projectTypeToPkg projectType
919 compileInput ifaces =
920 case Compile.compile pkg ifaces modul of
921 Right (Compile.Artifacts canonical annotations objects) ->
922 let
923 h = Can._name canonical
924 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
925 ms = Map.foldrWithKey addInside [] results
926 in
927 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
929 Left errors ->
930 return $ Left $ Exit.ReplBadInput source errors
931 in
932 case depsStatus of
933 DepsChange ifaces ->
934 compileInput ifaces
936 DepsSame same cached ->
937 do maybeLoaded <- loadInterfaces root same cached
938 case maybeLoaded of
939 Just ifaces -> compileInput ifaces
940 Nothing -> return $ Left $ Exit.ReplBadCache
942 DepsBlock ->
943 case Map.foldr addErrors [] results of
944 [] -> return $ Left $ Exit.ReplBlocked
945 e:es -> return $ Left $ Exit.ReplBadLocalDeps e es
947 DepsNotFound problems ->
948 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
949 toImportErrors env resultMVars imports problems
953--------------------------------------------------------------------------------
954--------------------------------------------------------------------------------
955------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
956--------------------------------------------------------------------------------
957--------------------------------------------------------------------------------
961-- FIND MAIN
964data MainLocation
965 = LInside ModuleName.Raw
966 | LOutside FilePath
969findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
970findMains env paths =
971 do mvars <- traverse (fork . findLocation env) paths
972 elocs <- traverse readMVar mvars
973 return $ checkLocations =<< sequence elocs
976checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
977checkLocations locations =
978 let
979 toOneOrMore loc@(Location absolute _ _) =
980 (absolute, OneOrMore.one loc)
982 fromOneOrMore loc locs =
983 case locs of
984 [] -> Right ()
985 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
986 in
987 fmap (\_ -> fmap _location locations) $
988 traverse (OneOrMore.destruct fromOneOrMore) $
989 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
993-- LOCATIONS
996data Location =
997 Location
998 { _absolute :: FilePath
999 , _relative :: FilePath
1000 , _location :: MainLocation
1004findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
1005findLocation env path =
1006 do exists <- File.exists path
1007 if exists
1008 then findLoc env path =<< Dir.canonicalizePath path
1009 else return (Left (Exit.BP_PathUnknown path))
1012findLoc :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
1013findLoc (Env _ root _ srcDirs _ _ _) path absolutePath =
1014 let
1015 (dirs, file) = FP.splitFileName absolutePath
1016 (final, ext) = FP.splitExtension file
1017 in
1018 if ext /= ".elm"
1019 then
1020 return $ Left $ Exit.BP_WithBadExtension path
1021 else
1022 let
1023 absoluteSegments = FP.splitDirectories dirs ++ [final]
1024 in
1025 case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
1026 [] ->
1027 return $ Right $ Location absolutePath path (LOutside path)
1029 [(_, Right names)] ->
1030 do let name = Name.fromChars (List.intercalate "." names)
1031 matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
1032 case matchingDirs of
1033 d1:d2:_ ->
1034 do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
1035 let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1036 return $ Left $ Exit.BP_MainNameDuplicate name p1 p2
1038 _ ->
1039 return $ Right $ Location absolutePath path (LInside name)
1041 [(s, Left names)] ->
1042 return $ Left $ Exit.BP_MainNameInvalid path s names
1044 (s1,_):(s2,_):_ ->
1045 return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1049isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
1050isInsideSrcDirByName names srcDir =
1051 File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1054isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1055isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1056 case dropPrefix (FP.splitDirectories srcDir) segments of
1057 Nothing ->
1058 Nothing
1060 Just names ->
1061 if all isGoodName names
1062 then Just (srcDir, Right names)
1063 else Just (srcDir, Left names)
1066isGoodName :: [Char] -> Bool
1067isGoodName name =
1068 case name of
1069 [] ->
1070 False
1072 char:chars ->
1073 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1076-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1078dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1079dropPrefix roots paths =
1080 case roots of
1081 [] ->
1082 Just paths
1084 r:rs ->
1085 case paths of
1086 [] -> Nothing
1087 p:ps -> if r == p then dropPrefix rs ps else Nothing
1091-- CRAWL MAINS
1094data MainStatus
1095 = SInside ModuleName.Raw
1096 | SOutsideOk Details.Local B.ByteString Src.Module
1097 | SOutsideErr Error.Module
1100crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
1101crawlMain env@(Env _ _ projectType _ buildID _ _) mvar given =
1102 case given of
1103 LInside name ->
1104 do statusMVar <- newEmptyMVar
1105 statusDict <- takeMVar mvar
1106 putMVar mvar (Map.insert name statusMVar statusDict)
1107 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1108 return (SInside name)
1110 LOutside path ->
1111 do time <- File.getTime path
1112 source <- File.readUtf8 path
1113 case Parse.fromByteString projectType source of
1114 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1115 do let deps = map Src.getImportName imports
1116 let local = Details.Local path time deps (any isMain values) buildID buildID
1117 crawlDeps env mvar deps (SOutsideOk local source modul)
1119 Left syntaxError ->
1120 return $ SOutsideErr $
1121 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1125-- CHECK MAINS
1128data MainResult
1129 = RInside ModuleName.Raw
1130 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1131 | ROutsideErr Error.Module
1132 | ROutsideBlocked
1135checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
1136checkMain env@(Env _ root _ _ _ _ _) results pendingMain =
1137 case pendingMain of
1138 SInside name ->
1139 return (RInside name)
1141 SOutsideErr err ->
1142 return (ROutsideErr err)
1144 SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1145 do depsStatus <- checkDeps root results deps lastCompile
1146 case depsStatus of
1147 DepsChange ifaces ->
1148 compileOutside env local source ifaces modul
1150 DepsSame same cached ->
1151 do maybeLoaded <- loadInterfaces root same cached
1152 case maybeLoaded of
1153 Nothing -> return ROutsideBlocked
1154 Just ifaces -> compileOutside env local source ifaces modul
1156 DepsBlock ->
1157 return ROutsideBlocked
1159 DepsNotFound problems ->
1160 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1161 Error.BadImports (toImportErrors env results imports problems)
1164compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO MainResult
1165compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1166 let
1167 pkg = projectTypeToPkg projectType
1168 name = Src.getName modul
1169 in
1170 case Compile.compile pkg ifaces modul of
1171 Right (Compile.Artifacts canonical annotations objects) ->
1172 do Reporting.report key Reporting.BDone
1173 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1175 Left errors ->
1176 return $ ROutsideErr $ Error.Module name path time source errors
1180-- TO ARTIFACTS
1183data Main
1184 = Inside ModuleName.Raw
1185 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1188toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
1189toArtifacts (Env _ _ projectType _ _ _ _) foreigns results mainResults =
1190 case gatherProblemsOrMains results mainResults of
1191 Left (NE.List e es) ->
1192 Left (Exit.BuildBadModules e es)
1194 Right mains ->
1195 Right $ Artifacts (projectTypeToPkg projectType) foreigns mains $
1196 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
1199gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Error.Module) (NE.List Main)
1200gatherProblemsOrMains results (NE.List mainResult mainResults) =
1201 let
1202 sortMain result (es, mains) =
1203 case result of
1204 RInside n -> ( es, Inside n : mains)
1205 ROutsideOk n i o -> ( es, Outside n i o : mains)
1206 ROutsideErr e -> (e:es, mains)
1207 ROutsideBlocked -> ( es, mains)
1209 errors = Map.foldr addErrors [] results
1210 in
1211 case (mainResult, foldr sortMain (errors, []) mainResults) of
1212 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1213 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1214 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1215 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1216 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1217 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1218 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1221addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1222addInside name result modules =
1223 case result of
1224 RNew _ iface objs _ -> Fresh name iface objs : modules
1225 RSame _ iface objs _ -> Fresh name iface objs : modules
1226 RCached main _ mvar -> Cached name main mvar : modules
1227 RNotFound _ -> error (badInside name)
1228 RProblem _ -> error (badInside name)
1229 RBlocked -> error (badInside name)
1230 RForeign _ -> modules
1231 RKernel -> modules
1234badInside :: ModuleName.Raw -> [Char]
1235badInside name =
1236 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1239addOutside :: MainResult -> [Module] -> [Module]
1240addOutside main modules =
1241 case main of
1242 RInside _ -> modules
1243 ROutsideOk name iface objs -> Fresh name iface objs : modules
1244 ROutsideErr _ -> modules
1245 ROutsideBlocked -> modules