Skip to content
GitLab
Commit 7412fe39 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add ShowArg for single string options, clean up code.

parent 3cbacccf
Hide whitespace changes
Inline Side-by-side
src/Base.hs
View file @ 7412fe39
......@@ -8,7 +8,7 @@ module Base (
module Data.Monoid,
module Data.List,
Stage (..),
Args, arg, ShowArgs (..),
Args, arg, ShowArg (..), ShowArgs (..),
Condition (..),
(<+>),
filterOut,
......@@ -37,6 +37,9 @@ instance Monoid a => Monoid (Action a) where
mempty = return mempty
mappend p q = mappend <$> p <*> q
class ShowArg a where
showArg :: a -> Action String
-- Using the Creators' trick for overlapping String instances
class ShowArgs a where
showArgs :: a -> Args
......
src/Config.hs
View file @ 7412fe39
......@@ -3,6 +3,7 @@ module Config (
) where
import Base
import Util
cfgPath :: FilePath
cfgPath = "shake" </> "cfg"
......@@ -10,11 +11,15 @@ cfgPath = "shake" </> "cfg"
autoconfRules :: Rules ()
autoconfRules = do
"configure" %> \out -> do
need ["shake/src/Config.hs"]
copyFile' (cfgPath </> "configure.ac") "configure.ac"
putColoured Vivid White $ "Running autoconf..."
cmd "bash autoconf" -- TODO: get rid of 'bash'
configureRules :: Rules ()
configureRules = do
cfgPath </> "default.config" %> \out -> do
need ["shake/src/Config.hs"]
need [cfgPath </> "default.config.in", "configure"]
putColoured Vivid White "Running configure..."
cmd "bash configure" -- TODO: get rid of 'bash'
src/Oracles.hs
View file @ 7412fe39
......@@ -10,6 +10,7 @@ module Oracles (
import Development.Shake.Config
import qualified Data.HashMap.Strict as M
import Base
import Util
import Config
import Oracles.Base
import Oracles.Flag
......@@ -31,15 +32,21 @@ configOracle = do
++ "' is missing; unwilling to proceed."
return ()
need [defaultConfig]
putNormal $ "Parsing " ++ toStandard defaultConfig ++ "..."
cfgDefault <- liftIO $ readConfigFile defaultConfig
existsUser <- doesFileExist userConfig
cfgUser <- if existsUser
then liftIO $ readConfigFile userConfig
then do
putNormal $ "Parsing "
++ toStandard userConfig ++ "..."
liftIO $ readConfigFile userConfig
else do
putLoud $ "\nUser defined configuration file '"
putColoured Dull Red $
"\nUser defined configuration file '"
++ userConfig ++ "' is missing; "
++ "proceeding with default configuration.\n"
return M.empty
putColoured Vivid Green $ "Finished processing configuration files."
return $ cfgUser `M.union` cfgDefault
addOracle $ \(ConfigKey key) -> M.lookup key <$> cfg ()
return ()
......
src/Oracles/Builder.hs
View file @ 7412fe39
......@@ -30,8 +30,8 @@ data Builder = Ar
| GhcPkg Stage
deriving Show
instance ShowArgs Builder where
showArgs builder = showArgs $ fmap (map toStandard . words) $ do
instance ShowArg Builder where
showArg builder = toStandard <$> do
let key = case builder of
Ar -> "ar"
Ld -> "ld"
......@@ -49,7 +49,7 @@ instance ShowArgs Builder where
cfgPath <- askConfigWithDefault key $
error $ "\nCannot find path to '" ++ key
++ "' in configuration files."
let cfgPathExe = if cfgPath /= "" then cfgPath -<.> exe else ""
let cfgPathExe = if null cfgPath then "" else cfgPath -<.> exe
windows <- windowsHost
-- Note, below is different from FilePath.isAbsolute:
if (windows && "/" `isPrefixOf` cfgPathExe)
......@@ -66,19 +66,17 @@ instance ShowArgs Builder where
-- should reset the flag (at least temporarily).
-- Make sure the builder exists on the given path and rebuild it if out of date
-- Raise an error if the builder is not uniquely specified in config files
needBuilder :: Builder -> Action ()
needBuilder ghc @ (Ghc stage) = do
[exe] <- showArgs ghc
exe <- showArg ghc
laxDeps <- test LaxDeps
if laxDeps then orderOnly [exe] else need [exe]
needBuilder builder = do
[exe] <- showArgs builder
exe <- showArg builder
need [exe]
-- Action 'with Gcc' returns '--with-gcc=/path/to/gcc' and needs Gcc
-- Raises an error if the builder is not uniquely specified in config files
with :: Builder -> Args
with builder = do
let key = case builder of
......@@ -90,17 +88,17 @@ with builder = do
Happy -> "--with-happy="
GhcPkg _ -> "--with-ghc-pkg="
HsColour -> "--with-hscolour="
[exe] <- showArgs builder
exe <- showArg builder
needBuilder builder
arg $ key ++ normaliseEx exe
return [key ++ exe]
-- Run the builder with a given collection of arguments
-- Raises an error if the builder is not uniquely specified in config files
run :: ShowArgs a => Builder -> a -> Action ()
run builder as = do
needBuilder builder
[exe] <- showArgs builder
args <- showArgs as
exe <- showArg builder
args <- showArgs as
cmd [exe] args
-- Run the builder with a given collection of arguments printing out a
......@@ -123,7 +121,7 @@ interestingInfo builder ss = case builder of
Ghc _ -> if head ss == "-M"
then prefixAndSuffix 1 1 ss
else prefixAndSuffix 0 4 ss
GhcPkg _ -> prefixAndSuffix 2 0 ss
GhcPkg _ -> prefixAndSuffix 3 0 ss
GhcCabal -> prefixAndSuffix 3 0 ss
_ -> ss
where
......@@ -136,11 +134,6 @@ interestingInfo builder ss = case builder of
++ " arguments ..."]
++ drop (length ss - m) ss
-- Check if the builder is uniquely specified in config files
-- Check if the builder is specified in config files
specified :: Builder -> Condition
specified builder = do
exes <- showArgs builder
return $ case exes of
[_] -> True
_ -> False
specified = fmap (not . null) . showArg
src/Oracles/Flag.hs
View file @ 7412fe39
......@@ -3,14 +3,15 @@
module Oracles.Flag (
module Control.Monad,
module Prelude,
Flag (..),
test, when, unless, not, (&&), (||), (<?>)
Flag (..),
test, when, unless, not, (&&), (||)
) where
import Control.Monad hiding (when, unless)
import qualified Prelude
import Prelude hiding (not, (&&), (||))
import Base
import Util
import Oracles.Base
data Flag = LaxDeps
......@@ -39,8 +40,8 @@ test flag = do
SplitObjectsBroken -> ("split-objects-broken" , False)
GhcUnregisterised -> ("ghc-unregisterised" , False)
let defaultString = if defaultValue then "YES" else "NO"
value <- askConfigWithDefault key $
do putLoud $ "\nFlag '"
value <- askConfigWithDefault key $ -- TODO: warn just once
do putColoured Dull Red $ "\nFlag '"
++ key
++ "' not set in configuration files. "
++ "Proceeding with default value '"
......@@ -71,10 +72,6 @@ unless x act = do
bool <- toCondition x
if bool then mempty else act
-- Infix version of when
(<?>) :: (ToCondition a, Monoid m) => a -> Action m -> Action m
(<?>) = when
class Not a where
type NotResult a
not :: a -> NotResult a
......
src/Oracles/Option.hs
View file @ 7412fe39
{-# LANGUAGE NoImplicitPrelude #-}
module Oracles.Option (
Option (..),
Option (..), MultiOption (..),
ghcWithInterpreter, platformSupportsSharedLibs, windowsHost, splitObjects
) where
......@@ -10,47 +10,56 @@ import Oracles.Base
-- For each Option the files {default.config, user.config} contain
-- a line of the form 'target-os = mingw32'.
-- (showArgs TargetOS) is an action that consults the config files
-- and returns ["mingw32"].
-- TODO: separate single string options from multiple string ones.
data Option = TargetOS
-- (showArg TargetOs) is an action that consults the config files
-- and returns "mingw32".
--
-- MultiOption is used for multiple string options separated by spaces,
-- such as 'src-hc-args' = -H32m -O'.
-- (showArgs SrcHcArgs) therefore returns a list of strings ["-H32", "-O"].
data Option = TargetOs
| TargetArch
| TargetPlatformFull
| ConfCcArgs Stage
| ConfGccLinkerArgs Stage
| ConfLdLinkerArgs Stage
| ConfCppArgs Stage
| IconvIncludeDirs
| IconvLibDirs
| GmpIncludeDirs
| GmpLibDirs
| SrcHcOpts
| HostOsCpp
| DynamicExtension
| ProjectVersion
instance ShowArgs Option where
showArgs opt = showArgs $ fmap words $ askConfig $ case opt of
TargetOS -> "target-os"
data MultiOption = SrcHcArgs
| ConfCcArgs Stage
| ConfGccLinkerArgs Stage
| ConfLdLinkerArgs Stage
| ConfCppArgs Stage
| IconvIncludeDirs
| IconvLibDirs
| GmpIncludeDirs
| GmpLibDirs
instance ShowArg Option where
showArg opt = askConfig $ case opt of
TargetOs -> "target-os"
TargetArch -> "target-arch"
TargetPlatformFull -> "target-platform-full"
ConfCcArgs stage -> "conf-cc-args-stage-" ++ show stage
ConfCppArgs stage -> "conf-cpp-args-stage-" ++ show stage
ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage-" ++ show stage
ConfLdLinkerArgs stage -> "conf-ld-linker-args-stage-" ++ show stage
HostOsCpp -> "host-os-cpp"
DynamicExtension -> "dynamic-extension"
ProjectVersion -> "project-version"
instance ShowArgs MultiOption where
showArgs opt = showArgs $ fmap words $ askConfig $ case opt of
SrcHcArgs -> "src-hc-args"
ConfCcArgs stage -> "conf-cc-args" ++ showStage stage
ConfCppArgs stage -> "conf-cpp-args" ++ showStage stage
ConfGccLinkerArgs stage -> "conf-gcc-linker-args" ++ showStage stage
ConfLdLinkerArgs stage -> "conf-ld-linker-args" ++ showStage stage
IconvIncludeDirs -> "iconv-include-dirs"
IconvLibDirs -> "iconv-lib-dirs"
GmpIncludeDirs -> "gmp-include-dirs"
GmpLibDirs -> "gmp-lib-dirs"
SrcHcOpts -> "src-hc-opts"
HostOsCpp -> "host-os-cpp"
DynamicExtension -> "dynamic-extension"
ProjectVersion -> "project-version"
where
showStage = ("-stage-" ++) . show
ghcWithInterpreter :: Condition
ghcWithInterpreter = do
[os] <- showArgs TargetOS
[arch] <- showArgs TargetArch
os <- showArg TargetOs
arch <- showArg TargetArch
return $
os `elem` ["mingw32", "cygwin32", "linux", "solaris2",
"freebsd", "dragonfly", "netbsd", "openbsd",
......@@ -60,7 +69,7 @@ ghcWithInterpreter = do
platformSupportsSharedLibs :: Condition
platformSupportsSharedLibs = do
[platform] <- showArgs TargetPlatformFull
platform <- showArg TargetPlatformFull
solarisBrokenShld <- test SolarisBrokenShld
return $ notElem platform $
["powerpc-unknown-linux",
......@@ -70,19 +79,17 @@ platformSupportsSharedLibs = do
windowsHost :: Condition
windowsHost = do
[hostOsCpp] <- showArgs HostOsCpp
hostOsCpp <- showArg HostOsCpp
return $ hostOsCpp `elem` ["mingw32", "cygwin32"]
-- TODO: refactor helper Condition functions into a separate file
splitObjects :: Stage -> Condition
splitObjects stage = do
[os] <- showArgs TargetOS
[arch] <- showArgs TargetArch
splitObjectsBroken <- test SplitObjectsBroken
ghcUnregisterised <- test GhcUnregisterised
return $ not splitObjectsBroken && not ghcUnregisterised
&& stage == Stage1
&& arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
&& os `elem` ["mingw32", "cygwin32", "linux", "darwin",
"solaris2", "freebsd", "dragonfly", "netbsd",
"openbsd"]
arch <- showArg TargetArch
os <- showArg TargetOs
not SplitObjectsBroken && not GhcUnregisterised
&& stage == Stage1
&& arch `elem` ["i386", "x86_64", "powerpc", "sparc"]
&& os `elem` ["mingw32", "cygwin32", "linux", "darwin",
"solaris2", "freebsd", "dragonfly", "netbsd",
"openbsd"]
src/Util.hs
View file @ 7412fe39
......@@ -35,6 +35,7 @@ chunksOfSize size ss = reverse chunk : chunksOfSize size rest
then (chunk , s:ss)
else (newChunk, rest)
-- A more colourful version of Shake's putNormal
putColoured :: ColorIntensity -> Color -> String -> Action ()
putColoured intensity colour msg = do
liftIO $ setSGR [SetColor Foreground intensity colour]
......
src/Ways.hs
View file @ 7412fe39
{-# LANGUAGE NoImplicitPrelude #-}
module Ways (
WayUnit (..),
Way, tag,
allWays, defaultWays,
Way, tag,
vanilla, profiling, logging, parallel, granSim,
threaded, threadedProfiling, threadedLogging,
allWays, defaultWays,
vanilla, profiling, logging, parallel, granSim,
threaded, threadedProfiling, threadedLogging,
debug, debugProfiling, threadedDebug, threadedDebugProfiling,
dynamic, profilingDynamic, threadedProfilingDynamic,
threadedDynamic, threadedDebugDynamic, debugDynamic,
loggingDynamic, threadedLoggingDynamic,
wayHcArgs,
wayHcArgs,
wayPrefix,
hisuf, osuf, hcsuf, obootsuf, ssuf, libsuf,
detectWay
......@@ -61,8 +61,8 @@ debugDynamic = Way "debug_dyn" [Debug, Dynamic]
loggingDynamic = Way "l_dyn" [Logging, Dynamic]
threadedLoggingDynamic = Way "thr_l_dyn" [Threaded, Logging, Dynamic]
allWays = [vanilla, profiling, logging, parallel, granSim,
threaded, threadedProfiling, threadedLogging,
allWays = [vanilla, profiling, logging, parallel, granSim,
threaded, threadedProfiling, threadedLogging,
debug, debugProfiling, threadedDebug, threadedDebugProfiling,
dynamic, profilingDynamic, threadedProfilingDynamic,
threadedDynamic, threadedDebugDynamic, debugDynamic,
......@@ -72,22 +72,23 @@ defaultWays :: Stage -> Action [Way]
defaultWays stage = do
sharedLibs <- platformSupportsSharedLibs
return $ [vanilla]
++ [profiling | stage /= Stage0]
++ [profiling | stage /= Stage0]
++ [dynamic | sharedLibs ]
-- TODO: do '-ticky' in all debug ways?
wayHcArgs :: Way -> Args
wayHcArgs (Way _ units) =
(Dynamic `notElem` units) <?> arg "-static"
<> (Dynamic `elem` units) <?> arg ["-fPIC", "-dynamic"]
<> (Threaded `elem` units) <?> arg "-optc-DTHREADED_RTS"
<> (Debug `elem` units) <?> arg "-optc-DDEBUG"
<> (Profiling `elem` units) <?> arg "-prof"
<> (Logging `elem` units) <?> arg "-eventlog"
<> (Parallel `elem` units) <?> arg "-parallel"
<> (GranSim `elem` units) <?> arg "-gransim"
<> (units == [Debug] || units == [Debug, Dynamic]) <?>
arg ["-ticky", "-DTICKY_TICKY"]
wayHcArgs (Way _ units) = arg
[ if (Dynamic `elem` units)
then arg ["-fPIC", "-dynamic"]
else arg "-static"
, when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
, when (Debug `elem` units) $ arg "-optc-DDEBUG"
, when (Profiling `elem` units) $ arg "-prof"
, when (Logging `elem` units) $ arg "-eventlog"
, when (Parallel `elem` units) $ arg "-parallel"
, when (GranSim `elem` units) $ arg "-gransim"
, when (units == [Debug] || units == [Debug, Dynamic]) $
arg ["-ticky", "-DTICKY_TICKY"] ]
wayPrefix :: Way -> String
wayPrefix way | way == vanilla = ""
......@@ -110,8 +111,8 @@ libsuf way = do
if Dynamic `notElem` units way
then return $ staticSuffix ++ "a"
else do
[extension] <- showArgs DynamicExtension
[version] <- showArgs ProjectVersion
extension <- showArg DynamicExtension
version <- showArg ProjectVersion
return $ staticSuffix ++ "-ghc" ++ version ++ extension
-- TODO: This may be slow -- optimise if overhead is significant.
......
Supports Markdown
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