Commit 0530e0df authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor command line arguments and flavours

* Get rid of unsafePerformIO using shakeExtra
* Move diagnostic info utilities to the library

See #347
parent db56cf4e
......@@ -20,7 +20,7 @@ executable hadrian
, src
other-modules: Base
, Builder
, CmdLineFlag
, CommandLine
, Context
, Environment
, Expression
......
module CmdLineFlag (
putCmdLineFlags, cmdFlags, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
cmdProgressColour, cmdProgressInfo, ProgressInfo (..), cmdSkipConfigure,
cmdSplitObjects
module CommandLine (
optDescrs, cmdLineArgsMap, cmdBuildHaddock, cmdFlavour, cmdIntegerSimple,
cmdProgressColour, cmdProgressInfo, cmdSkipConfigure, cmdSplitObjects
) where
import Data.IORef
import Data.Dynamic
import Data.Either
import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Hadrian.Utilities
import System.Console.GetOpt
import System.IO.Unsafe
import System.Environment
-- | 'CmdLineFlag.Untracked' is a collection of flags that can be passed via the
-- command line. These flags are not tracked, that is they do not force any
-- build rules to be rurun.
data Untracked = Untracked
-- | All arguments that can be passed to Hadrian via the command line.
data CommandLineArgs = CommandLineArgs
{ buildHaddock :: Bool
, flavour :: Maybe String
, integerSimple :: Bool
......@@ -23,11 +23,9 @@ data Untracked = Untracked
, splitObjects :: Bool }
deriving (Eq, Show)
data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
-- | Default values for 'CmdLineFlag.Untracked'.
defaultUntracked :: Untracked
defaultUntracked = Untracked
-- | Default values for 'CommandLineArgs'.
defaultCommandLineArgs :: CommandLineArgs
defaultCommandLineArgs = CommandLineArgs
{ buildHaddock = False
, flavour = Nothing
, integerSimple = False
......@@ -36,16 +34,16 @@ defaultUntracked = Untracked
, skipConfigure = False
, splitObjects = False }
readBuildHaddock :: Either String (Untracked -> Untracked)
readBuildHaddock :: Either String (CommandLineArgs -> CommandLineArgs)
readBuildHaddock = Right $ \flags -> flags { buildHaddock = True }
readFlavour :: Maybe String -> Either String (Untracked -> Untracked)
readFlavour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readFlavour ms = Right $ \flags -> flags { flavour = lower <$> ms }
readIntegerSimple :: Either String (Untracked -> Untracked)
readIntegerSimple :: Either String (CommandLineArgs -> CommandLineArgs)
readIntegerSimple = Right $ \flags -> flags { integerSimple = True }
readProgressColour :: Maybe String -> Either String (Untracked -> Untracked)
readProgressColour :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressColour ms =
maybe (Left "Cannot parse progress-colour") (Right . set) (go =<< lower <$> ms)
where
......@@ -54,10 +52,10 @@ readProgressColour ms =
go "auto" = Just Auto
go "always" = Just Always
go _ = Nothing
set :: UseColour -> Untracked -> Untracked
set :: UseColour -> CommandLineArgs -> CommandLineArgs
set flag flags = flags { progressColour = flag }
readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressInfo ms =
maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
where
......@@ -67,17 +65,18 @@ readProgressInfo ms =
go "normal" = Just Normal
go "unicorn" = Just Unicorn
go _ = Nothing
set :: ProgressInfo -> Untracked -> Untracked
set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
set flag flags = flags { progressInfo = flag }
readSkipConfigure :: Either String (Untracked -> Untracked)
readSkipConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
readSkipConfigure = Right $ \flags -> flags { skipConfigure = True }
readSplitObjects :: Either String (Untracked -> Untracked)
readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
readSplitObjects = Right $ \flags -> flags { splitObjects = True }
cmdFlags :: [OptDescr (Either String (Untracked -> Untracked))]
cmdFlags =
-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
optDescrs =
[ Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
"Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
, Option [] ["haddock"] (NoArg readBuildHaddock)
......@@ -93,36 +92,37 @@ cmdFlags =
, Option [] ["split-objects"] (NoArg readSplitObjects)
"Generate split objects (requires a full clean rebuild)." ]
-- TODO: Avoid unsafePerformIO by using shakeExtra.
{-# NOINLINE cmdLineFlags #-}
cmdLineFlags :: IORef Untracked
cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked
-- | A type-indexed map containing Hadrian command line arguments to be passed
-- to Shake via 'shakeExtra'.
cmdLineArgsMap :: IO (Map.HashMap TypeRep Dynamic)
cmdLineArgsMap = do
(opts, _, _) <- getOpt Permute optDescrs <$> getArgs
let args = foldl (flip id) defaultCommandLineArgs (rights opts)
return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
$ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
$ insertExtra args Map.empty
putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
cmdLineArgs :: Action CommandLineArgs
cmdLineArgs = userSetting defaultCommandLineArgs
-- TODO: Avoid unsafePerformIO by using shakeExtra.
{-# NOINLINE getCmdLineFlags #-}
getCmdLineFlags :: Untracked
getCmdLineFlags = unsafePerformIO $ readIORef cmdLineFlags
cmdBuildHaddock :: Action Bool
cmdBuildHaddock = buildHaddock <$> cmdLineArgs
cmdBuildHaddock :: Bool
cmdBuildHaddock = buildHaddock getCmdLineFlags
cmdFlavour :: Action (Maybe String)
cmdFlavour = flavour <$> cmdLineArgs
cmdFlavour :: Maybe String
cmdFlavour = flavour getCmdLineFlags
cmdIntegerSimple :: Action Bool
cmdIntegerSimple = integerSimple <$> cmdLineArgs
cmdIntegerSimple :: Bool
cmdIntegerSimple = integerSimple getCmdLineFlags
cmdProgressColour :: Action UseColour
cmdProgressColour = progressColour <$> cmdLineArgs
cmdProgressColour :: UseColour
cmdProgressColour = progressColour getCmdLineFlags
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
cmdProgressInfo :: ProgressInfo
cmdProgressInfo = progressInfo getCmdLineFlags
cmdSkipConfigure :: Action Bool
cmdSkipConfigure = skipConfigure <$> cmdLineArgs
cmdSplitObjects :: Bool
cmdSplitObjects = splitObjects getCmdLineFlags
cmdSplitObjects :: Action Bool
cmdSplitObjects = splitObjects <$> cmdLineArgs
cmdSkipConfigure :: Bool
cmdSkipConfigure = skipConfigure getCmdLineFlags
......@@ -12,7 +12,7 @@ data Flavour = Flavour
{ name :: String -- ^ Flavour name, to set from command line.
, args :: Args -- ^ Use these command line arguments.
, packages :: Packages -- ^ Build these packages.
, integerLibrary :: Package -- ^ Either 'integerGmp' or 'integerSimple'.
, integerLibrary :: Action Package -- ^ Either 'integerGmp' or 'integerSimple'.
, libraryWays :: Ways -- ^ Build libraries these ways.
, rtsWays :: Ways -- ^ Build RTS these ways.
, splitObjects :: Predicate -- ^ Build split objects.
......
module Hadrian.Utilities (
-- * List manipulation
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll,
......@@ -9,19 +8,30 @@ module Hadrian.Utilities (
-- * FilePath manipulation
unifyPath, (-/-), matchVersionedFilePath,
-- * Miscellaneous
UseColour (..), putColoured
-- * Accessing Shake's type-indexed map
insertExtra, userSetting,
-- * Diagnostic info
UseColour (..), putColoured, BuildProgressColour (..), putBuild,
SuccessColour (..), putSuccess, ProgressInfo (..),
putProgressInfo, renderAction, renderProgram, renderLibrary, renderBox,
renderUnicorn
) where
import Control.Monad
import Data.Char
import Data.Dynamic
import Data.HashMap.Strict (HashMap)
import Data.List.Extra
import Development.Shake
import Data.Maybe
import Development.Shake hiding (Normal)
import Development.Shake.FilePath
import System.Console.ANSI
import System.Info.Extra
import System.IO
import qualified Data.HashMap.Strict as Map
-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
fromSingleton :: String -> [a] -> a
......@@ -109,11 +119,24 @@ matchVersionedFilePath prefix suffix filePath =
Nothing -> False
Just version -> all (\c -> isDigit c || c == '-' || c == '.') version
data UseColour = Never | Auto | Always deriving (Eq, Show)
-- | Insert a value into Shake's type-indexed map.
insertExtra :: Typeable a => a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
insertExtra value = Map.insert (typeOf value) (toDyn value)
-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
-- setting is not found, return the provided default value instead.
userSetting :: Typeable a => a -> Action a
userSetting defaultValue = do
extra <- shakeExtra <$> getShakeOptions
let maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
return $ fromMaybe defaultValue maybeValue
data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
-- | A more colourful version of Shake's 'putNormal'.
putColoured :: UseColour -> ColorIntensity -> Color -> String -> Action ()
putColoured useColour intensity colour msg = do
putColoured :: ColorIntensity -> Color -> String -> Action ()
putColoured intensity colour msg = do
useColour <- userSetting Never
supported <- liftIO $ hSupportsANSI stdout
let c Never = False
c Auto = supported || isWindows -- Colours do work on Windows
......@@ -121,3 +144,126 @@ putColoured useColour intensity colour msg = do
when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
putNormal msg
when (c useColour) . liftIO $ setSGR [] >> hFlush stdout
newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
deriving Typeable
-- | Default 'BuildProgressColour'.
magenta :: BuildProgressColour
magenta = BuildProgressColour (Dull, Magenta)
-- | Print a build progress message (e.g. executing a build command).
putBuild :: String -> Action ()
putBuild msg = do
BuildProgressColour (intensity, colour) <- userSetting magenta
putColoured intensity colour msg
newtype SuccessColour = SuccessColour (ColorIntensity, Color)
deriving Typeable
-- | Default 'SuccessColour'.
green :: SuccessColour
green = SuccessColour (Dull, Green)
-- | Print a success message (e.g. a package is built successfully).
putSuccess :: String -> Action ()
putSuccess msg = do
SuccessColour (intensity, colour) <- userSetting green
putColoured intensity colour msg
data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
-- | Version of 'putBuild' controlled by @--progress-info@ command line flag.
putProgressInfo :: String -> Action ()
putProgressInfo msg = do
progressInfo <- userSetting None
when (progressInfo /= None) $ putBuild msg
-- | Render an action.
renderAction :: String -> FilePath -> FilePath -> Action String
renderAction what input output = do
progressInfo <- userSetting Normal
return $ case progressInfo of
None -> ""
Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
where
i = unifyPath input
o = unifyPath output
-- | Render the successful build of a program.
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox [ "Successfully built program " ++ name
, "Executable: " ++ bin
, "Program synopsis: " ++ synopsis ++ "."]
-- | Render the successful build of a library.
renderLibrary :: String -> String -> String -> String
renderLibrary name lib synopsis = renderBox [ "Successfully built library " ++ name
, "Library: " ++ lib
, "Library synopsis: " ++ synopsis ++ "."]
-- | Render the given set of lines in an ASCII box. The minimum width and
-- whether to use Unicode symbols are hardcoded in the function's body.
--
-- >>> renderBox (words "lorem ipsum")
-- /----------\
-- | lorem |
-- | ipsum |
-- \----------/
renderBox :: [String] -> String
renderBox ls = tail $ concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
where
-- Minimum total width of the box in characters
minimumBoxWidth = 32
-- TODO: Make this setting configurable? Setting to True by default seems
-- to work poorly with many fonts.
useUnicode = False
-- Characters to draw the box
(dash, pipe, topLeft, topRight, botLeft, botRight, padding)
| useUnicode = ('─', '│', '╭', '╮', '╰', '╯', ' ')
| otherwise = ('-', '|', '/', '\\', '\\', '/', ' ')
-- Box width, taking minimum desired length and content into account.
-- The -4 is for the beginning and end pipe/padding symbols, as
-- in "| xxx |".
boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
where
maxContentLength = maximum (map length ls)
renderLine l = concat
[ [pipe, padding]
, padToLengthWith boxContentWidth padding l
, [padding, pipe] ]
where
padToLengthWith n filler x = x ++ replicate (n - length x) filler
(boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
, botLeft : dashes ++ [botRight] )
where
-- +1 for each non-dash (= corner) char
dashes = replicate (boxContentWidth + 2) dash
-- | Render the given set of lines next to our favorite unicorn Robert.
renderUnicorn :: [String] -> String
renderUnicorn ls =
unlines $ take (max (length ponyLines) (length boxLines)) $
zipWith (++) (ponyLines ++ repeat ponyPadding) (boxLines ++ repeat "")
where
ponyLines :: [String]
ponyLines = [ " ,;,,;'"
, " ,;;'( Robert the spitting unicorn"
, " __ ,;;' ' \\ wants you to know"
, " /' '\\'~~'~' \\ /'\\.) that a task "
, " ,;( ) / |. / just finished! "
, " ,;' \\ /-.,,( ) \\ "
, " ^ ) / ) / )| Almost there! "
, " || || \\) "
, " (_\\ (_\\ " ]
ponyPadding :: String
ponyPadding = " "
boxLines :: [String]
boxLines = ["", "", ""] ++ (lines . renderBox $ ls)
module Main (main) where
import Development.Shake
import Hadrian.Utilities
import qualified CmdLineFlag
import qualified CommandLine
import qualified Environment
import qualified Rules
import qualified Rules.Clean
......@@ -11,15 +12,24 @@ import qualified Rules.SourceDist
import qualified Rules.Selftest
import qualified Rules.Test
import qualified Settings.Path
import qualified UserSettings
main :: IO ()
main = shakeArgsWith options CmdLineFlag.cmdFlags $ \cmdLineFlags targets -> do
CmdLineFlag.putCmdLineFlags cmdLineFlags
Environment.setupEnvironment
return . Just $ if null targets
then rules
else want targets >> withoutActions rules
where
main = do
-- Provide access to command line arguments and some user settings through
-- Shake's type-indexed map 'shakeExtra'.
argsMap <- CommandLine.cmdLineArgsMap
let extra = insertExtra UserSettings.buildProgressColour
$ insertExtra UserSettings.successColour argsMap
options :: ShakeOptions
options = shakeOptions
{ shakeChange = ChangeModtimeAndDigest
, shakeFiles = Settings.Path.shakeFilesPath
, shakeProgress = progressSimple
, shakeTimings = True
, shakeExtra = extra }
rules :: Rules ()
rules = do
Rules.buildRules
......@@ -30,9 +40,9 @@ main = shakeArgsWith options CmdLineFlag.cmdFlags $ \cmdLineFlags targets -> do
Rules.SourceDist.sourceDistRules
Rules.Test.testRules
Rules.topLevelTargets
options :: ShakeOptions
options = shakeOptions
{ shakeChange = ChangeModtimeAndDigest
, shakeFiles = Settings.Path.shakeFilesPath
, shakeProgress = progressSimple
, shakeTimings = True }
shakeArgsWith options CommandLine.optDescrs $ \_ targets -> do
Environment.setupEnvironment
return . Just $ if null targets
then rules
else want targets >> withoutActions rules
......@@ -57,13 +57,13 @@ packageTargets stage pkg = do
then do -- Collect all targets of a library package.
ways <- interpretInContext context getLibraryWays
libs <- mapM (pkgLibraryFile . Context stage pkg) ways
docs <- interpretInContext context $ buildHaddock flavour
docs <- interpretInContext context =<< buildHaddock <$> flavour
more <- libraryTargets context
return $ [ pkgSetupConfigFile context | nonCabalContext context ]
++ [ pkgHaddockFile context | docs && stage == Stage1 ]
++ libs ++ more
else -- The only target of a program package is the executable.
maybeToList <$> programPath (programContext stage pkg)
fmap maybeToList . programPath =<< programContext stage pkg
packageRules :: Rules ()
packageRules = do
......@@ -77,24 +77,21 @@ packageRules = do
let contexts = liftM3 Context allStages knownPackages allWays
vanillaContexts = liftM2 vanillaContext allStages knownPackages
programContexts = liftM2 programContext allStages knownPackages
forM_ contexts $ mconcat
[ Rules.Compile.compilePackage readPackageDb
, Rules.Library.buildPackageLibrary ]
let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic]
forM_ dynamicContexts Rules.Library.buildDynamicLib
forM_ programContexts $ Rules.Program.buildProgram readPackageDb
forM_ vanillaContexts $ mconcat
[ Rules.Data.buildPackageData
, Rules.Dependencies.buildPackageDependencies readPackageDb
, Rules.Documentation.buildPackageDocumentation
, Rules.Library.buildPackageGhciLibrary
, Rules.Generate.generatePackageCode
, Rules.Program.buildProgram readPackageDb
, Rules.Register.registerPackage writePackageDb ]
buildRules :: Rules ()
......
......@@ -11,7 +11,6 @@ import Base
import GHC
import Settings
import Settings.Path
import UserSettings
cabalRules :: Rules ()
cabalRules = do
......
......@@ -3,17 +3,17 @@ module Rules.Configure (configureRules) where
import qualified System.Info as System
import Base
import CmdLineFlag
import CommandLine
import Context
import GHC
import Target
import UserSettings
import Utilities
configureRules :: Rules ()
configureRules = do
[configFile, "settings", configH] &%> \outs -> do
if cmdSkipConfigure
skip <- cmdSkipConfigure
if skip
then unlessM (doesFileExist configFile) $
error $ "Configuration file " ++ configFile ++ " is missing."
++ "\nRun the configure script manually or do not use the "
......@@ -29,7 +29,8 @@ configureRules = do
build $ target context (Configure ".") srcs outs
["configure", configH <.> "in"] &%> \_ -> do
if cmdSkipConfigure
skip <- cmdSkipConfigure
if skip
then unlessM (doesFileExist "configure") $
error $ "The configure script is missing.\nRun the boot script"
++ " manually or do not use the --skip-configure flag."
......
......@@ -8,7 +8,6 @@ import Oracles.Setting
import Rules.Generate
import Settings.Path
import Target
import UserSettings
import Utilities
-- | Build @package-data.mk@ by using ghc-cabal utility to process .cabal files.
......
......@@ -32,7 +32,8 @@ buildPackageDocumentation context@Context {..} =
-- Build Haddock documentation
-- TODO: pass the correct way from Rules via Context
let haddockWay = if dynamicGhcPrograms flavour then dynamic else vanilla
dynamicPrograms <- dynamicGhcPrograms <$> flavour
let haddockWay = if dynamicPrograms then dynamic else vanilla
build $ target (context {way = haddockWay}) Haddock srcs [file]
when (package == haddock) $ haddockHtmlLib %> \_ -> do
......
......@@ -15,7 +15,6 @@ import Rules.Libffi
import Settings
import Settings.Path
import Target
import UserSettings
import Utilities
-- | Track this file to rebuild generated files whenever it changes.
......@@ -59,11 +58,12 @@ derivedConstantsDependencies = fmap (generatedPath -/-)
compilerDependencies :: Expr [FilePath]
compilerDependencies = do
stage <- getStage
intLib <- expr (integerLibrary =<< flavour)
let path = buildPath $ vanillaContext stage compiler
mconcat [ return [platformH stage]
, return includesDependencies
, return derivedConstantsDependencies
, notStage0 ? integerLibrary flavour == integerGmp ? return [gmpLibraryH]
, notStage0 ? intLib == integerGmp ? return [gmpLibraryH]
, notStage0 ? return libffiDependencies
, return $ fmap (path -/-)
[ "primop-can-fail.hs-incl"
......@@ -260,10 +260,12 @@ generateConfigHs = do
cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
cBooterVersion <- getSetting GhcVersion
intLib <- expr (integerLibrary =<< flavour)
debugged <- ghcDebugged <$> expr flavour
let cIntegerLibraryType
| integerLibrary flavour == integerGmp = "IntegerGMP"
| integerLibrary flavour == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: " ++ integerLibraryName
| intLib == integerGmp = "IntegerGMP"
| intLib == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: " ++ pkgNameString intLib
cSupportsSplitObjs <- expr $ yesNo <$> supportsSplitObjects
cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
......@@ -311,7 +313,7 @@ generateConfigHs = do
, "cStage :: String"
, "cStage = show (STAGE :: Int)"
, "cIntegerLibrary :: String"
, "cIntegerLibrary = " ++ show integerLibraryName
, "cIntegerLibrary = " ++ show (pkgNameString intLib)
, "cIntegerLibraryType :: IntegerLibrary"
, "cIntegerLibraryType = " ++ cIntegerLibraryType
, "cSupportsSplitObjs :: String"
......@@ -337,7 +339,7 @@ generateConfigHs = do
, "cGhcThreaded :: Bool"
, "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
, "cGhcDebugged :: Bool"
, "cGhcDebugged = " ++ show (ghcDebugged flavour)
, "cGhcDebugged = " ++ show debugged
, "cGhcRtsWithLibdw :: Bool"
, "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
......
......@@ -6,7 +6,6 @@ import Oracles.Setting
import Settings.Packages.IntegerGmp
import Settings.Path
import Target
import UserSettings
import Utilities
gmpBase :: FilePath
......
......@@ -76,8 +76,8 @@ installLibExecs = do
installDirectory (destDir ++ libExecDir)
forM_ installBinPkgs $ \pkg -> do
withLatestBuildStage pkg $ \stage -> do
let context = programContext stage pkg