Add ShowArg for single string options, clean up code.

src/Base.hs

@@ -8,7 +8,7 @@ module Base (
     module Data.Monoid,
     module Data.List,
     Stage (..),
-    Args, arg, ShowArgs (..),
+    Args, arg, ShowArg (..), ShowArgs (..),
     Condition (..),
     (<+>),
     filterOut,
@@ -37,6 +37,9 @@ instance Monoid a => Monoid (Action a) where
     mempty = return mempty
     mappend p q = mappend <$> p <*> q
 
+class ShowArg a where
+    showArg :: a -> Action String
+
 -- Using the Creators' trick for overlapping String instances
 class ShowArgs a where
     showArgs     :: a -> Args

src/Config.hs

@@ -3,6 +3,7 @@ module Config (
     ) where
 
 import Base
+import Util
 
 cfgPath :: FilePath
 cfgPath = "shake" </> "cfg"
@@ -10,11 +11,15 @@ cfgPath = "shake" </> "cfg"
 autoconfRules :: Rules ()
 autoconfRules = do
     "configure" %> \out -> do
+        need ["shake/src/Config.hs"]
         copyFile' (cfgPath </> "configure.ac") "configure.ac"
+        putColoured Vivid White $ "Running autoconf..."
         cmd "bash autoconf" -- TODO: get rid of 'bash'
 
 configureRules :: Rules ()
 configureRules = do
     cfgPath </> "default.config" %> \out -> do
+        need ["shake/src/Config.hs"]
         need [cfgPath </> "default.config.in", "configure"]
+        putColoured Vivid White "Running configure..."
         cmd "bash configure" -- TODO: get rid of 'bash'

src/Oracles.hs

@@ -10,6 +10,7 @@ module Oracles (
 import Development.Shake.Config
 import qualified Data.HashMap.Strict as M
 import Base
+import Util
 import Config
 import Oracles.Base
 import Oracles.Flag
@@ -31,15 +32,21 @@ configOracle = do
                 ++ "' is missing; unwilling to proceed."
             return ()
         need [defaultConfig]
+        putNormal $ "Parsing " ++ toStandard defaultConfig ++ "..."
         cfgDefault <- liftIO $ readConfigFile defaultConfig
         existsUser <- doesFileExist userConfig
         cfgUser    <- if existsUser
-                      then liftIO $ readConfigFile userConfig
+                      then do
+                          putNormal $ "Parsing "
+                                    ++ toStandard userConfig ++ "..."
+                          liftIO $ readConfigFile userConfig
                       else do
-                          putLoud $ "\nUser defined configuration file '"
+                          putColoured Dull Red $
+                              "\nUser defined configuration file '"
                               ++ userConfig ++ "' is missing; "
                               ++ "proceeding with default configuration.\n"
                           return M.empty
+        putColoured Vivid Green $ "Finished processing configuration files."
         return $ cfgUser `M.union` cfgDefault
     addOracle $ \(ConfigKey key) -> M.lookup key <$> cfg ()
     return ()

src/Oracles/Builder.hs

@@ -30,8 +30,8 @@ data Builder = Ar
              | GhcPkg Stage
              deriving Show
 
-instance ShowArgs Builder where
-    showArgs builder = showArgs $ fmap (map toStandard . words) $ do
+instance ShowArg Builder where
+    showArg builder = toStandard <$> do
         let key = case builder of
                 Ar            -> "ar"
                 Ld            -> "ld"
@@ -49,7 +49,7 @@ instance ShowArgs Builder where
         cfgPath <- askConfigWithDefault key $
             error $ "\nCannot find path to '" ++ key
                   ++ "' in configuration files."
-        let cfgPathExe = if cfgPath /= "" then cfgPath -<.> exe else ""
+        let cfgPathExe = if null cfgPath then "" else cfgPath -<.> exe
         windows <- windowsHost
         -- Note, below is different from FilePath.isAbsolute:
         if (windows && "/" `isPrefixOf` cfgPathExe)
@@ -66,19 +66,17 @@ instance ShowArgs Builder where
 -- should reset the flag (at least temporarily).
 
 -- Make sure the builder exists on the given path and rebuild it if out of date
--- Raise an error if the builder is not uniquely specified in config files
 needBuilder :: Builder -> Action ()
 needBuilder ghc @ (Ghc stage) = do
-    [exe]   <- showArgs ghc
+    exe     <- showArg ghc
     laxDeps <- test LaxDeps
     if laxDeps then orderOnly [exe] else need [exe]
 
 needBuilder builder = do
-    [exe] <- showArgs builder
+    exe <- showArg builder
     need [exe]
 
 -- Action 'with Gcc' returns '--with-gcc=/path/to/gcc' and needs Gcc
--- Raises an error if the builder is not uniquely specified in config files
 with :: Builder -> Args
 with builder = do
     let key = case builder of
@@ -90,17 +88,17 @@ with builder = do
             Happy    -> "--with-happy="
             GhcPkg _ -> "--with-ghc-pkg="
             HsColour -> "--with-hscolour="
-    [exe] <- showArgs builder
+    exe <- showArg builder
     needBuilder builder
-    arg $ key ++ normaliseEx exe
+    return [key ++ exe]
 
 -- Run the builder with a given collection of arguments
 -- Raises an error if the builder is not uniquely specified in config files
 run :: ShowArgs a => Builder -> a -> Action ()
 run builder as = do
     needBuilder builder
-    [exe] <- showArgs builder
-    args  <- showArgs as
+    exe  <- showArg builder
+    args <- showArgs as
     cmd [exe] args
 
 -- Run the builder with a given collection of arguments printing out a
@@ -123,7 +121,7 @@ interestingInfo builder ss = case builder of
     Ghc _    -> if head ss == "-M"
                 then prefixAndSuffix 1 1 ss
                 else prefixAndSuffix 0 4 ss
-    GhcPkg _ -> prefixAndSuffix 2 0 ss
+    GhcPkg _ -> prefixAndSuffix 3 0 ss
     GhcCabal -> prefixAndSuffix 3 0 ss
     _        -> ss
   where
@@ -136,11 +134,6 @@ interestingInfo builder ss = case builder of
              ++ " arguments ..."]
              ++ drop (length ss - m) ss
 
--- Check if the builder is uniquely specified in config files
+-- Check if the builder is specified in config files
 specified :: Builder -> Condition
-specified builder = do
-    exes <- showArgs builder
-    return $ case exes of
-        [_] -> True
-        _   -> False
-
+specified = fmap (not . null) . showArg

src/Oracles/Flag.hs

@@ -3,14 +3,15 @@
 module Oracles.Flag (
     module Control.Monad,
     module Prelude,
-    Flag (..), 
-    test, when, unless, not, (&&), (||), (<?>)
+    Flag (..),
+    test, when, unless, not, (&&), (||)
     ) where
 
 import Control.Monad hiding (when, unless)
 import qualified Prelude
 import Prelude hiding (not, (&&), (||))
 import Base
+import Util
 import Oracles.Base
 
 data Flag = LaxDeps
@@ -39,8 +40,8 @@ test flag = do
         SplitObjectsBroken -> ("split-objects-broken" , False)
         GhcUnregisterised  -> ("ghc-unregisterised"   , False)
     let defaultString = if defaultValue then "YES" else "NO"
-    value <- askConfigWithDefault key $
-        do putLoud $ "\nFlag '"
+    value <- askConfigWithDefault key $ -- TODO: warn just once
+        do putColoured Dull Red $ "\nFlag '"
                 ++ key
                 ++ "' not set in configuration files. "
                 ++ "Proceeding with default value '"
@@ -71,10 +72,6 @@ unless x act = do
     bool <- toCondition x
     if bool then mempty else act
 
--- Infix version of when
-(<?>) :: (ToCondition a, Monoid m) => a -> Action m -> Action m
-(<?>) = when
-
 class Not a where
     type NotResult a
     not :: a -> NotResult a

src/Oracles/Option.hs

 {-# LANGUAGE NoImplicitPrelude #-}
 module Oracles.Option (
-    Option (..),
+    Option (..), MultiOption (..),
     ghcWithInterpreter, platformSupportsSharedLibs, windowsHost, splitObjects
     ) where
 
@@ -10,47 +10,56 @@ import Oracles.Base
 
 -- For each Option the files {default.config, user.config} contain
 -- a line of the form 'target-os = mingw32'.
--- (showArgs TargetOS) is an action that consults the config files
--- and returns ["mingw32"].
--- TODO: separate single string options from multiple string ones.
-data Option = TargetOS
+-- (showArg TargetOs) is an action that consults the config files
+-- and returns "mingw32".
+--
+-- MultiOption is used for multiple string options separated by spaces,
+-- such as 'src-hc-args' = -H32m -O'.
+-- (showArgs SrcHcArgs) therefore returns a list of strings ["-H32", "-O"].
+data Option = TargetOs
             | TargetArch
             | TargetPlatformFull
-            | ConfCcArgs Stage
-            | ConfGccLinkerArgs Stage
-            | ConfLdLinkerArgs Stage
-            | ConfCppArgs Stage
-            | IconvIncludeDirs
-            | IconvLibDirs
-            | GmpIncludeDirs
-            | GmpLibDirs
-            | SrcHcOpts
             | HostOsCpp
             | DynamicExtension
             | ProjectVersion
 
-instance ShowArgs Option where
-    showArgs opt = showArgs $ fmap words $ askConfig $ case opt of 
-        TargetOS                -> "target-os"
+data MultiOption = SrcHcArgs
+                 | ConfCcArgs Stage
+                 | ConfGccLinkerArgs Stage
+                 | ConfLdLinkerArgs Stage
+                 | ConfCppArgs Stage
+                 | IconvIncludeDirs
+                 | IconvLibDirs
+                 | GmpIncludeDirs
+                 | GmpLibDirs
+
+instance ShowArg Option where
+    showArg opt = askConfig $ case opt of
+        TargetOs                -> "target-os"
         TargetArch              -> "target-arch"
         TargetPlatformFull      -> "target-platform-full"
-        ConfCcArgs        stage -> "conf-cc-args-stage-"         ++ show stage
-        ConfCppArgs       stage -> "conf-cpp-args-stage-"        ++ show stage
-        ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage-" ++ show stage
-        ConfLdLinkerArgs  stage -> "conf-ld-linker-args-stage-"  ++ show stage
+        HostOsCpp               -> "host-os-cpp"
+        DynamicExtension        -> "dynamic-extension"
+        ProjectVersion          -> "project-version"
+
+instance ShowArgs MultiOption where
+    showArgs opt = showArgs $ fmap words $ askConfig $ case opt of
+        SrcHcArgs               -> "src-hc-args"
+        ConfCcArgs        stage -> "conf-cc-args"         ++ showStage stage
+        ConfCppArgs       stage -> "conf-cpp-args"        ++ showStage stage
+        ConfGccLinkerArgs stage -> "conf-gcc-linker-args" ++ showStage stage
+        ConfLdLinkerArgs  stage -> "conf-ld-linker-args"  ++ showStage stage
         IconvIncludeDirs        -> "iconv-include-dirs"
         IconvLibDirs            -> "iconv-lib-dirs"
         GmpIncludeDirs          -> "gmp-include-dirs"
         GmpLibDirs              -> "gmp-lib-dirs"
-        SrcHcOpts               -> "src-hc-opts"
-        HostOsCpp               -> "host-os-cpp"
-        DynamicExtension        -> "dynamic-extension"
-        ProjectVersion          -> "project-version"
+      where
+        showStage = ("-stage-" ++) . show
 
 ghcWithInterpreter :: Condition
 ghcWithInterpreter = do
-    [os]   <- showArgs TargetOS
-    [arch] <- showArgs TargetArch
+    os   <- showArg TargetOs
+    arch <- showArg TargetArch
     return $
         os `elem` ["mingw32", "cygwin32", "linux", "solaris2",
                    "freebsd", "dragonfly", "netbsd", "openbsd",
@@ -60,7 +69,7 @@ ghcWithInterpreter = do
 
 platformSupportsSharedLibs :: Condition
 platformSupportsSharedLibs = do
-    [platform] <- showArgs TargetPlatformFull
+    platform <- showArg TargetPlatformFull
     solarisBrokenShld <- test SolarisBrokenShld
     return $ notElem platform $
         ["powerpc-unknown-linux",
@@ -70,19 +79,17 @@ platformSupportsSharedLibs = do
 
 windowsHost :: Condition
 windowsHost = do
-    [hostOsCpp] <- showArgs HostOsCpp
+    hostOsCpp <- showArg HostOsCpp
     return $ hostOsCpp `elem` ["mingw32", "cygwin32"]
 
 -- TODO: refactor helper Condition functions into a separate file
 splitObjects :: Stage -> Condition
 splitObjects stage = do
-    [os]   <- showArgs TargetOS
-    [arch] <- showArgs TargetArch
-    splitObjectsBroken <- test SplitObjectsBroken
-    ghcUnregisterised  <- test GhcUnregisterised
-    return $ not splitObjectsBroken && not ghcUnregisterised
-           && stage == Stage1
-           && arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
-           && os   `elem` ["mingw32", "cygwin32", "linux", "darwin",
-                           "solaris2", "freebsd", "dragonfly", "netbsd",
-                           "openbsd"]
+    arch <- showArg TargetArch
+    os   <- showArg TargetOs
+    not SplitObjectsBroken && not GhcUnregisterised
+        && stage == Stage1
+        && arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
+        && os   `elem` ["mingw32", "cygwin32", "linux", "darwin",
+                       "solaris2", "freebsd", "dragonfly", "netbsd",
+                       "openbsd"]

src/Util.hs

@@ -35,6 +35,7 @@ chunksOfSize size ss = reverse chunk : chunksOfSize size rest
                                 then (chunk   , s:ss)
                                 else (newChunk, rest)
 
+-- A more colourful version of Shake's putNormal
 putColoured :: ColorIntensity -> Color -> String -> Action ()
 putColoured intensity colour msg = do
     liftIO $ setSGR [SetColor Foreground intensity colour]

src/Ways.hs

 {-# LANGUAGE NoImplicitPrelude #-}
 module Ways (
     WayUnit (..),
-    Way, tag, 
-    
-    allWays, defaultWays, 
+    Way, tag,
 
-    vanilla, profiling, logging, parallel, granSim, 
-    threaded, threadedProfiling, threadedLogging, 
+    allWays, defaultWays,
+
+    vanilla, profiling, logging, parallel, granSim,
+    threaded, threadedProfiling, threadedLogging,
     debug, debugProfiling, threadedDebug, threadedDebugProfiling,
     dynamic, profilingDynamic, threadedProfilingDynamic,
     threadedDynamic, threadedDebugDynamic, debugDynamic,
     loggingDynamic, threadedLoggingDynamic,
 
-    wayHcArgs, 
+    wayHcArgs,
     wayPrefix,
     hisuf, osuf, hcsuf, obootsuf, ssuf, libsuf,
     detectWay
@@ -61,8 +61,8 @@ debugDynamic             = Way "debug_dyn"     [Debug, Dynamic]
 loggingDynamic           = Way "l_dyn"         [Logging, Dynamic]
 threadedLoggingDynamic   = Way "thr_l_dyn"     [Threaded, Logging, Dynamic]
 
-allWays = [vanilla, profiling, logging, parallel, granSim, 
-    threaded, threadedProfiling, threadedLogging, 
+allWays = [vanilla, profiling, logging, parallel, granSim,
+    threaded, threadedProfiling, threadedLogging,
     debug, debugProfiling, threadedDebug, threadedDebugProfiling,
     dynamic, profilingDynamic, threadedProfilingDynamic,
     threadedDynamic, threadedDebugDynamic, debugDynamic,
@@ -72,22 +72,23 @@ defaultWays :: Stage -> Action [Way]
 defaultWays stage = do
     sharedLibs <- platformSupportsSharedLibs
     return $ [vanilla]
-          ++ [profiling | stage /= Stage0] 
+          ++ [profiling | stage /= Stage0]
           ++ [dynamic   | sharedLibs     ]
 
 -- TODO: do '-ticky' in all debug ways?
 wayHcArgs :: Way -> Args
-wayHcArgs (Way _ units) =
-       (Dynamic `notElem` units) <?> arg "-static"
-    <> (Dynamic    `elem` units) <?> arg ["-fPIC", "-dynamic"]
-    <> (Threaded   `elem` units) <?> arg "-optc-DTHREADED_RTS"
-    <> (Debug      `elem` units) <?> arg "-optc-DDEBUG"
-    <> (Profiling  `elem` units) <?> arg "-prof"
-    <> (Logging    `elem` units) <?> arg "-eventlog"
-    <> (Parallel   `elem` units) <?> arg "-parallel"
-    <> (GranSim    `elem` units) <?> arg "-gransim"
-    <> (units == [Debug] || units == [Debug, Dynamic]) <?>
-       arg ["-ticky", "-DTICKY_TICKY"]
+wayHcArgs (Way _ units) = arg
+    [ if (Dynamic    `elem` units)
+      then arg ["-fPIC", "-dynamic"]
+      else arg "-static"
+    , when (Threaded   `elem` units) $ arg "-optc-DTHREADED_RTS"
+    , when (Debug      `elem` units) $ arg "-optc-DDEBUG"
+    , when (Profiling  `elem` units) $ arg "-prof"
+    , when (Logging    `elem` units) $ arg "-eventlog"
+    , when (Parallel   `elem` units) $ arg "-parallel"
+    , when (GranSim    `elem` units) $ arg "-gransim"
+    , when (units == [Debug] || units == [Debug, Dynamic]) $
+      arg ["-ticky", "-DTICKY_TICKY"] ]
 
 wayPrefix :: Way -> String
 wayPrefix way | way == vanilla = ""
@@ -110,8 +111,8 @@ libsuf way = do
     if Dynamic `notElem` units way
     then return $ staticSuffix ++ "a"
     else do
-        [extension] <- showArgs DynamicExtension
-        [version]   <- showArgs ProjectVersion
+        extension <- showArg DynamicExtension
+        version   <- showArg ProjectVersion
         return $ staticSuffix ++ "-ghc" ++ version ++ extension
 
 -- TODO: This may be slow -- optimise if overhead is significant.