Commit 9c218adf authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Restrict ShowArgs and args to accept only lists.

parent 7c2279b5
......@@ -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
......
......@@ -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
......
......@@ -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] ]
......
......@@ -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 ++ "'."
......
......@@ -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 ]
......
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