Commit e874fed8 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add initial support for --configure command line flag.

parent 87c6fae6
module CmdLineFlag (
putCmdLineFlags, flags, cmdProgressInfo, ProgressInfo (..), cmdSplitObjects
putCmdLineFlags, flags, cmdProgressInfo, ProgressInfo (..), cmdSplitObjects,
Configure (..), cmdConfigure
) where
import Base
import Data.Char (toLower)
import Data.List.Extra
import System.Console.GetOpt
import Data.IORef
......@@ -11,24 +11,27 @@ import System.IO.Unsafe (unsafePerformIO)
-- Command line flags
data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show)
data Configure = SkipConfigure | RunConfigure String deriving (Eq, Show)
-- | '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
{ progressInfo :: ProgressInfo
, splitObjects :: Bool }
, splitObjects :: Bool
, configure :: Configure }
deriving (Eq, Show)
-- | Default values for 'CmdLineFlag.Untracked'.
defaultUntracked :: Untracked
defaultUntracked = Untracked
{ progressInfo = Normal
, splitObjects = False }
, splitObjects = False
, configure = SkipConfigure }
readProgressInfo :: Maybe String -> Either String (Untracked -> Untracked)
readProgressInfo ms =
maybe (Left "no parse") (Right . mkClosure) (go =<< fmap (map toLower) ms)
maybe (Left "Cannot parse progressInfo") (Right . set) (go =<< lower <$> ms)
where
go :: String -> Maybe ProgressInfo
go "none" = Just None
......@@ -36,19 +39,31 @@ readProgressInfo ms =
go "normal" = Just Normal
go "unicorn" = Just Unicorn
go _ = Nothing -- Left "no parse"
mkClosure :: ProgressInfo -> Untracked -> Untracked
mkClosure flag flags = flags { progressInfo = flag }
set :: ProgressInfo -> Untracked -> Untracked
set flag flags = flags { progressInfo = flag }
readConfigure :: Maybe String -> Either String (Untracked -> Untracked)
readConfigure ms =
maybe (Left "Cannot parse configure") (Right . set) (go $ lower <$> ms)
where
go :: Maybe String -> Maybe Configure
go (Just args) = Just $ RunConfigure args
go Nothing = Just $ RunConfigure ""
set :: Configure -> Untracked -> Untracked
set flag flags = flags { configure = flag }
readSplitObjects :: Either String (Untracked -> Untracked)
readSplitObjects = Right $ \flags -> flags { splitObjects = True }
flags :: [OptDescr (Either String (Untracked -> Untracked))]
flags = [ Option [] ["progress-info"] (OptArg readProgressInfo "")
"Progress Info Style (None, Brief, Normal, or Unicorn)"
flags = [ Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
"Progress info style (None, Brief, Normal, or Unicorn)."
, Option [] ["split-objects"] (NoArg readSplitObjects)
"Generate split objects (requires a full clean rebuild)." ]
"Generate split objects (requires a full clean rebuild)."
, Option [] ["configure"] (OptArg readConfigure "ARGS")
"Run boot and configure scripts (passing ARGS to the latter)." ]
-- TODO: Get rid of unsafePerformIO by using shakeExtra.
-- TODO: Avoid unsafePerformIO by using shakeExtra (awaiting Shake's release)
{-# NOINLINE cmdLineFlags #-}
cmdLineFlags :: IORef Untracked
cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked
......@@ -56,11 +71,16 @@ cmdLineFlags = unsafePerformIO $ newIORef defaultUntracked
putCmdLineFlags :: [Untracked -> Untracked] -> IO ()
putCmdLineFlags flags = modifyIORef cmdLineFlags (\f -> foldl (flip id) f flags)
getCmdLineFlags :: Action Untracked
getCmdLineFlags = liftIO $ readIORef cmdLineFlags
-- TODO: Avoid unsafePerformIO by using shakeExtra (awaiting Shake's release)
{-# NOINLINE getCmdLineFlags #-}
getCmdLineFlags :: Untracked
getCmdLineFlags = unsafePerformIO $ readIORef cmdLineFlags
cmdProgressInfo :: ProgressInfo
cmdProgressInfo = progressInfo getCmdLineFlags
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> getCmdLineFlags
cmdSplitObjects :: Bool
cmdSplitObjects = splitObjects getCmdLineFlags
cmdSplitObjects :: Action Bool
cmdSplitObjects = splitObjects <$> getCmdLineFlags
cmdConfigure :: Configure
cmdConfigure = configure getCmdLineFlags
......@@ -67,7 +67,7 @@ captureStdout target path argList = do
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
putProgressInfo =<< renderAction "Copy file" source target
putProgressInfo $ renderAction "Copy file" source target
copyFileChanged source target
createDirectory :: FilePath -> Action ()
......@@ -83,7 +83,7 @@ removeDirectory dir = do
-- Note, the source directory is untracked
moveDirectory :: FilePath -> FilePath -> Action ()
moveDirectory source target = do
putProgressInfo =<< renderAction "Move directory" source target
putProgressInfo $ renderAction "Move directory" source target
liftIO $ IO.renameDirectory source target
-- Transform a given file by applying a function to its contents
......@@ -97,8 +97,13 @@ fixFile file f = do
runConfigure :: FilePath -> [CmdOption] -> [String] -> Action ()
runConfigure dir opts args = do
need [dir -/- "configure"]
putBuild $ "| Run configure in " ++ dir ++ "..."
quietly $ cmd Shell (EchoStdout False) [Cwd dir] "bash configure" opts' args
if dir == "."
then do
putBuild $ "| Run configure..."
quietly $ cmd Shell (EchoStdout False) "bash configure" opts' args
else do
putBuild $ "| Run configure in " ++ dir ++ "..."
quietly $ cmd Shell (EchoStdout False) [Cwd dir] "bash configure" opts' args
where
-- Always configure with bash.
-- This also injects /bin/bash into `libtool`, instead of /bin/sh
......@@ -145,7 +150,7 @@ makeExecutable file = do
-- Print out key information about the command being executed
putInfo :: Target.Target -> Action ()
putInfo Target.Target {..} = putProgressInfo =<< renderAction
putInfo Target.Target {..} = putProgressInfo $ renderAction
("Run " ++ show builder ++ " (" ++ stageInfo
++ "package = " ++ pkgNameString package ++ wayInfo ++ ")")
(digest inputs)
......@@ -157,25 +162,21 @@ putInfo Target.Target {..} = putProgressInfo =<< renderAction
digest [x] = x
digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
-- | Switch for @putBuild@ filtered through @progressInfo@
-- | Version of @putBuild@ controlled by @progressInfo@ command line flag.
putProgressInfo :: String -> Action ()
putProgressInfo msg = do
skip <- (None ==) <$> cmdProgressInfo
unless skip $ putBuild msg
putProgressInfo msg = when (cmdProgressInfo /= None) $ putBuild msg
-- | Render an action.
renderAction :: String -> String -> String -> Action String
renderAction what input output = do
style <- cmdProgressInfo
return $ case style of
Normal -> renderBox [ what
renderAction :: String -> String -> String -> String
renderAction what input output = case cmdProgressInfo of
Normal -> renderBox [ what
, " input: " ++ input
, " => output: " ++ output ]
Brief -> "| " ++ what ++ ": " ++ input ++ " => " ++ output
Unicorn -> renderUnicorn [ what
, " input: " ++ input
, " => output: " ++ output ]
Brief -> "| " ++ what ++ ": " ++ input ++ " => " ++ output
Unicorn -> renderUnicorn [ what
, " input: " ++ input
, " => output: " ++ output ]
None -> ""
None -> ""
-- | Render the successful build of a program
renderProgram :: String -> String -> String -> String
......
......@@ -8,7 +8,6 @@ import Distribution.PackageDescription.Parse
import Distribution.Verbosity
import Expression
import GHC
import Rules.Actions
import Settings
cabalRules :: Rules ()
......
module Rules.Config (configRules) where
import Base
import Settings.User
import CmdLineFlag
import Rules.Actions
-- TODO: Consider removing this file.
configRules :: Rules ()
configRules = when buildSystemConfigFile $ do
configPath -/- "system.config" %> \_ -> do
need [configPath -/- "system.config.in", "configure"]
putBuild "Running configure..."
cmd "bash configure" -- TODO: get rid of 'bash'
configRules = case cmdConfigure of
SkipConfigure -> mempty
RunConfigure args -> do
configPath -/- "system.config" %> \_ -> do
need [configPath -/- "system.config.in"]
runConfigure "." [] [args]
"configure" %> \_ -> do
putBuild "Running autoconf..."
cmd "bash autoconf" -- TODO: get rid of 'bash'
"configure" %> \_ -> do
putBuild "| Running boot..."
unit $ cmd "perl boot"
......@@ -2,8 +2,8 @@ module Settings.User (
buildRootPath, trackBuildSystem, compileInterfaceFilesSeparately,
userArgs, userPackages, userLibraryWays, userRtsWays, userKnownPackages,
integerLibrary, buildHaddock, validating, ghciWithDebugger, ghcProfiled,
ghcDebugged, dynamicGhcPrograms, laxDependencies, buildSystemConfigFile,
verboseCommands, turnWarningsIntoErrors, splitObjects
ghcDebugged, dynamicGhcPrograms, laxDependencies, verboseCommands,
turnWarningsIntoErrors, splitObjects
) where
import Base
......@@ -61,7 +61,7 @@ validating = False
-- | Control when split objects are generated. Note, due to the GHC bug #11315
-- it is necessary to do a full clean rebuild when changing this option.
splitObjects :: Predicate
splitObjects = (lift $ cmdSplitObjects) &&^ defaultSplitObjects
splitObjects = (return cmdSplitObjects) &&^ defaultSplitObjects
dynamicGhcPrograms :: Bool
dynamicGhcPrograms = False
......@@ -86,9 +86,6 @@ laxDependencies = False
buildHaddock :: Predicate
buildHaddock = return False -- FIXME: should be return True, see #98
buildSystemConfigFile :: Bool
buildSystemConfigFile = False
-- | Set to True to print full command lines during the build process. Note,
-- this is a Predicate, hence you can enable verbose output for a chosen package
-- only, e.g.: verboseCommands = package ghcPrim
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment