Refactor using variadic args.

src/Base.hs

@@ -7,9 +7,9 @@ module Base (
     module Data.Monoid,
     module Data.List,
     Stage (..),
-    Args, arg, args, ShowAction (..),
+    Args, arg, args, ShowAction (..), Collect (..),
     Condition (..),
-    joinArgs, joinArgsWithSpaces, splitArgs,
+    joinArgs, joinArgsSpaced, splitArgs,
     filterOut
     ) where
 
@@ -23,7 +23,6 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum)
 
 type Args = Action [String]
 
-
 type Condition = Action Bool
 
 instance Monoid a => Monoid (Action a) where
@@ -31,16 +30,22 @@ instance Monoid a => Monoid (Action a) where
     mappend p q = mappend <$> p <*> q
 
 class ShowAction a where
-    showAction :: a -> Action String
+    showAction     :: a -> Args
+    showListAction :: [a] -> Args -- the Creators' trick for overlapping String instances
+    showListAction = mconcat . map showAction
+
+instance ShowAction Char where
+    showAction c     = return [[c]]
+    showListAction s = return [s]
 
-instance ShowAction String where
-    showAction = return
+instance ShowAction a => ShowAction [a] where
+    showAction = showListAction
 
-instance ShowAction (Action String) where
-    showAction = id
+instance ShowAction a => ShowAction (Action a) where
+    showAction = (showAction =<<)
 
-arg :: ShowAction a => [a] -> Args
-arg = mapM showAction
+arg :: ShowAction a => a -> Args
+arg = showAction
 
 type ArgsCombine = Args -> Args -> Args
 
@@ -51,19 +56,16 @@ instance Collect Args where
     collect = const id
 
 instance (ShowAction a, Collect r) => Collect (a -> r) where
-    collect combine x = \y -> collect combine $ x `combine` arg [y]
-
-instance Collect r => Collect (Args -> r) where
-    collect combine x = \y -> collect combine $ x `combine` y
+    collect combine x = \y -> collect combine $ x `combine` arg y
 
 args :: Collect a => a
 args = collect (<>) mempty
 
 joinArgs :: Collect a => a
-joinArgs = collect (\x y -> intercalateArgs "" x <> y) mempty
+joinArgs = collect (\x y -> intercalateArgs "" $ x <> y) mempty
 
-joinArgsWithSpaces :: Collect a => a
-joinArgsWithSpaces = collect (\x y -> intercalateArgs " " x <> y) mempty
+joinArgsSpaced :: Collect a => a
+joinArgsSpaced = collect (\x y -> intercalateArgs " " $ x <> y) mempty
 
 intercalateArgs :: String -> Args -> Args
 intercalateArgs s as = do

src/Oracles/Builder.hs

@@ -15,7 +15,7 @@ import Oracles.Option
 data Builder = Ar | Ld | Gcc | Alex | Happy | HsColour | GhcCabal | GhcPkg Stage | Ghc Stage
 
 instance ShowAction Builder where
-    showAction builder = do
+    showAction builder = showAction $ do
         let key = case builder of
                 Ar            -> "ar"
                 Ld            -> "ld"
@@ -50,12 +50,12 @@ instance ShowAction Builder where
 -- the flag (at least temporarily).
 needBuilder :: Builder -> Action ()
 needBuilder ghc @ (Ghc stage) = do
-    target  <- showAction ghc
-    laxDeps <- test LaxDeps
+    [target] <- showAction ghc
+    laxDeps  <- test LaxDeps
     if laxDeps then orderOnly [target] else need [target]
 
 needBuilder builder = do 
-    target <- showAction builder
+    [target] <- showAction builder
     need [target]
 
 -- Action 'with Gcc' returns an argument '--with-gcc=/path/to/gcc' and needs the builder 
@@ -70,18 +70,18 @@ with builder = do
             Happy    -> "--with-happy="
             GhcPkg _ -> "--with-ghc-pkg="
             HsColour -> "--with-hscolour="
-    suffix <- showAction builder
+    [suffix] <- showAction builder
     needBuilder builder
     return [prefix ++ suffix]
 
 run :: Builder -> Args -> Action ()
 run builder args = do
     needBuilder builder
-    exe   <- showAction builder
+    [exe] <- showAction builder
     args' <- args
-    cmd [exe :: FilePath] args'
+    cmd [exe] args'
 
 hsColourSrcs :: Condition
 hsColourSrcs = do
-    hscolour <- showAction HsColour
+    [hscolour] <- showAction HsColour
     return $ hscolour /= ""

src/Oracles/Flag.hs

@@ -51,14 +51,14 @@ instance ToCondition Flag where
     toCondition = test
 
 when :: (ToCondition a, Monoid m) => a -> Action m -> Action m
-when x args = do
+when x act = do
     bool <- toCondition x
-    if bool then args else mempty
+    if bool then act else mempty
 
 unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
-unless x args = do
+unless x act = do
     bool <- toCondition x
-    if bool then mempty else args
+    if bool then mempty else act
 
 class Not a where
     type NotResult a

src/Oracles/Option.hs

@@ -13,7 +13,7 @@ data Option = TargetOS | TargetArch | TargetPlatformFull
             | HostOsCpp
 
 instance ShowAction Option where
-    showAction opt = askConfig $ case opt of 
+    showAction opt = showAction $ askConfig $ case opt of 
         TargetOS                -> "target-os"
         TargetArch              -> "target-arch"
         TargetPlatformFull      -> "target-platform-full"
@@ -30,8 +30,8 @@ instance ShowAction Option where
 
 ghcWithInterpreter :: Condition
 ghcWithInterpreter = do
-    os   <- showAction TargetOS
-    arch <- showAction TargetArch
+    [os]   <- showAction TargetOS
+    [arch] <- showAction TargetArch
     return $
         os `elem` ["mingw32", "cygwin32", "linux", "solaris2", "freebsd", "dragonfly", "netbsd", "openbsd", "darwin", "kfreebsdgnu"]
         &&
@@ -39,10 +39,10 @@ ghcWithInterpreter = do
 
 platformSupportsSharedLibs :: Condition
 platformSupportsSharedLibs = do
-    platform <- showAction TargetPlatformFull
+    [platform] <- showAction TargetPlatformFull
     return $ platform `notElem` [ "powerpc-unknown-linux", "x86_64-unknown-mingw32", "i386-unknown-mingw32" ] -- TODO: i386-unknown-solaris2?
 
 windowsHost :: Condition
 windowsHost = do
-    hostOsCpp <- showAction HostOsCpp
+    [hostOsCpp] <- showAction HostOsCpp
     return $ hostOsCpp `elem` ["mingw32", "cygwin32"]

src/Package.hs

-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables #-}
 module Package (
     packageRules
     ) where
@@ -50,7 +50,7 @@ libraryPackage name stage settings =
         )]
 
 commonCcArgs :: Args
-commonCcArgs = when Validating $ arg ["-Werror", "-Wall"]
+commonCcArgs = when Validating $ args "-Werror" "-Wall"
 
 commonLdArgs :: Args
 commonLdArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?
@@ -60,21 +60,17 @@ commonCppArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?
 
 commonCcWarninigArgs :: Args
 commonCcWarninigArgs = when Validating $ mconcat
-    [ when GccIsClang                      $ arg ["-Wno-unknown-pragmas"]
-    , when (not GccIsClang && not GccLt46) $ arg ["-Wno-error=inline"]
-    , when (    GccIsClang && not GccLt46) $ hostOsCppWarning
+    [ when GccIsClang                                     $ arg "-Wno-unknown-pragmas"
+    , when (not GccIsClang && not GccLt46)                $ arg "-Wno-error=inline"
+    , when (    GccIsClang && not GccLt46 && windowsHost) $ arg "-Werror=unused-but-set-variable" 
     ]
-      where
-        hostOsCppWarning = do
-            hostOsCpp <- option HostOsCpp
-            when (hostOsCpp /= "mingw32") $ arg ["-Werror=unused-but-set-variable" ]
 
 bootPkgConstraints :: Args
 bootPkgConstraints = mempty
 
 libraryArgs :: [Way] -> Args
 libraryArgs ways = 
-    let argEnable x suffix = arg [(if x then "--enable-" else "--disable-") ++ suffix]
+    let argEnable x suffix = arg $ (if x then "--enable-" else "--disable-") ++ suffix
     in mconcat
         [ argEnable False "library-for-ghci" -- TODO: why always disable?
         , argEnable (vanilla `elem` ways) "library-vanilla"        
@@ -86,32 +82,31 @@ libraryArgs ways =
 
 configureArgs :: Stage -> Settings -> Args
 configureArgs stage settings = 
-    let argConf key args = joinArgs $ arg ["--configure-option=", key, "="] <> joinArgsWithSpaces args
+    let argConf :: String -> Args -> Args
+        argConf key as = joinArgs "--configure-option=" key "=" as
 
         argConfWith key opt = do
-            value <- option opt
-            when (value /= "") $ argConf ("--with-" ++ key) $ arg [value]
-
-        cflags   = mconcat
-                   [ commonCcArgs `filterOut` ["-Werror"]
-                   , argOption $ ConfCcArgs stage
-                   , customCcArgs settings
-                   , commonCcWarninigArgs
-                   ]
-        ldflags  = mconcat [  commonLdArgs, argOption $ ConfGccLinkerArgs stage,  customLdArgs settings ]
-        cppflags = mconcat [ commonCppArgs, argOption $ ConfCppArgs       stage, customCppArgs settings ]
+            [value] <- showAction opt
+            when (value /= "") $ argConf ("--with-" ++ key) $ arg value
+
+        cflags   = joinArgsSpaced (commonCcArgs `filterOut` ["-Werror"])
+                                  (ConfCcArgs stage)
+                                  (customCcArgs settings)
+                                  (commonCcWarninigArgs)
+        ldflags  = joinArgsSpaced commonLdArgs  (ConfGccLinkerArgs stage) (customLdArgs  settings)
+        cppflags = joinArgsSpaced commonCppArgs (ConfCppArgs       stage) (customCppArgs settings)
                    
     in mconcat
         [ argConf "CFLAGS"   cflags
         , argConf "LDFLAGS"  ldflags
         , argConf "CPPFLAGS" cppflags
-        , joinArgs $ mconcat [arg ["--gcc-options="], cflags, arg [" "], ldflags]
+        , joinArgs "--gcc-options=" cflags " " ldflags
         , argConfWith "iconv-includes"  IconvIncludeDirs
         , argConfWith "iconv-libraries" IconvLibDirs
         , argConfWith "gmp-includes"    GmpIncludeDirs
         , argConfWith "gmp-libraries"   GmpLibDirs
-        , when CrossCompiling $ argConf "--host" $ argOption $ TargetPlatformFull -- TODO: why not host?
-        , argConf "--with-cc" $ argPath Gcc
+        , when CrossCompiling $ argConf "--host" $ arg TargetPlatformFull -- TODO: why not host?
+        , argConf "--with-cc" $ arg Gcc
         ]
 
 buildPackageData :: Package -> TodoItem -> Rules ()
@@ -132,11 +127,11 @@ buildPackageData pkg @ (Package name path _) (stage, dist, settings) =
               where
                 cabalArgs, ghcPkgArgs :: Args
                 cabalArgs = mconcat
-                    [ arg ["configure", path, dist]
+                    [ args "configure" path dist
                     -- this is a positional argument, hence:
                     -- * if it is empty, we need to emit one empty string argument
                     -- * if there are many, we must collapse them into one string argument
-                    , joinArgsWithSpaces $ customDllArgs settings 
+                    , joinArgsSpaced $ customDllArgs settings
                     , with $ Ghc stage -- TODO: used to be stage01 (using max Stage1 GHC)
                     , with $ GhcPkg stage             
 
@@ -155,11 +150,9 @@ buildPackageData pkg @ (Package name path _) (stage, dist, settings) =
                     , with Happy
                     ] -- TODO: reorder with's
 
-                ghcPkgArgs = mconcat
-                    [ arg ["update", "--force"]
-                    , when (stage == Stage0) $ arg ["--package-db=libraries/bootstrapping.conf"]
-                    , arg [path </> dist </> "inplace-pkg-config"]
-                    ]
+                ghcPkgArgs = args "update" "--force"
+                    (when (stage == Stage0) $ arg "--package-db=libraries/bootstrapping.conf")
+                    (path </> dist </> "inplace-pkg-config")
 
 
 -- $1_$2_$3_MOST_DIR_HC_OPTS = \
@@ -239,7 +232,7 @@ buildPackageDeps pkg @ (Package name path _) (stage, dist, settings) =
         run (Ghc stage) $ mconcat
             [ arg ["-M"]
             , wayHcOpts vanilla -- TODO: i) is this needed? ii) shall we run GHC -M multiple times?
-            , splitArgs $ argOption SrcHcOpts
+            , splitArgs $ arg [SrcHcOpts]
             , when (stage == Stage0) $ arg ["-package-db libraries/bootstrapping.conf"]
             , arg [if usePackageKey then "-this-package-key" else "-package-name"]
             , arg [packageKey] -- TODO: check reasoning ($$($4_THIS_PACKAGE_KEY) $$($1_$2_PACKAGE_KEY))