diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Evan Czaplicki + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Evan Czaplicki nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,137 @@ +# elm-make + +`elm-make` is a build tool for Elm. + + * **Compile down to JS or HTML** — turn Elm files into artifacts that + can be used with whatever backend you are already using. + + * **Build in parallel** — if you have four cores, `elm-make` will try to + compile four files at all times. + + * **Build dependencies** — `elm-make` is designed to work with + `elm-package` so if you use a bunch of 3rd party packages they will all + work just fine. + + * **Build what you need** — if a module is not needed for your project it + will not be built or appear in the resulting JS or HTML. + + +## Basic Usage + +Your Elm projects should all have a root directory, like `project/` that all +of your Elm related stuff is going to live in. Lets imagine having the +following directory structure. + +``` +project/ + Main.elm + SearchBox.elm + SearchResults.elm + Theme.elm +``` + +We have a couple Elm modules, maybe they depend on each other in some way. To +turn this into JavaScript, you can run the following command: + +```bash +elm-make Main.elm --output=main.html +``` + +Before creating an HTML file called `main.html`, this will prompt you to +install `elm-lang/core` which contains all of the core modules needed to make +Elm programs work. + +It will also create a file called `elm-package.json` which gives a structured +description of your project. `elm-make` uses this file to figure out what +directories it needs to look in and which packages are relevant. + + +## More Advanced Usage + +A lot of the more advanced stuff involves fiddling with `elm-package.json` to +make your directory structure nicer or to make sure you are working with the +right dependencies. + +### Directory Structure + +In the Basic Usage section above, we saw a pretty boring directory structure. +As we actually used it, it would probably expand to look like this: + +``` +project/ + elm-package.json + elm-stuff/... + LICENSE + Main.elm + README.md + SearchBox.elm + SearchResults.elm + Theme.elm +``` + +Pretty messy! There is a field in `elm-package.json` called `source-directories` +that allows you to list all the directories that contain Elm modules. By default +it only lists the root directory `.` but it is best to change that a bit. If you +are doing an Elm only project, this structure is pretty nice. + +``` +project/ + src/ + Main.elm + SearchBox.elm + SearchResults.elm + Theme.elm + elm-package.json + LICENSE + README.md +``` + +I would set `"source-directories": [ "src" ]` keeping the root of the project +as clean as possible. + +If you have a project that has both frontend and backend components, I have +been experimenting with this directory structure. + +``` +project/ + backend/... + frontend/ + Main.elm + SearchBox.elm + SearchResults.elm + Theme.elm + elm-package.json + LICENSE + README.md +``` + +In this world you set `"source-directories": [ "frontend" ]`. This pattern is +used for [the `package.elm-lang.org` project][src] and seems to work pretty +well. + +[src]: https://github.com/elm-lang/package.elm-lang.org/ + +### Managing Dependencies + +There are two general approaches to managing dependencies depending on what you +are trying to do. These rules may not apply in every case, but they are good +guidelines. + + 1. If you are creating a package for others to use, you want to keep your + dependency ranges as broad as possible. You also only want to extend + ranges as far as you have tested. When you say "my library works with + 4.0.0 of this package" before that version has been released or before + you have tested with it, you are likely to make life suck for your users. + Do not do that! + + 2. If you are creating an app or product, you want to keep your dependency + ranges very specific. When you build, a file is generated called + `elm-stuff/exact-dependencies.json` which lists all of the packages needed + for your project and the exact versions you happen to be using right now. + You may want to check this in to version control if you want the same + exact thing every time. + +If you are in camp #1 creating a package for others, we have plans to help +automate the process of expanding version bounds. If your project compiles +with the new stuff and your tests pass, it is conceivable that everything +just works. We will be experimenting with this! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elm-make.cabal b/elm-make.cabal new file mode 100644 --- /dev/null +++ b/elm-make.cabal @@ -0,0 +1,70 @@ +Name: elm-make +Version: 0.1 + +Synopsis: + A build tool for Elm projects +Description: + A nice way to build projects that is aware of both elm-compile and + elm-package, so it can make the build process very smooth. + +Homepage: + http://elm-lang.org + +License: BSD3 +License-file: LICENSE + +Author: Evan Czaplicki +Maintainer: info@elm-lang.org +Copyright: Copyright (c) 2014 Evan Czaplicki + +Category: Build Tool + +Build-type: Simple +Cabal-version: >=1.9 + +Extra-source-files: README.md + +source-repository head + type: git + location: git://github.com/elm-lang/elm-make.git + +Executable elm-make + + ghc-options: + -threaded -O2 -W + + hs-source-dirs: + src + + Main-is: + Main.hs + + other-modules: + Arguments, + Build, + CrawlPackage, + CrawlProject, + Display, + Generate, + LoadInterfaces, + Path, + Paths_elm_make, + TheMasterPlan, + Utils.File, + Utils.Queue + + Build-depends: + ansi-wl-pprint, + base >=4.2 && <5, + binary, + blaze-html, + blaze-markup, + bytestring, + containers >= 0.3, + directory, + elm-compiler >= 0.13, + elm-package, + filepath, + mtl, + optparse-applicative >=0.10 && <0.11, + text diff --git a/src/Arguments.hs b/src/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Arguments.hs @@ -0,0 +1,85 @@ +module Arguments where + +import Control.Applicative ((<$>), (<*>), many, optional) +import Data.Monoid ((<>), mconcat, mempty) +import Data.Version (showVersion) +import qualified Options.Applicative as Opt +import qualified Paths_elm_make as This +import qualified Text.PrettyPrint.ANSI.Leijen as PP + + +data Arguments = Arguments + { files :: [FilePath] + , outputFile :: Maybe FilePath + , autoYes :: Bool + } + + +parse :: IO Arguments +parse = + Opt.customExecParser preferences parser + where + preferences :: Opt.ParserPrefs + preferences = + Opt.prefs (mempty <> Opt.showHelpOnError) + + parser :: Opt.ParserInfo Arguments + parser = + Opt.info (Opt.helper <*> options) helpInfo + + +-- COMMANDS + +options :: Opt.Parser Arguments +options = + Arguments + <$> files + <*> optional outputFile + <*> yes + where + files = + many (Opt.strArgument ( Opt.metavar "FILES..." )) + + outputFile = + Opt.strOption $ + mconcat + [ Opt.long "output" + , Opt.metavar "FILE" + , Opt.help "Write output to FILE." + ] + + +-- HELP + +helpInfo :: Opt.InfoMod Arguments +helpInfo = + mconcat + [ Opt.fullDesc + , Opt.header top + , Opt.progDesc "build Elm projects" + , Opt.footerDoc (Just moreHelp) + ] + where + top = + "elm-make " ++ showVersion This.version + ++ ", (c) Evan Czaplicki 2014\n" + + moreHelp = + linesToDoc + [ "To learn more about a particular command run:" + , " elm-package COMMAND --help" + ] + + +linesToDoc :: [String] -> PP.Doc +linesToDoc lines = + PP.vcat (map PP.text lines) + + +yes :: Opt.Parser Bool +yes = + Opt.switch $ + mconcat + [ Opt.long "yes" + , Opt.help "Reply 'yes' to all automated prompts." + ] diff --git a/src/Build.hs b/src/Build.hs new file mode 100644 --- /dev/null +++ b/src/Build.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE FlexibleContexts #-} +module Build where + +import Control.Concurrent (ThreadId, myThreadId, forkIO, killThread) +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Exception as Exception +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 Display +import qualified Elm.Compiler as Compiler +import qualified Elm.Compiler.Module as Module +import qualified Elm.Package.Name as Pkg +import qualified Path +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(..) + ) + + +data Env = Env + { maxActiveThreads :: Int + , numTasks :: Int + , resultChan :: Chan.Chan Result + , displayChan :: Chan.Chan Display.Update + , reverseDependencies :: Map.Map ModuleID [ModuleID] + , cachePath :: FilePath + , publicModules :: Set.Set ModuleID + } + +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 + } + +data CurrentState = Wait | Update + +data Result + = Error ModuleID Location String + | Success ModuleID Module.Interface String ThreadId + + +-- HELPERS for ENV and STATE + +initEnv + :: Int + -> FilePath + -> [ModuleID] + -> Map.Map ModuleID [ModuleID] + -> BuildSummary + -> IO Env +initEnv numProcessors cachePath publicModules dependencies (BuildSummary blocked _completed) = + do resultChan <- Chan.newChan + displayChan <- Chan.newChan + return $ Env { + maxActiveThreads = numProcessors, + numTasks = Map.size blocked, + resultChan = resultChan, + displayChan = displayChan, + reverseDependencies = reverseGraph dependencies, + cachePath = cachePath, + publicModules = Set.fromList publicModules + } + + +-- reverse dependencies, "who depends on me?" +reverseGraph :: (Ord a) => Map.Map a [a] -> Map.Map a [a] +reverseGraph graph = + Map.foldrWithKey flipEdges Map.empty graph + where + flipEdges name dependencies reversedGraph = + foldr (insertDependency name) reversedGraph dependencies + + insertDependency name dep reversedGraph = + Map.insertWith (++) dep [name] reversedGraph + + +initState :: BuildSummary -> State +initState (BuildSummary blocked completed) = + State { + currentState = Update, + activeThreads = Set.empty, + readyQueue = Queue.fromList (Map.elems readyModules), + blockedModules = blockedModules, + completedInterfaces = completed + } + where + (readyModules, blockedModules) = + Map.mapEitherWithKey categorize blocked + + categorize name buildData@(BuildData blocking location) = + case blocking of + [] -> Left (name, location) + _ -> Right buildData + + +numIncompleteTasks :: State -> Int +numIncompleteTasks state = + Set.size (activeThreads state) + + Queue.size (readyQueue state) + + Map.size (blockedModules state) + + +-- PARALLEL BUILDS!!! + +build :: Int -> PackageID -> FilePath -> [ModuleID] -> Map.Map ModuleID [ModuleID] -> BuildSummary -> IO () +build numProcessors rootPkg cachePath publicModules dependencies summary = + do env <- initEnv numProcessors cachePath publicModules dependencies summary + forkIO (buildManager env (initState summary)) + Display.display (displayChan env) rootPkg 0 (numTasks env) + + +buildManager :: Env -> State -> IO () +buildManager env state = + case currentState state of + _ | numIncompleteTasks state == 0 -> + Chan.writeChan (displayChan env) Display.Success + + Wait -> + do result <- Chan.readChan (resultChan env) + case result of + Success moduleID interface js threadId -> + do let cache = cachePath env + File.writeBinary (Path.toInterface cache moduleID) interface + writeFile (Path.toObjectFile cache moduleID) js + Chan.writeChan (displayChan env) (Display.Completion moduleID) + buildManager env (registerSuccess env state moduleID interface threadId) + + Error moduleID location msg -> + do mapM killThread (Set.toList (activeThreads state)) + Chan.writeChan (displayChan env) (Display.Error moduleID location msg) + + Update -> + do let interfaces = completedInterfaces state + let compile = buildModule env interfaces + threadIds <- mapM (forkIO . compile) runNow + buildManager env $ + state + { currentState = Wait + , activeThreads = foldr Set.insert (activeThreads state) threadIds + , readyQueue = runLater + } + where + (runNow, runLater) = + Queue.dequeue + (maxActiveThreads env - Set.size (activeThreads state)) + (readyQueue state) + + progress = + fromIntegral (numIncompleteTasks state) / fromIntegral (numTasks env) + + +-- WAIT - REGISTER RESULTS + +registerSuccess :: Env -> State -> ModuleID -> Module.Interface -> ThreadId -> State +registerSuccess env state name interface threadId = + state + { currentState = + Update + , activeThreads = + Set.delete threadId (activeThreads state) + , blockedModules = + updatedBlockedModules + , readyQueue = + Queue.enqueue (Maybe.catMaybes readyModules) (readyQueue state) + , completedInterfaces = + Map.insert name interface (completedInterfaces state) + } + where + (updatedBlockedModules, readyModules) = + List.mapAccumR + (updateBlockedModules name interface) + (blockedModules state) + (Maybe.fromMaybe [] (Map.lookup name (reverseDependencies env))) + + +updateBlockedModules + :: ModuleID + -> Module.Interface + -> Map.Map ModuleID BuildData + -> ModuleID + -> (Map.Map ModuleID BuildData, Maybe (ModuleID, Location)) +updateBlockedModules name interface blockedModules potentiallyFreedModule = + case Map.lookup potentiallyFreedModule blockedModules of + Nothing -> + (blockedModules, Nothing) + + Just (BuildData blocking location) -> + case filter (/= name) blocking of + [] -> + ( Map.delete potentiallyFreedModule blockedModules + , Just (potentiallyFreedModule, location) + ) + + newBlocking -> + ( Map.insert + potentiallyFreedModule + (BuildData newBlocking location) + blockedModules + , Nothing + ) + + +-- UPDATE - BUILD SOME MODULES + +buildModule + :: Env + -> Map.Map ModuleID Module.Interface + -> (ModuleID, Location) + -> IO () +buildModule env interfaces (moduleID, location) = + Exception.catch compile recover + where + (Pkg.Name user project) = + fst (TMP.packageID moduleID) + + compile = + do source <- readFile (Path.toSource location) + let ifaces = Map.mapKeysMonotonic TMP.moduleName interfaces + let rawResult = Compiler.compile user project source ifaces + result <- + case rawResult of + Left errorMsg -> + return (Error moduleID location errorMsg) + + Right (interface, js) -> + case checkPorts env moduleID interface of + Just msg -> + return (Error moduleID location msg) + + Nothing -> + do threadId <- myThreadId + return (Success moduleID interface js threadId) + + Chan.writeChan (resultChan env) result + + recover :: Exception.SomeException -> IO () + recover msg = + Chan.writeChan (resultChan env) (Error moduleID location (show msg)) + + +checkPorts :: Env -> ModuleID -> Module.Interface -> Maybe String +checkPorts env moduleID interface = + case Set.member moduleID (publicModules env) of + True -> Nothing + False -> + case Module.interfacePorts interface of + [] -> Nothing + _ -> Just portError + + +portError :: String +portError = + concat + [ "Port Error: ports may only appear in the main module. We do not want ports\n" + , " appearing in library code where it adds a non-modular dependency. If I\n" + , " import it twice, what does that really mean? This restriction may be\n" + , " lifted later." + ] diff --git a/src/CrawlPackage.hs b/src/CrawlPackage.hs new file mode 100644 --- /dev/null +++ b/src/CrawlPackage.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE FlexibleContexts #-} +module CrawlPackage where + +import Control.Arrow (second) +import Control.Monad.Error (MonadError, MonadIO, liftIO, throwError) +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 +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 qualified TheMasterPlan as TMP +import TheMasterPlan ( PackageSummary(..), PackageData(..) ) + + +-- STATE and ENVIRONMENT + +data Env = Env + { 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 root desc solution = + do availableForeignModules <- readAvailableForeignModules desc solution + let sourceDirs = map (root ) (Desc.sourceDirs desc) + return (Env sourceDirs availableForeignModules) + + +-- GENERIC CRAWLER + +dfsFromFiles + :: (MonadIO m, MonadError String m) + => FilePath + -> Solution.Solution + -> Desc.Description + -> [FilePath] + -> m ([Module.Name], PackageSummary) + +dfsFromFiles root solution desc filePaths = + do env <- initEnv root desc solution + + let pkgName = Desc.name desc + info <- mapM (readPackageData pkgName Nothing) 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 + + summary <- + dfs (Desc.natives desc) pkgName unvisited env initialSummary + + return (names, summary) + + +dfsFromExposedModules + :: (MonadIO m, MonadError String m) + => FilePath + -> Solution.Solution + -> Desc.Description + -> m PackageSummary + +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 + dfs (Desc.natives desc) (Desc.name desc) unvisited env summary + + + +-- DEPTH FIRST SEARCH + +dfs :: (MonadIO m, MonadError String m) + => Bool + -> Pkg.Name + -> [(Module.Name, Maybe Module.Name)] + -> Env + -> PackageSummary + -> m PackageSummary + +dfs _allowNatives _pkgName [] _env summary = + return summary + +dfs allowNatives pkgName ((name,_) : unvisited) env summary + | Map.member name (packageData 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 + ([Elm filePath], Nothing) -> + do (name, (pkgData, newUnvisited)) <- + readPackageData pkgName (Just name) filePath + + dfs allowNatives pkgName (newUnvisited ++ unvisited) env $ summary { + packageData = Map.insert name pkgData (packageData summary) + } + + ([JS filePath], Nothing) -> + dfs allowNatives pkgName unvisited env $ summary { + packageNatives = Map.insert name filePath (packageNatives summary) + } + + ([], Just [pkg]) -> + dfs allowNatives pkgName unvisited env $ summary { + packageForeignDependencies = + Map.insert name pkg (packageForeignDependencies summary) + } + + ([], Nothing) -> + throwError (errorNotFound name maybeParent) + + (_, maybePkgs) -> + throwError (errorTooMany name maybeParent filePaths maybePkgs) + + +-- FIND LOCAL FILE PATH + +data CodePath = Elm FilePath | JS FilePath + +find :: (MonadIO m) => Bool -> Module.Name -> [FilePath] -> m [CodePath] +find allowNatives moduleName sourceDirs = + findHelp allowNatives [] moduleName sourceDirs + + +findHelp + :: (MonadIO m) + => Bool + -> [CodePath] + -> Module.Name + -> [FilePath] + -> m [CodePath] + +findHelp _allowNatives locations _moduleName [] = + return locations + +findHelp allowNatives locations moduleName (dir:srcDirs) = + do locations' <- addElmPath locations + updatedLocations <- + if allowNatives then addJsPath locations' else return locations' + findHelp allowNatives updatedLocations moduleName srcDirs + where + consIf bool x xs = + if bool then x:xs else xs + + addElmPath locs = + do let elmPath = dir Module.nameToPath moduleName <.> "elm" + elmExists <- liftIO (doesFileExist elmPath) + return (consIf elmExists (Elm elmPath) locs) + + addJsPath locs = + do let jsPath = dir Module.nameToPath moduleName <.> "js" + jsExists <- + case moduleName of + Module.Name ("Native" : _) -> liftIO (doesFileExist jsPath) + _ -> return False + + return (consIf jsExists (JS jsPath) locs) + + + +-- READ and VALIDATE PACKAGE DATA for a file + +readPackageData + :: (MonadIO m, MonadError String m) + => Pkg.Name + -> Maybe Module.Name + -> FilePath + -> m (Module.Name, (PackageData, [(Module.Name, Maybe Module.Name)])) +readPackageData pkgName maybeName filePath = + do source <- liftIO (readFile filePath) + (name, rawDeps) <- Compiler.parseDependencies source + checkName filePath name maybeName + + let deps = + if pkgName == TMP.core + then rawDeps + else Module.defaultImports ++ rawDeps + + return (name, (PackageData filePath deps, addParent (Just name) deps)) + + +checkName + :: (MonadError String m) + => FilePath -> Module.Name -> Maybe Module.Name -> m () +checkName path nameFromSource maybeName = + case maybeName of + Nothing -> return () + Just nameFromPath + | nameFromSource == nameFromPath -> return () + | otherwise -> + throwError (errorNameMismatch path nameFromPath nameFromSource) + + +addParent :: Maybe Module.Name -> [Module.Name] -> [(Module.Name, Maybe Module.Name)] +addParent maybeParent names = + map (\name -> (name, maybeParent)) names + + +-- FOREIGN MODULES -- which ones are available, who exposes them? + +readAvailableForeignModules + :: (MonadIO m, MonadError String m) + => Desc.Description + -> Solution.Solution + -> m (Map.Map Module.Name [(Pkg.Name, V.Version)]) +readAvailableForeignModules desc solution = + do visiblePackages <- allVisible desc solution + rawLocations <- mapM exposedModules visiblePackages + return (Map.unionsWith (++) rawLocations) + + +allVisible + :: (MonadError String m) + => Desc.Description + -> Solution.Solution + -> m [(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) + 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'." + ] + + +exposedModules + :: (MonadIO m, MonadError String m) + => (Pkg.Name, V.Version) + -> m (Map.Map Module.Name [(Pkg.Name, V.Version)]) +exposedModules packageID@(pkgName, version) = + within (Path.package pkgName version) $ do + description <- Desc.read Path.description + let exposed = Desc.exposed description + return (foldr insert Map.empty exposed) + where + insert moduleName dict = + Map.insert moduleName [packageID] dict + + +within :: (MonadIO m) => FilePath -> m a -> m a +within directory command = + do root <- liftIO getCurrentDirectory + liftIO (setCurrentDirectory directory) + result <- 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/CrawlProject.hs b/src/CrawlProject.hs new file mode 100644 --- /dev/null +++ b/src/CrawlProject.hs @@ -0,0 +1,53 @@ +{-# 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') diff --git a/src/Display.hs b/src/Display.hs new file mode 100644 --- /dev/null +++ b/src/Display.hs @@ -0,0 +1,96 @@ +module Display where + +import qualified Control.Concurrent.Chan as Chan +import Control.Monad (when) +import System.Exit (exitFailure) +import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) +import GHC.IO.Handle (hIsTerminalDevice) +import qualified Elm.Compiler.Module as Module +import qualified Elm.Package.Name as Pkg +import qualified Elm.Package.Paths as Path +import qualified Elm.Package.Version as V +import qualified Path +import TheMasterPlan (Location, ModuleID(ModuleID), PackageID) + + +data Update + = Completion ModuleID + | Success + | Error ModuleID Location String + + +display :: Chan.Chan Update -> PackageID -> Int -> Int -> IO () +display updatesChan rootPkg completeTasks totalTasks = + do isTerminal <- hIsTerminalDevice stdout + loop isTerminal updatesChan rootPkg completeTasks totalTasks + + +loop :: Bool -> Chan.Chan Update -> PackageID -> Int -> Int -> IO () +loop isTerminal updatesChan rootPkg completeTasks totalTasks = + do when isTerminal $ + do hPutStr stdout (renderProgressBar completeTasks totalTasks) + hFlush stdout + + update <- Chan.readChan updatesChan + + when isTerminal $ + hPutStr stdout clearProgressBar + + case update of + Completion _moduleID -> + loop isTerminal updatesChan rootPkg (completeTasks + 1) totalTasks + + Success -> + case completeTasks of + 0 -> return () + 1 -> putStrLn $ "Compiled 1 file" + _ -> putStrLn $ "Compiled " ++ show completeTasks ++ " files" + + Error (ModuleID name pkg) location msg -> + do putStrLn "" + hPutStrLn stderr (errorMessage rootPkg pkg name location msg) + exitFailure + + +-- ERROR MESSAGE + +errorMessage :: PackageID -> PackageID -> Module.Name -> Location -> String -> String +errorMessage rootPkg errorPkg@(pkgName, version) name location msg = + "Error" ++ context ++ ":\n\n" ++ msg ++ report + where + isLocalError = errorPkg == rootPkg + + context + | isLocalError = " in " ++ Path.toSource location + | otherwise = + " in package " ++ Pkg.toString pkgName ++ " " ++ V.toString version + ++ " in module " ++ Module.nameToString name + + report + | isLocalError = "" + | otherwise = + "\n\nThis error is probably due to bad version bounds. You should definitely\n" + ++ "inform the maintainer of " ++ Pkg.toString pkgName ++ " to get this fixed.\n\n" + ++ "In the meantime, you can attempt to get rid of the problematic dependency by\n" + ++ "modifying " ++ Path.solvedDependencies ++ ", though that is not a long term\n" + ++ "solution." + + +-- PROGRESS BAR + +barLength :: Float +barLength = 50.0 + + +renderProgressBar :: Int -> Int -> String +renderProgressBar complete total = + "[" ++ replicate numDone '=' ++ replicate numLeft ' ' ++ "] - " ++ show complete ++ " / " ++ show total + where + fraction = fromIntegral complete / fromIntegral total + numDone = truncate (fraction * barLength) + numLeft = truncate barLength - numDone + + +clearProgressBar :: String +clearProgressBar = + '\r' : replicate (length (renderProgressBar 99999 99999)) ' ' ++ "\r" diff --git a/src/Generate.hs b/src/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Generate.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Generate where + +import Control.Monad.Error (MonadError, MonadIO, forM_, liftIO, throwError) +import qualified Data.Graph as Graph +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.IO as Text +import qualified Data.Tree as Tree +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( dropFileName, takeExtension ) +import System.IO ( IOMode(WriteMode), withFile ) +import qualified Text.Blaze as Blaze +import Text.Blaze.Html5 ((!)) +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 Path +import TheMasterPlan ( ModuleID(ModuleID), Location ) + + +generate + :: (MonadIO m, MonadError String m) + => FilePath + -> Map.Map ModuleID [ModuleID] + -> Map.Map ModuleID Location + -> [ModuleID] + -> FilePath + -> m () + +generate _cachePath _dependencies _natives [] _outputFile = + return () + +generate cachePath dependencies natives moduleIDs outputFile = + do let objectFiles = + setupNodes cachePath dependencies natives + |> getReachableObjectFiles moduleIDs + + liftIO (createDirectoryIfMissing True (dropFileName outputFile)) + + case takeExtension outputFile of + ".html" -> + case moduleIDs of + [ModuleID moduleName _] -> + liftIO $ + do js <- mapM Text.readFile objectFiles + Text.writeFile outputFile (html (Text.concat (header:js)) moduleName) + + _ -> + throwError (errorNotOneModule moduleIDs) + + _ -> + liftIO $ + withFile outputFile WriteMode $ \handle -> + do Text.hPutStrLn handle header + forM_ objectFiles $ \jsFile -> + Text.hPutStrLn handle =<< Text.readFile jsFile + + liftIO (putStrLn ("Successfully generated " ++ outputFile)) + + +header :: Text.Text +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])] +setupNodes cachePath dependencies natives = + let nativeNodes = + Map.toList natives + |> map (\(name, loc) -> (Path.toSource loc, name, [])) + + dependencyNodes = + Map.toList dependencies + |> map (\(name, deps) -> (Path.toObjectFile cachePath name, name, deps)) + in + nativeNodes ++ dependencyNodes + + +getReachableObjectFiles + :: [ModuleID] + -> [(FilePath, ModuleID, [ModuleID])] + -> [FilePath] +getReachableObjectFiles moduleNames nodes = + let (dependencyGraph, vertexToKey, keyToVertex) = + Graph.graphFromEdges nodes + in + Maybe.mapMaybe keyToVertex moduleNames + |> Graph.dfs dependencyGraph + |> concatMap Tree.flatten + |> Set.fromList + |> Set.toList + |> map vertexToKey + |> map (\(path, _, _) -> path) + + +-- GENERATE HTML + +html :: Text.Text -> Module.Name -> Text.Text +html generatedJavaScript moduleName = + Blaze.renderMarkup $ + H.docTypeHtml $ do + H.head $ do + H.meta ! A.charset "UTF-8" + H.title (H.toHtml (Module.nameToString moduleName)) + H.style $ Blaze.preEscapedToMarkup + ("html,head,body { padding:0; margin:0; }\n\ + \body { font-family: calibri, helvetica, arial, sans-serif; }" :: Text.Text) + H.script ! A.type_ "text/javascript" $ + Blaze.preEscapedToMarkup generatedJavaScript + H.body $ do + H.script ! A.type_ "text/javascript" $ + Blaze.preEscapedToMarkup ("Elm.fullscreen(Elm." ++ Module.nameToString moduleName ++ ")") diff --git a/src/LoadInterfaces.hs b/src/LoadInterfaces.hs new file mode 100644 --- /dev/null +++ b/src/LoadInterfaces.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE FlexibleContexts #-} +module LoadInterfaces where + +import Control.Monad.Error (MonadError, MonadIO, liftIO, throwError) +import Control.Monad.Reader (MonadReader, ask) +import qualified Data.Graph as Graph +import qualified Data.List as List +import Data.Map ((!)) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import System.Directory (doesFileExist, getModificationTime) + +import qualified Elm.Compiler.Module as Module +import qualified Path +import qualified Utils.File as File +import TheMasterPlan + ( ModuleID(ModuleID), Location(..) + , ProjectSummary(ProjectSummary), ProjectData(..) + , BuildSummary(..), BuildData(..) + ) + + +prepForBuild + :: (MonadIO m, MonadError String m, MonadReader FilePath m) + => ProjectSummary Location + -> m BuildSummary +prepForBuild (ProjectSummary projectData _projectNatives) = + do enhancedData <- addInterfaces projectData + filteredData <- filterStaleInterfaces enhancedData + return (toBuildSummary 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) + return (Map.fromList enhancedData) + + +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 + let sourcePath = Path.toSource location + fresh <- liftIO (isFresh sourcePath interfacePath) + + maybeInterface <- + case fresh of + False -> return Nothing + True -> + do interface <- File.readBinary interfacePath + return (Just interface) + + return (moduleID, ProjectData (location, maybeInterface) deps) + + +isFresh :: FilePath -> FilePath -> IO Bool +isFresh sourcePath interfacePath = + do exists <- doesFileExist interfacePath + case exists of + False -> return False + True -> + do sourceTime <- getModificationTime sourcePath + interfaceTime <- getModificationTime interfacePath + return (sourceTime <= interfaceTime) + + +-- FILTER STALE INTERFACES -- have files become stale due to other changes? + +filterStaleInterfaces + :: (MonadError String m) + => Map.Map ModuleID (ProjectData (Location, Maybe Module.Interface)) + -> m (Map.Map ModuleID (ProjectData (Either Location Module.Interface))) +filterStaleInterfaces summary = + do sortedNames <- topologicalSort (Map.map projectDependencies summary) + return (List.foldl' (filterIfStale summary) Map.empty sortedNames) + + +filterIfStale + :: Map.Map ModuleID (ProjectData (Location, Maybe Module.Interface)) + -> Map.Map ModuleID (ProjectData (Either Location Module.Interface)) + -> ModuleID + -> Map.Map ModuleID (ProjectData (Either Location Module.Interface)) +filterIfStale enhancedSummary filteredSummary moduleName = + Map.insert moduleName (ProjectData trueLocation deps) filteredSummary + where + (ProjectData (filePath, maybeInterface) deps) = + enhancedSummary ! moduleName + + trueLocation = + case maybeInterface of + Just interface + | all (haveInterface enhancedSummary) deps -> + Right interface + + _ -> Left filePath + + +haveInterface + :: Map.Map ModuleID (ProjectData (Location, Maybe Module.Interface)) + -> ModuleID + -> Bool +haveInterface enhancedSummary rawName = + case filterNativeDeps rawName of + Nothing -> True + Just name -> + case Map.lookup name enhancedSummary of + Just (ProjectData (_, Just _) _) -> True + _ -> False + + +-- FILTER DEPENDENCIES -- which modules actually need to be compiled? + +toBuildSummary + :: Map.Map ModuleID (ProjectData (Either Location Module.Interface)) + -> BuildSummary +toBuildSummary summary = + BuildSummary + { blockedModules = Map.map (toBuildData interfaces) locations + , completedInterfaces = interfaces + } + where + (locations, interfaces) = + Map.mapEither divide summary + + divide (ProjectData either deps) = + case either of + Left location -> + Left (ProjectData location deps) + + Right interface -> + Right interface + +toBuildData + :: Map.Map ModuleID Module.Interface + -> ProjectData Location + -> BuildData +toBuildData interfaces (ProjectData location dependencies) = + BuildData blocking location + where + blocking = + Maybe.mapMaybe filterDeps dependencies + + filterDeps :: ModuleID -> Maybe ModuleID + filterDeps deps = + filterCachedDeps interfaces =<< filterNativeDeps deps + + +filterCachedDeps + :: Map.Map ModuleID Module.Interface + -> ModuleID + -> Maybe ModuleID +filterCachedDeps interfaces name = + case Map.lookup name interfaces of + Just _interface -> Nothing + Nothing -> Just name + + +filterNativeDeps :: ModuleID -> Maybe ModuleID +filterNativeDeps name = + case name of + ModuleID (Module.Name ("Native" : _)) _pkg -> + Nothing + + _ -> + Just name + + +-- SORT GRAPHS / CHECK FOR CYCLES + +topologicalSort :: (MonadError String m) => Map.Map ModuleID [ModuleID] -> m [ModuleID] +topologicalSort dependencies = + mapM errorOnCycle components + where + components = + Graph.stronglyConnComp (map toNode (Map.toList dependencies)) + + toNode (name, deps) = + (name, name, deps) + + errorOnCycle scc = + case scc of + Graph.AcyclicSCC name -> return name + Graph.CyclicSCC cycle@(first:_) -> + throwError $ + "Your dependencies for a cycle:\n\n" + ++ showCycle first cycle + ++ "\nYou may need to move some values to a new module to get rid of the cycle." + + +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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE FlexibleContexts #-} +module Main where + +import Control.Monad (forM) +import Control.Monad.Error (MonadError, runErrorT, MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, runReaderT, ask) +import qualified Data.List as List +import qualified Data.Map as Map +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(..) + ) + + +main :: IO () +main = + do args <- Arguments.parse + + result <- runErrorT (runReaderT (run args) artifactDirectory) + case result of + Right () -> + return () + + Left msg -> + do hPutStrLn stderr msg + exitFailure + + +artifactDirectory :: FilePath +artifactDirectory = + Path.stuffDirectory "build-artifacts" + + +run :: (MonadIO m, MonadError String m, MonadReader FilePath m) + => Arguments.Arguments + -> m () +run args = + do numProcessors <- liftIO getNumProcessors + liftIO (setNumCapabilities numProcessors) + + (thisPackage, publicModules, projectSummary) <- + crawl (Arguments.autoYes args) (Arguments.files args) + + let dependencies = Map.map projectDependencies (projectData projectSummary) + buildSummary <- LoadInterfaces.prepForBuild projectSummary + + cachePath <- ask + liftIO $ + Build.build + numProcessors + thisPackage + cachePath + publicModules + dependencies + buildSummary + + Generate.generate + cachePath + dependencies + (projectNatives projectSummary) + publicModules + (maybe "elm.js" id (Arguments.outputFile args)) + + +crawl + :: (MonadIO m, MonadError String m) + => Bool + -> [FilePath] + -> m (PackageID, [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 + + (moduleNames, 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 + + return + ( thisPackage + , map (\n -> ModuleID n thisPackage) moduleNames + , 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 new file mode 100644 --- /dev/null +++ b/src/Path.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} +module Path where + +import qualified Data.List as List +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)) + + +toInterface :: FilePath -> ModuleID -> FilePath +toInterface root (ModuleID (Module.Name names) package) = + root inPackage package (List.intercalate "-" names <.> "elmi") + + +toObjectFile :: FilePath -> ModuleID -> FilePath +toObjectFile root (ModuleID (Module.Name names) package) = + root inPackage package (List.intercalate "-" names <.> "elmo") + + +toSource :: Location -> FilePath +toSource (Location relativePath _package) = + relativePath + + +inPackage :: (Pkg.Name, V.Version) -> FilePath -> FilePath +inPackage (name, version) relativePath = + fromPackage name version relativePath + + +fromPackage :: Pkg.Name -> V.Version -> FilePath +fromPackage name version = + Pkg.toFilePath name V.toString version diff --git a/src/TheMasterPlan.hs b/src/TheMasterPlan.hs new file mode 100644 --- /dev/null +++ b/src/TheMasterPlan.hs @@ -0,0 +1,104 @@ +module TheMasterPlan where +{-| I'm trying something a little weird here. This file models each step in +the build process, so you will see a sequence of types representing "all the +data we have so far" formatted in a way that will be nice for the next stage. + +The idea is that our implementation should be guiding us between these models. +-} + +import qualified Data.Map as Map +import qualified Elm.Compiler.Module as Module +import qualified Elm.Package.Name as Pkg +import qualified Elm.Package.Version as V + + +-- UNIQUE IDENTIFIERS FOR MODULES + +data ModuleID = ModuleID + { moduleName :: Module.Name + , packageID :: PackageID + } + deriving (Eq, Ord) + +type PackageID = (Pkg.Name, V.Version) + +core :: Pkg.Name +core = + Pkg.Name "elm-lang" "core" + + +-- CRAWL AN INDIVIDUAL PACKGE + +{-| Basic information about all modules that are part of a certain package. +We obtain this information by doing a depth first search starting with a +file or package description. + + * packageData + file path to module and modules depended upon + * packageForeignDependencies + any foreign modules that are needed locally and which package owns them + +-} +data PackageSummary = PackageSummary + { packageData :: Map.Map Module.Name PackageData + , packageNatives :: Map.Map Module.Name FilePath + , packageForeignDependencies :: Map.Map Module.Name PackageID + } + +data PackageData = PackageData + { packagePath :: FilePath + , packageDepenencies :: [Module.Name] + } + + +-- COMBINE ALL PACKAGE SUMMARIES + +{-| Very similar to a PackageSummary, 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 +without thinking about package boundaries. +-} +data ProjectSummary a = ProjectSummary + { projectData :: Map.Map ModuleID (ProjectData a) + , projectNatives :: Map.Map ModuleID Location + } + +data ProjectData a = ProjectData + { projectLocation :: a + , projectDependencies :: [ModuleID] + } + +data Location = Location + { relativePath :: FilePath + , package :: PackageID + } + + +-- BUILD-FRIENDLY SUMMARY + +{-| Combines the ProjectSummary 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 + } + + +{-| Everything you need to know to build a file. + + * blocking - modules I depend upon that are not ready yet + * location - location of source code for when its time to compile + +We remove modules from 'blocking' as the build progresses and interfaces are +produced. When 'blocking' is empty, it is safe to add this module to the build +queue. +-} +data BuildData = BuildData + { blocking :: [ModuleID] + , location :: Location + } + diff --git a/src/Utils/File.hs b/src/Utils/File.hs new file mode 100644 --- /dev/null +++ b/src/Utils/File.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +module Utils.File where + +import Control.Monad.Error (MonadError, throwError, MonadIO, liftIO) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Binary as Binary +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (dropFileName) +import System.IO (withBinaryFile, IOMode(WriteMode)) + + +writeBinary :: (Binary.Binary a) => FilePath -> a -> IO () +writeBinary path value = + do let dir = dropFileName path + createDirectoryIfMissing True dir + withBinaryFile path WriteMode $ \handle -> + LBS.hPut handle (Binary.encode value) + + +readBinary :: (Binary.Binary a, MonadError String m, MonadIO m) => FilePath -> m a +readBinary path = + do exists <- liftIO (doesFileExist path) + if exists then decode else throwError (errorNotFound 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." + ] + + +errorNotFound :: FilePath -> String +errorNotFound filePath = + "Unable to find file " ++ filePath ++ " for deserialization!" diff --git a/src/Utils/Queue.hs b/src/Utils/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Utils/Queue.hs @@ -0,0 +1,41 @@ +module Utils.Queue where + + +newtype Queue a = + Queue ([a], [a]) + + +empty :: Queue a +empty = + Queue ([],[]) + + +fromList :: [a] -> Queue a +fromList list = + Queue (list, []) + + +size :: Queue a -> Int +size (Queue (front, back)) = + length front + length back + + +enqueue :: [a] -> Queue a -> Queue a +enqueue names (Queue (front, back)) = + Queue (front, names ++ back) + + +dequeue :: Int -> Queue a -> ([a], Queue a) +dequeue n queue = + dequeueHelp [] n queue + + +dequeueHelp :: [a] -> Int -> Queue a -> ([a], Queue a) +dequeueHelp results n queue@(Queue (front, back)) = + case n of + 0 -> (results, queue) + _ -> + case (front, back) of + ([], []) -> (results, queue) + ([], _) -> dequeueHelp results n (Queue (reverse back, [])) + (x:xs, _) -> dequeueHelp (x:results) (n-1) (Queue (xs, back))