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

Add initial support for --configure command line flag.

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