[commit: ghc] wip/nfs-locking: Restrict ShowArgs and args to accept only lists. (9c218ad)
git at git.haskell.org
git at git.haskell.org
Thu Oct 26 23:09:05 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nfs-locking
Link : http://ghc.haskell.org/trac/ghc/changeset/9c218adf6e025572ae550302419f0bcc632d3be6/ghc
>---------------------------------------------------------------
commit 9c218adf6e025572ae550302419f0bcc632d3be6
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date: Thu Jan 22 23:38:46 2015 +0000
Restrict ShowArgs and args to accept only lists.
>---------------------------------------------------------------
9c218adf6e025572ae550302419f0bcc632d3be6
src/Base.hs | 31 +++++++++++--------------------
src/Package/Base.hs | 14 ++++++++------
src/Package/Compile.hs | 2 +-
src/Package/Data.hs | 9 +++++----
src/Package/Dependencies.hs | 6 +++---
5 files changed, 28 insertions(+), 34 deletions(-)
diff --git a/src/Base.hs b/src/Base.hs
index 232bca2..fa9104a 100644
--- a/src/Base.hs
+++ b/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
diff --git a/src/Package/Base.hs b/src/Package/Base.hs
index 88e357f..d54320f 100644
--- a/src/Package/Base.hs
+++ b/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
diff --git a/src/Package/Compile.hs b/src/Package/Compile.hs
index 99aee33..fe9ba73 100644
--- a/src/Package/Compile.hs
+++ b/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] ]
diff --git a/src/Package/Data.hs b/src/Package/Data.hs
index 602993e..5373f6e 100644
--- a/src/Package/Data.hs
+++ b/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 ++ "'."
diff --git a/src/Package/Dependencies.hs b/src/Package/Dependencies.hs
index c861707..8fb27b2 100644
--- a/src/Package/Dependencies.hs
+++ b/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 ]
More information about the ghc-commits
mailing list