From 5c7c8a2a9b5c91398c1be82fc9f1961ea8a7e9ca Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Fri, 21 Aug 2015 02:51:58 -0700 Subject: [PATCH] Beginning of refactor Start a refactor to better organize the code in this repo. This change also begins addressing error reporting stuff described in #23, #47, and #46. It also adds rudimentary timing information so we know how long different phases take. --- elm-make.cabal | 13 +- src/BuildManager.hs | 203 ++++++++++++++++++ src/CrawlProject.hs | 53 ----- src/{Arguments.hs => Flags.hs} | 97 ++++++--- src/Main.hs | 134 +++--------- src/Path.hs | 16 +- src/{Build.hs => Pipeline/Compile.hs} | 105 +++++---- src/Pipeline/Crawl.hs | 119 ++++++++++ .../Crawl/Package.hs} | 179 +++++---------- src/{ => Pipeline}/Generate.hs | 80 +++---- src/{LoadInterfaces.hs => Pipeline/Plan.hs} | 136 +++++------- src/Pipeline/README.md | 9 + src/Report.hs | 32 +-- src/TheMasterPlan.hs | 43 ++-- src/Utils/File.hs | 31 +-- 15 files changed, 694 insertions(+), 556 deletions(-) create mode 100644 src/BuildManager.hs delete mode 100644 src/CrawlProject.hs rename src/{Arguments.hs => Flags.hs} (55%) rename src/{Build.hs => Pipeline/Compile.hs} (74%) create mode 100644 src/Pipeline/Crawl.hs rename src/{CrawlPackage.hs => Pipeline/Crawl/Package.hs} (56%) rename src/{ => Pipeline}/Generate.hs (65%) rename src/{LoadInterfaces.hs => Pipeline/Plan.hs} (54%) create mode 100644 src/Pipeline/README.md diff --git a/elm-make.cabal b/elm-make.cabal index 318b1ce..c00f04d 100644 --- a/elm-make.cabal +++ b/elm-make.cabal @@ -40,14 +40,14 @@ Executable elm-make Main.hs other-modules: - Arguments, - Build, - CrawlPackage, - CrawlProject, - Generate, - LoadInterfaces, + Flags, Path, Paths_elm_make, + Pipeline.Compile, + Pipeline.Crawl, + Pipeline.Crawl.Package, + Pipeline.Generate, + Pipeline.Plan, Report, TheMasterPlan, Utils.File, @@ -68,4 +68,5 @@ Executable elm-make filepath, mtl >= 2.2.1 && < 3, optparse-applicative >=0.11 && <0.12, + time, text diff --git a/src/BuildManager.hs b/src/BuildManager.hs new file mode 100644 index 0000000..cd9deac --- /dev/null +++ b/src/BuildManager.hs @@ -0,0 +1,203 @@ +{-# OPTIONS_GHC -Wall #-} +module BuildManager where + +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.State (StateT, liftIO, runStateT) +import qualified Control.Monad.State as State +import qualified Data.Time.Clock.POSIX as Time +import qualified Elm.Compiler as Compiler +import qualified Elm.Compiler.Module as Module +import qualified Elm.Package.Name as Pkg +import qualified Elm.Package.Paths as Path +import System.FilePath (()) + +import qualified Report +import qualified TheMasterPlan as TMP + + +-- CONFIGURATION + +data Config = Config + { _artifactDirectory :: FilePath + , _files :: [FilePath] + , _output :: Output + , _autoYes :: Bool + , _reportType :: Report.Type + , _warn :: Bool + , _docs :: Maybe FilePath + } + + +data Output + = Html FilePath + | JS FilePath + + +outputFilePath :: Config -> FilePath +outputFilePath config = + case _output config of + Html file -> file + JS file -> file + + +artifactDirectory :: FilePath +artifactDirectory = + Path.stuffDirectory "build-artifacts" + + +-- RUN A BUILD + +type Task a = + ExceptT Error (StateT [Phase] IO) a + + +run :: Task a -> IO (Either Error (a, Timeline)) +run task = + do result <- + runStateT (runExceptT (phase "elm-make" task)) [] + case result of + (Right answer, [Phase _ start phases end]) -> + return (Right (answer, Timeline start phases end)) + + (Left err, _) -> + return (Left err) + + +-- TIMELINE + +data Timeline = Timeline + { _start :: Time.POSIXTime + , _phases :: [Phase] + , _end :: Time.POSIXTime + } + + +data Phase = Phase + { _tag :: String + , _start_ :: Time.POSIXTime + , _subphases :: [Phase] + , _end_ :: Time.POSIXTime + } + + +phase :: String -> Task a -> Task a +phase name task = + do phasesSoFar <- State.get + State.put [] + start <- liftIO Time.getPOSIXTime + result <- task + end <- liftIO Time.getPOSIXTime + State.modify' (\phases -> Phase name start (reverse phases) end : phasesSoFar) + return result + + +timelineToString :: Timeline -> String +timelineToString (Timeline start phases end) = + let + duration = end - start + in + "\nOverall time: " ++ show duration ++ "\n" + ++ concatMap (phaseToString duration 1) phases + ++ "\n" + + +phaseToString :: Time.POSIXTime -> Int -> Phase -> String +phaseToString overallDuration indent (Phase tag start subphases end) = + let + duration = end - start + percent = truncate (100 * duration / overallDuration) :: Int + in + '\n' : replicate (indent * 4) ' ' ++ show percent ++ "% - " ++ tag + ++ concatMap (phaseToString duration (indent + 1)) subphases + + +-- ERRORS + +data Error + = BadFlags + | CompilerErrors FilePath String [Compiler.Error] + | CorruptedArtifact FilePath + | Cycle [TMP.CanonicalModule] + | PackageProblem String + | MissingPackage Pkg.Name + | ModuleNotFound Module.Name (Maybe Module.Name) + | ModuleDuplicates + { _name :: Module.Name + , _parent :: Maybe Module.Name + , _local :: [FilePath] + , _foreign :: [Pkg.Name] + } + | ModuleName + { _path :: FilePath + , _expectedName :: Module.Name + , _actualName :: Module.Name + } + + +errorToString :: Error -> String +errorToString err = + case err of + BadFlags -> + error "TODO bad flags" + + CompilerErrors _ _ _ -> + error "TODO" + + CorruptedArtifact filePath -> + concat + [ "Error reading build artifact ", filePath, "\n" + , " The file was generated by a previous build and may be outdated or corrupt.\n" + , " Please remove the file and try again." + ] + + Cycle moduleCycle -> + "Your dependencies form a cycle:\n\n" + ++ error "TODO" moduleCycle + ++ "\nYou may need to move some values to a new module to get rid of the cycle." + + PackageProblem msg -> + msg + + MissingPackage name -> + error "TODO" name + + ModuleNotFound name maybeParent -> + unlines + [ "Error when searching for modules" ++ toContext maybeParent ++ ":" + , " Could not find module '" ++ Module.nameToString name ++ "'" + , "" + , "Potential problems could be:" + , " * Misspelled the module name" + , " * Need to add a source directory or new dependency to " ++ Path.description + ] + + ModuleDuplicates name maybeParent filePaths pkgs -> + "Error when searching for modules" ++ toContext maybeParent ++ ".\n" ++ + "Found multiple modules named '" ++ Module.nameToString name ++ "'\n" ++ + "Modules with that name were found in the following locations:\n\n" ++ + concatMap (\str -> " " ++ str ++ "\n") (paths ++ packages) + where + packages = + map ("package " ++) (map Pkg.toString pkgs) + + paths = + map ("directory " ++) filePaths + + ModuleName path nameFromPath nameFromSource -> + unlines + [ "The module name is messed up for " ++ path + , " According to the file's name it should be " ++ Module.nameToString nameFromPath + , " According to the source code it should be " ++ Module.nameToString nameFromSource + , "Which is it?" + ] + + +toContext :: Maybe Module.Name -> String +toContext maybeParent = + case maybeParent of + Nothing -> + " exposed by " ++ Path.description + + Just parent -> + " imported by module '" ++ Module.nameToString parent ++ "'" + diff --git a/src/CrawlProject.hs b/src/CrawlProject.hs deleted file mode 100644 index be0a6a0..0000000 --- a/src/CrawlProject.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module CrawlProject where - -import qualified Data.Map as Map - -import qualified Elm.Compiler.Module as Module -import TheMasterPlan - ( ModuleID(ModuleID), PackageID, Location(Location) - , PackageSummary(..), PackageData(..) - , ProjectSummary(..), ProjectData(..) - ) - - -canonicalizePackageSummary - :: PackageID - -> PackageSummary - -> ProjectSummary Location -canonicalizePackageSummary package (PackageSummary pkgData natives foreignDependencies) = - ProjectSummary - { projectData = - Map.map - (canonicalizePackageData package foreignDependencies) - (canonicalizeKeys pkgData) - , projectNatives = - Map.map (\path -> Location path package) (canonicalizeKeys natives) - } - where - canonicalizeKeys = - Map.mapKeysMonotonic (\name -> ModuleID name package) - - -canonicalizePackageData - :: PackageID - -> Map.Map Module.Name PackageID - -> PackageData - -> ProjectData Location -canonicalizePackageData package foreignDependencies (PackageData filePath deps) = - ProjectData { - projectLocation = Location filePath package, - projectDependencies = map canonicalizeModule deps - } - where - canonicalizeModule :: Module.Name -> ModuleID - canonicalizeModule moduleName = - case Map.lookup moduleName foreignDependencies of - Nothing -> ModuleID moduleName package - Just foreignPackage -> - ModuleID moduleName foreignPackage - - -union :: ProjectSummary a -> ProjectSummary a -> ProjectSummary a -union (ProjectSummary d natives) (ProjectSummary d' natives') = - ProjectSummary (Map.union d d') (Map.union natives natives') \ No newline at end of file diff --git a/src/Arguments.hs b/src/Flags.hs similarity index 55% rename from src/Arguments.hs rename to src/Flags.hs index 294ff92..4fb894a 100644 --- a/src/Arguments.hs +++ b/src/Flags.hs @@ -1,30 +1,62 @@ -module Arguments where +{-# OPTIONS_GHC -Wall #-} +module Flags where import Control.Applicative ((<$>), (<*>), many, optional) +import Control.Monad.Except (liftIO, throwError) import qualified Data.List as List import Data.Monoid ((<>), mconcat, mempty) import Data.Version (showVersion) +import qualified Elm.Compiler as Compiler import qualified Options.Applicative as Opt import qualified Paths_elm_make as This import qualified Text.PrettyPrint.ANSI.Leijen as PP -import qualified Elm.Compiler as Compiler +import qualified BuildManager as BM import qualified Report -data Arguments = Arguments - { files :: [FilePath] - , outputFile :: Maybe FilePath - , autoYes :: Bool - , reportType :: Report.Type - , warn :: Bool - , docs :: Maybe FilePath +data Flags = Flags + { _files :: [FilePath] + , _html :: Maybe FilePath + , _js :: Maybe FilePath + , _autoYes :: Bool + , _reportType :: Report.Type + , _warn :: Bool + , _docs :: Maybe FilePath } +-- TO CONFIG + +toConfig :: BM.Task BM.Config +toConfig = + do (Flags files html js autoYes reportType warn docs) <- liftIO parse + output <- toOutput files html js + return (BM.Config BM.artifactDirectory files output autoYes reportType warn docs) + + +toOutput :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> BM.Task BM.Output +toOutput sourceFiles html js = + case (sourceFiles, html, js) of + ( [], _, _ ) -> + throwError BM.BadFlags + + ( _, Just _, Just _ ) -> + throwError BM.BadFlags + + ( [_], _, Nothing ) -> + return (BM.Html (maybe "index.html" id html)) + + ( _, _, Just outputPath ) -> + return (BM.JS outputPath) + + ( _ : _ : _, _, Nothing ) -> + throwError BM.BadFlags + + -- PARSE ARGUMENTS -parse :: IO Arguments +parse :: IO Flags parse = Opt.customExecParser preferences parser where @@ -32,18 +64,19 @@ parse = preferences = Opt.prefs (mempty <> Opt.showHelpOnError) - parser :: Opt.ParserInfo Arguments + parser :: Opt.ParserInfo Flags parser = - Opt.info (Opt.helper <*> options) helpInfo + Opt.info (Opt.helper <*> flags) helpInfo -- COMMANDS -options :: Opt.Parser Arguments -options = - Arguments +flags :: Opt.Parser Flags +flags = + Flags <$> files - <*> optional outputFile + <*> optional html + <*> optional js <*> yes <*> reportFlag <*> warnFlag @@ -52,12 +85,20 @@ options = files = many (Opt.strArgument ( Opt.metavar "FILES..." )) - outputFile = + html = + Opt.strOption $ + mconcat + [ Opt.long "html" + , Opt.metavar "FILE" + , Opt.help "Write resulting HTML to the given FILE." + ] + + js = Opt.strOption $ mconcat - [ Opt.long "output" + [ Opt.long "js" , Opt.metavar "FILE" - , Opt.help "Write output to FILE." + , Opt.help "Write resulting JS to the given FILE." ] docs = @@ -71,29 +112,33 @@ options = -- HELP -helpInfo :: Opt.InfoMod Arguments +helpInfo :: Opt.InfoMod Flags helpInfo = mconcat [ Opt.fullDesc , Opt.header top , Opt.progDesc "build Elm projects" - , Opt.footerDoc (Just moreHelp) + , Opt.footerDoc (Just examples) ] where top = "elm-make " ++ showVersion This.version ++ " (Elm Platform " ++ Compiler.version ++ ")\n" - moreHelp = + examples = linesToDoc - [ "To learn more about a particular command run:" - , " elm-make COMMAND --help" + [ "Examples:" + , " elm-make Main.elm # make HTML in index.html" + , " elm-make Main.elm --html main.html # make HTML in main.html" + , " elm-make Main.elm --js elm.js # make JS in elm.js" + , "" + , "Full guide to using elm-make at " ] linesToDoc :: [String] -> PP.Doc -linesToDoc lines = - PP.vcat (map PP.text lines) +linesToDoc lineList = + PP.vcat (map PP.text lineList) yes :: Opt.Parser Bool diff --git a/src/Main.hs b/src/Main.hs index 4e90231..ba5f63a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,143 +1,71 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} module Main where -import Control.Monad (forM) -import Control.Monad.Except (MonadError, runExceptT, MonadIO, liftIO) -import Control.Monad.Reader (MonadReader, runReaderT, ask) -import qualified Data.List as List +import Control.Monad.Except (liftIO) import qualified Data.Map as Map import qualified Data.Set as Set -import System.Directory (doesFileExist) -import System.FilePath (()) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) import GHC.Conc (getNumProcessors, setNumCapabilities) -import qualified Build -import qualified CrawlPackage -import qualified CrawlProject -import qualified LoadInterfaces -import qualified Arguments -import qualified Elm.Package.Description as Desc -import qualified Elm.Package.Initialize as Initialize -import qualified Elm.Package.Paths as Path -import qualified Elm.Package.Solution as Solution -import qualified Generate -import TheMasterPlan - ( ModuleID(ModuleID), Location, PackageID - , ProjectSummary(..), ProjectData(..) - ) +import qualified BuildManager as BM +import qualified Flags +import qualified Pipeline.Compile as Compile +import qualified Pipeline.Crawl as Crawl +import qualified Pipeline.Plan as Plan +import qualified Pipeline.Generate as Generate +import TheMasterPlan (ProjectGraph(..), ProjectData(..)) main :: IO () main = - do args <- Arguments.parse + do numProcessors <- getNumProcessors + setNumCapabilities numProcessors - result <- runExceptT (runReaderT (run args) artifactDirectory) + result <- BM.run (make numProcessors) case result of - Right () -> - return () + Right (_, timeline) -> + putStrLn (BM.timelineToString timeline) - Left msg -> - do hPutStrLn stderr msg + Left err -> + do hPutStrLn stderr (BM.errorToString err) exitFailure -artifactDirectory :: FilePath -artifactDirectory = - Path.stuffDirectory "build-artifacts" +make :: Int -> BM.Task () +make numProcessors = + do config <- Flags.toConfig - -run :: (MonadIO m, MonadError String m, MonadReader FilePath m) - => Arguments.Arguments - -> m () -run args = - do numProcessors <- liftIO getNumProcessors - liftIO (setNumCapabilities numProcessors) - - (thisPackage, exposedModules, moduleForGeneration, projectSummary) <- - crawl (Arguments.autoYes args) (Arguments.files args) + (Crawl.ProjectInfo thisPackage exposedModules moduleForGeneration projectSummary) <- + BM.phase "Crawl Project" (Crawl.crawl config) let dependencies = Map.map projectDependencies (projectData projectSummary) let modulesToDocument = - maybe Set.empty (const exposedModules) (Arguments.docs args) + maybe Set.empty (const exposedModules) (BM._docs config) buildSummary <- - LoadInterfaces.prepForBuild modulesToDocument projectSummary + BM.phase "Plan Build" (Plan.planBuild config modulesToDocument projectSummary) - cachePath <- ask docs <- - liftIO $ - Build.build - (Arguments.reportType args) - (Arguments.warn args) + BM.phase "Compile" $ liftIO $ + Compile.build + config numProcessors thisPackage - cachePath exposedModules moduleForGeneration dependencies buildSummary - maybe (return ()) (Generate.docs docs) (Arguments.docs args) + BM.phase "Generate Docs" $ + maybe (return ()) (Generate.docs docs) (BM._docs config) - Generate.generate - cachePath + BM.phase "Generate Code" $ + Generate.generate + config dependencies (projectNatives projectSummary) moduleForGeneration - (maybe "elm.js" id (Arguments.outputFile args)) - - -crawl - :: (MonadIO m, MonadError String m) - => Bool - -> [FilePath] - -> m (PackageID, Set.Set ModuleID, [ModuleID], ProjectSummary Location) -crawl autoYes filePaths = - do solution <- getSolution autoYes - - summaries <- - forM (Map.toList solution) $ \(name,version) -> do - let root = Path.package name version - desc <- Desc.read (root Path.description) - packageSummary <- CrawlPackage.dfsFromExposedModules root solution desc - return (CrawlProject.canonicalizePackageSummary (name,version) packageSummary) - - - desc <- Desc.read Path.description - - (moduleForGeneration, packageSummary) <- - case filePaths of - [] -> - do summary <- CrawlPackage.dfsFromExposedModules "." solution desc - return ([], summary) - - _ -> CrawlPackage.dfsFromFiles "." solution desc filePaths - - let thisPackage = - (Desc.name desc, Desc.version desc) - - let summary = - CrawlProject.canonicalizePackageSummary thisPackage packageSummary - - let localize moduleName = - ModuleID moduleName thisPackage - - return - ( thisPackage - , Set.fromList (map localize (Desc.exposed desc)) - , map localize moduleForGeneration - , List.foldl1 CrawlProject.union (summary : summaries) - ) - - -getSolution :: (MonadIO m, MonadError String m) => Bool -> m Solution.Solution -getSolution autoYes = - do exists <- liftIO (doesFileExist Path.solvedDependencies) - if exists - then Solution.read Path.solvedDependencies - else Initialize.solution autoYes diff --git a/src/Path.hs b/src/Path.hs index 4fb0c44..aff686f 100644 --- a/src/Path.hs +++ b/src/Path.hs @@ -7,25 +7,25 @@ import System.FilePath ((), (<.>)) import Elm.Compiler.Module as Module import Elm.Package.Name as Pkg import Elm.Package.Version as V -import TheMasterPlan (ModuleID(ModuleID), Location(Location)) +import qualified TheMasterPlan as TMP -toInterface :: FilePath -> ModuleID -> FilePath -toInterface root (ModuleID (Module.Name names) package) = +toInterface :: FilePath -> TMP.CanonicalModule -> FilePath +toInterface root (TMP.CanonicalModule package (Module.Name names)) = root inPackage package (List.intercalate "-" names <.> "elmi") -toObjectFile :: FilePath -> ModuleID -> FilePath -toObjectFile root (ModuleID (Module.Name names) package) = +toObjectFile :: FilePath -> TMP.CanonicalModule -> FilePath +toObjectFile root (TMP.CanonicalModule package (Module.Name names)) = root inPackage package (List.intercalate "-" names <.> "elmo") -toSource :: Location -> FilePath -toSource (Location relativePath _package) = +toSource :: TMP.Location -> FilePath +toSource (TMP.Location relativePath _package) = relativePath -inPackage :: (Pkg.Name, V.Version) -> FilePath -> FilePath +inPackage :: TMP.Package -> FilePath -> FilePath inPackage (name, version) relativePath = fromPackage name version relativePath diff --git a/src/Build.hs b/src/Pipeline/Compile.hs similarity index 74% rename from src/Build.hs rename to src/Pipeline/Compile.hs index 17917a0..7701586 100644 --- a/src/Build.hs +++ b/src/Pipeline/Compile.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -module Build where +module Pipeline.Compile where import Control.Concurrent (ThreadId, myThreadId, forkIO) import qualified Control.Concurrent.Chan as Chan @@ -7,19 +6,20 @@ import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set - import qualified Elm.Compiler as Compiler import qualified Elm.Compiler.Module as Module import qualified Elm.Docs as Docs import qualified Elm.Package.Name as Pkg + +import qualified BuildManager as BM import qualified Path import qualified Report import qualified Utils.File as File import qualified Utils.Queue as Queue import qualified TheMasterPlan as TMP import TheMasterPlan - ( ModuleID, Location, PackageID - , BuildSummary(BuildSummary), BuildData(..) + ( CanonicalModule, Location, Package + , BuildGraph(BuildGraph), BuildData(..) ) @@ -29,19 +29,19 @@ data Env = Env , resultChan :: Chan.Chan Result , reportChan :: Chan.Chan Report.Message , docsChan :: Chan.Chan [Docs.Documentation] - , reverseDependencies :: Map.Map ModuleID [ModuleID] + , reverseDependencies :: Map.Map CanonicalModule [CanonicalModule] , cachePath :: FilePath - , exposedModules :: Set.Set ModuleID - , modulesForGeneration :: Set.Set ModuleID + , exposedModules :: Set.Set CanonicalModule + , modulesForGeneration :: Set.Set CanonicalModule } data State = State { currentState :: CurrentState , activeThreads :: Set.Set ThreadId - , readyQueue :: Queue.Queue (ModuleID, Location) - , blockedModules :: Map.Map ModuleID BuildData - , completedInterfaces :: Map.Map ModuleID Module.Interface + , readyQueue :: Queue.Queue (CanonicalModule, Location) + , blockedModules :: Map.Map CanonicalModule BuildData + , completedInterfaces :: Map.Map CanonicalModule Module.Interface , documentation :: [Docs.Documentation] } @@ -54,12 +54,12 @@ data CurrentState = Wait | Update initEnv :: Int -> FilePath - -> Set.Set ModuleID - -> [ModuleID] - -> Map.Map ModuleID [ModuleID] - -> BuildSummary + -> Set.Set CanonicalModule + -> [CanonicalModule] + -> Map.Map CanonicalModule [CanonicalModule] + -> BuildGraph -> IO Env -initEnv numProcessors cachePath exposedModules modulesForGeneration dependencies (BuildSummary blocked _completed) = +initEnv numProcessors cachePath exposedModules modulesForGeneration dependencies (BuildGraph blocked _completed) = do resultChan <- Chan.newChan reportChan <- Chan.newChan docsChan <- Chan.newChan @@ -88,8 +88,8 @@ reverseGraph graph = Map.insertWith (++) dep [name] reversedGraph -initState :: BuildSummary -> State -initState (BuildSummary blocked completed) = +initState :: BuildGraph -> State +initState (BuildGraph blocked completed) = State { currentState = Update , activeThreads = Set.empty @@ -117,20 +117,18 @@ numIncompleteTasks state = -- PARALLEL BUILDS!!! build - :: Report.Type - -> Bool + :: BM.Config -> Int - -> PackageID - -> FilePath - -> Set.Set ModuleID - -> [ModuleID] - -> Map.Map ModuleID [ModuleID] - -> BuildSummary + -> Package + -> Set.Set CanonicalModule + -> [CanonicalModule] + -> Map.Map CanonicalModule [CanonicalModule] + -> BuildGraph -> IO [Docs.Documentation] -build reportType warn numProcessors rootPkg cachePath exposedModules modulesForGeneration dependencies summary = - do env <- initEnv numProcessors cachePath exposedModules modulesForGeneration dependencies summary +build config numProcessors rootPkg exposedModules modulesForGeneration dependencies summary = + do env <- initEnv numProcessors (BM._artifactDirectory config) exposedModules modulesForGeneration dependencies summary forkIO (buildManager env (initState summary)) - Report.thread reportType warn (reportChan env) rootPkg (numTasks env) + Report.thread (BM._reportType config) (BM._warn config) (reportChan env) rootPkg (numTasks env) Chan.readChan (docsChan env) @@ -142,25 +140,25 @@ buildManager env state = Chan.writeChan (docsChan env) (documentation state) Wait -> - do (Result source path moduleID threadId dealiaser warnings result) <- + do (Result source path modul threadId dealiaser warnings result) <- Chan.readChan (resultChan env) if null warnings then return () else Chan.writeChan (reportChan env) - (Report.Warn moduleID dealiaser path source warnings) + (Report.Warn modul dealiaser path source warnings) case result of Right (Compiler.Result maybeDocs interface js) -> do let cache = cachePath env - File.writeBinary (Path.toInterface cache moduleID) interface - writeFile (Path.toObjectFile cache moduleID) js - Chan.writeChan (reportChan env) (Report.Complete moduleID) - buildManager env (registerSuccess env state moduleID interface maybeDocs threadId) + File.writeBinary (Path.toInterface cache modul) interface + writeFile (Path.toObjectFile cache modul) js + Chan.writeChan (reportChan env) (Report.Complete modul) + buildManager env (registerSuccess env state modul interface maybeDocs threadId) Left errors -> - do Chan.writeChan (reportChan env) (Report.Error moduleID dealiaser path source errors) + do Chan.writeChan (reportChan env) (Report.Error modul dealiaser path source errors) buildManager env (registerFailure state threadId) Update -> @@ -193,7 +191,7 @@ registerFailure state threadId = registerSuccess :: Env -> State - -> ModuleID + -> CanonicalModule -> Module.Interface -> Maybe Docs.Documentation -> ThreadId @@ -202,7 +200,7 @@ registerSuccess env state name interface maybeDocs threadId = let (updatedBlockedModules, readyModules) = List.mapAccumR - (updateBlockedModules name interface) + (updateBlockedModules name) (blockedModules state) (Maybe.fromMaybe [] (Map.lookup name (reverseDependencies env))) @@ -223,18 +221,17 @@ registerSuccess env state name interface maybeDocs threadId = updateBlockedModules - :: ModuleID - -> Module.Interface - -> Map.Map ModuleID BuildData - -> ModuleID - -> (Map.Map ModuleID BuildData, Maybe (ModuleID, Location)) -updateBlockedModules name interface blockedModules potentiallyFreedModule = + :: CanonicalModule + -> Map.Map CanonicalModule BuildData + -> CanonicalModule + -> (Map.Map CanonicalModule BuildData, Maybe (CanonicalModule, Location)) +updateBlockedModules modul blockedModules potentiallyFreedModule = case Map.lookup potentiallyFreedModule blockedModules of Nothing -> (blockedModules, Nothing) Just (BuildData blocking location) -> - case filter (/= name) blocking of + case filter (/= modul) blocking of [] -> ( Map.delete potentiallyFreedModule blockedModules , Just (potentiallyFreedModule, location) @@ -253,16 +250,16 @@ updateBlockedModules name interface blockedModules potentiallyFreedModule = buildModule :: Env - -> Map.Map ModuleID Module.Interface - -> (ModuleID, Location) + -> Map.Map CanonicalModule Module.Interface + -> (CanonicalModule, Location) -> IO () -buildModule env interfaces (moduleID, location) = +buildModule env interfaces (modul, location) = let - (Pkg.Name user project) = fst (TMP.packageID moduleID) + (Pkg.Name user project) = fst (TMP.package modul) path = Path.toSource location - ifaces = Map.mapKeysMonotonic TMP.moduleName interfaces - isRoot = Set.member moduleID (modulesForGeneration env) - isExposed = Set.member moduleID (exposedModules env) + ifaces = Map.mapKeys TMP.name interfaces + isRoot = Set.member modul (modulesForGeneration env) + isExposed = Set.member modul (exposedModules env) in do source <- readFile path @@ -274,7 +271,7 @@ buildModule env interfaces (moduleID, location) = threadId <- myThreadId let result = - Result source path moduleID threadId dealiaser warnings rawResult + Result source path modul threadId dealiaser warnings rawResult Chan.writeChan (resultChan env) result @@ -282,7 +279,7 @@ buildModule env interfaces (moduleID, location) = data Result = Result { _source :: String , _path :: FilePath - , _moduleID :: ModuleID + , _moduleID :: CanonicalModule , _threadId :: ThreadId , _dealiaser :: Compiler.Dealiaser , _warnings :: [Compiler.Warning] diff --git a/src/Pipeline/Crawl.hs b/src/Pipeline/Crawl.hs new file mode 100644 index 0000000..7bf1aff --- /dev/null +++ b/src/Pipeline/Crawl.hs @@ -0,0 +1,119 @@ +{-# OPTIONS_GHC -Wall #-} +module Pipeline.Crawl where + +import Control.Monad (forM) +import Control.Monad.Except (liftIO, withExceptT) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Elm.Compiler.Module as Module +import qualified Elm.Package.Description as Desc +import qualified Elm.Package.Initialize as Initialize +import qualified Elm.Package.Name as Pkg +import qualified Elm.Package.Paths as Path +import qualified Elm.Package.Solution as Solution +import System.Directory (doesFileExist) +import System.FilePath (()) + +import qualified BuildManager as BM +import qualified Pipeline.Crawl.Package as CrawlPackage +import TheMasterPlan + ( CanonicalModule(CanonicalModule), Package, Location(Location) + , PackageGraph(..), PackageData(..) + , ProjectGraph(..), ProjectData(..) + ) + + +data ProjectInfo = ProjectInfo + { _package :: Package + , _exposedModules :: Set.Set CanonicalModule + , _allModules :: [CanonicalModule] + , _summary :: ProjectGraph Location + } + + +crawl :: BM.Config -> BM.Task ProjectInfo +crawl config = + do solution <- getSolution (BM._autoYes config) + + summaries <- + forM (Map.toList solution) $ \(name,version) -> + BM.phase (Pkg.toString name) $ do + let root = Path.package name version + desc <- withExceptT BM.PackageProblem (Desc.read (root Path.description)) + packageGraph <- CrawlPackage.dfsFromExposedModules root solution desc + return (canonicalizePackageGraph (name,version) packageGraph) + + + desc <- withExceptT BM.PackageProblem (Desc.read Path.description) + + (moduleForGeneration, packageGraph) <- + CrawlPackage.dfsFromFiles "." solution desc (BM._files config) + + let thisPackage = + (Desc.name desc, Desc.version desc) + + let summary = + canonicalizePackageGraph thisPackage packageGraph + + let localize moduleName = + CanonicalModule thisPackage moduleName + + return $ ProjectInfo + thisPackage + (Set.fromList (map localize (Desc.exposed desc))) + (map localize moduleForGeneration) + (List.foldl1 union (summary : summaries)) + + +getSolution :: Bool -> BM.Task Solution.Solution +getSolution autoYes = + do exists <- liftIO (doesFileExist Path.solvedDependencies) + withExceptT BM.PackageProblem $ + if exists then + Solution.read Path.solvedDependencies + else + Initialize.solution autoYes + + +canonicalizePackageGraph + :: Package + -> PackageGraph + -> ProjectGraph Location +canonicalizePackageGraph package (PackageGraph pkgData natives foreignDependencies) = + ProjectGraph + { projectData = + Map.map + (canonicalizePackageData package foreignDependencies) + (canonicalizeKeys pkgData) + , projectNatives = + Map.map (\path -> Location path package) (canonicalizeKeys natives) + } + where + canonicalizeKeys = + Map.mapKeys (CanonicalModule package) + + +canonicalizePackageData + :: Package + -> Map.Map Module.Name Package + -> PackageData + -> ProjectData Location +canonicalizePackageData package foreignDependencies (PackageData filePath deps) = + ProjectData { + projectLocation = Location filePath package, + projectDependencies = map canonicalizeModule deps + } + where + canonicalizeModule :: Module.Name -> CanonicalModule + canonicalizeModule moduleName = + case Map.lookup moduleName foreignDependencies of + Nothing -> + CanonicalModule package moduleName + Just foreignPackage -> + CanonicalModule foreignPackage moduleName + + +union :: ProjectGraph a -> ProjectGraph a -> ProjectGraph a +union (ProjectGraph d natives) (ProjectGraph d' natives') = + ProjectGraph (Map.union d d') (Map.union natives natives') \ No newline at end of file diff --git a/src/CrawlPackage.hs b/src/Pipeline/Crawl/Package.hs similarity index 56% rename from src/CrawlPackage.hs rename to src/Pipeline/Crawl/Package.hs index 426e863..1eaca10 100644 --- a/src/CrawlPackage.hs +++ b/src/Pipeline/Crawl/Package.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -module CrawlPackage where +{-# OPTIONS_GHC -Wall #-} +module Pipeline.Crawl.Package where import Control.Arrow (second) -import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError) +import Control.Monad.Except (liftIO, throwError, withExceptT) import qualified Data.Map as Map -import qualified Data.Maybe as Maybe -import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) -import System.FilePath ((), (<.>)) - import qualified Elm.Compiler as Compiler import qualified Elm.Compiler.Module as Module import qualified Elm.Package.Description as Desc @@ -15,25 +11,24 @@ import qualified Elm.Package.Name as Pkg import qualified Elm.Package.Paths as Path import qualified Elm.Package.Solution as Solution import qualified Elm.Package.Version as V +import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) +import System.FilePath ((), (<.>)) + +import qualified BuildManager as BM import qualified Utils.File as File import qualified TheMasterPlan as TMP -import TheMasterPlan ( PackageSummary(..), PackageData(..) ) +import TheMasterPlan ( PackageGraph(..), PackageData(..) ) -- STATE and ENVIRONMENT data Env = Env - { sourceDirs :: [FilePath] - , availableForeignModules :: Map.Map Module.Name [(Pkg.Name, V.Version)] + { _sourceDirs :: [FilePath] + , _availableForeignModules :: Map.Map Module.Name [(Pkg.Name, V.Version)] } -initEnv - :: (MonadIO m, MonadError String m) - => FilePath - -> Desc.Description - -> Solution.Solution - -> m Env +initEnv :: FilePath -> Desc.Description -> Solution.Solution -> BM.Task Env initEnv root desc solution = do availableForeignModules <- readAvailableForeignModules desc solution let sourceDirs = map (root ) (Desc.sourceDirs desc) @@ -43,12 +38,11 @@ initEnv root desc solution = -- GENERIC CRAWLER dfsFromFiles - :: (MonadIO m, MonadError String m) - => FilePath + :: FilePath -> Solution.Solution -> Desc.Description -> [FilePath] - -> m ([Module.Name], PackageSummary) + -> BM.Task ([Module.Name], PackageGraph) dfsFromFiles root solution desc filePaths = do env <- initEnv root desc solution @@ -58,38 +52,35 @@ dfsFromFiles root solution desc filePaths = let names = map fst info let unvisited = concatMap (snd . snd) info let pkgData = Map.fromList (map (second fst) info) - let initialSummary = PackageSummary pkgData Map.empty Map.empty + let initialGraph = PackageGraph pkgData Map.empty Map.empty summary <- - dfs (Desc.natives desc) pkgName unvisited env initialSummary + dfs (Desc.natives desc) pkgName unvisited env initialGraph return (names, summary) dfsFromExposedModules - :: (MonadIO m, MonadError String m) - => FilePath + :: FilePath -> Solution.Solution -> Desc.Description - -> m PackageSummary - + -> BM.Task PackageGraph dfsFromExposedModules root solution desc = do env <- initEnv root desc solution let unvisited = addParent Nothing (Desc.exposed desc) - let summary = PackageSummary Map.empty Map.empty Map.empty + let summary = PackageGraph Map.empty Map.empty Map.empty dfs (Desc.natives desc) (Desc.name desc) unvisited env summary -- DEPTH FIRST SEARCH -dfs :: (MonadIO m, MonadError String m) - => Bool +dfs :: Bool -> Pkg.Name -> [(Module.Name, Maybe Module.Name)] -> Env - -> PackageSummary - -> m PackageSummary + -> PackageGraph + -> BM.Task PackageGraph dfs _allowNatives _pkgName [] _env summary = return summary @@ -99,8 +90,8 @@ dfs allowNatives pkgName ((name,_) : unvisited) env summary dfs allowNatives pkgName unvisited env summary dfs allowNatives pkgName ((name,maybeParent) : unvisited) env summary = - do filePaths <- find allowNatives name (sourceDirs env) - case (filePaths, Map.lookup name (availableForeignModules env)) of + do filePaths <- find allowNatives name (_sourceDirs env) + case (filePaths, Map.lookup name (_availableForeignModules env)) of ([Elm filePath], Nothing) -> do (name, (pkgData, newUnvisited)) <- readPackageData pkgName (Just name) filePath @@ -121,29 +112,35 @@ dfs allowNatives pkgName ((name,maybeParent) : unvisited) env summary = } ([], Nothing) -> - throwError (errorNotFound name maybeParent) + throwError (BM.ModuleNotFound name maybeParent) (_, maybePkgs) -> - throwError (errorTooMany name maybeParent filePaths maybePkgs) + throwError $ + BM.ModuleDuplicates + name + maybeParent + (map toFilePath filePaths) + (maybe [] (map fst) maybePkgs) -- FIND LOCAL FILE PATH data CodePath = Elm FilePath | JS FilePath -find :: (MonadIO m) => Bool -> Module.Name -> [FilePath] -> m [CodePath] + +toFilePath :: CodePath -> FilePath +toFilePath codePath = + case codePath of + Elm file -> file + JS file -> file + + +find :: Bool -> Module.Name -> [FilePath] -> BM.Task [CodePath] find allowNatives moduleName sourceDirs = findHelp allowNatives [] moduleName sourceDirs -findHelp - :: (MonadIO m) - => Bool - -> [CodePath] - -> Module.Name - -> [FilePath] - -> m [CodePath] - +findHelp :: Bool -> [CodePath] -> Module.Name -> [FilePath] -> BM.Task [CodePath] findHelp _allowNatives locations _moduleName [] = return locations @@ -175,11 +172,10 @@ findHelp allowNatives locations moduleName (dir:srcDirs) = -- READ and VALIDATE PACKAGE DATA for a file readPackageData - :: (MonadIO m, MonadError String m) - => Pkg.Name + :: Pkg.Name -> Maybe Module.Name -> FilePath - -> m (Module.Name, (PackageData, [(Module.Name, Maybe Module.Name)])) + -> BM.Task (Module.Name, (PackageData, [(Module.Name, Maybe Module.Name)])) readPackageData pkgName maybeName filePath = do sourceCode <- liftIO (File.readStringUtf8 filePath) @@ -188,7 +184,7 @@ readPackageData pkgName maybeName filePath = Right result -> return result Left msgs -> - throwError (concatMap (format sourceCode) msgs) + throwError (BM.CompilerErrors filePath sourceCode msgs) checkName filePath name maybeName @@ -198,21 +194,16 @@ readPackageData pkgName maybeName filePath = else Module.defaultImports ++ rawDeps return (name, (PackageData filePath deps, addParent (Just name) deps)) - where - format src msg = - Compiler.errorToString Compiler.dummyDealiaser filePath src msg -checkName - :: (MonadError String m) - => FilePath -> Module.Name -> Maybe Module.Name -> m () +checkName :: FilePath -> Module.Name -> Maybe Module.Name -> BM.Task () checkName path nameFromSource maybeName = case maybeName of Nothing -> return () Just nameFromPath | nameFromSource == nameFromPath -> return () | otherwise -> - throwError (errorNameMismatch path nameFromPath nameFromSource) + throwError (BM.ModuleName path nameFromPath nameFromSource) addParent :: Maybe Module.Name -> [Module.Name] -> [(Module.Name, Maybe Module.Name)] @@ -223,10 +214,9 @@ addParent maybeParent names = -- FOREIGN MODULES -- which ones are available, who exposes them? readAvailableForeignModules - :: (MonadIO m, MonadError String m) - => Desc.Description + :: Desc.Description -> Solution.Solution - -> m (Map.Map Module.Name [(Pkg.Name, V.Version)]) + -> BM.Task (Map.Map Module.Name [(Pkg.Name, V.Version)]) readAvailableForeignModules desc solution = do visiblePackages <- allVisible desc solution rawLocations <- mapM exposedModules visiblePackages @@ -234,32 +224,27 @@ readAvailableForeignModules desc solution = allVisible - :: (MonadError String m) - => Desc.Description + :: Desc.Description -> Solution.Solution - -> m [(Pkg.Name, V.Version)] + -> BM.Task [(Pkg.Name, V.Version)] allVisible desc solution = mapM getVersion visible where visible = map fst (Desc.dependencies desc) getVersion name = case Map.lookup name solution of - Just version -> return (name, version) + Just version -> + return (name, version) Nothing -> - throwError $ - unlines - [ "your " ++ Path.description ++ " file says you depend on package " ++ Pkg.toString name ++ "," - , "but it looks like it is not properly installed. Try running 'elm-package install'." - ] + throwError (BM.MissingPackage name) exposedModules - :: (MonadIO m, MonadError String m) - => (Pkg.Name, V.Version) - -> m (Map.Map Module.Name [(Pkg.Name, V.Version)]) + :: (Pkg.Name, V.Version) + -> BM.Task (Map.Map Module.Name [(Pkg.Name, V.Version)]) exposedModules packageID@(pkgName, version) = within (Path.package pkgName version) $ do - description <- Desc.read Path.description + description <- withExceptT BM.PackageProblem (Desc.read Path.description) let exposed = Desc.exposed description return (foldr insert Map.empty exposed) where @@ -267,7 +252,7 @@ exposedModules packageID@(pkgName, version) = Map.insert moduleName [packageID] dict -within :: (MonadIO m) => FilePath -> m a -> m a +within :: FilePath -> BM.Task a -> BM.Task a within directory command = do root <- liftIO getCurrentDirectory liftIO (setCurrentDirectory directory) @@ -275,55 +260,3 @@ within directory command = liftIO (setCurrentDirectory root) return result - --- ERROR MESSAGES - -errorNotFound :: Module.Name -> Maybe Module.Name -> String -errorNotFound name maybeParent = - unlines - [ "Error when searching for modules" ++ context ++ ":" - , " Could not find module '" ++ Module.nameToString name ++ "'" - , "" - , "Potential problems could be:" - , " * Misspelled the module name" - , " * Need to add a source directory or new dependency to " ++ Path.description - ] - where - context = - case maybeParent of - Nothing -> " exposed by " ++ Path.description - Just parent -> " imported by module '" ++ Module.nameToString parent ++ "'" - - -errorTooMany :: Module.Name -> Maybe Module.Name -> [CodePath] -> Maybe [(Pkg.Name,V.Version)] -> String -errorTooMany name maybeParent filePaths maybePkgs = - "Error when searching for modules" ++ context ++ ".\n" ++ - "Found multiple modules named '" ++ Module.nameToString name ++ "'\n" ++ - "Modules with that name were found in the following locations:\n\n" ++ - concatMap (\str -> " " ++ str ++ "\n") (paths ++ packages) - where - context = - case maybeParent of - Nothing -> " exposed by " ++ Path.description - Just parent -> " imported by module '" ++ Module.nameToString parent ++ "'" - - packages = - map ("package " ++) (Maybe.maybe [] (map (Pkg.toString . fst)) maybePkgs) - - paths = - map ("directory " ++) (map extract filePaths) - - extract codePath = - case codePath of - Elm path -> path - JS path -> path - - -errorNameMismatch :: FilePath -> Module.Name -> Module.Name -> String -errorNameMismatch path nameFromPath nameFromSource = - unlines - [ "The module name is messed up for " ++ path - , " According to the file's name it should be " ++ Module.nameToString nameFromPath - , " According to the source code it should be " ++ Module.nameToString nameFromSource - , "Which is it?" - ] diff --git a/src/Generate.hs b/src/Pipeline/Generate.hs similarity index 65% rename from src/Generate.hs rename to src/Pipeline/Generate.hs index 8ecf6d2..06a6074 100644 --- a/src/Generate.hs +++ b/src/Pipeline/Generate.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Generate where +module Pipeline.Generate where -import Control.Monad.Except (MonadError, MonadIO, forM_, liftIO, throwError) +import Control.Monad.Except (forM_, liftIO) import qualified Data.Graph as Graph import qualified Data.Map as Map import qualified Data.Maybe as Maybe @@ -13,8 +12,11 @@ import qualified Data.Text.Lazy as LazyText import qualified Data.Text.Lazy.Encoding as LazyText import qualified Data.Text.Lazy.IO as LazyText import qualified Data.Tree as Tree +import Elm.Utils ((|>)) +import qualified Elm.Compiler.Module as Module +import qualified Elm.Docs as Docs import System.Directory ( createDirectoryIfMissing ) -import System.FilePath ( dropFileName, takeExtension ) +import System.FilePath ( dropFileName ) import System.IO ( IOMode(WriteMode) ) import qualified Text.Blaze as Blaze import Text.Blaze.Html5 ((!)) @@ -22,17 +24,15 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import qualified Text.Blaze.Renderer.Text as Blaze -import Elm.Utils ((|>)) -import qualified Elm.Compiler.Module as Module -import qualified Elm.Docs as Docs +import qualified BuildManager as BM import qualified Path -import TheMasterPlan ( ModuleID(ModuleID), Location ) +import TheMasterPlan ( CanonicalModule(CanonicalModule), Location ) import qualified Utils.File as File -- GENERATE DOCS -docs :: (MonadIO m) => [Docs.Documentation] -> FilePath -> m () +docs :: [Docs.Documentation] -> FilePath -> BM.Task () docs docsList path = Docs.prettyJson docsList |> LazyText.decodeUtf8 @@ -44,37 +44,32 @@ docs docsList path = -- GENERATE ELM STUFF generate - :: (MonadIO m, MonadError String m) - => FilePath - -> Map.Map ModuleID [ModuleID] - -> Map.Map ModuleID Location - -> [ModuleID] - -> FilePath - -> m () - -generate _cachePath _dependencies _natives [] _outputFile = + :: BM.Config + -> Map.Map CanonicalModule [CanonicalModule] + -> Map.Map CanonicalModule Location + -> [CanonicalModule] + -> BM.Task () + +generate _config _dependencies _natives [] = return () -generate cachePath dependencies natives moduleIDs outputFile = +generate config dependencies natives rootModules = do let objectFiles = - setupNodes cachePath dependencies natives - |> getReachableObjectFiles moduleIDs + setupNodes (BM._artifactDirectory config) dependencies natives + |> getReachableObjectFiles rootModules + let outputFile = BM.outputFilePath config liftIO (createDirectoryIfMissing True (dropFileName outputFile)) - case takeExtension outputFile of - ".html" -> - case moduleIDs of - [ModuleID moduleName _] -> - liftIO $ - do js <- mapM File.readTextUtf8 objectFiles - let outputText = html (Text.concat (header:js)) moduleName - LazyText.writeFile outputFile outputText - - _ -> - throwError (errorNotOneModule moduleIDs) + case BM._output config of + BM.Html outputFile -> + liftIO $ + do js <- mapM File.readTextUtf8 objectFiles + let (Just (CanonicalModule _ moduleName)) = Maybe.listToMaybe rootModules + let outputText = html (Text.concat (header:js)) moduleName + LazyText.writeFile outputFile outputText - _ -> + BM.JS outputFile -> liftIO $ File.withFileUtf8 outputFile WriteMode $ \handle -> do Text.hPutStrLn handle header @@ -89,20 +84,11 @@ header = "var Elm = Elm || { Native: {} };" -errorNotOneModule :: [ModuleID] -> String -errorNotOneModule names = - unlines - [ "You have specified an HTML output file, so elm-make is attempting to\n" - , "generate a fullscreen Elm program as HTML. To do this, elm-make must get\n" - , "exactly one input file, but you have given " ++ show (length names) ++ "." - ] - - setupNodes :: FilePath - -> Map.Map ModuleID [ModuleID] - -> Map.Map ModuleID Location - -> [(FilePath, ModuleID, [ModuleID])] + -> Map.Map CanonicalModule [CanonicalModule] + -> Map.Map CanonicalModule Location + -> [(FilePath, CanonicalModule, [CanonicalModule])] setupNodes cachePath dependencies natives = let nativeNodes = Map.toList natives @@ -116,8 +102,8 @@ setupNodes cachePath dependencies natives = getReachableObjectFiles - :: [ModuleID] - -> [(FilePath, ModuleID, [ModuleID])] + :: [CanonicalModule] + -> [(FilePath, CanonicalModule, [CanonicalModule])] -> [FilePath] getReachableObjectFiles moduleNames nodes = let (dependencyGraph, vertexToKey, keyToVertex) = diff --git a/src/LoadInterfaces.hs b/src/Pipeline/Plan.hs similarity index 54% rename from src/LoadInterfaces.hs rename to src/Pipeline/Plan.hs index 7b7ff03..fe1fc3e 100644 --- a/src/LoadInterfaces.hs +++ b/src/Pipeline/Plan.hs @@ -1,45 +1,40 @@ -{-# LANGUAGE FlexibleContexts #-} -module LoadInterfaces where +module Pipeline.Plan where -import Control.Monad.Except (MonadError, MonadIO, liftIO, throwError) -import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.Except (liftIO, throwError) import qualified Data.Graph as Graph import qualified Data.List as List import qualified Data.Set as Set import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Maybe as Maybe +import qualified Elm.Compiler.Module as Module import System.Directory (doesFileExist, getModificationTime) -import qualified Elm.Compiler.Module as Module +import qualified BuildManager as BM import qualified Path import qualified Utils.File as File import TheMasterPlan - ( ModuleID(ModuleID), Location(..) - , ProjectSummary(ProjectSummary), ProjectData(..) - , BuildSummary(..), BuildData(..) + ( CanonicalModule(CanonicalModule), Location(..) + , ProjectGraph(ProjectGraph), ProjectData(..) + , BuildGraph(..), BuildData(..) ) -prepForBuild - :: (MonadIO m, MonadError String m, MonadReader FilePath m) - => Set.Set ModuleID - -> ProjectSummary Location - -> m BuildSummary -prepForBuild modulesToDocument (ProjectSummary projectData _projectNatives) = - do enhancedData <- addInterfaces projectData +planBuild :: BM.Config -> Set.Set CanonicalModule -> ProjectGraph Location -> BM.Task BuildGraph +planBuild config modulesToDocument (ProjectGraph projectData _projectNatives) = + do enhancedData <- addInterfaces (BM._artifactDirectory config) projectData filteredData <- filterStaleInterfaces modulesToDocument enhancedData - return (toBuildSummary filteredData) + return (toBuildGraph filteredData) --- LOAD INTERFACES -- what has already been compiled? addInterfaces - :: (MonadIO m, MonadReader FilePath m, MonadError String m) - => Map.Map ModuleID (ProjectData Location) - -> m (Map.Map ModuleID (ProjectData (Location, Maybe Module.Interface))) -addInterfaces projectData = - do enhancedData <- mapM maybeLoadInterface (Map.toList projectData) + :: FilePath + -> Map.Map CanonicalModule (ProjectData Location) + -> BM.Task (Map.Map CanonicalModule (ProjectData (Location, Maybe Module.Interface))) +addInterfaces artifactRoot projectData = + do enhancedData <- mapM (maybeLoadInterface artifactRoot) (Map.toList projectData) return (Map.fromList enhancedData) @@ -49,12 +44,11 @@ addInterfaces projectData = -- Main. The real fix may be to add a hash of the source code to the interface -- files. maybeLoadInterface - :: (MonadIO m, MonadReader FilePath m, MonadError String m) - => (ModuleID, ProjectData Location) - -> m (ModuleID, ProjectData (Location, Maybe Module.Interface)) -maybeLoadInterface (moduleID, (ProjectData location deps)) = - do cacheRoot <- ask - let interfacePath = Path.toInterface cacheRoot moduleID + :: FilePath + -> (CanonicalModule, ProjectData Location) + -> BM.Task (CanonicalModule, ProjectData (Location, Maybe Module.Interface)) +maybeLoadInterface artifactRoot (moduleID, (ProjectData location deps)) = + do let interfacePath = Path.toInterface artifactRoot moduleID let sourcePath = Path.toSource location fresh <- liftIO (isFresh sourcePath interfacePath) @@ -79,8 +73,8 @@ isFresh sourcePath interfacePath = return (sourceTime <= interfaceTime) -isMain :: ModuleID -> Bool -isMain (ModuleID (Module.Name names) _) = +isMain :: CanonicalModule -> Bool +isMain (CanonicalModule _ (Module.Name names)) = case names of ["Main"] -> True _ -> False @@ -89,29 +83,28 @@ isMain (ModuleID (Module.Name names) _) = -- FILTER STALE INTERFACES -- have files become stale due to other changes? filterStaleInterfaces - :: (MonadError String m) - => Set.Set ModuleID - -> Map.Map ModuleID (ProjectData (Location, Maybe Module.Interface)) - -> m (Map.Map ModuleID (ProjectData (Either Location Module.Interface))) + :: Set.Set CanonicalModule + -> Map.Map CanonicalModule (ProjectData (Location, Maybe Module.Interface)) + -> BM.Task (Map.Map CanonicalModule (ProjectData (Either Location Module.Interface))) filterStaleInterfaces modulesToDocument summary = do sortedNames <- topologicalSort (Map.map projectDependencies summary) return (List.foldl' (filterIfStale summary modulesToDocument) Map.empty sortedNames) filterIfStale - :: Map.Map ModuleID (ProjectData (Location, Maybe Module.Interface)) - -> Set.Set ModuleID - -> Map.Map ModuleID (ProjectData (Either Location Module.Interface)) - -> ModuleID - -> Map.Map ModuleID (ProjectData (Either Location Module.Interface)) -filterIfStale enhancedSummary modulesToDocument filteredSummary moduleName = - Map.insert moduleName (ProjectData trueLocation deps) filteredSummary + :: Map.Map CanonicalModule (ProjectData (Location, Maybe Module.Interface)) + -> Set.Set CanonicalModule + -> Map.Map CanonicalModule (ProjectData (Either Location Module.Interface)) + -> CanonicalModule + -> Map.Map CanonicalModule (ProjectData (Either Location Module.Interface)) +filterIfStale enhancedGraph modulesToDocument filteredGraph moduleName = + Map.insert moduleName (ProjectData trueLocation deps) filteredGraph where (ProjectData (filePath, maybeInterface) deps) = - enhancedSummary ! moduleName + enhancedGraph ! moduleName depsAreDone = - all (haveInterface filteredSummary) deps + all (haveInterface filteredGraph) deps needsDocs = Set.member moduleName modulesToDocument @@ -126,25 +119,25 @@ filterIfStale enhancedSummary modulesToDocument filteredSummary moduleName = haveInterface - :: Map.Map ModuleID (ProjectData (Either Location Module.Interface)) - -> ModuleID + :: Map.Map CanonicalModule (ProjectData (Either Location Module.Interface)) + -> CanonicalModule -> Bool -haveInterface enhancedSummary rawName = +haveInterface enhancedGraph rawName = case filterNativeDeps rawName of Nothing -> True Just name -> - case Map.lookup name enhancedSummary of + case Map.lookup name enhancedGraph of Just (ProjectData (Right _) _) -> True _ -> False -- FILTER DEPENDENCIES -- which modules actually need to be compiled? -toBuildSummary - :: Map.Map ModuleID (ProjectData (Either Location Module.Interface)) - -> BuildSummary -toBuildSummary summary = - BuildSummary +toBuildGraph + :: Map.Map CanonicalModule (ProjectData (Either Location Module.Interface)) + -> BuildGraph +toBuildGraph summary = + BuildGraph { blockedModules = Map.map (toBuildData interfaces) locations , completedInterfaces = interfaces } @@ -161,7 +154,7 @@ toBuildSummary summary = Right interface toBuildData - :: Map.Map ModuleID Module.Interface + :: Map.Map CanonicalModule Module.Interface -> ProjectData Location -> BuildData toBuildData interfaces (ProjectData location dependencies) = @@ -170,25 +163,25 @@ toBuildData interfaces (ProjectData location dependencies) = blocking = Maybe.mapMaybe filterDeps dependencies - filterDeps :: ModuleID -> Maybe ModuleID + filterDeps :: CanonicalModule -> Maybe CanonicalModule filterDeps deps = filterCachedDeps interfaces =<< filterNativeDeps deps filterCachedDeps - :: Map.Map ModuleID Module.Interface - -> ModuleID - -> Maybe ModuleID + :: Map.Map CanonicalModule Module.Interface + -> CanonicalModule + -> Maybe CanonicalModule filterCachedDeps interfaces name = case Map.lookup name interfaces of Just _interface -> Nothing Nothing -> Just name -filterNativeDeps :: ModuleID -> Maybe ModuleID +filterNativeDeps :: CanonicalModule -> Maybe CanonicalModule filterNativeDeps name = case name of - ModuleID (Module.Name ("Native" : _)) _pkg -> + CanonicalModule _pkg (Module.Name ("Native" : _)) -> Nothing _ -> @@ -197,7 +190,7 @@ filterNativeDeps name = -- SORT GRAPHS / CHECK FOR CYCLES -topologicalSort :: (MonadError String m) => Map.Map ModuleID [ModuleID] -> m [ModuleID] +topologicalSort :: Map.Map CanonicalModule [CanonicalModule] -> BM.Task [CanonicalModule] topologicalSort dependencies = mapM errorOnCycle components where @@ -209,25 +202,8 @@ topologicalSort dependencies = errorOnCycle scc = case scc of - Graph.AcyclicSCC name -> return name - Graph.CyclicSCC cycle@(first:_) -> - throwError $ - "Your dependencies form a cycle:\n\n" - ++ showCycle first cycle - ++ "\nYou may need to move some values to a new module to get rid of the cycle." - + Graph.AcyclicSCC name -> + return name -showCycle :: ModuleID -> [ModuleID] -> String -showCycle first cycle = - case cycle of - [] -> "" - - [last] -> - " " ++ idToString last ++ " => " ++ idToString first ++ "\n" - - one:two:rest -> - " " ++ idToString one ++ " => " ++ idToString two ++ "\n" - ++ showCycle first (two:rest) - where - idToString (ModuleID moduleName _pkg) = - Module.nameToString moduleName + Graph.CyclicSCC cycle -> + throwError (BM.Cycle cycle) diff --git a/src/Pipeline/README.md b/src/Pipeline/README.md new file mode 100644 index 0000000..6003213 --- /dev/null +++ b/src/Pipeline/README.md @@ -0,0 +1,9 @@ + +The pipeline for building a project goes like this: + + * Crawl - start at the root file and figure out everything it depends on. + * Organize - organize all these dependencies, loading any relevant cached information + * Compile - run elm-compile on everything that needs it + * Generate - take all that info and smash it together into JS + +These steps are all managed in a BuildManager.Task which has a fixed set of BuildManager.Error reports. This means we can report errors in a structured way. \ No newline at end of file diff --git a/src/Report.hs b/src/Report.hs index eb48ff4..f01af6a 100644 --- a/src/Report.hs +++ b/src/Report.hs @@ -4,16 +4,16 @@ import qualified Control.Concurrent.Chan as Chan import Control.Monad (when) import qualified Data.Aeson as Json import qualified Data.ByteString.Lazy.Char8 as BS -import GHC.IO.Handle (hIsTerminalDevice) -import System.Exit (exitFailure) -import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) - import qualified Elm.Compiler as Compiler import qualified Elm.Package.Name as Pkg import qualified Elm.Package.Paths as Path import qualified Elm.Package.Version as V import Elm.Utils ((|>)) -import TheMasterPlan (ModuleID(ModuleID), PackageID) +import GHC.IO.Handle (hIsTerminalDevice) +import System.Exit (exitFailure) +import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) + +import TheMasterPlan (CanonicalModule(CanonicalModule), Package) data Type = Normal | Json @@ -21,14 +21,14 @@ data Type = Normal | Json data Message = Close - | Complete ModuleID - | Error ModuleID Compiler.Dealiaser FilePath String [Compiler.Error] - | Warn ModuleID Compiler.Dealiaser FilePath String [Compiler.Warning] + | Complete CanonicalModule + | Error CanonicalModule Compiler.Dealiaser FilePath String [Compiler.Error] + | Warn CanonicalModule Compiler.Dealiaser FilePath String [Compiler.Warning] -- REPORTING THREAD -thread :: Type -> Bool -> Chan.Chan Message -> PackageID -> Int -> IO () +thread :: Type -> Bool -> Chan.Chan Message -> Package -> Int -> IO () thread reportType warn messageChan rootPkg totalTasks = case reportType of Normal -> @@ -70,7 +70,7 @@ jsonLoop messageChan failures = -- NORMAL LOOP -normalLoop :: Bool -> Bool -> Chan.Chan Message -> PackageID -> Int -> Int -> Int -> IO () +normalLoop :: Bool -> Bool -> Chan.Chan Message -> Package -> Int -> Int -> Int -> IO () normalLoop isTerminal warn messageChan rootPkg total successes failures = let go = @@ -100,7 +100,7 @@ normalLoop isTerminal warn messageChan rootPkg total successes failures = do hPutStrLn stdout (closeMessage failures total) when (failures > 0) exitFailure - Error (ModuleID _ pkg) dealiaser path source errors -> + Error (CanonicalModule pkg _) dealiaser path source errors -> do hFlush stdout errors @@ -109,7 +109,7 @@ normalLoop isTerminal warn messageChan rootPkg total successes failures = go successes (failures + 1) - Warn (ModuleID _ pkg) dealiaser path source warnings -> + Warn (CanonicalModule pkg _) dealiaser path source warnings -> if not warn then go successes failures else @@ -124,9 +124,9 @@ normalLoop isTerminal warn messageChan rootPkg total successes failures = -- ERROR MESSAGE -errorMessage :: PackageID -> PackageID -> FilePath -> IO () -> IO () +errorMessage :: Package -> Package -> FilePath -> IO () -> IO () errorMessage rootPkg errorPkg path printMessage = - if errorPkg /= rootPkg + if False -- TODO -- errorPkg /= rootPkg then hPutStr stderr (dependencyError errorPkg) else @@ -134,7 +134,7 @@ errorMessage rootPkg errorPkg path printMessage = printMessage -dependencyError :: PackageID -> String +dependencyError :: Package -> String dependencyError (pkgName, version) = header "ERRORS" ("dependency " ++ Pkg.toString pkgName ++ " " ++ V.toString version) ++ "This error probably means that the '" ++ Pkg.toString pkgName ++ "' has some\n" @@ -147,7 +147,7 @@ dependencyError (pkgName, version) = -- WARNING MESSAGE -warningMessage :: PackageID -> PackageID -> FilePath -> IO () -> IO () +warningMessage :: Package -> Package -> FilePath -> IO () -> IO () warningMessage rootPkg warningPkg path printMessage = if warningPkg /= rootPkg then return () diff --git a/src/TheMasterPlan.hs b/src/TheMasterPlan.hs index 1895310..32d4fe8 100644 --- a/src/TheMasterPlan.hs +++ b/src/TheMasterPlan.hs @@ -14,13 +14,15 @@ import qualified Elm.Package.Version as V -- UNIQUE IDENTIFIERS FOR MODULES -data ModuleID = ModuleID - { moduleName :: Module.Name - , packageID :: PackageID +data CanonicalModule = CanonicalModule + { package :: Package + , name :: Module.Name } deriving (Eq, Ord) -type PackageID = (Pkg.Name, V.Version) + +type Package = (Pkg.Name, V.Version) + core :: Pkg.Name core = @@ -39,12 +41,13 @@ file or package description. any foreign modules that are needed locally and which package owns them -} -data PackageSummary = PackageSummary +data PackageGraph = PackageGraph { packageData :: Map.Map Module.Name PackageData , packageNatives :: Map.Map Module.Name FilePath - , packageForeignDependencies :: Map.Map Module.Name PackageID + , packageForeignDependencies :: Map.Map Module.Name Package } + data PackageData = PackageData { packagePath :: FilePath , packageDepenencies :: [Module.Name] @@ -53,38 +56,40 @@ data PackageData = PackageData -- COMBINE ALL PACKAGE SUMMARIES -{-| Very similar to a PackageSummary, but we now have made each module name +{-| Very similar to a PackageGraph, but we now have made each module name unique by adding which package it comes from. This makes it safe to merge a -bunch of PackageSummaries together, so we can write the rest of our code +bunch of PackageGraphs together, so we can write the rest of our code without thinking about package boundaries. -} -data ProjectSummary a = ProjectSummary - { projectData :: Map.Map ModuleID (ProjectData a) - , projectNatives :: Map.Map ModuleID Location +data ProjectGraph a = ProjectGraph + { projectData :: Map.Map CanonicalModule (ProjectData a) + , projectNatives :: Map.Map CanonicalModule Location } + data ProjectData a = ProjectData { projectLocation :: a - , projectDependencies :: [ModuleID] + , projectDependencies :: [CanonicalModule] } + data Location = Location - { relativePath :: FilePath - , package :: PackageID + { _relativePath :: FilePath + , _package :: Package } -- BUILD-FRIENDLY SUMMARY -{-| Combines the ProjectSummary with all cached build information. At this +{-| Combines the ProjectGraph with all cached build information. At this stage we crawl any cached interface files. File changes may have invalidated these cached interfaces, so we filter out any stale interfaces. The resulting format is very convenient for managing parallel builds. -} -data BuildSummary = BuildSummary - { blockedModules :: Map.Map ModuleID BuildData - , completedInterfaces :: Map.Map ModuleID Module.Interface +data BuildGraph = BuildGraph + { blockedModules :: Map.Map CanonicalModule BuildData + , completedInterfaces :: Map.Map CanonicalModule Module.Interface } @@ -98,7 +103,7 @@ produced. When 'blocking' is empty, it is safe to add this module to the build queue. -} data BuildData = BuildData - { blocking :: [ModuleID] + { blocking :: [CanonicalModule] , location :: Location } diff --git a/src/Utils/File.hs b/src/Utils/File.hs index bc341c5..3b41f16 100644 --- a/src/Utils/File.hs +++ b/src/Utils/File.hs @@ -1,17 +1,17 @@ -{-# LANGUAGE FlexibleContexts #-} module Utils.File where -import Control.Monad.Except (MonadError, throwError, MonadIO, liftIO) +import Control.Monad.Except (liftIO, throwError) import qualified Data.ByteString.Lazy as LBS import qualified Data.Binary as Binary +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (dropFileName) import System.IO (utf8, hSetEncoding, withBinaryFile, withFile, Handle, IOMode(ReadMode, WriteMode)) import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError) -import qualified Data.Text as Text -import qualified Data.Text.IO as TextIO +import qualified BuildManager as BM writeBinary :: (Binary.Binary a) => FilePath -> a -> IO () @@ -22,30 +22,19 @@ writeBinary path value = LBS.hPut handle (Binary.encode value) -readBinary :: (Binary.Binary a, MonadError String m, MonadIO m) => FilePath -> m a +readBinary :: (Binary.Binary a) => FilePath -> BM.Task a readBinary path = do exists <- liftIO (doesFileExist path) - if exists then decode else throwError (errorNotFound path) + if exists then decode else throwError (BM.CorruptedArtifact path) where decode = do bits <- liftIO (LBS.readFile path) case Binary.decodeOrFail bits of - Left _ -> throwError (errorCorrupted path) - Right (_, _, value) -> return value - - -errorCorrupted :: FilePath -> String -errorCorrupted filePath = - concat - [ "Error reading build artifact ", filePath, "\n" - , " The file was generated by a previous build and may be outdated or corrupt.\n" - , " Please remove the file and try again." - ] - + Left _ -> + throwError (BM.CorruptedArtifact path) -errorNotFound :: FilePath -> String -errorNotFound filePath = - "Unable to find file " ++ filePath ++ " for deserialization!" + Right (_, _, value) -> + return value {-|