Refactor paths using Context.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Fri, 19 Feb 2016 02:49:11 +0000 (02:49 +0000)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Fri, 19 Feb 2016 02:49:11 +0000 (02:49 +0000)
See #207.

32 files changed:
src/Builder.hs
src/Expression.hs
src/GHC.hs
src/Oracles/ModuleFiles.hs
src/Rules.hs
src/Rules/Clean.hs
src/Rules/Compile.hs
src/Rules/Data.hs
src/Rules/Dependencies.hs
src/Rules/Documentation.hs
src/Rules/Generate.hs
src/Rules/Gmp.hs
src/Rules/Libffi.hs
src/Rules/Library.hs
src/Rules/Program.hs
src/Rules/Register.hs
src/Settings.hs
src/Settings/Builders/Common.hs
src/Settings/Builders/Ghc.hs
src/Settings/Builders/GhcCabal.hs
src/Settings/Builders/GhcPkg.hs
src/Settings/Builders/Haddock.hs
src/Settings/Builders/HsCpp.hs
src/Settings/Builders/Hsc2Hs.hs
src/Settings/Packages/Compiler.hs
src/Settings/Packages/Ghc.hs
src/Settings/Packages/GhcCabal.hs
src/Settings/Packages/Hp2ps.hs
src/Settings/Packages/Rts.hs
src/Settings/Packages/Touchy.hs
src/Settings/Packages/Unlit.hs
src/Settings/Paths.hs

index d97c0ad..75d3d4e 100644 (file)
@@ -6,12 +6,12 @@ module Builder (
 import Control.Monad.Trans.Reader
 
 import Base
+import Context
 import GHC
 import GHC.Generics (Generic)
 import Oracles.Config
 import Oracles.LookupInPath
 import Oracles.WindowsPath
-import Package
 import Stage
 
 -- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
@@ -54,22 +54,25 @@ data Builder = Alex
              deriving (Show, Eq, Generic)
 
 -- | Some builders are built by this very build system, in which case
--- 'builderProvenance' returns the corresponding 'Stage' and GHC 'Package'.
-builderProvenance :: Builder -> Maybe (Stage, Package)
+-- 'builderProvenance' returns the corresponding build 'Context' (which includes
+-- 'Stage' and GHC 'Package').
+builderProvenance :: Builder -> Maybe Context
 builderProvenance = \case
-    DeriveConstants  -> Just (Stage0, deriveConstants)
-    GenApply         -> Just (Stage0, genapply)
-    GenPrimopCode    -> Just (Stage0, genprimopcode)
-    Ghc stage        -> if stage == Stage0 then Nothing else Just (pred stage, ghc)
+    DeriveConstants  -> context Stage0 deriveConstants
+    GenApply         -> context Stage0 genapply
+    GenPrimopCode    -> context Stage0 genprimopcode
+    Ghc stage        -> if stage == Stage0 then Nothing else context (pred stage) ghc
     GhcM stage       -> builderProvenance $ Ghc stage
-    GhcCabal         -> Just (Stage0, ghcCabal)
+    GhcCabal         -> context Stage0 ghcCabal
     GhcCabalHsColour -> builderProvenance $ GhcCabal
-    GhcPkg stage     -> if stage > Stage0 then Just (Stage0, ghcPkg) else Nothing
-    Haddock          -> Just (Stage2, haddock)
-    Hpc              -> Just (Stage1, hpcBin)
-    Hsc2Hs           -> Just (Stage0, hsc2hs)
-    Unlit            -> Just (Stage0, unlit)
+    GhcPkg stage     -> if stage > Stage0 then context Stage0 ghcPkg else Nothing
+    Haddock          -> context Stage2 haddock
+    Hpc              -> context Stage1 hpcBin
+    Hsc2Hs           -> context Stage0 hsc2hs
+    Unlit            -> context Stage0 unlit
     _                -> Nothing
+  where
+    context s p = Just $ vanillaContext s p
 
 isInternal :: Builder -> Bool
 isInternal = isJust . builderProvenance
@@ -87,7 +90,7 @@ isStaged = \case
 -- | Determine the location of a 'Builder'
 builderPath :: Builder -> Action FilePath
 builderPath builder = case builderProvenance builder of
-    Just (stage, pkg) -> return . fromJust $ programPath stage pkg
+    Just context -> return . fromJust $ programPath context
     Nothing -> do
         let builderKey = case builder of
                 Alex          -> "alex"
index b83d8a2..8797502 100644 (file)
@@ -15,7 +15,7 @@ module Expression (
     Context, vanillaContext, stageContext, Target, dummyTarget,
 
     -- * Convenient accessors
-    getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
+    getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
     getInput, getOutput,
 
     -- * Re-exports
@@ -163,22 +163,26 @@ fromDiffExpr = fmap (($ mempty) . fromDiff)
 interpretDiff :: Monoid a => Target -> DiffExpr a -> Action a
 interpretDiff target = interpret target . fromDiffExpr
 
--- | Convenient getters for target parameters.
+-- | Get the current build 'Context'.
+getContext :: Expr Context
+getContext = asks context
+
+-- | Get the 'Stage' of the current 'Context'.
 getStage :: Expr Stage
 getStage = stage <$> asks context
 
--- | Get the 'Package' of the current 'Target'.
+-- | Get the 'Package' of the current 'Context'.
 getPackage :: Expr Package
 getPackage = package <$> asks context
 
+-- | Get the 'Way' of the current 'Context'.
+getWay :: Expr Way
+getWay = way <$> asks context
+
 -- | Get the 'Builder' for the current 'Target'.
 getBuilder :: Expr Builder
 getBuilder = asks builder
 
--- | Get the 'Way' of the current 'Target'.
-getWay :: Expr Way
-getWay = way <$> asks context
-
 -- | Get the input files of the current 'Target'.
 getInputs :: Expr [FilePath]
 getInputs = asks inputs
index d29cbbf..d4cf1f8 100644 (file)
@@ -8,10 +8,11 @@ module GHC (
     primitive, process, rts, runGhc, stm, templateHaskell, terminfo, time,
     touchy, transformers, unlit, unix, win32, xhtml,
 
-    defaultKnownPackages, programPath, targetDirectory
+    defaultKnownPackages, programPath, contextDirectory, rtsContext
     ) where
 
 import Base
+import Context
 import Package
 import Stage
 
@@ -103,26 +104,29 @@ ghcSplit = "inplace/lib/bin/ghc-split"
 -- TODO: move to buildRootPath, see #113
 -- TODO: simplify, add programInplaceLibPath
 -- | The relative path to the program executable
-programPath :: Stage -> Package -> Maybe FilePath
-programPath stage pkg
-    | pkg == ghc = Just . inplaceProgram $ "ghc-stage" ++ show (fromEnum stage + 1)
-    | pkg `elem` [ghcTags, haddock, mkUserGuidePart] = case stage of
-        Stage2 -> Just . inplaceProgram $ pkgNameString pkg
+programPath :: Context -> Maybe FilePath
+programPath context @ (Context {..})
+    | package == ghc = Just . inplaceProgram $ "ghc-stage" ++ show (fromEnum stage + 1)
+    | package `elem` [ghcTags, haddock, mkUserGuidePart] = case stage of
+        Stage2 -> Just . inplaceProgram $ pkgNameString package
         _      -> Nothing
-    | pkg `elem` [touchy, unlit] = case stage of
-        Stage0 -> Just $ "inplace/lib/bin" -/- pkgNameString pkg <.> exe
+    | package `elem` [touchy, unlit] = case stage of
+        Stage0 -> Just $ "inplace/lib/bin" -/- pkgNameString package <.> exe
         _      -> Nothing
-    | pkg == hpcBin = case stage of
+    | package == hpcBin = case stage of
         Stage1 -> Just $ inplaceProgram "hpc"
         _      -> Nothing
-    | isProgram pkg = case stage of
-        Stage0 -> Just . inplaceProgram $ pkgNameString pkg
-        _      -> Just . installProgram $ pkgNameString pkg
+    | isProgram package = case stage of
+        Stage0 -> Just . inplaceProgram $ pkgNameString package
+        _      -> Just . installProgram $ pkgNameString package
     | otherwise = Nothing
   where
     inplaceProgram name = programInplacePath -/- name <.> exe
-    installProgram name = pkgPath pkg -/- targetDirectory stage pkg
-                                      -/- "build/tmp" -/- name <.> exe
+    installProgram name = pkgPath package -/- contextDirectory context
+                                          -/- "build/tmp" -/- name <.> exe
+
+rtsContext :: Context
+rtsContext = vanillaContext Stage1 rts
 
 -- | GHC build results will be placed into target directories with the
 -- following typical structure:
@@ -130,6 +134,6 @@ programPath stage pkg
 -- * @build/@ contains compiled object code
 -- * @doc/@ is produced by haddock
 -- * @package-data.mk@ contains output of ghc-cabal applied to pkgCabal
-targetDirectory :: Stage -> Package -> FilePath
-targetDirectory stage _ = stageString stage
+contextDirectory :: Context -> FilePath
+contextDirectory (Context {..}) = stageString stage
 
index b831f76..67d68f3 100644 (file)
@@ -2,31 +2,31 @@
 module Oracles.ModuleFiles (moduleFiles, haskellModuleFiles, moduleFilesOracle) where
 
 import Base
+import Context
 import Oracles.PackageData
 import Package
-import Stage
 import Settings.Paths
 
 newtype ModuleFilesKey = ModuleFilesKey ([String], [FilePath])
     deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
-moduleFiles :: Stage -> Package -> Action [FilePath]
-moduleFiles stage pkg = do
-    let path = targetPath stage pkg
+moduleFiles :: Context -> Action [FilePath]
+moduleFiles context @ (Context {..}) = do
+    let path = contextPath context
     srcDirs <- fmap sort . pkgDataList $ SrcDirs path
     modules <- fmap sort . pkgDataList $ Modules path
-    let dirs = [ pkgPath pkg -/- dir | dir <- srcDirs ]
+    let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
     found :: [(String, FilePath)] <- askOracle $ ModuleFilesKey (modules, dirs)
     return $ map snd found
 
-haskellModuleFiles :: Stage -> Package -> Action ([FilePath], [String])
-haskellModuleFiles stage pkg = do
-    let path        = targetPath stage pkg
+haskellModuleFiles :: Context -> Action ([FilePath], [String])
+haskellModuleFiles context @ (Context {..}) = do
+    let path        = contextPath context
         autogen     = path -/- "build/autogen"
-        dropPkgPath = drop $ length (pkgPath pkg) + 1
+        dropPkgPath = drop $ length (pkgPath package) + 1
     srcDirs <- fmap sort . pkgDataList $ SrcDirs path
     modules <- fmap sort . pkgDataList $ Modules path
-    let dirs = [ pkgPath pkg -/- dir | dir <- srcDirs ]
+    let dirs = [ pkgPath package -/- dir | dir <- srcDirs ]
     foundSrcDirs <- askOracle $ ModuleFilesKey (modules, dirs     )
     foundAutogen <- askOracle $ ModuleFilesKey (modules, [autogen])
 
index 0136c27..0d8fde0 100644 (file)
@@ -3,7 +3,7 @@ module Rules (topLevelTargets, buildRules) where
 import Data.Foldable
 
 import Base
-import Context hiding (stage, package, way)
+import Context
 import Expression
 import GHC
 import Rules.Compile
@@ -33,8 +33,8 @@ topLevelTargets = do
     -- TODO: do we want libffiLibrary to be a top-level target?
 
     action $ do -- TODO: Add support for all rtsWays
-        rtsLib    <- pkgLibraryFile Stage1 rts vanilla
-        rtsThrLib <- pkgLibraryFile Stage1 rts threaded
+        rtsLib    <- pkgLibraryFile $ rtsContext { way = vanilla  }
+        rtsThrLib <- pkgLibraryFile $ rtsContext { way = threaded }
         need [ rtsLib, rtsThrLib ]
 
     for_ allStages $ \stage ->
@@ -45,11 +45,11 @@ topLevelTargets = do
                 if isLibrary pkg
                 then do -- build a library
                     ways <- interpretInContext context getLibraryWays
-                    libs <- traverse (pkgLibraryFile stage pkg) ways
+                    libs <- traverse (pkgLibraryFile . Context stage pkg) ways
                     docs <- interpretInContext context buildHaddock
-                    need $ libs ++ [ pkgHaddockFile pkg | docs && stage == Stage1 ]
+                    need $ libs ++ [ pkgHaddockFile context | docs && stage == Stage1 ]
                 else do -- otherwise build a program
-                    need [ fromJust $ programPath stage pkg ] -- TODO: drop fromJust
+                    need [ fromJust $ programPath context ] -- TODO: drop fromJust
 
 packageRules :: Rules ()
 packageRules = do
index eb7f8de..ea1cc37 100644 (file)
@@ -1,6 +1,7 @@
 module Rules.Clean (cleanRules) where
 
 import Base
+import Context
 import Package
 import Rules.Generate
 import Settings.Packages
@@ -25,7 +26,7 @@ cleanRules = do
         putBuild $ "| Remove files generated by ghc-cabal..."
         forM_ knownPackages $ \pkg ->
             forM_ [Stage0 ..] $ \stage -> do
-                let dir = pkgPath pkg -/- targetDirectory stage pkg
+                let dir = pkgPath pkg -/- contextDirectory (vanillaContext stage pkg)
                 removeDirectoryIfExists dir
         putBuild $ "| Remove the Shake database " ++ shakeFilesPath ++ "..."
         removeFilesAfter shakeFilesPath ["//*"]
index c9a1bba..539dfb9 100644 (file)
@@ -10,7 +10,7 @@ import Target
 
 compilePackage :: [(Resource, Int)] -> Context -> Rules ()
 compilePackage rs context @ (Context {..}) = do
-    let buildPath = targetPath stage package -/- "build"
+    let buildPath = contextPath context -/- "build"
 
     buildPath <//> "*" <.> hisuf way %> \hi ->
         if compileInterfaceFilesSeparately
index 0e27699..db7f92c 100644 (file)
@@ -20,8 +20,8 @@ buildPackageData :: Context -> Rules ()
 buildPackageData context @ (Context {..}) = do
     let cabalFile = pkgCabalFile package
         configure = pkgPath package -/- "configure"
-        dataFile  = pkgDataFile stage package
-        oldPath   = pkgPath package -/- targetDirectory stage package -- TODO: remove, #113
+        dataFile  = pkgDataFile context
+        oldPath   = pkgPath package -/- contextDirectory context -- TODO: remove, #113
 
     [dataFile, oldPath -/- "package-data.mk"] &%> \_ -> do
         -- The first thing we do with any package is make sure all generated
@@ -35,7 +35,7 @@ buildPackageData context @ (Context {..}) = do
         deps <- packageDeps package
         pkgs <- interpretInContext context getPackages
         let depPkgs = matchPackageNames (sort pkgs) deps
-        need =<< traverse (pkgConfFile stage) depPkgs
+        need =<< traverse (pkgConfFile . vanillaContext stage) depPkgs
 
         -- TODO: get rid of this, see #113
         let inTreeMk = oldPath -/- takeFileName dataFile
@@ -46,19 +46,19 @@ buildPackageData context @ (Context {..}) = do
         -- TODO: get rid of this, see #113
         liftIO $ IO.copyFile inTreeMk dataFile
         autogenFiles <- getDirectoryFiles oldPath ["build/autogen/*"]
-        createDirectory $ targetPath stage package -/- "build/autogen"
+        createDirectory $ contextPath context -/- "build/autogen"
         forM_ autogenFiles $ \file -> do
-            copyFile (oldPath -/- file) (targetPath stage package -/- file)
+            copyFile (oldPath -/- file) (contextPath context -/- file)
         let haddockPrologue = "haddock-prologue.txt"
-        copyFile (oldPath -/- haddockPrologue) (targetPath stage package -/- haddockPrologue)
+        copyFile (oldPath -/- haddockPrologue) (contextPath context -/- haddockPrologue)
 
-        postProcessPackageData stage package dataFile
+        postProcessPackageData context dataFile
 
     -- TODO: PROGNAME was $(CrossCompilePrefix)hp2ps
     priority 2.0 $ do
         when (package == hp2ps) $ dataFile %> \mk -> do
             includes <- interpretInContext context $ fromDiffExpr includesArgs
-            let prefix = fixKey (targetPath stage package) ++ "_"
+            let prefix = fixKey (contextPath context) ++ "_"
                 cSrcs  = [ "AreaBelow.c", "Curves.c", "Error.c", "Main.c"
                          , "Reorder.c", "TopTwenty.c", "AuxFile.c"
                          , "Deviation.c", "HpFile.c", "Marks.c", "Scale.c"
@@ -73,7 +73,7 @@ buildPackageData context @ (Context {..}) = do
             putSuccess $ "| Successfully generated '" ++ mk ++ "'."
 
         when (package == unlit) $ dataFile %> \mk -> do
-            let prefix   = fixKey (targetPath stage package) ++ "_"
+            let prefix   = fixKey (contextPath context) ++ "_"
                 contents = unlines $ map (prefix++)
                     [ "PROGNAME = unlit"
                     , "C_SRCS = unlit.c"
@@ -82,7 +82,7 @@ buildPackageData context @ (Context {..}) = do
             putSuccess $ "| Successfully generated '" ++ mk ++ "'."
 
         when (package == touchy) $ dataFile %> \mk -> do
-            let prefix   = fixKey (targetPath stage package) ++ "_"
+            let prefix   = fixKey (contextPath context) ++ "_"
                 contents = unlines $ map (prefix++)
                     [ "PROGNAME = touchy"
                     , "C_SRCS = touchy.c" ]
@@ -93,7 +93,7 @@ buildPackageData context @ (Context {..}) = do
         -- package, we cannot generate the corresponding `package-data.mk` file
         -- by running by running `ghcCabal`, because it has not yet been built.
         when (package == ghcCabal && stage == Stage0) $ dataFile %> \mk -> do
-            let prefix   = fixKey (targetPath stage package) ++ "_"
+            let prefix   = fixKey (contextPath context) ++ "_"
                 contents = unlines $ map (prefix++)
                     [ "PROGNAME = ghc-cabal"
                     , "MODULES = Main"
@@ -106,7 +106,7 @@ buildPackageData context @ (Context {..}) = do
             dataFile %> \mk -> do
                 orderOnly $ generatedDependencies stage package
                 windows <- windowsHost
-                let prefix = fixKey (targetPath stage package) ++ "_"
+                let prefix = fixKey (contextPath context) ++ "_"
                     dirs   = [ ".", "hooks", "sm", "eventlog" ]
                           ++ [ "posix" | not windows ]
                           ++ [ "win32" |     windows ]
@@ -137,8 +137,8 @@ buildPackageData context @ (Context {..}) = do
 -- For example libraries/deepseq/dist-install_VERSION = 1.4.0.0
 -- is replaced by libraries_deepseq_dist-install_VERSION = 1.4.0.0
 -- Reason: Shake's built-in makefile parser doesn't recognise slashes
-postProcessPackageData :: Stage -> Package -> FilePath -> Action ()
-postProcessPackageData stage package file = fixFile file fixPackageData
+postProcessPackageData :: Context -> FilePath -> Action ()
+postProcessPackageData context @ (Context {..}) file = fixFile file fixPackageData
   where
     fixPackageData = unlines . map processLine . filter (not . null) . filter ('$' `notElem`) . lines
     processLine line = fixKey fixedPrefix ++ suffix
@@ -147,7 +147,7 @@ postProcessPackageData stage package file = fixFile file fixPackageData
         -- Change package/path/targetDir to takeDirectory file
         -- This is a temporary hack until we get rid of ghc-cabal
         fixedPrefix = takeDirectory file ++ drop len prefix
-        len         = length (pkgPath package -/- targetDirectory stage package)
+        len         = length (pkgPath package -/- contextDirectory context)
 
 -- TODO: remove, see #113
 fixKey :: String -> String
index f2a2141..dcfb47d 100644 (file)
@@ -13,7 +13,7 @@ import Target
 -- TODO: simplify handling of AutoApply.cmm
 buildPackageDependencies :: [(Resource, Int)] -> Context -> Rules ()
 buildPackageDependencies rs context @ (Context {..}) =
-    let path      = targetPath stage package
+    let path      = contextPath context
         buildPath = path -/- "build"
         dropBuild = (pkgPath package ++) . drop (length buildPath)
         hDepFile  = buildPath -/- ".hs-dependencies"
index 7e98e27..d3a16ae 100644 (file)
@@ -18,12 +18,12 @@ haddockHtmlLib = "inplace/lib/html/haddock-util.js"
 buildPackageDocumentation :: Context -> Rules ()
 buildPackageDocumentation context @ (Context {..}) =
     let cabalFile   = pkgCabalFile package
-        haddockFile = pkgHaddockFile package
+        haddockFile = pkgHaddockFile context
     in when (stage == Stage1) $ do
         haddockFile %> \file -> do
             srcs <- interpretInContext context getPackageSources
             deps <- map PackageName <$> interpretInContext context (getPkgDataList DepNames)
-            let haddocks = [ pkgHaddockFile depPkg
+            let haddocks = [ pkgHaddockFile $ vanillaContext Stage1 depPkg
                            | Just depPkg <- map findKnownPackage deps
                            , depPkg /= rts ]
             need $ srcs ++ haddocks ++ [haddockHtmlLib]
@@ -31,7 +31,7 @@ buildPackageDocumentation context @ (Context {..}) =
             -- HsColour sources
             -- TODO: what is the output of GhcCabalHsColour?
             whenM (specified HsColour) $ do
-                pkgConf <- pkgConfFile stage package
+                pkgConf <- pkgConfFile context
                 need [ cabalFile, pkgConf ] -- TODO: check if need pkgConf
                 build $ Target context GhcCabalHsColour [cabalFile] []
 
index 050f83c..878db95 100644 (file)
@@ -34,10 +34,12 @@ primopsSource :: FilePath
 primopsSource = "compiler/prelude/primops.txt.pp"
 
 primopsTxt :: Stage -> FilePath
-primopsTxt stage = targetPath stage compiler -/- "build/primops.txt"
+primopsTxt stage =
+    contextPath (vanillaContext stage compiler) -/- "build/primops.txt"
 
 platformH :: Stage -> FilePath
-platformH stage = targetPath stage compiler -/- "ghc_boot_platform.h"
+platformH stage =
+    contextPath (vanillaContext stage compiler) -/- "ghc_boot_platform.h"
 
 -- TODO: move generated files to buildRootPath, see #113
 includesDependencies :: [FilePath]
@@ -47,7 +49,8 @@ includesDependencies = ("includes" -/-) <$>
     , "ghcversion.h" ]
 
 ghcPrimDependencies :: Stage -> [FilePath]
-ghcPrimDependencies stage = ((targetPath stage ghcPrim -/- "build") -/-) <$>
+ghcPrimDependencies stage =
+    ((contextPath (vanillaContext stage ghcPrim) -/- "build") -/-) <$>
        [ "autogen/GHC/Prim.hs"
        , "GHC/PrimopWrappers.hs" ]
 
@@ -68,7 +71,7 @@ compilerDependencies stage =
     ++ [ gmpLibraryH | stage > Stage0 ]
     ++ filter (const $ stage > Stage0) libffiDependencies
     ++ derivedConstantsDependencies
-    ++ fmap ((targetPath stage compiler -/- "build") -/-)
+    ++ fmap ((contextPath (vanillaContext stage compiler) -/- "build") -/-)
        [ "primop-can-fail.hs-incl"
        , "primop-code-size.hs-incl"
        , "primop-commutable.hs-incl"
@@ -115,7 +118,7 @@ generate file context expr = do
 
 generatePackageCode :: Context -> Rules ()
 generatePackageCode context @ (Context stage pkg _) =
-    let buildPath   = targetPath stage pkg -/- "build"
+    let buildPath   = contextPath context -/- "build"
         dropBuild   = drop (length buildPath + 1)
         generated f = (buildPath ++ "//*.hs") ?== f && not ("//autogen/*" ?== f)
         file <~ gen = generate file context gen
@@ -123,7 +126,7 @@ generatePackageCode context @ (Context stage pkg _) =
         generated ?> \file -> do
             let srcFile = dropBuild file
                 pattern = "//" ++ srcFile -<.> "*"
-            files <- fmap (filter (pattern ?==)) $ moduleFiles stage pkg
+            files <- fmap (filter (pattern ?==)) $ moduleFiles context
             let gens = [ (f, b) | f <- files, Just b <- [determineBuilder f] ]
             when (length gens /= 1) . putError $
                 "Exactly one generator expected for " ++ file
@@ -148,7 +151,7 @@ generatePackageCode context @ (Context stage pkg _) =
                 need [primopsTxt stage]
                 build $ Target context GenPrimopCode [primopsTxt stage] [file]
                 -- TODO: this is temporary hack, get rid of this (#113)
-                let oldPath = pkgPath pkg -/- targetDirectory stage pkg -/- "build"
+                let oldPath = pkgPath pkg -/- contextDirectory context -/- "build"
                     newFile = oldPath ++ (drop (length buildPath) file)
                 createDirectory $ takeDirectory newFile
                 liftIO $ IO.copyFile file newFile
@@ -159,8 +162,8 @@ generatePackageCode context @ (Context stage pkg _) =
 
         priority 2.0 $ do
             -- TODO: this is temporary hack, get rid of this (#113)
-            let oldPath = pkgPath pkg -/- targetDirectory stage pkg
-                olden f = oldPath ++ (drop (length (targetPath stage pkg)) f)
+            let oldPath = pkgPath pkg -/- contextDirectory context
+                olden f = oldPath ++ (drop (length (contextPath context)) f)
 
             when (pkg == compiler) $ buildPath -/- "Config.hs" %> \file -> do
                 file <~ generateConfigHs
@@ -200,7 +203,7 @@ generateRules = do
     -- TODO: simplify, get rid of fake rts context
     derivedConstantsPath ++ "//*" %> \file -> do
         withTempDir $ \dir -> build $
-            Target (vanillaContext Stage1 rts) DeriveConstants [] [file, dir]
+            Target rtsContext DeriveConstants [] [file, dir]
 
   where
     file <~ gen = file %> \out -> generate out emptyTarget gen
index 15be9f2..ec91e72 100644 (file)
@@ -122,4 +122,4 @@ gmpRules = do
 
     -- This causes integerGmp package to be configured, hence creating the files
     [gmpBase -/- "config.mk", gmpBuildInfoPath] &%> \_ ->
-        need [pkgDataFile Stage1 integerGmp]
+        need [pkgDataFile gmpContext]
index a6d6348..fc66155 100644 (file)
@@ -15,7 +15,7 @@ import Target
 
 -- TODO: this should be moved elsewhere
 rtsBuildPath :: FilePath
-rtsBuildPath = targetPath Stage1 rts -/- "build"
+rtsBuildPath = contextPath rtsContext -/- "build"
 
 -- TODO: Why copy these include files into rts? Keep in libffi!
 libffiDependencies :: [FilePath]
index 980139f..1d26efd 100644 (file)
@@ -17,7 +17,7 @@ import Target
 
 buildPackageLibrary :: Context -> Rules ()
 buildPackageLibrary context @ (Context {..}) = do
-    let buildPath = targetPath stage package -/- "build"
+    let buildPath = contextPath context -/- "build"
         libPrefix = buildPath -/- "libHS" ++ pkgNameString package
 
     -- TODO: handle dynamic libraries
@@ -61,7 +61,7 @@ buildPackageLibrary context @ (Context {..}) = do
 
 buildPackageGhciLibrary :: Context -> Rules ()
 buildPackageGhciLibrary context @ (Context {..}) = priority 2 $ do
-    let buildPath = targetPath stage package -/- "build"
+    let buildPath = contextPath context -/- "build"
         libPrefix = buildPath -/- "HS" ++ pkgNameString package
 
     -- TODO: simplify handling of AutoApply.cmm
index af6023d..87f9319 100644 (file)
@@ -32,10 +32,10 @@ wrappers = [ (vanillaContext Stage0 ghc   , ghcWrapper   )
 
 buildProgram :: [(Resource, Int)] -> Context -> Rules ()
 buildProgram rs context @ (Context {..}) = do
-    let match file = case programPath stage package of
+    let match file = case programPath context of
             Nothing      -> False
             Just program -> program == file
-        matchWrapped file = case programPath stage package of
+        matchWrapped file = case programPath context of
             Nothing      -> False
             Just program -> case computeWrappedPath program of
                 Nothing             -> False
@@ -71,7 +71,7 @@ buildWrapper context @ (Context stage package _) wrapper wrapperPath binPath = d
 -- TODO: Do we need to consider other ways when building programs?
 buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildBinary rs context @ (Context stage package _) bin = do
-    let buildPath = targetPath stage package -/- "build"
+    let buildPath = contextPath context -/- "build"
     cSrcs <- cSources context -- TODO: remove code duplication (Library.hs)
     hSrcs <- hSources context
     let cObjs = [ buildPath -/- src -<.> osuf vanilla | src <- cSrcs   ]
@@ -89,11 +89,11 @@ buildBinary rs context @ (Context stage package _) bin = do
         let depContext = vanillaContext libStage dep
         ghciFlag <- interpretInContext depContext $ getPkgData BuildGhciLib
         libFiles <- fmap concat . forM ways $ \way -> do
-            libFile  <- pkgLibraryFile  libStage dep way
-            lib0File <- pkgLibraryFile0 libStage dep way
+            libFile  <- pkgLibraryFile  $ Context libStage dep way
+            lib0File <- pkgLibraryFile0 $ Context libStage dep way
             dll0     <- needDll0 libStage dep
             return $ libFile : [ lib0File | dll0 ]
-        ghciLib <- pkgGhciLibraryFile libStage dep
+        ghciLib <- pkgGhciLibraryFile $ vanillaContext libStage dep
         return $ libFiles ++ [ ghciLib | ghciFlag == "YES" && stage == Stage1 ]
     let binDeps = if package == ghcCabal && stage == Stage0
                   then [ pkgPath package -/- src <.> "hs" | src <- hSrcs ]
index bddce8a..e002426 100644 (file)
@@ -13,19 +13,19 @@ import Target
 -- Build package-data.mk by using GhcCabal to process pkgCabal file
 registerPackage :: [(Resource, Int)] -> Context -> Rules ()
 registerPackage rs context @ (Context {..}) = do
-    let oldPath = pkgPath package -/- targetDirectory stage package -- TODO: remove, #113
+    let oldPath = pkgPath package -/- contextDirectory context -- TODO: remove, #113
         pkgConf = packageDbDirectory stage -/- pkgNameString package
 
     when (stage <= Stage1) $ matchVersionedFilePath pkgConf "conf" ?> \conf -> do
         -- This produces inplace-pkg-config. TODO: Add explicit tracking
-        need [pkgDataFile stage package]
+        need [pkgDataFile context]
 
         -- Post-process inplace-pkg-config. TODO: remove, see #113, #148
         let pkgConfig  = oldPath -/- "inplace-pkg-config"
             fixPkgConf = unlines
-                       . map (replace oldPath (targetPath stage package)
+                       . map (replace oldPath (contextPath context)
                        . replace (replaceSeparators '\\' $ oldPath)
-                                 (targetPath stage package) )
+                                 (contextPath context) )
                        . lines
 
         fixFile pkgConfig fixPkgConf
@@ -40,7 +40,7 @@ registerPackage rs context @ (Context {..}) = do
                 Target context (GhcPkg stage) [rtsConf] [conf]
 
         rtsConf %> \_ -> do
-            need [ pkgDataFile Stage1 rts, rtsConfIn ]
+            need [ pkgDataFile rtsContext, rtsConfIn ]
             build $ Target context HsCpp [rtsConfIn] [rtsConf]
 
             let fixRtsConf = unlines
index 449b440..e134fbc 100644 (file)
@@ -4,7 +4,7 @@ module Settings (
     module Settings.User,
     module Settings.Ways,
     getPkgData, getPkgDataList, getTopDirectory, isLibrary,
-    getPackagePath, getTargetDirectory, getTargetPath, getPackageSources
+    getPackagePath, getContextDirectory, getContextPath, getPackageSources
     ) where
 
 import Base
@@ -20,17 +20,17 @@ import Settings.Ways
 getPackagePath :: Expr FilePath
 getPackagePath = pkgPath <$> getPackage
 
-getTargetDirectory :: Expr FilePath
-getTargetDirectory = targetDirectory <$> getStage <*> getPackage
+getContextDirectory :: Expr FilePath
+getContextDirectory = contextDirectory <$> getContext
 
-getTargetPath :: Expr FilePath
-getTargetPath = targetPath <$> getStage <*> getPackage
+getContextPath :: Expr FilePath
+getContextPath = contextPath <$> getContext
 
 getPkgData :: (FilePath -> PackageData) -> Expr String
-getPkgData key = lift . pkgData . key =<< getTargetPath
+getPkgData key = lift . pkgData . key =<< getContextPath
 
 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
-getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
+getPkgDataList key = lift . pkgDataList . key =<< getContextPath
 
 getTopDirectory :: Expr FilePath
 getTopDirectory = lift topDirectory
@@ -38,12 +38,10 @@ getTopDirectory = lift topDirectory
 -- | Find all Haskell source files for the current target
 getPackageSources :: Expr [FilePath]
 getPackageSources = do
-    stage <- getStage
-    pkg   <- getPackage
-    path  <- getTargetPath
-    let buildPath = path -/- "build"
+    context <- getContext
+    let buildPath = contextPath context -/- "build"
         autogen   = buildPath -/- "autogen"
-    (found, missingMods) <- lift $ haskellModuleFiles stage pkg
+    (found, missingMods) <- lift $ haskellModuleFiles context
     -- Generated source files live in buildPath and have extension "hs"...
     let generated = [ buildPath -/- (replaceEq '.' '/' m) <.> "hs" | m <- missingMods ]
     -- ...except that GHC/Prim.hs lives in autogen. TODO: fix the inconsistency?
index 019d89a..e3b16bb 100644 (file)
@@ -18,11 +18,11 @@ includesArgs = append $ map ("-I" ++) includes
 
 cIncludeArgs :: Args
 cIncludeArgs = do
-    stage   <- getStage
+    context <- getContext
     pkg     <- getPackage
     incDirs <- getPkgDataList IncludeDirs
     depDirs <- getPkgDataList DepIncludeDirs
-    let buildPath = targetPath stage pkg -/- "build"
+    let buildPath = contextPath context -/- "build"
     mconcat [ arg $ "-I" ++ buildPath
             , arg $ "-I" ++ buildPath -/- "autogen"
             , append [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ]
index ef3130f..c8dcb6d 100644 (file)
@@ -52,7 +52,8 @@ ghcBuilderArgs = stagedBuilder Ghc ? do
             , not buildHi ? mconcat [ arg "-o", arg =<< getOutput ] ]
 
 needTouchy :: Action ()
-needTouchy = whenM windowsHost $ need [fromJust $ programPath Stage0 touchy]
+needTouchy =
+    whenM windowsHost $ need [fromJust $ programPath (vanillaContext Stage0 touchy)]
 
 splitObjectsArgs :: Args
 splitObjectsArgs = splitObjects ? do
@@ -73,7 +74,7 @@ ghcMBuilderArgs = stagedBuilder GhcM ? do
 commonGhcArgs :: Args
 commonGhcArgs = do
     way     <- getWay
-    path    <- getTargetPath
+    path    <- getContextPath
     hsArgs  <- getPkgDataList HsArgs
     cppArgs <- getPkgDataList CppArgs
     let buildPath = path -/- "build"
@@ -107,12 +108,12 @@ wayGhcArgs = do
 -- TODO: Improve handling of "-hide-all-packages"
 packageGhcArgs :: Args
 packageGhcArgs = do
-    stage     <- getStage
+    context   <- getContext
     pkg       <- getPackage
     compId    <- getPkgData ComponentId
     pkgDepIds <- getPkgDataList DepIds
     lift . when (isLibrary pkg) $ do
-        conf <- pkgConfFile stage pkg
+        conf <- pkgConfFile context
         need [conf]
     mconcat
         [ arg "-hide-all-packages"
@@ -125,7 +126,7 @@ packageGhcArgs = do
 includeGhcArgs :: Args
 includeGhcArgs = do
     pkg     <- getPackage
-    path    <- getTargetPath
+    path    <- getContextPath
     srcDirs <- getPkgDataList SrcDirs
     let buildPath   = path -/- "build"
         autogenPath = buildPath -/- "autogen"
index 4a46b84..be89546 100644 (file)
@@ -20,7 +20,7 @@ import Settings.Builders.Common
 ghcCabalBuilderArgs :: Args
 ghcCabalBuilderArgs = builder GhcCabal ? do
     path <- getPackagePath
-    dir  <- getTargetDirectory
+    dir  <- getContextDirectory
     mconcat [ arg "configure"
             , arg path
             , arg dir
@@ -41,7 +41,7 @@ ghcCabalBuilderArgs = builder GhcCabal ? do
 ghcCabalHsColourBuilderArgs :: Args
 ghcCabalHsColourBuilderArgs = builder GhcCabalHsColour ? do
     path <- getPackagePath
-    dir  <- getTargetDirectory
+    dir  <- getContextDirectory
     mconcat [ arg "hscolour"
             , arg path
             , arg dir ]
index 04dc64b..e85bb56 100644 (file)
@@ -21,9 +21,9 @@ initArgs = initPredicate ? do
 -- TODO: move inplace-pkg-config to buildRootPath, see #113.
 updateArgs :: Args
 updateArgs = notM initPredicate ? do
-    pkg       <- getPackage
-    targetDir <- getTargetDirectory
+    pkg <- getPackage
+    dir <- getContextDirectory
     mconcat [ arg "update"
             , arg "--force"
             , bootPackageDbArgs
-            , arg $ pkgPath pkg -/- targetDir -/- "inplace-pkg-config" ]
+            , arg $ pkgPath pkg -/- dir -/- "inplace-pkg-config" ]
index 6b26aea..3b5cb89 100644 (file)
@@ -14,13 +14,13 @@ haddockBuilderArgs :: Args
 haddockBuilderArgs = builder Haddock ? do
     output   <- getOutput
     pkg      <- getPackage
-    path     <- getTargetPath
+    path     <- getContextPath
     version  <- getPkgData Version
     synopsis <- getPkgData Synopsis
     hidden   <- getPkgDataList HiddenModules
     deps     <- getPkgDataList Deps
     depNames <- getPkgDataList DepNames
-    hVersion <- lift . pkgData . Version $ targetPath Stage2 haddock
+    hVersion <- lift . pkgData . Version $ contextPath (vanillaContext Stage2 haddock)
     ghcOpts  <- fromDiffExpr commonGhcArgs
     mconcat
         [ arg $ "--odir=" ++ takeDirectory output
@@ -35,7 +35,7 @@ haddockBuilderArgs = builder Haddock ? do
         , append $ map ("--hide=" ++) hidden
         , append $ [ "--read-interface=../" ++ dep
                      ++ ",../" ++ dep ++ "/src/%{MODULE/./-}.html\\#%{NAME},"
-                     ++ pkgHaddockFile depPkg
+                     ++ pkgHaddockFile (vanillaContext Stage1 depPkg)
                    | (dep, depName) <- zip deps depNames
                    , Just depPkg <- [findKnownPackage $ PackageName depName]
                    , depPkg /= rts ]
index caff277..efa061c 100644 (file)
@@ -13,7 +13,7 @@ hsCppBuilderArgs = builder HsCpp ? do
     mconcat [ append =<< getSettingList HsCppArgs
             , arg "-P"
             , cppArgs
-            , arg $ "-I" ++ targetPath stage compiler
+            , arg $ "-I" ++ contextPath (vanillaContext stage compiler)
             , arg "-x"
             , arg "c"
             , arg =<< getInput ]
index c2de9f1..5c55628 100644 (file)
@@ -50,7 +50,7 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
 
 getCFlags :: Expr [String]
 getCFlags = fromDiffExpr $ do
-    path      <- getTargetPath
+    path      <- getContextPath
     cppArgs   <- getPkgDataList CppArgs
     depCcArgs <- getPkgDataList DepCcArgs
     mconcat [ cArgs
index c2f31e6..b45c50c 100644 (file)
@@ -12,7 +12,7 @@ compilerPackageArgs :: Args
 compilerPackageArgs = package compiler ? do
     stage   <- getStage
     rtsWays <- getRtsWays
-    path    <- getTargetPath
+    path    <- getContextPath
     mconcat [ builder Alex ? arg "--latin1"
 
             , builderGhc ? arg ("-I" ++ path)
index a7936e9..dcb7b2a 100644 (file)
@@ -10,7 +10,7 @@ ghcPackageArgs :: Args
 ghcPackageArgs = package ghc ? do
     stage <- getStage
     mconcat [ builderGhc ? mconcat
-              [ arg $ "-I" ++ targetPath stage compiler
+              [ arg $ "-I" ++ contextPath (vanillaContext stage compiler)
               , arg "-no-hs-main" ]
 
             , builder GhcCabal ?
index f1a7373..5788dc6 100644 (file)
@@ -16,7 +16,7 @@ ghcCabalPackageArgs = package ghcCabal ? mconcat
 -- TODO: do we need -DCABAL_VERSION=$(CABAL_VERSION)?
 ghcCabalBootArgs :: Args
 ghcCabalBootArgs = stage0 ? do
-    path <- getTargetPath
+    path <- getContextPath
     let cabalMacros     = path -/- "build/autogen/cabal_macros.h"
         cabalMacrosBoot = pkgPath ghcCabal -/- "cabal_macros_boot.h"
     mconcat
index 26518c6..8430cb9 100644 (file)
@@ -8,7 +8,7 @@ import Settings
 
 hp2psPackageArgs :: Args
 hp2psPackageArgs = package hp2ps ? do
-    path <- getTargetPath
+    path <- getContextPath
     let cabalMacros = path -/- "build/autogen/cabal_macros.h"
     mconcat [ builderGhc ?
               mconcat [ arg "-no-hs-main"
index f67b709..4bc90b9 100644 (file)
@@ -4,7 +4,7 @@ module Settings.Packages.Rts (
 
 import Base
 import Expression
-import GHC (rts)
+import GHC (rts, rtsContext)
 import Oracles.Config.Flag
 import Oracles.Config.Setting
 import Predicates (builder, builderGcc, builderGhc, package, file)
@@ -16,7 +16,7 @@ rtsConfIn = pkgPath rts -/- "package.conf.in"
 
 -- TODO: move to buildRootPath, see #113
 rtsConf :: FilePath
-rtsConf = pkgPath rts -/- targetDirectory Stage1 rts -/- "package.conf.inplace"
+rtsConf = pkgPath rts -/- contextDirectory rtsContext -/- "package.conf.inplace"
 
 rtsLibffiLibraryName :: Action FilePath
 rtsLibffiLibraryName = do
@@ -46,7 +46,7 @@ rtsPackageArgs = package rts ? do
     ghcUnreg       <- yesNo $ flag GhcUnregisterised
     ghcEnableTNC   <- yesNo ghcEnableTablesNextToCode
     way            <- getWay
-    path           <- getTargetPath
+    path           <- getContextPath
     top            <- getTopDirectory
     libffiName     <- lift $ rtsLibffiLibraryName
     ffiIncludeDir  <- getSetting FfiIncludeDir
index 8345449..ee0ee52 100644 (file)
@@ -8,7 +8,7 @@ import Settings
 
 touchyPackageArgs :: Args
 touchyPackageArgs = package touchy ? do
-    path <- getTargetPath
+    path <- getContextPath
     let cabalMacros = path -/- "build/autogen/cabal_macros.h"
     mconcat [ builderGhc ?
               mconcat [ arg "-no-hs-main"
index e654a66..df72ff2 100644 (file)
@@ -4,11 +4,11 @@ import Base
 import Expression
 import GHC (unlit)
 import Predicates (builderGhc, package)
-import Settings (getTargetPath)
+import Settings
 
 unlitPackageArgs :: Args
 unlitPackageArgs = package unlit ? do
-    path <- getTargetPath
+    path <- getContextPath
     let cabalMacros = path -/- "build/autogen/cabal_macros.h"
     mconcat [ builderGhc ?
               mconcat [ arg "-no-hs-main"
index 96cd3bf..8d9a32d 100644 (file)
@@ -1,49 +1,51 @@
 module Settings.Paths (
-    targetDirectory, targetPath, pkgDataFile, pkgHaddockFile, pkgLibraryFile,
+    contextDirectory, contextPath, pkgDataFile, pkgHaddockFile, pkgLibraryFile,
     pkgLibraryFile0, pkgGhciLibraryFile, gmpBuildPath, gmpBuildInfoPath,
     packageDbDirectory, pkgConfFile
     ) where
 
 import Base
+import Context
 import Expression
 import GHC
 import Oracles.PackageData
 import Settings.User
 
 -- Path to the target directory from GHC source root
-targetPath :: Stage -> Package -> FilePath
-targetPath stage pkg = buildRootPath -/- targetDirectory stage pkg -/- pkgPath pkg
+contextPath :: Context -> FilePath
+contextPath context @ (Context {..}) =
+    buildRootPath -/- contextDirectory context -/- pkgPath package
 
-pkgDataFile :: Stage -> Package -> FilePath
-pkgDataFile stage pkg = targetPath stage pkg -/- "package-data.mk"
+pkgDataFile :: Context -> FilePath
+pkgDataFile context = contextPath context -/- "package-data.mk"
 
 -- Relative path to a package haddock file, e.g.:
 -- "libraries/array/dist-install/doc/html/array/array.haddock"
-pkgHaddockFile :: Package -> FilePath
-pkgHaddockFile pkg =
-    targetPath Stage1 pkg -/- "doc/html" -/- name -/- name <.> "haddock"
-  where name = pkgNameString pkg
+pkgHaddockFile :: Context -> FilePath
+pkgHaddockFile context @ (Context {..}) =
+    contextPath context -/- "doc/html" -/- name -/- name <.> "haddock"
+  where name = pkgNameString package
 
 -- Relative path to a package library file, e.g.:
 -- "libraries/array/stage2/build/libHSarray-0.5.1.0.a"
-pkgLibraryFile :: Stage -> Package -> Way -> Action FilePath
-pkgLibraryFile stage pkg way = do
+pkgLibraryFile :: Context -> Action FilePath
+pkgLibraryFile context @ (Context {..}) = do
     extension <- libsuf way
-    pkgFile stage pkg "build/libHS" extension
+    pkgFile context "build/libHS" extension
 
-pkgLibraryFile0 :: Stage -> Package -> Way -> Action FilePath
-pkgLibraryFile0 stage pkg way = do
+pkgLibraryFile0 :: Context -> Action FilePath
+pkgLibraryFile0 context @ (Context {..}) = do
     extension <- libsuf way
-    pkgFile stage pkg "build/libHS" ("-0" ++ extension)
+    pkgFile context "build/libHS" ("-0" ++ extension)
 
 -- Relative path to a package ghci library file, e.g.:
 -- "libraries/array/dist-install/build/HSarray-0.5.1.0.o"
-pkgGhciLibraryFile :: Stage -> Package -> Action FilePath
-pkgGhciLibraryFile stage pkg = pkgFile stage pkg "build/HS" ".o"
+pkgGhciLibraryFile :: Context -> Action FilePath
+pkgGhciLibraryFile context = pkgFile context "build/HS" ".o"
 
-pkgFile :: Stage -> Package -> String -> String -> Action FilePath
-pkgFile stage pkg prefix suffix = do
-    let path = targetPath stage pkg
+pkgFile :: Context -> String -> String -> Action FilePath
+pkgFile context prefix suffix = do
+    let path = contextPath context
     componentId <- pkgData $ ComponentId path
     return $ path -/- prefix ++ componentId ++ suffix
 
@@ -61,7 +63,7 @@ packageDbDirectory :: Stage -> FilePath
 packageDbDirectory Stage0 = buildRootPath -/- "stage0/bootstrapping.conf"
 packageDbDirectory _      = "inplace/lib/package.conf.d"
 
-pkgConfFile :: Stage -> Package -> Action FilePath
-pkgConfFile stage pkg = do
-    componentId <- pkgData . ComponentId $ targetPath stage pkg
+pkgConfFile :: Context -> Action FilePath
+pkgConfFile context @ (Context {..}) = do
+    componentId <- pkgData . ComponentId $ contextPath context
     return $ packageDbDirectory stage -/- componentId <.> "conf"