Commit a4f318fd authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor using variadic args.

parent c6870b2f
......@@ -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
......
......@@ -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 /= ""
......@@ -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
......
......@@ -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"]
{-# 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))
......
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