Restrict ShowArgs and args to accept only lists.

src/Base.hs

@@ -12,7 +12,6 @@ module Base (
     ShowArg (..), ShowArgs (..),
     arg, args,
     Condition (..),
-    (<+>),
     filterOut,
     productArgs, concatArgs
     ) where
@@ -49,34 +48,26 @@ instance ShowArg String where
 instance ShowArg a => ShowArg (Action a) where
     showArg = (showArg =<<)
 
--- Using the Creators' trick for overlapping String instances
 class ShowArgs a where
-    showArgs     :: a -> Args
-    showListArgs :: [a] -> Args
-    showListArgs = mconcat . map showArgs
+    showArgs :: a -> Args
 
-instance ShowArgs Char where
-    showArgs c     = return [[c]]
-    showListArgs s = return [s]
+instance ShowArgs [String] where
+    showArgs = return
 
-instance ShowArgs a => ShowArgs [a] where
-    showArgs = showListArgs
+instance ShowArgs [Arg] where
+    showArgs = sequence
+
+instance ShowArgs [Args] where
+    showArgs = mconcat
 
 instance ShowArgs a => ShowArgs (Action a) where
     showArgs = (showArgs =<<)
 
--- TODO: improve args type safety
 args :: ShowArgs a => a -> Args
 args = showArgs
 
 arg :: ShowArg a => a -> Args
-arg = args . showArg
-
--- Combine two heterogeneous ShowArgs values
-(<+>) :: (ShowArgs a, ShowArgs b) => a -> b -> Args
-a <+> b = (<>) <$> showArgs a <*> showArgs b
-
-infixr 6 <+>
+arg a = args [showArg a]
 
 -- Filter out given arg(s) from a collection
 filterOut :: ShowArgs a => Args -> a -> Args
@@ -85,7 +76,7 @@ filterOut as exclude = do
     filter (`notElem` exclude') <$> as
 
 -- Generate a cross product collection of two argument collections
--- Example: productArgs ["-a", "-b"] "c" = arg ["-a", "c", "-b", "c"]
+-- Example: productArgs ["-a", "-b"] "c" = args ["-a", "c", "-b", "c"]
 productArgs :: (ShowArgs a, ShowArgs b) => a -> b -> Args
 productArgs as bs = do
     as' <- showArgs as
@@ -93,7 +84,7 @@ productArgs as bs = do
     return $ concat $ sequence [as', bs']
 
 -- Similar to productArgs but concat resulting arguments pairwise
--- Example: concatArgs ["-a", "-b"] "c" = arg ["-ac", "-bc"]
+-- Example: concatArgs ["-a", "-b"] "c" = args ["-ac", "-bc"]
 concatArgs :: (ShowArgs a, ShowArgs b) => a -> b -> Args
 concatArgs as bs = do
     as' <- showArgs as

src/Package/Base.hs

@@ -122,10 +122,11 @@ packageArgs stage pathDist = do
          , when (stage == Stage0) $
            arg "-package-db libraries/bootstrapping.conf"
          , if usePackageKey
-           then productArgs "-this-package-key" (arg  $ PackageKey pathDist)
-             <> productArgs "-package-key"      (args $ DepKeys    pathDist)
-           else productArgs "-package-name"     (arg  $ PackageKey pathDist)
-             <> productArgs "-package"          (args $ Deps       pathDist) ]
+           then productArgs ["-this-package-key"] [arg  $ PackageKey pathDist]
+             <> productArgs ["-package-key"     ] [args $ DepKeys    pathDist]
+           else productArgs ["-package-name"    ] [arg  $ PackageKey pathDist]
+             <> productArgs ["-package"         ] [args $ Deps       pathDist]
+         ]
 
 includeGccArgs :: FilePath -> FilePath -> Args
 includeGccArgs path dist =
@@ -145,8 +146,9 @@ includeGhcArgs path dist =
               [buildDir, unifyPath $ buildDir </> "autogen"]
             , pathArgs "-I" path $ IncludeDirs pathDist
             , arg "-optP-include" -- TODO: Shall we also add -cpp?
-            , concatArgs "-optP" $
-              unifyPath $ buildDir </> "autogen/cabal_macros.h" ]
+            , concatArgs ["-optP"]
+              [unifyPath $ buildDir </> "autogen/cabal_macros.h"]
+            ]
 
 pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
 pkgHsSources path dist = do

src/Package/Compile.hs

@@ -23,7 +23,7 @@ ghcArgs (Package _ path _ _) (stage, dist, _) way srcs result =
             , args $ HsArgs pathDist
             -- TODO: now we have both -O and -O2
             -- <> arg ["-O2"]
-            , productArgs ["-odir", "-hidir", "-stubdir"] buildDir
+            , productArgs ["-odir", "-hidir", "-stubdir"] [buildDir]
             , when (splitObjects stage) $ arg "-split-objs"
             , args ("-c":srcs)
             , args ["-o", result] ]

src/Package/Data.hs

@@ -24,7 +24,7 @@ configureArgs stage settings =
     let conf key as = do
             s <- unwords <$> args as
             unless (null s) $ arg $ "--configure-option=" ++ key ++ "=" ++ s
-        cflags   = [ commonCcArgs `filterOut` "-Werror"
+        cflags   = [ commonCcArgs `filterOut` ["-Werror"]
                    , args $ ConfCcArgs stage
                    -- , customCcArgs settings -- TODO: bring this back
                    , commonCcWarninigArgs ] -- TODO: check why cflags are glued
@@ -37,7 +37,8 @@ configureArgs stage settings =
     in args [ conf "CFLAGS"   cflags
             , conf "LDFLAGS"  ldflags
             , conf "CPPFLAGS" cppflags
-            , arg $ concat <$> "--gcc-options=" <+> cflags <+> " " <+> ldflags
+            , arg $ concat <$>
+              arg "--gcc-options=" <> args cflags <> arg " " <> args ldflags
             , conf "--with-iconv-includes"  IconvIncludeDirs
             , conf "--with-iconv-libraries" IconvLibDirs
             , conf "--with-gmp-includes"    GmpIncludeDirs
@@ -73,8 +74,8 @@ bootPkgConstraints = args $ do
         content <- lines <$> liftIO (readFile cabal)
         let versionLines = filter (("ersion:" `isPrefixOf`) . drop 1) content
         case versionLines of
-            [versionLine] -> args ["--constraint", depName ++ " == "
-                                    ++ dropWhile (not . isDigit) versionLine ]
+            [versionLine] -> return $ "--constraint " ++ depName ++ " == "
+                                    ++ dropWhile (not . isDigit) versionLine
             _             -> redError $ "Cannot determine package version in '"
                                       ++ unifyPath cabal ++ "'."
 

src/Package/Dependencies.hs

@@ -16,9 +16,9 @@ ghcArgs (Package name path _ _) (stage, dist, settings) =
             , packageArgs stage pathDist
             , includeGhcArgs path dist
             , concatArgs ["-optP"] $ CppArgs pathDist
-            , productArgs ["-odir", "-stubdir", "-hidir"] buildDir
-            , args ["-dep-makefile", depFile ]
-            , productArgs "-dep-suffix" $ map wayPrefix <$> ways settings
+            , productArgs ["-odir", "-stubdir", "-hidir"] [buildDir]
+            , args ["-dep-makefile", depFile]
+            , productArgs ["-dep-suffix"] $ map wayPrefix <$> ways settings
             , args $ HsArgs pathDist
             , args $ pkgHsSources path dist ]