git.iko.soy/elk
on 253bb13 help sign in
elk/builder/src/Build.hs
956 lines 31 kB history raw
1{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2{-# LANGUAGE BangPatterns #-}
3module Build
4 ( fromExposed
5 , fromMains
6 , Artifacts(..)
7 , Main(..)
8 , Module(..)
9 , CachedInterface(..)
10 )
11 where
14import Control.Concurrent (forkIO)
15import Control.Concurrent.MVar
16import Control.Monad (filterM, mapM_, sequence_)
17import qualified Data.ByteString as B
18import qualified Data.Char as Char
19import qualified Data.Either as Either
20import qualified Data.Graph as Graph
21import qualified Data.List as List
22import qualified Data.Map.Utils as Map
23import qualified Data.Map.Strict as Map
24import Data.Map.Strict ((!))
25import qualified Data.Maybe as Maybe
26import qualified Data.Name as Name
27import qualified Data.NonEmptyList as NE
28import qualified Data.OneOrMore as OneOrMore
29import qualified System.Directory as Dir
30import qualified System.FilePath as FP
31import System.FilePath ((</>), (<.>))
33import qualified AST.Source as Src
34import qualified AST.Optimized as Opt
35import qualified Compile
36import qualified Elm.Details as Details
37import qualified Elm.Interface as I
38import qualified Elm.ModuleName as ModuleName
39import qualified Elm.Outline as Outline
40import qualified Elm.Package as Pkg
41import qualified File
42import qualified Parse.Module as Parse
43import qualified Reporting
44import qualified Reporting.Annotation as A
45import qualified Reporting.Exit as Exit
46import qualified Reporting.Problem as Problem
47import qualified Reporting.Render.Type.Localizer as Localizer
48import qualified Stuff
52-- ENVIRONMENT
55data Env =
56 Env
57 { _key :: Reporting.BKey
58 , _root :: FilePath
59 , _pkg :: Pkg.Name
60 , _srcDirs :: [FilePath]
61 , _locals :: Map.Map ModuleName.Raw Details.Local
62 , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
63 }
66makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> Env
67makeEnv key root (Details.Details _ validOutline locals foreigns _) =
68 case validOutline of
69 Details.ValidApp (Outline.AppOutline _ srcDirs _ _ _ _) ->
70 Env key root Pkg.dummyName srcDirs locals foreigns
72 Details.ValidPkg (Outline.PkgOutline pkg _ _ _ _ _ _ _) _ ->
73 Env key root pkg ["src"] locals foreigns
77-- FORK
80fork :: IO a -> IO (MVar a)
81fork work =
82 do mvar <- newEmptyMVar
83 _ <- forkIO $ putMVar mvar =<< work
84 return mvar
87{-# INLINE forkWithKey #-}
88forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
89forkWithKey func dict =
90 Map.traverseWithKey (\k v -> fork (func k v)) dict
94-- FROM EXPOSED
97fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
98fromExposed style root details (NE.List e es) =
99 Reporting.trackBuild style $ \key ->
100 do let env = makeEnv key root details
101 dmvar <- Details.loadInterfaces root details
103 -- crawl
104 mvar <- newEmptyMVar
105 roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
106 putMVar mvar roots
107 mapM_ readMVar roots
108 statuses <- traverse readMVar =<< readMVar mvar
110 -- compile
111 midpoint <- checkExposedMidpoint dmvar statuses
112 case midpoint of
113 Left problem ->
114 return (Left (Exit.BuildProjectProblem problem))
116 Right foreigns ->
117 do rmvar <- newEmptyMVar
118 resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
119 putMVar rmvar resultMVars
120 results <- traverse readMVar resultMVars
121 writeDetails root details results
122 return (detectProblems results)
126-- FROM MAINS
129data Artifacts =
130 Artifacts
131 { _name :: Pkg.Name
132 , _deps :: Dependencies
133 , _mains :: NE.List Main
134 , _modules :: [Module]
135 }
138data Module
139 = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
140 | Cached ModuleName.Raw Bool (MVar CachedInterface)
143type Dependencies =
144 Map.Map ModuleName.Canonical I.DependencyInterface
147fromMains :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
148fromMains style root details paths =
149 Reporting.trackBuild style $ \key ->
150 do let env = makeEnv key root details
152 elmains <- findMains env paths
153 case elmains of
154 Left problem ->
155 return (Left (Exit.BuildProjectProblem problem))
157 Right lmains ->
158 do -- crawl
159 dmvar <- Details.loadInterfaces root details
160 smvar <- newMVar Map.empty
161 smainMVars <- traverse (fork . crawlMain env smvar) lmains
162 smains <- traverse readMVar smainMVars
163 statuses <- traverse readMVar =<< readMVar smvar
165 midpoint <- checkMainsMidpoint dmvar statuses smains
166 case midpoint of
167 Left problem ->
168 return (Left (Exit.BuildProjectProblem problem))
170 Right foreigns ->
171 do -- compile
172 rmvar <- newEmptyMVar
173 resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
174 putMVar rmvar resultsMVars
175 rmainMVars <- traverse (fork . checkMain env resultsMVars) smains
176 results <- traverse readMVar resultsMVars
177 writeDetails root details results
178 toArtifacts env foreigns results <$> traverse readMVar rmainMVars
182-- CRAWL
185type StatusDict =
186 Map.Map ModuleName.Raw (MVar Status)
189data Status
190 = SCached Details.Local
191 | SChanged Details.Local B.ByteString Src.Module
192 | SBadImport Problem.Import
193 | SBadSyntax Problem.Syntax
194 | SForeign Pkg.Name
195 | SKernel
198crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
199crawlDeps env mvar deps blockedValue =
200 do statusDict <- takeMVar mvar
201 let depsDict = Map.fromKeys (\_ -> ()) deps
202 let newsDict = Map.difference depsDict statusDict
203 statuses <- Map.traverseWithKey crawlNew newsDict
204 putMVar mvar (Map.union statuses statusDict)
205 mapM_ readMVar statuses
206 return blockedValue
207 where
208 crawlNew name () = fork (crawlModule env mvar name)
211crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
212crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
213 do let fileName = ModuleName.toFilePath name <.> "elm"
214 let inRoot path = File.exists (root </> path)
216 paths <- filterM inRoot (map (</> fileName) srcDirs)
218 case paths of
219 [path] ->
220 case Map.lookup name foreigns of
221 Just (Details.Foreign dep deps) ->
222 return $ SBadImport $ Import.Ambiguous name path [] dep deps
224 Nothing ->
225 case Map.lookup name locals of
226 Nothing ->
227 crawlFile env mvar name path
229 Just local@(Details.Local oldPath oldTime deps _) ->
230 if path /= oldPath
231 then crawlFile env mvar name path
232 else
233 do newTime <- File.getTime path
234 if oldTime < newTime
235 then crawlFile env mvar name path
236 else crawlDeps env mvar deps (SCached local)
238 p1:p2:ps ->
239 return $ SBadImport $ Import.AmbiguousLocal name p1 p2 ps
241 [] ->
242 case Map.lookup name foreigns of
243 Just (Details.Foreign dep deps) ->
244 case deps of
245 [] ->
246 return $ SForeign dep
248 d:ds ->
249 return $ SBadImport $ Import.AmbiguousForeign name dep d ds
251 Nothing ->
252 if Name.isKernel name && Pkg.isKernel pkg then
253 do exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
254 return $ if exists then SKernel else SBadImport (Import.NotFound name)
255 else
256 return $ SBadImport (Import.NotFound name)
259crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
260crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
261 do time <- File.getTime path
262 source <- File.readUtf8 (root </> path)
264 case Parse.fromByteString pkg source of
265 Right modul@(Src.Module maybeActualName _ imports values _ _ _ _) ->
266 case maybeActualName of
267 Just actualName ->
268 if expectedName == actualName then
269 let
270 deps = map Src.getImportName imports
271 local = Details.Local path time deps (any isMain values)
272 in
273 crawlDeps env mvar deps (SChanged local source modul)
274 else
275 return $ SBadSyntax $ Problem.ModuleNameMismatch expectedName actualName
277 Nothing ->
278 return $ SBadSyntax $ Problem.ModuleNameUnspecified expectedName
280 Left syntaxError ->
281 return $ SBadSyntax $ Problem.SyntaxProblem path time syntaxError
284isMain :: A.Located Src.Value -> Bool
285isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
286 name == Name.main
290-- CHECK MODULE
293type ResultDict =
294 Map.Map ModuleName.Raw (MVar Result)
297data Result
298 = RNew Details.Local I.Interface Opt.LocalGraph
299 | RSame Details.Local I.Interface Opt.LocalGraph
300 | RCached Bool (MVar CachedInterface)
301 | RNotFound Problem.Import
302 | RProblem Problem.Problem
303 | RBlocked
304 | RForeign I.Interface
305 | RKernel
308data CachedInterface
309 = Unneeded
310 | Loaded I.Interface
311 | Corrupted
314checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
315checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
316 case status of
317 SCached local@(Details.Local path time deps hasMain) ->
318 do results <- readMVar resultsMVar
319 depsStatus <- checkDeps root results deps
320 case depsStatus of
321 DepsChange ifaces ->
322 do source <- File.readUtf8 path
323 case Parse.fromByteString pkg source of
324 Right modul -> compile env local source ifaces modul
325 Left syntaxError ->
326 return $ RProblem $ Problem.BadSyntax $
327 Problem.SyntaxProblem path time syntaxError
329 DepsSame _ _ ->
330 do mvar <- newMVar Unneeded
331 return (RCached hasMain mvar)
333 DepsBlock ->
334 return RBlocked
336 DepsNotFound name1 problem1 others ->
337 return (RProblem (Problem.BadImports name1 problem1 others))
339 SChanged local@(Details.Local _ _ deps _) source modul ->
340 do results <- readMVar resultsMVar
341 depsStatus <- checkDeps root results deps
342 case depsStatus of
343 DepsChange ifaces ->
344 compile env local source ifaces modul
346 DepsSame same cached ->
347 do maybeLoaded <- checkCachedInterfaces root cached
348 case maybeLoaded of
349 Nothing ->
350 return RBlocked
352 Just loaded ->
353 do let ifaces = Map.union loaded (Map.fromList same)
354 compile env local source ifaces modul
356 DepsBlock ->
357 return RBlocked
359 DepsNotFound name1 problem1 others ->
360 return (RProblem (Problem.BadImports name1 problem1 others))
362 SBadImport importProblem ->
363 return (RNotFound importProblem)
365 SBadSyntax syntaxProblem ->
366 return (RProblem (Problem.BadSyntax syntaxProblem))
368 SForeign home ->
369 case foreigns ! ModuleName.Canonical home name of
370 I.Public iface -> return (RForeign iface)
371 I.Private _ _ _ -> error "loading private interface in Build"
373 SKernel ->
374 return RKernel
378-- CHECK DEPS
381data DepsStatus
382 = DepsChange (Map.Map ModuleName.Raw I.Interface)
383 | DepsSame [Dep] [CDep]
384 | DepsBlock
385 | DepsNotFound ModuleName.Raw Problem.Import [(ModuleName.Raw, Problem.Import)]
388checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> IO DepsStatus
389checkDeps root results deps =
390 checkDepsHelp root results deps [] [] [] [] False
393type Dep = (ModuleName.Raw, I.Interface)
394type CDep = (ModuleName.Raw, MVar CachedInterface)
397checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw, Problem.Import)] -> Bool -> IO DepsStatus
398checkDepsHelp root results deps new same cached badImports isBlocked =
399 case deps of
400 dep:otherDeps ->
401 do result <- readMVar (results ! dep)
402 case result of
403 RNew _ iface _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached badImports isBlocked
404 RSame _ iface _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached badImports isBlocked
405 RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) badImports isBlocked
406 RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : badImports) True
407 RProblem _ -> checkDepsHelp root results otherDeps new same cached badImports True
408 RBlocked -> checkDepsHelp root results otherDeps new same cached badImports True
409 RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached badImports isBlocked
410 RKernel -> checkDepsHelp root results otherDeps new same cached badImports isBlocked
412 [] ->
413 case badImports of
414 (name, problem) : otherBadImports ->
415 return $ DepsNotFound name problem otherBadImports
417 [] ->
418 if isBlocked then
419 return $ DepsBlock
421 else if null new then
422 return $ DepsSame same cached
424 else
425 do maybeLoaded <- checkCachedInterfaces root cached
426 case maybeLoaded of
427 Nothing ->
428 return DepsBlock
430 Just loaded ->
431 return $ DepsChange $
432 Map.union loaded (Map.union (Map.fromList new) (Map.fromList same))
436-- CACHED INTERFACE
439checkCachedInterfaces :: FilePath -> [(ModuleName.Raw, MVar CachedInterface)] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
440checkCachedInterfaces root deps =
441 do loading <- traverse (fork . checkCache root) deps
442 loaded <- traverse readMVar loading
443 return $ Map.fromList <$> sequence loaded
446checkCache :: FilePath -> (ModuleName.Raw, MVar CachedInterface) -> IO (Maybe Dep)
447checkCache root (name, ciMvar) =
448 do cachedInterface <- takeMVar ciMvar
449 case cachedInterface of
450 Corrupted ->
451 do putMVar ciMvar cachedInterface
452 return Nothing
454 Loaded iface ->
455 do putMVar ciMvar cachedInterface
456 return (Just (name, iface))
458 Unneeded ->
459 do maybeIface <- File.readBinary (Stuff.elmi root name)
460 case maybeIface of
461 Nothing ->
462 do putMVar ciMvar Corrupted
463 return Nothing
465 Just iface ->
466 do putMVar ciMvar (Loaded iface)
467 return (Just (name, iface))
471-- CHECK PROJECT
474checkExposedMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
475checkExposedMidpoint dmvar statuses =
476 case checkForCycles statuses of
477 Nothing ->
478 do maybeForeigns <- readMVar dmvar
479 case maybeForeigns of
480 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
481 Just fs -> return (Right fs)
483 Just (NE.List name names) ->
484 do _ <- readMVar dmvar
485 return (Left (Exit.BP_Cycle name names))
488checkMainsMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List MainStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
489checkMainsMidpoint dmvar statuses smains =
490 case checkForCycles statuses of
491 Nothing ->
492 case checkUniqueMains statuses smains of
493 Nothing ->
494 do maybeForeigns <- readMVar dmvar
495 case maybeForeigns of
496 Nothing -> return (Left Exit.BP_CannotLoadDependencies)
497 Just fs -> return (Right fs)
499 Just problem ->
500 do _ <- readMVar dmvar
501 return (Left problem)
503 Just (NE.List name names) ->
504 do _ <- readMVar dmvar
505 return (Left (Exit.BP_Cycle name names))
509-- CHECK FOR CYCLES
512checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
513checkForCycles modules =
514 let
515 !graph = Map.foldrWithKey addToGraph [] modules
516 !sccs = Graph.stronglyConnComp graph
517 in
518 checkForCyclesHelp sccs
521checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
522checkForCyclesHelp sccs =
523 case sccs of
524 [] ->
525 Nothing
527 scc:otherSccs ->
528 case scc of
529 Graph.AcyclicSCC _ -> checkForCyclesHelp otherSccs
530 Graph.CyclicSCC [] -> checkForCyclesHelp otherSccs
531 Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
534type Node =
535 ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
538addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
539addToGraph name status graph =
540 let
541 dependencies =
542 case status of
543 SCached (Details.Local _ _ deps _) -> deps
544 SChanged (Details.Local _ _ deps _) _ _ -> deps
545 SBadImport _ -> []
546 SBadSyntax _ -> []
547 SForeign _ -> []
548 SKernel -> []
549 in
550 (name, name, dependencies) : graph
554-- CHECK UNIQUE MAINS
557checkUniqueMains :: Map.Map ModuleName.Raw Status -> NE.List MainStatus -> Maybe Exit.BuildProjectProblem
558checkUniqueMains insides smains =
559 let
560 outsidesDict =
561 Map.fromListWith OneOrMore.more (Maybe.mapMaybe mainStatusToNamePathPair (NE.toList smains))
562 in
563 case Map.traverseWithKey checkOutside outsidesDict of
564 Left problem ->
565 Just problem
567 Right outsides ->
568 case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
569 Right () -> Nothing
570 Left problem -> Just problem
573mainStatusToNamePathPair :: MainStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
574mainStatusToNamePathPair smain =
575 case smain of
576 SInside _ -> Nothing
577 SOutsideOk (Details.Local path _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
578 SOutsideErr _ -> Nothing
581checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
582checkOutside name paths =
583 case OneOrMore.destruct NE.List paths of
584 NE.List p [] -> Right p
585 NE.List p1 (p2:_) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
588checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
589checkInside name p1 status =
590 case status of
591 SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
592 SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
593 SBadImport _ -> Right ()
594 SBadSyntax _ -> Right ()
595 SForeign _ -> Right ()
596 SKernel -> Right ()
600-- COMPILE MODULE
603compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
604compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifaces modul =
605 case Compile.compile pkg ifaces modul of
606 Right (Compile.Artifacts canonical annotations objects) ->
607 do let name = Src.getName modul
608 let iface = I.fromModule pkg canonical annotations
609 File.writeBinary (Stuff.elmo root name) objects
610 maybeOldi <- File.readBinary (Stuff.elmi root name)
611 case maybeOldi of
612 Just oldi | oldi == iface ->
613 do -- iface should be fully forced by equality check
614 Reporting.report key Reporting.BDone
615 return (RSame local iface objects)
617 _ ->
618 do -- iface may be lazy still
619 -- TODO try adding forkIO here
620 File.writeBinary (Stuff.elmi root name) iface
621 Reporting.report key Reporting.BDone
622 return (RNew local iface objects)
624 Left errors ->
625 do Reporting.report key Reporting.BDone
626 return $ RProblem $ Problem.BadContent $
627 Problem.Module (Src.getName modul) path time source errors (Localizer.fromModule modul)
631-- WRITE DETAILS
634writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
635writeDetails root (Details.Details time outline locals foreigns extras) results =
636 File.writeBinary (Stuff.details root) $
637 Details.Details time outline (Map.foldrWithKey addNewLocal locals results) foreigns extras
640addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
641addNewLocal name result locals =
642 case result of
643 RNew local _ _ -> Map.insert name local locals
644 RSame local _ _ -> Map.insert name local locals
645 RCached _ _ -> locals
646 RNotFound _ -> locals
647 RProblem _ -> locals
648 RBlocked -> locals
649 RForeign _ -> locals
650 RKernel -> locals
654-- DETECT PROBLEMS
657detectProblems :: Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
658detectProblems results =
659 case Map.foldr addProblem [] results of
660 [] -> Right ()
661 p:ps -> Left (Exit.BuildModuleProblems p ps)
664addProblem :: Result -> [Problem.Problem] -> [Problem.Problem]
665addProblem result problems =
666 case result of
667 RNew _ _ _ -> problems
668 RSame _ _ _ -> problems
669 RCached _ _ -> problems
670 RNotFound _ -> problems
671 RProblem p -> p:problems
672 RBlocked -> problems
673 RForeign _ -> problems
674 RKernel -> problems
678--------------------------------------------------------------------------------
679--------------------------------------------------------------------------------
680------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
681--------------------------------------------------------------------------------
682--------------------------------------------------------------------------------
686-- FIND MAIN
689data MainLocation
690 = LInside ModuleName.Raw
691 | LOutside FilePath
694findMains :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List MainLocation))
695findMains env paths =
696 do mvars <- traverse (fork . findLocation env) paths
697 elocs <- traverse readMVar mvars
698 return $ checkLocations =<< sequence elocs
701checkLocations :: NE.List Location -> Either Exit.BuildProjectProblem (NE.List MainLocation)
702checkLocations locations =
703 let
704 toOneOrMore loc@(Location absolute _ _) =
705 (absolute, OneOrMore.one loc)
707 fromOneOrMore loc locs =
708 case locs of
709 [] -> Right ()
710 loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
711 in
712 fmap (\_ -> fmap _location locations) $
713 traverse (OneOrMore.destruct fromOneOrMore) $
714 Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList locations)
718-- LOCATIONS
721data Location =
722 Location
723 { _absolute :: FilePath
724 , _relative :: FilePath
725 , _location :: MainLocation
726 }
729findLocation :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem Location)
730findLocation env path =
731 do exists <- File.exists path
732 if exists
733 then isInsideSrcDirs env path <$> Dir.canonicalizePath path
734 else return (Left (Exit.BP_PathUnknown path))
737isInsideSrcDirs :: Env -> FilePath -> FilePath -> Either Exit.BuildProjectProblem Location
738isInsideSrcDirs (Env _ root _ srcDirs _ _) path absolutePath =
739 let
740 (dirs, file) = FP.splitFileName absolutePath
741 (final, ext) = break (=='.') file
742 in
743 if ext /= ".elm"
744 then Left (Exit.BP_WithBadExtension path)
745 else
746 let
747 roots = FP.splitDirectories root
748 segments = FP.splitDirectories dirs ++ [final]
749 in
750 case dropPrefix roots segments of
751 Nothing ->
752 Right (Location absolutePath path (LOutside path))
754 Just relativeSegments ->
755 let
756 (exits, maybes) =
757 Either.partitionEithers (map (isInsideSrcDirsHelp relativeSegments) srcDirs)
758 in
759 case (exits, Maybe.catMaybes maybes) of
760 (_, [(_,name)]) -> Right (Location absolutePath path (LInside name))
761 ([], []) -> Right (Location absolutePath path (LOutside path))
762 (_, (s1,_):(s2,_):_) -> Left (Exit.BP_WithAmbiguousSrcDir s1 s2)
763 (exit:_, _) -> Left exit
766isInsideSrcDirsHelp :: [String] -> FilePath -> Either Exit.BuildProjectProblem (Maybe (FilePath, ModuleName.Raw))
767isInsideSrcDirsHelp segments srcDir =
768 case dropPrefix (FP.splitDirectories srcDir) segments of
769 Nothing ->
770 Right Nothing
772 Just names ->
773 if all isGoodName names
774 then Right (Just (srcDir, Name.fromChars (List.intercalate "." names)))
775 else Left (error "Exit.MakeWithInvalidModuleName" srcDir segments)
778isGoodName :: [Char] -> Bool
779isGoodName name =
780 case name of
781 [] ->
782 False
784 char:chars ->
785 Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
788dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
789dropPrefix roots paths =
790 case roots of
791 [] ->
792 Just paths
794 r:rs ->
795 case paths of
796 [] -> Nothing
797 p:ps -> if r == p then dropPrefix rs ps else Nothing
801-- CRAWL MAINS
804data MainStatus
805 = SInside ModuleName.Raw
806 | SOutsideOk Details.Local B.ByteString Src.Module
807 | SOutsideErr Problem.Syntax
810crawlMain :: Env -> MVar StatusDict -> MainLocation -> IO MainStatus
811crawlMain env@(Env _ _ pkg _ _ _) mvar given =
812 case given of
813 LInside name ->
814 do statusMVar <- newEmptyMVar
815 statusDict <- takeMVar mvar
816 putMVar mvar (Map.insert name statusMVar statusDict)
817 putMVar statusMVar =<< crawlModule env mvar name
818 return (SInside name)
820 LOutside path ->
821 do time <- File.getTime path
822 source <- File.readUtf8 path
823 case Parse.fromByteString pkg source of
824 Right modul@(Src.Module _ _ imports values _ _ _ _) ->
825 do let deps = map Src.getImportName imports
826 let local = Details.Local path time deps (any isMain values)
827 crawlDeps env mvar deps (SOutsideOk local source modul)
829 Left syntaxError ->
830 return (SOutsideErr (Problem.SyntaxProblem path time syntaxError))
834-- CHECK MAINS
837data MainResult
838 = RInside ModuleName.Raw
839 | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
840 | ROutsideErr Problem.Problem
841 | ROutsideBlocked
844checkMain :: Env -> ResultDict -> MainStatus -> IO MainResult
845checkMain env@(Env _ root _ _ _ _) results pendingMain =
846 case pendingMain of
847 SInside name ->
848 return (RInside name)
850 SOutsideErr syntaxProblem ->
851 return (ROutsideErr (Problem.BadSyntax syntaxProblem))
853 SOutsideOk local@(Details.Local _ _ deps _) source modul ->
854 do depsStatus <- checkDeps root results deps
855 case depsStatus of
856 DepsChange ifaces ->
857 return $ compileOutside env local source ifaces modul
859 DepsSame same cached ->
860 do maybeLoaded <- checkCachedInterfaces root cached
861 case maybeLoaded of
862 Nothing ->
863 return ROutsideBlocked
865 Just loaded ->
866 do let ifaces = Map.union loaded (Map.fromList same)
867 return $ compileOutside env local source ifaces modul
869 DepsBlock ->
870 return ROutsideBlocked
872 DepsNotFound name1 problem1 others ->
873 return (ROutsideErr (Problem.BadImports name1 problem1 others))
876compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> MainResult
877compileOutside (Env _ _ pkg _ _ _) (Details.Local path time _ _) source ifaces modul =
878 let
879 name = Src.getName modul
880 in
881 case Compile.compile pkg ifaces modul of
882 Right (Compile.Artifacts canonical annotations objects) ->
883 ROutsideOk name (I.fromModule pkg canonical annotations) objects
885 Left errors ->
886 ROutsideErr $ Problem.BadContent $
887 Problem.Module name path time source errors (Localizer.fromModule modul)
891-- TO ARTIFACTS
894data Main
895 = Inside ModuleName.Raw
896 | Outside ModuleName.Raw I.Interface Opt.LocalGraph
899toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either Exit.BuildProblem Artifacts
900toArtifacts (Env _ _ pkg _ _ _) foreigns results mainResults =
901 case gatherProblemsOrMains results mainResults of
902 Left (NE.List p ps) ->
903 Left (Exit.BuildModuleProblems p ps)
905 Right mains ->
906 Right $ Artifacts pkg foreigns mains $
907 Map.foldrWithKey addInside (foldr addOutside [] mainResults) results
910gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List MainResult -> Either (NE.List Problem.Problem) (NE.List Main)
911gatherProblemsOrMains results (NE.List mainResult mainResults) =
912 let
913 sortMain result (ps, mains) =
914 case result of
915 RInside n -> ( ps, Inside n : mains)
916 ROutsideOk n i o -> ( ps, Outside n i o : mains)
917 ROutsideErr p -> (p:ps, mains)
918 ROutsideBlocked -> ( ps, mains)
920 problems = Map.foldr addProblem [] results
921 in
922 case (mainResult, foldr sortMain (problems, []) mainResults) of
923 (RInside n , ( [], ms)) -> Right (NE.List (Inside n) ms)
924 (RInside _ , (p:ps, _ )) -> Left (NE.List p ps)
925 (ROutsideOk n i o, ( [], ms)) -> Right (NE.List (Outside n i o) ms)
926 (ROutsideOk _ _ _, (p:ps, _ )) -> Left (NE.List p ps)
927 (ROutsideErr p , ( ps, _ )) -> Left (NE.List p ps)
928 (ROutsideBlocked , ( [], _ )) -> error "seems like elm-stuff/ is corrupted"
929 (ROutsideBlocked , (p:ps, _ )) -> Left (NE.List p ps)
932addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
933addInside name result modules =
934 case result of
935 RNew _ iface objs -> Fresh name iface objs : modules
936 RSame _ iface objs -> Fresh name iface objs : modules
937 RCached main mvar -> Cached name main mvar : modules
938 RNotFound _ -> error (badInside name)
939 RProblem _ -> error (badInside name)
940 RBlocked -> error (badInside name)
941 RForeign _ -> modules
942 RKernel -> modules
945badInside :: ModuleName.Raw -> [Char]
946badInside name =
947 "Error from `" ++ Name.toChars name ++ "` should have been reported already."
950addOutside :: MainResult -> [Module] -> [Module]
951addOutside main modules =
952 case main of
953 RInside _ -> modules
954 ROutsideOk name iface objs -> Fresh name iface objs : modules
955 ROutsideErr _ -> modules
956 ROutsideBlocked -> modules