elm-make (empty) → 0.1
raw patch · 16 files changed
+1750/−0 lines, 16 filesdep +ansi-wl-pprintdep +basedep +binarysetup-changed
Dependencies added: ansi-wl-pprint, base, binary, blaze-html, blaze-markup, bytestring, containers, directory, elm-compiler, elm-package, filepath, mtl, optparse-applicative, text
Files
- LICENSE +30/−0
- README.md +137/−0
- Setup.hs +2/−0
- elm-make.cabal +70/−0
- src/Arguments.hs +85/−0
- src/Build.hs +267/−0
- src/CrawlPackage.hs +318/−0
- src/CrawlProject.hs +53/−0
- src/Display.hs +96/−0
- src/Generate.hs +132/−0
- src/LoadInterfaces.hs +211/−0
- src/Main.hs +126/−0
- src/Path.hs +35/−0
- src/TheMasterPlan.hs +104/−0
- src/Utils/File.hs +43/−0
- src/Utils/Queue.hs +41/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elm-make.cabal view
@@ -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
+ src/Arguments.hs view
@@ -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."+ ]
+ src/Build.hs view
@@ -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."+ ]
+ src/CrawlPackage.hs view
@@ -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?"+ ]
+ src/CrawlProject.hs view
@@ -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')
+ src/Display.hs view
@@ -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"
+ src/Generate.hs view
@@ -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 ++ ")")
+ src/LoadInterfaces.hs view
@@ -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
+ src/Main.hs view
@@ -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+
+ src/Path.hs view
@@ -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
+ src/TheMasterPlan.hs view
@@ -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+ }+
+ src/Utils/File.hs view
@@ -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!"
+ src/Utils/Queue.hs view
@@ -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))