git.iko.soy/elk
on master help sign in
elk/builder/src/Build.hs
1251 lines 41 kB history raw
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
3module Build
4 ( fromExposed
5 , fromPaths
6 , fromRepl
7 , Artifacts(..)
8 , Root(..)
9 , Module(..)
10 , CachedInterface(..)
11 , ReplArtifacts(..)
12 , DocsGoal(..)
13 , getRootNames
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.Docs as EDocs
54import qualified Reporting.Error.Syntax as Syntax
55import qualified Reporting.Error.Import as Import
56import qualified Reporting.Exit as Exit
57import qualified Reporting.Render.Type.Localizer as L
58import qualified Stuff
62-- ENVIRONMENT
65data Env =
66 Env
67 { _key :: Reporting.BKey
68 , _root :: FilePath
69 , _project :: Parse.ProjectType
70 , _srcDirs :: [AbsoluteSrcDir]
71 , _buildID :: Details.BuildID
72 , _locals :: Map.Map ModuleName.Raw Details.Local
73 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
74 }
77makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
78makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
79 case validOutline of
80 Details.ValidApp givenSrcDirs ->
81 do srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
82 return $ Env key root Parse.Application srcDirs buildID locals foreigns
84 Details.ValidPkg pkg _ _ ->
85 do srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
86 return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
90-- SOURCE DIRECTORY
93newtype AbsoluteSrcDir =
94 AbsoluteSrcDir FilePath
97toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
98toAbsoluteSrcDir root srcDir =
99 AbsoluteSrcDir <$> Dir.canonicalizePath
100 (
101 case srcDir of
102 Outline.AbsoluteSrcDir dir -> dir
103 Outline.RelativeSrcDir dir -> root </> dir
104 )
107addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
108addRelative (AbsoluteSrcDir srcDir) path =
109 srcDir </> path
113-- FORK
116-- PERF try using IORef semephore on file crawl phase?
117-- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
118-- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
119--
120fork :: IO a -> IO (MVar a)
121fork work =
122 do mvar <- newEmptyMVar
123 _ <- forkIO $ putMVar mvar =<< work
124 return mvar
127{-# INLINE forkWithKey #-}
128forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
129forkWithKey func dict =
130 Map.traverseWithKey (\k v -> fork (func k v)) dict
134-- FROM EXPOSED
137fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
138fromExposed style root details docsGoal exposed@(NE.List e es) =
139 Reporting.trackBuild style $ \key ->
140 do env <- makeEnv key root details
141 dmvar <- Details.loadInterfaces root details
143 -- crawl
144 mvar <- newEmptyMVar
145 let docsNeed = toDocsNeed docsGoal
146 roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
147 putMVar mvar roots
148 mapM_ readMVar roots
149 statuses <- traverse readMVar =<< readMVar mvar
151 -- compile
152 midpoint <- checkMidpoint dmvar statuses
153 case midpoint of
154 Left problem ->
155 return (Left (Exit.BuildProjectProblem problem))
157 Right foreigns ->
158 do rmvar <- newEmptyMVar
159 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
160 putMVar rmvar resultMVars
161 results <- traverse readMVar resultMVars
162 writeDetails root details results
163 finalizeExposed root docsGoal exposed results
167-- FROM PATHS
170data Artifacts =
171 Artifacts
172 { _name :: Pkg.Name
173 , _deps :: Dependencies
174 , _roots :: NE.List Root
175 , _modules :: [Module]
176 }
179data Module
180 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
181 | Cached ModuleName.Raw Bool (MVar CachedInterface)
184type Dependencies =
185 Map.Map ModuleName.Canonical I.DependencyInterface
188fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
189fromPaths style root details paths =
190 Reporting.trackBuild style $ \key ->
191 do env <- makeEnv key root details
193 elroots <- findRoots env paths
194 case elroots of
195 Left problem ->
196 return (Left (Exit.BuildProjectProblem problem))
198 Right lroots ->
199 do -- crawl
200 dmvar <- Details.loadInterfaces root details
201 smvar <- newMVar Map.empty
202 srootMVars <- traverse (fork . crawlRoot env smvar) lroots
203 sroots <- traverse readMVar srootMVars
204 statuses <- traverse readMVar =<< readMVar smvar
206 midpoint <- checkMidpointAndRoots dmvar statuses sroots
207 case midpoint of
208 Left problem ->
209 return (Left (Exit.BuildProjectProblem problem))
211 Right foreigns ->
212 do -- compile
213 rmvar <- newEmptyMVar
214 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
215 putMVar rmvar resultsMVars
216 rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
217 results <- traverse readMVar resultsMVars
218 writeDetails root details results
219 toArtifacts env foreigns results <$> traverse readMVar rrootMVars
223-- GET ROOT NAMES
226getRootNames :: Artifacts -> NE.List ModuleName.Raw
227getRootNames (Artifacts _ _ roots _) =
228 fmap getRootName roots
231getRootName :: Root -> ModuleName.Raw
232getRootName root =
233 case root of
234 Inside name -> name
235 Outside name _ _ -> name
239-- CRAWL
242type StatusDict =
243 Map.Map ModuleName.Raw (MVar Status)
246data Status
247 = SCached Details.Local
248 | SChanged Details.Local B.ByteString Src.Module DocsNeed
249 | SBadImport Import.Problem
250 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
251 | SForeign Pkg.Name
252 | SKernel
255crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
256crawlDeps env mvar deps blockedValue =
257 do statusDict <- takeMVar mvar
258 let depsDict = Map.fromKeys (\_ -> ()) deps
259 let newsDict = Map.difference depsDict statusDict
260 statuses <- Map.traverseWithKey crawlNew newsDict
261 putMVar mvar (Map.union statuses statusDict)
262 mapM_ readMVar statuses
263 return blockedValue
264 where
265 crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
268crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
269crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
270 do let fileName = ModuleName.toFilePath name <.> "elm"
272 paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
274 case paths of
275 [path] ->
276 case Map.lookup name foreigns of
277 Just (Details.Foreign dep deps) ->
278 return $ SBadImport $ Import.Ambiguous path [] dep deps
280 Nothing ->
281 do newTime <- File.getTime path
282 case Map.lookup name locals of
283 Nothing ->
284 crawlFile env mvar docsNeed name path newTime buildID
286 Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
287 if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
288 then crawlFile env mvar docsNeed name path newTime lastChange
289 else crawlDeps env mvar deps (SCached local)
291 p1:p2:ps ->
292 return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
294 [] ->
295 case Map.lookup name foreigns of
296 Just (Details.Foreign dep deps) ->
297 case deps of
298 [] ->
299 return $ SForeign dep
301 d:ds ->
302 return $ SBadImport $ Import.AmbiguousForeign dep d ds
304 Nothing ->
305 if Name.isKernel name && Parse.isKernel projectType then
306 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
307 return $ if exists then SKernel else SBadImport Import.NotFound
308 else
309 return $ SBadImport Import.NotFound
312crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
313crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
314 do source <- File.readUtf8 (root </> path)
316 case Parse.fromByteString projectType source of
317 Left err ->
318 return $ SBadSyntax path time source err
320 Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
321 case maybeActualName of
322 Nothing ->
323 return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
325 Just name@(A.At _ actualName) ->
326 if expectedName == actualName then
327 let
328 deps = map Src.getImportName imports
329 local = Details.Local path time deps (any isMain values) lastChange buildID
330 in
331 crawlDeps env mvar deps (SChanged local source modul docsNeed)
332 else
333 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
336isMain :: A.Located Src.Value -> Bool
337isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
338 name == Name._main
342-- CHECK MODULE
345type ResultDict =
346 Map.Map ModuleName.Raw (MVar Result)
349data Result
350 = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
351 | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
352 | RCached Bool Details.BuildID (MVar CachedInterface)
353 | RNotFound Import.Problem
354 | RProblem Error.Module
355 | RBlocked
356 | RForeign I.Interface
357 | RKernel
360data CachedInterface
361 = Unneeded
362 | Loaded I.Interface
363 | Corrupted
366checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
367checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
368 case status of
369 SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
370 do results <- readMVar resultsMVar
371 depsStatus <- checkDeps root results deps lastCompile
372 case depsStatus of
373 DepsChange ifaces ->
374 do source <- File.readUtf8 path
375 case Parse.fromByteString projectType source of
376 Right modul -> compile env (DocsNeed False) local source ifaces modul
377 Left err ->
378 return $ RProblem $
379 Error.Module name path time source (Error.BadSyntax err)
381 DepsSame _ _ ->
382 do mvar <- newMVar Unneeded
383 return (RCached hasMain lastChange mvar)
385 DepsBlock ->
386 return RBlocked
388 DepsNotFound problems ->
389 do source <- File.readUtf8 path
390 return $ RProblem $ Error.Module name path time source $
391 case Parse.fromByteString projectType source of
392 Right (Src.Module _ _ _ imports _ _ _ _ _) ->
393 Error.BadImports (toImportErrors env results imports problems)
395 Left err ->
396 Error.BadSyntax err
398 SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
399 do results <- readMVar resultsMVar
400 depsStatus <- checkDeps root results deps lastCompile
401 case depsStatus of
402 DepsChange ifaces ->
403 compile env docsNeed local source ifaces modul
405 DepsSame same cached ->
406 do maybeLoaded <- loadInterfaces root same cached
407 case maybeLoaded of
408 Nothing -> return RBlocked
409 Just ifaces -> compile env docsNeed local source ifaces modul
411 DepsBlock ->
412 return RBlocked
414 DepsNotFound problems ->
415 return $ RProblem $ Error.Module name path time source $
416 Error.BadImports (toImportErrors env results imports problems)
418 SBadImport importProblem ->
419 return (RNotFound importProblem)
421 SBadSyntax path time source err ->
422 return $ RProblem $ Error.Module name path time source $
423 Error.BadSyntax err
425 SForeign home ->
426 case foreigns ! ModuleName.Canonical home name of
427 I.Public iface -> return (RForeign iface)
428 I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
430 SKernel ->
431 return RKernel
435-- CHECK DEPS
438data DepsStatus
439 = DepsChange (Map.Map ModuleName.Raw I.Interface)
440 | DepsSame [Dep] [CDep]
441 | DepsBlock
442 | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
445checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
446checkDeps root results deps lastCompile =
447 checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
450type Dep = (ModuleName.Raw, I.Interface)
451type CDep = (ModuleName.Raw, MVar CachedInterface)
454checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
455checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
456 case deps of
457 dep:otherDeps ->
458 do result <- readMVar (results ! dep)
459 case result of
460 RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
461 checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
463 RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
464 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
466 RCached _ lastChange mvar ->
467 checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
469 RNotFound prob ->
470 checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
472 RProblem _ ->
473 checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
475 RBlocked ->
476 checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
478 RForeign iface ->
479 checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
481 RKernel ->
482 checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
485 [] ->
486 case reverse importProblems of
487 p:ps ->
488 return $ DepsNotFound (NE.List p ps)
490 [] ->
491 if isBlocked then
492 return $ DepsBlock
494 else if null new && lastDepChange <= lastCompile then
495 return $ DepsSame same cached
497 else
498 do maybeLoaded <- loadInterfaces root same cached
499 case maybeLoaded of
500 Nothing -> return DepsBlock
501 Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
505-- TO IMPORT ERROR
508toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
509toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
510 let
511 knownModules =
512 Set.unions
513 [ Map.keysSet foreigns
514 , Map.keysSet locals
515 , Map.keysSet results
516 ]
518 unimportedModules =
519 Set.difference knownModules (Set.fromList (map Src.getImportName imports))
521 regionDict =
522 Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
524 toError (name, problem) =
525 Import.Error (regionDict ! name) name unimportedModules problem
526 in
527 fmap toError problems
531-- LOAD CACHED INTERFACES
534loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
535loadInterfaces root same cached =
536 do loading <- traverse (fork . loadInterface root) cached
537 maybeLoaded <- traverse readMVar loading
538 case sequence maybeLoaded of
539 Nothing ->
540 return Nothing
542 Just loaded ->
543 return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
546loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
547loadInterface root (name, ciMvar) =
548 do cachedInterface <- takeMVar ciMvar
549 case cachedInterface of
550 Corrupted ->
551 do putMVar ciMvar cachedInterface
552 return Nothing
554 Loaded iface ->
555 do putMVar ciMvar cachedInterface
556 return (Just (name, iface))
558 Unneeded ->
559 do maybeIface <- File.readBinary (Stuff.elmi root name)
560 case maybeIface of
561 Nothing ->
562 do putMVar ciMvar Corrupted
563 return Nothing
565 Just iface ->
566 do putMVar ciMvar (Loaded iface)
567 return (Just (name, iface))
571-- CHECK PROJECT
574checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
575checkMidpoint dmvar statuses =
576 case checkForCycles statuses of
577 Nothing ->
578 do maybeForeigns <- readMVar dmvar
579 case maybeForeigns of
580 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
581 Just fs -> return (Right fs)
583 Just (NE.List name names) ->
584 do _ <- readMVar dmvar
585 return (Left (Exit.BP_Cycle name names))
588checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
589checkMidpointAndRoots dmvar statuses sroots =
590 case checkForCycles statuses of
591 Nothing ->
592 case checkUniqueRoots statuses sroots of
593 Nothing ->
594 do maybeForeigns <- readMVar dmvar
595 case maybeForeigns of
596 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
597 Just fs -> return (Right fs)
599 Just problem ->
600 do _ <- readMVar dmvar
601 return (Left problem)
603 Just (NE.List name names) ->
604 do _ <- readMVar dmvar
605 return (Left (Exit.BP_Cycle name names))
609-- CHECK FOR CYCLES
612checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
613checkForCycles modules =
614 let
615 !graph = Map.foldrWithKey addToGraph [] modules
616 !sccs = Graph.stronglyConnComp graph
617 in
618 checkForCyclesHelp sccs
621checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
622checkForCyclesHelp sccs =
623 case sccs of
624 [] ->
625 Nothing
627 scc:otherSccs ->
628 case scc of
629 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
630 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
631 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
634type Node =
635 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
638addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
639addToGraph name status graph =
640 let
641 dependencies =
642 case status of
643 SCached (Details.Local _ _ deps _ _ _) -> deps
644 SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
645 SBadImport _ -> []
646 SBadSyntax _ _ _ _ -> []
647 SForeign _ -> []
648 SKernel -> []
649 in
650 (name, name, dependencies) : graph
654-- CHECK UNIQUE ROOTS
657checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
658checkUniqueRoots insides sroots =
659 let
660 outsidesDict =
661 Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
662 in
663 case Map.traverseWithKey checkOutside outsidesDict of
664 Left problem ->
665 Just problem
667 Right outsides ->
668 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
669 Right () -> Nothing
670 Left problem -> Just problem
673rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
674rootStatusToNamePathPair sroot =
675 case sroot of
676 SInside _ -> Nothing
677 SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
678 SOutsideErr _ -> Nothing
681checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
682checkOutside name paths =
683 case OneOrMore.destruct NE.List paths of
684 NE.List p [] -> Right p
685 NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
688checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
689checkInside name p1 status =
690 case status of
691 SCached (Details.Local p2 _ _ _ _ _) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
692 SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
693 SBadImport _ -> Right ()
694 SBadSyntax _ _ _ _ -> Right ()
695 SForeign _ -> Right ()
696 SKernel -> Right ()
700-- COMPILE MODULE
703compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
704compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
705 let
706 pkg = projectTypeToPkg projectType
707 in
708 case Compile.compile pkg ifaces modul of
709 Right (Compile.Artifacts canonical annotations objects) ->
710 case makeDocs docsNeed canonical of
711 Left err ->
712 return $ RProblem $
713 Error.Module (Src.getName modul) path time source (Error.BadDocs err)
715 Right docs ->
716 do let name = Src.getName modul
717 let iface = I.fromModule pkg canonical annotations
718 let elmi = Stuff.elmi root name
719 File.writeBinary (Stuff.elmo root name) objects
720 maybeOldi <- File.readBinary elmi
721 case maybeOldi of
722 Just oldi | oldi == iface ->
723 do -- iface should be fully forced by equality check
724 Reporting.report key Reporting.BDone
725 let local = Details.Local path time deps main lastChange buildID
726 return (RSame local iface objects docs)
728 _ ->
729 do -- iface may be lazy still
730 File.writeBinary elmi iface
731 Reporting.report key Reporting.BDone
732 let local = Details.Local path time deps main buildID buildID
733 return (RNew local iface objects docs)
735 Left err ->
736 return $ RProblem $
737 Error.Module (Src.getName modul) path time source err
740projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
741projectTypeToPkg projectType =
742 case projectType of
743 Parse.Package pkg -> pkg
744 Parse.Application -> Pkg.dummyName
748-- WRITE DETAILS
751writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
752writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
753 File.writeBinary (Stuff.details root) $
754 Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
757addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
758addNewLocal name result locals =
759 case result of
760 RNew local _ _ _ -> Map.insert name local locals
761 RSame local _ _ _ -> Map.insert name local locals
762 RCached _ _ _ -> locals
763 RNotFound _ -> locals
764 RProblem _ -> locals
765 RBlocked -> locals
766 RForeign _ -> locals
767 RKernel -> locals
771-- FINALIZE EXPOSED
774finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
775finalizeExposed root docsGoal exposed results =
776 case foldr (addImportProblems results) [] (NE.toList exposed) of
777 p:ps ->
778 return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
780 [] ->
781 case Map.foldr addErrors [] results of
782 [] -> Right <$> finalizeDocs docsGoal results
783 e:es -> return $ Left $ Exit.BuildBadModules root e es
786addErrors :: Result -> [Error.Module] -> [Error.Module]
787addErrors result errors =
788 case result of
789 RNew _ _ _ _ -> errors
790 RSame _ _ _ _ -> errors
791 RCached _ _ _ -> errors
792 RNotFound _ -> errors
793 RProblem e -> e:errors
794 RBlocked -> errors
795 RForeign _ -> errors
796 RKernel -> errors
799addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
800addImportProblems results name problems =
801 case results ! name of
802 RNew _ _ _ _ -> problems
803 RSame _ _ _ _ -> problems
804 RCached _ _ _ -> problems
805 RNotFound p -> (name, p) : problems
806 RProblem _ -> problems
807 RBlocked -> problems
808 RForeign _ -> problems
809 RKernel -> problems
813-- DOCS
816data DocsGoal a where
817 KeepDocs :: DocsGoal Docs.Documentation
818 WriteDocs :: FilePath -> DocsGoal ()
819 IgnoreDocs :: DocsGoal ()
822newtype DocsNeed =
823 DocsNeed { needsDocs :: Bool }
826toDocsNeed :: DocsGoal a -> DocsNeed
827toDocsNeed goal =
828 case goal of
829 IgnoreDocs -> DocsNeed False
830 WriteDocs _ -> DocsNeed True
831 KeepDocs -> DocsNeed True
834makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
835makeDocs (DocsNeed isNeeded) modul =
836 if isNeeded then
837 case Docs.fromModule modul of
838 Right docs -> Right (Just docs)
839 Left err -> Left err
840 else
841 Right Nothing
844finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
845finalizeDocs goal results =
846 case goal of
847 KeepDocs ->
848 return $ Map.mapMaybe toDocs results
850 WriteDocs path ->
851 E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
853 IgnoreDocs ->
854 return ()
857toDocs :: Result -> Maybe Docs.Module
858toDocs result =
859 case result of
860 RNew _ _ _ d -> d
861 RSame _ _ _ d -> d
862 RCached _ _ _ -> Nothing
863 RNotFound _ -> Nothing
864 RProblem _ -> Nothing
865 RBlocked -> Nothing
866 RForeign _ -> Nothing
867 RKernel -> Nothing
871--------------------------------------------------------------------------------
872------ NOW FOR SOME REPL STUFF -------------------------------------------------
873--------------------------------------------------------------------------------
876-- FROM REPL
879data ReplArtifacts =
880 ReplArtifacts
881 { _repl_home :: ModuleName.Canonical
882 , _repl_modules :: [Module]
883 , _repl_localizer :: L.Localizer
884 , _repl_annotations :: Map.Map Name.Name Can.Annotation
885 }
888fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
889fromRepl root details source =
890 do env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
891 case Parse.fromByteString projectType source of
892 Left syntaxError ->
893 return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
895 Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
896 do dmvar <- Details.loadInterfaces root details
898 let deps = map Src.getImportName imports
899 mvar <- newMVar Map.empty
900 crawlDeps env mvar deps ()
902 statuses <- traverse readMVar =<< readMVar mvar
903 midpoint <- checkMidpoint dmvar statuses
905 case midpoint of
906 Left problem ->
907 return $ Left $ Exit.ReplProjectProblem problem
909 Right foreigns ->
910 do rmvar <- newEmptyMVar
911 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
912 putMVar rmvar resultMVars
913 results <- traverse readMVar resultMVars
914 writeDetails root details results
915 depsStatus <- checkDeps root resultMVars deps 0
916 finalizeReplArtifacts env source modul depsStatus resultMVars results
919finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
920finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
921 let
922 pkg =
923 projectTypeToPkg projectType
925 compileInput ifaces =
926 case Compile.compile pkg ifaces modul of
927 Right (Compile.Artifacts canonical annotations objects) ->
928 let
929 h = Can._name canonical
930 m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
931 ms = Map.foldrWithKey addInside [] results
932 in
933 return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
935 Left errors ->
936 return $ Left $ Exit.ReplBadInput source errors
937 in
938 case depsStatus of
939 DepsChange ifaces ->
940 compileInput ifaces
942 DepsSame same cached ->
943 do maybeLoaded <- loadInterfaces root same cached
944 case maybeLoaded of
945 Just ifaces -> compileInput ifaces
946 Nothing -> return $ Left $ Exit.ReplBadCache
948 DepsBlock ->
949 case Map.foldr addErrors [] results of
950 [] -> return $ Left $ Exit.ReplBlocked
951 e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
953 DepsNotFound problems ->
954 return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
955 toImportErrors env resultMVars imports problems
959--------------------------------------------------------------------------------
960--------------------------------------------------------------------------------
961------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
962--------------------------------------------------------------------------------
963--------------------------------------------------------------------------------
967-- FIND ROOT
970data RootLocation
971 = LInside ModuleName.Raw
972 | LOutside FilePath
975findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
976findRoots env paths =
977 do mvars <- traverse (fork . getRootInfo env) paths
978 einfos <- traverse readMVar mvars
979 return $ checkRoots =<< sequence einfos
982checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
983checkRoots infos =
984 let
985 toOneOrMore loc@(RootInfo absolute _ _) =
986 (absolute, OneOrMore.one loc)
988 fromOneOrMore loc locs =
989 case locs of
990 [] -> Right ()
991 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
992 in
993 fmap (\_ -> fmap _location infos) $
994 traverse (OneOrMore.destruct fromOneOrMore) $
995 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
999-- ROOT INFO
1002data RootInfo =
1003 RootInfo
1004 { _absolute :: FilePath
1005 , _relative :: FilePath
1006 , _location :: RootLocation
1010getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1011getRootInfo env path =
1012 do exists <- File.exists path
1013 if exists
1014 then getRootInfoHelp env path =<< Dir.canonicalizePath path
1015 else return (Left (Exit.BP_PathUnknown path))
1018getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
1019getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
1020 let
1021 (dirs, file) = FP.splitFileName absolutePath
1022 (final, ext) = FP.splitExtension file
1023 in
1024 if ext /= ".elm"
1025 then
1026 return $ Left $ Exit.BP_WithBadExtension path
1027 else
1028 let
1029 absoluteSegments = FP.splitDirectories dirs ++ [final]
1030 in
1031 case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
1032 [] ->
1033 return $ Right $ RootInfo absolutePath path (LOutside path)
1035 [(_, Right names)] ->
1036 do let name = Name.fromChars (List.intercalate "." names)
1037 matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
1038 case matchingDirs of
1039 d1:d2:_ ->
1040 do let p1 = addRelative d1 (FP.joinPath names <.> "elm")
1041 let p2 = addRelative d2 (FP.joinPath names <.> "elm")
1042 return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
1044 _ ->
1045 return $ Right $ RootInfo absolutePath path (LInside name)
1047 [(s, Left names)] ->
1048 return $ Left $ Exit.BP_RootNameInvalid path s names
1050 (s1,_):(s2,_):_ ->
1051 return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
1055isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
1056isInsideSrcDirByName names srcDir =
1057 File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
1060isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
1061isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
1062 case dropPrefix (FP.splitDirectories srcDir) segments of
1063 Nothing ->
1064 Nothing
1066 Just names ->
1067 if all isGoodName names
1068 then Just (srcDir, Right names)
1069 else Just (srcDir, Left names)
1072isGoodName :: [Char] -> Bool
1073isGoodName name =
1074 case name of
1075 [] ->
1076 False
1078 char:chars ->
1079 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
1082-- INVARIANT: Dir.canonicalizePath has been run on both inputs
1084dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
1085dropPrefix roots paths =
1086 case roots of
1087 [] ->
1088 Just paths
1090 r:rs ->
1091 case paths of
1092 [] -> Nothing
1093 p:ps -> if r == p then dropPrefix rs ps else Nothing
1097-- CRAWL ROOTS
1100data RootStatus
1101 = SInside ModuleName.Raw
1102 | SOutsideOk Details.Local B.ByteString Src.Module
1103 | SOutsideErr Error.Module
1106crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
1107crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
1108 case root of
1109 LInside name ->
1110 do statusMVar <- newEmptyMVar
1111 statusDict <- takeMVar mvar
1112 putMVar mvar (Map.insert name statusMVar statusDict)
1113 putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
1114 return (SInside name)
1116 LOutside path ->
1117 do time <- File.getTime path
1118 source <- File.readUtf8 path
1119 case Parse.fromByteString projectType source of
1120 Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
1121 do let deps = map Src.getImportName imports
1122 let local = Details.Local path time deps (any isMain values) buildID buildID
1123 crawlDeps env mvar deps (SOutsideOk local source modul)
1125 Left syntaxError ->
1126 return $ SOutsideErr $
1127 Error.Module "???" path time source (Error.BadSyntax syntaxError)
1131-- CHECK ROOTS
1134data RootResult
1135 = RInside ModuleName.Raw
1136 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
1137 | ROutsideErr Error.Module
1138 | ROutsideBlocked
1141checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
1142checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
1143 case rootStatus of
1144 SInside name ->
1145 return (RInside name)
1147 SOutsideErr err ->
1148 return (ROutsideErr err)
1150 SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
1151 do depsStatus <- checkDeps root results deps lastCompile
1152 case depsStatus of
1153 DepsChange ifaces ->
1154 compileOutside env local source ifaces modul
1156 DepsSame same cached ->
1157 do maybeLoaded <- loadInterfaces root same cached
1158 case maybeLoaded of
1159 Nothing -> return ROutsideBlocked
1160 Just ifaces -> compileOutside env local source ifaces modul
1162 DepsBlock ->
1163 return ROutsideBlocked
1165 DepsNotFound problems ->
1166 return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
1167 Error.BadImports (toImportErrors env results imports problems)
1170compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
1171compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
1172 let
1173 pkg = projectTypeToPkg projectType
1174 name = Src.getName modul
1175 in
1176 case Compile.compile pkg ifaces modul of
1177 Right (Compile.Artifacts canonical annotations objects) ->
1178 do Reporting.report key Reporting.BDone
1179 return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
1181 Left errors ->
1182 return $ ROutsideErr $ Error.Module name path time source errors
1186-- TO ARTIFACTS
1189data Root
1190 = Inside ModuleName.Raw
1191 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
1194toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
1195toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
1196 case gatherProblemsOrMains results rootResults of
1197 Left (NE.List e es) ->
1198 Left (Exit.BuildBadModules root e es)
1200 Right roots ->
1201 Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
1202 Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
1205gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
1206gatherProblemsOrMains results (NE.List rootResult rootResults) =
1207 let
1208 addResult result (es, roots) =
1209 case result of
1210 RInside n -> ( es, Inside n : roots)
1211 ROutsideOk n i o -> ( es, Outside n i o : roots)
1212 ROutsideErr e -> (e:es, roots)
1213 ROutsideBlocked -> ( es, roots)
1215 errors = Map.foldr addErrors [] results
1216 in
1217 case (rootResult, foldr addResult (errors, []) rootResults) of
1218 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
1219 (RInside _ , (e:es, _ )) -> Left (NE.List e es)
1220 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
1221 (ROutsideOk _ _ _, (e:es, _ )) -> Left (NE.List e es)
1222 (ROutsideErr e , ( es, _ )) -> Left (NE.List e es)
1223 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
1224 (ROutsideBlocked , (e:es, _ )) -> Left (NE.List e es)
1227addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
1228addInside name result modules =
1229 case result of
1230 RNew _ iface objs _ -> Fresh name iface objs : modules
1231 RSame _ iface objs _ -> Fresh name iface objs : modules
1232 RCached main _ mvar -> Cached name main mvar : modules
1233 RNotFound _ -> error (badInside name)
1234 RProblem _ -> error (badInside name)
1235 RBlocked -> error (badInside name)
1236 RForeign _ -> modules
1237 RKernel -> modules
1240badInside :: ModuleName.Raw -> [Char]
1241badInside name =
1242 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
1245addOutside :: RootResult -> [Module] -> [Module]
1246addOutside root modules =
1247 case root of
1248 RInside _ -> modules
1249 ROutsideOk name iface objs -> Fresh name iface objs : modules
1250 ROutsideErr _ -> modules
1251 ROutsideBlocked -> modules