Commit 772ea960 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Refactor Oracles/Builder.hs.

parent c319fbbf
{-# LANGUAGE DeriveGeneric #-}
module Oracles.Builder (
Builder (..), builderKey, withBuilderKey,
with, run, verboseRun, specified
module Builder (
Builder (..), builderKey, builderPath, needBuilder
) where
import Data.Char
import Base
import Util
import Oracles.Flag
import Oracles.Base
import Oracles.Flag
import Oracles.Option
import GHC.Generics
import Development.Shake.Classes
......@@ -33,10 +31,7 @@ data Builder = Ar
| GhcPkg Stage
deriving (Show, Eq, Generic)
-- Instances for storing Target in the Shake database
instance Binary Builder
instance Hashable Builder
-- Configuration files refer to Builders as follows:
builderKey :: Builder -> String
builderKey builder = case builder of
Ar -> "ar"
......@@ -54,20 +49,26 @@ builderKey builder = case builder of
GhcPkg Stage0 -> "system-ghc-pkg"
GhcPkg _ -> "ghc-pkg"
instance ShowArg Builder where
showArg builder = toStandard <$> do
cfgPath <- askConfigWithDefault (builderKey builder) $
builderPath :: Builder -> Action String
builderPath builder = do
path <- askConfigWithDefault (builderKey builder) $
redError $ "\nCannot find path to '" ++ (builderKey builder)
++ "' in configuration files."
let cfgPathExe = if null cfgPath then "" else cfgPath -<.> exe
windows <- windowsHost
-- Note, below is different from FilePath.isAbsolute:
if (windows && "/" `isPrefixOf` cfgPathExe)
then do
Stdout out <- quietly $ cmd ["cygpath", "-m", "/"]
return $ dropWhileEnd isSpace out ++ drop 1 cfgPathExe
else
return cfgPathExe
fixAbsolutePathOnWindows $ if null path then "" else path -<.> exe
-- TODO: get rid of code duplication (windowsHost)
-- On Windows: if the path starts with "/", prepend it with the correct path to
-- the root, e.g: "/usr/local/bin/ghc.exe" => "C:/msys/usr/local/bin/ghc.exe".
fixAbsolutePathOnWindows :: FilePath -> Action FilePath
fixAbsolutePathOnWindows path = do
windows <- windowsHost
-- Note, below is different from FilePath.isAbsolute:
if (windows && "/" `isPrefixOf` path)
then do
Stdout out <- quietly $ cmd ["cygpath", "-m", "/"]
return . unifyPath $ dropWhileEnd isSpace out ++ drop 1 path
else
return path
-- When LaxDeps flag is set ('lax-dependencies = YES' in user.config),
-- dependencies on the GHC executable are turned into order-only dependencies
......@@ -78,77 +79,14 @@ instance ShowArg Builder where
-- Make sure the builder exists on the given path and rebuild it if out of date
needBuilder :: Builder -> Action ()
needBuilder ghc @ (Ghc stage) = do
exe <- showArg ghc
path <- builderPath ghc
laxDeps <- test LaxDeps
if laxDeps then orderOnly [exe] else need [exe]
if laxDeps then orderOnly [path] else need [path]
needBuilder builder = do
exe <- showArg builder
need [exe]
-- Action 'with Gcc' returns '--with-gcc=/path/to/gcc' and needs Gcc
with :: Builder -> Action String
with builder = do
exe <- showArg builder
needBuilder builder
return $ withBuilderKey builder ++ exe
path <- builderPath builder
need [path]
withBuilderKey :: Builder -> String
withBuilderKey builder = case builder of
Ar -> "--with-ar="
Ld -> "--with-ld="
Gcc _ -> "--with-gcc="
Ghc _ -> "--with-ghc="
Alex -> "--with-alex="
Happy -> "--with-happy="
GhcPkg _ -> "--with-ghc-pkg="
HsColour -> "--with-hscolour="
_ -> error "withBuilderKey: not supported builder"
-- Run the builder with a given collection of arguments
verboseRun :: ShowArgs a => Builder -> a -> Action ()
verboseRun builder as = do
needBuilder builder
exe <- showArg builder
args <- showArgs as
cmd [exe] args
-- Run the builder with a given collection of arguments printing out a
-- terse commentary with only 'interesting' info for the builder.
run :: ShowArgs a => Builder -> a -> Action ()
run builder as = do
args <- showArgs as
putColoured White $ "/--------\n" ++
"| Running " ++ show builder ++ " with arguments:"
mapM_ (putColoured White . ("| " ++)) $
interestingInfo builder args
putColoured White $ "\\--------"
quietly $ verboseRun builder as
interestingInfo :: Builder -> [String] -> [String]
interestingInfo builder ss = case builder of
Ar -> prefixAndSuffix 2 1 ss
Ld -> prefixAndSuffix 4 0 ss
Gcc _ -> if head ss == "-MM"
then prefixAndSuffix 1 1 ss
else prefixAndSuffix 0 4 ss
Ghc _ -> if head ss == "-M"
then prefixAndSuffix 1 1 ss
else prefixAndSuffix 0 4 ss
GhcPkg _ -> prefixAndSuffix 3 0 ss
GhcCabal -> prefixAndSuffix 3 0 ss
_ -> ss
where
prefixAndSuffix n m ss =
if length ss <= n + m + 1
then ss
else take n ss
++ ["... skipping "
++ show (length ss - n - m)
++ " arguments ..."]
++ drop (length ss - m) ss
-- TODO: remove?
-- Check if the builder is specified in config files
specified :: Builder -> Action Bool
specified = fmap (not . null) . showArg
-- Instances for storing Target in the Shake database
instance Binary Builder
instance Hashable Builder
......@@ -13,10 +13,10 @@ module Expression (
import Base
import Ways
import Builder
import Package
import Target
import Oracles.Base
import Oracles.Builder
import Package
import Data.Monoid
import Control.Monad.Reader hiding (liftIO)
......
module Rules.Actions (
build, run, verboseRun,
) where
import Base
import Util
import Builder
import Settings
import Expression
import Oracles.ArgsHash
-- Build a given target using an appropriate builder. Force a rebuilt if the
-- argument list has changed since the last built (that is, track changes in
-- the build system).
build :: FullTarget -> Action ()
build target = do
argList <- interpret target args
putColoured Green (show target)
putColoured Green (show argList)
-- The line below forces the rule to be rerun if the args hash has changed
argsHash <- askArgsHash target
run (getBuilder target) argList
-- Run the builder with a given collection of arguments
verboseRun :: Builder -> [String] -> Action ()
verboseRun builder args = do
needBuilder builder
path <- builderPath builder
cmd [path] args
-- Run the builder with a given collection of arguments printing out a
-- terse commentary with only 'interesting' info for the builder.
run :: Builder -> [String] -> Action ()
run builder args = do
putColoured White $ "/--------\n" ++
"| Running " ++ show builder ++ " with arguments:"
mapM_ (putColoured White . ("| " ++)) $ interestingInfo builder args
putColoured White $ "\\--------"
quietly $ verboseRun builder args
interestingInfo :: Builder -> [String] -> [String]
interestingInfo builder ss = case builder of
Ar -> prefixAndSuffix 2 1 ss
Ld -> prefixAndSuffix 4 0 ss
Gcc _ -> if head ss == "-MM"
then prefixAndSuffix 1 1 ss
else prefixAndSuffix 0 4 ss
Ghc _ -> if head ss == "-M"
then prefixAndSuffix 1 1 ss
else prefixAndSuffix 0 4 ss
GhcPkg _ -> prefixAndSuffix 3 0 ss
GhcCabal -> prefixAndSuffix 3 0 ss
_ -> ss
where
prefixAndSuffix n m ss =
if length ss <= n + m + 1
then ss
else take n ss
++ ["... skipping "
++ show (length ss - n - m)
++ " arguments ..."]
++ drop (length ss - m) ss
......@@ -6,13 +6,13 @@ module Rules.Data (
import Base
import Package
import Builder
import Expression
import Control.Monad.Extra
import Oracles.Builder
import Settings.GhcPkg
import Settings.GhcCabal
import Settings.TargetDirectory
import Rules.Util
import Rules.Actions
import Util
import Ways
......
module Rules.Util (
build
) where
import Base
import Util
import Settings
import Expression
import Oracles.Builder
import Oracles.ArgsHash
build :: FullTarget -> Action ()
build target = do
argList <- interpret target args
putColoured Green (show target)
putColoured Green (show argList)
-- The line below forces the rule to be rerun if the args hash has changed
argsHash <- askArgsHash target
run (getBuilder target) argList
......@@ -3,11 +3,11 @@ module Settings.GhcCabal (
) where
import Base
import Oracles.Base
import Oracles.Builder
import Builder
import Package
import Ways
import Util
import Package
import Oracles.Base
import Switches
import Expression
import Settings.User
......@@ -24,18 +24,18 @@ cabalArgs = builder GhcCabal ? do
, arg $ pkgPath pkg
, arg $ targetDirectory stage pkg
, dllArgs
, argWith $ Ghc stage
, argWith $ GhcPkg stage
, with $ Ghc stage
, with $ GhcPkg stage
, stage0 ? bootPackageDbArgs
, libraryArgs
, configKeyNonEmpty "hscolour" ? argWith HsColour
, configKeyNonEmpty "hscolour" ? with HsColour
, configureArgs
, stage0 ? packageConstraints
, argWith $ Gcc stage
, notStage Stage0 ? argWith Ld
, argWith Ar
, argWith Alex
, argWith Happy ]
, with $ Gcc stage
, notStage Stage0 ? with Ld
, with Ar
, with Alex
, with Happy ]
-- TODO: Isn't vanilla always built? If yes, some conditions are redundant.
libraryArgs :: Args
......@@ -76,7 +76,7 @@ configureArgs = do
, conf "--with-gmp-libraries" $ argConfig "gmp-lib-dirs"
-- TODO: why TargetPlatformFull and not host?
, crossCompiling ? (conf "--host" $ argConfig "target-platform-full")
, conf "--with-cc" . argM . showArg $ Gcc stage ]
, conf "--with-cc" . argM . builderPath $ Gcc stage ]
bootPackageDbArgs :: Args
bootPackageDbArgs = do
......@@ -134,3 +134,22 @@ customPackageArgs = mconcat
, package ghcPrim ?
builder GhcCabal ? arg "--flag=include-ghc-prim" ]
withBuilderKey :: Builder -> String
withBuilderKey builder = case builder of
Ar -> "--with-ar="
Ld -> "--with-ld="
Gcc _ -> "--with-gcc="
Ghc _ -> "--with-ghc="
Alex -> "--with-alex="
Happy -> "--with-happy="
GhcPkg _ -> "--with-ghc-pkg="
HsColour -> "--with-hscolour="
_ -> error "withBuilderKey: not supported builder"
-- Expression 'with Gcc' appends "--with-gcc=/path/to/gcc" and needs Gcc.
with :: Builder -> Args
with builder = do
path <- lift $ builderPath builder
lift $ needBuilder builder
append [withBuilderKey builder ++ path]
......@@ -3,10 +3,10 @@ module Settings.GhcPkg (
) where
import Base
import Builder
import Switches
import Expression
import Settings.Util
import Oracles.Builder
import Settings.GhcCabal
import Settings.TargetDirectory
......
module Settings.Util (
-- Primitive settings elements
arg, argM, argWith,
arg, argM,
argConfig, argStagedConfig, argConfigList, argStagedConfigList,
appendCcArgs,
-- argBuilderPath, argStagedBuilderPath,
......@@ -12,8 +12,8 @@ module Settings.Util (
) where
import Base
import Builder
import Oracles.Base
import Oracles.Builder
import Expression
-- A single argument
......@@ -23,9 +23,6 @@ arg = append . return
argM :: Action String -> Args
argM = appendM . fmap return
argWith :: Builder -> Args
argWith = argM . with
argConfig :: String -> Args
argConfig = appendM . fmap return . askConfig
......
......@@ -7,7 +7,7 @@ module Target (
import Base
import Ways
import Package
import Oracles.Builder
import Builder
import GHC.Generics
import Development.Shake.Classes
......
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