Commit 5c1a7e4e authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Make single and multiple string options type safe.

parent 5a9b0a74
......@@ -8,7 +8,9 @@ module Base (
module Data.Monoid,
module Data.List,
Stage (..),
Args, arg, ShowArg (..), ShowArgs (..),
Arg, Args,
ShowArg (..), ShowArgs (..),
arg, args,
Condition (..),
(<+>),
filterOut,
......@@ -27,8 +29,9 @@ data Stage = Stage0 | Stage1 | Stage2 | Stage3 deriving (Eq, Enum)
instance Show Stage where
show = show . fromEnum
-- The returned list of strings is a list of arguments
-- The returned string or list of strings is a part of an argument list
-- to be passed to a Builder
type Arg = Action String
type Args = Action [String]
type Condition = Action Bool
......@@ -38,7 +41,13 @@ instance Monoid a => Monoid (Action a) where
mappend p q = mappend <$> p <*> q
class ShowArg a where
showArg :: a -> Action String
showArg :: a -> Arg
instance ShowArg String where
showArg = return
instance ShowArg a => ShowArg (Action a) where
showArg = (showArg =<<)
-- Using the Creators' trick for overlapping String instances
class ShowArgs a where
......@@ -56,8 +65,11 @@ instance ShowArgs a => ShowArgs [a] where
instance ShowArgs a => ShowArgs (Action a) where
showArgs = (showArgs =<<)
arg :: ShowArgs a => a -> Args
arg = showArgs
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
......
......@@ -14,7 +14,7 @@ import Oracles.Base
-- and returns "mingw32".
--
-- MultiOption is used for multiple string options separated by spaces,
-- such as 'src-hc-args' = -H32m -O'.
-- such as 'src-hc-args = -H32m -O'.
-- (showArgs SrcHcArgs) therefore returns a list of strings ["-H32", "-O"].
data Option = TargetOs
| TargetArch
......
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Oracles.PackageData (
PackageDataKey (..),
PackageData (..)
PackageData (..), MultiPackageData (..),
PackageDataKey (..)
) where
import Development.Shake.Classes
import Base
import Util
import Data.Maybe
newtype PackageDataKey = PackageDataKey (FilePath, String)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
-- For each (PackageData path) the file 'path/package-data.mk' contains
-- a line of the form 'path_VERSION = 1.2.3.4'.
-- (showArg $ PackageData path) is an action that consults the file and
-- returns "1.2.3.4".
--
-- MultiPackageData is used for multiple string options separated by spaces,
-- such as 'path_MODULES = Data.Array Data.Array.Base ...'.
-- (showArgs Modules) therefore returns ["Data.Array", "Data.Array.Base", ...].
data PackageData = Version FilePath
| Modules FilePath
| SrcDirs FilePath
| PackageKey FilePath
| IncludeDirs FilePath
| Deps FilePath
| DepKeys FilePath
| DepNames FilePath
| Synopsis FilePath
| CppOpts FilePath
| HsOpts FilePath
instance ShowArgs PackageData where
data MultiPackageData = Modules FilePath
| SrcDirs FilePath
| IncludeDirs FilePath
| Deps FilePath
| DepKeys FilePath
| DepNames FilePath
| CppArgs FilePath
| HsArgs FilePath
newtype PackageDataKey = PackageDataKey (FilePath, String)
deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
instance ShowArg PackageData where
showArg packageData = do
let (key, path) = case packageData of
Version path -> ("VERSION" , path)
PackageKey path -> ("PACKAGE_KEY" , path)
Synopsis path -> ("SYNOPSIS" , path)
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ fromMaybe
(error $ "No key '" ++ key ++ "' in " ++ toStandard pkgData ++ ".")
res
instance ShowArgs MultiPackageData where
showArgs packageData = do
let (key, file, defaultValue) = case packageData of
Version file -> ("VERSION" , file, "" )
Modules file -> ("MODULES" , file, "" )
SrcDirs file -> ("HS_SRC_DIRS" , file, ".")
PackageKey file -> ("PACKAGE_KEY" , file, "" )
IncludeDirs file -> ("INCLUDE_DIRS", file, ".")
Deps file -> ("DEPS" , file, "" )
DepKeys file -> ("DEP_KEYS" , file, "" )
DepNames file -> ("DEP_NAMES" , file, "" )
Synopsis file -> ("SYNOPSIS" , file, "" )
CppOpts file -> ("CPP_OPTS" , file, "" )
HsOpts file -> ("HC_OPTS" , file, "" )
fullKey = replaceSeparators '_' $ file ++ "_" ++ key
pkgData = file </> "package-data.mk"
let (key, path, defaultValue) = case packageData of
Modules path -> ("MODULES" , path, "" )
SrcDirs path -> ("HS_SRC_DIRS" , path, ".")
IncludeDirs path -> ("INCLUDE_DIRS", path, ".")
Deps path -> ("DEPS" , path, "" )
DepKeys path -> ("DEP_KEYS" , path, "" )
DepNames path -> ("DEP_NAMES" , path, "" )
CppArgs path -> ("CPP_OPTS" , path, "" )
HsArgs path -> ("HC_OPTS" , path, "" )
fullKey = replaceSeparators '_' $ path ++ "_" ++ key
pkgData = path </> "package-data.mk"
res <- askOracle $ PackageDataKey (pkgData, fullKey)
return $ words $ case res of
Nothing -> error $ "No key '" ++ key ++ "' in "
......
......@@ -10,12 +10,12 @@ import Targets
-- See Package.Base for definitions of basic types
packages :: [Package]
packages = map lib $ libraryPackageNames Stage1
packages = map lib $ libraryPackages
where
lib name =
libraryPackage
name
[s | s <- [Stage0, Stage1], name `elem` (libraryPackageNames s)]
[s | s <- [Stage0 ..], name `elem` (libraryPackagesInStage s)]
defaultSettings
-- Rule buildPackageX is defined in module Package.X
......
......@@ -52,14 +52,14 @@ libraryPackage :: String -> [Stage] -> (Stage -> Settings) -> Package
libraryPackage name stages settings =
Package
name
(toStandard $ "libraries" </> name)
("libraries" </> name)
[ (stage
, if stage == Stage0 then "dist-boot" else "dist-install"
, settings stage)
| stage <- stages ]
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?
......@@ -68,48 +68,47 @@ commonCppArgs :: Args
commonCppArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?
commonCcWarninigArgs :: Args
commonCcWarninigArgs = when Validating $ arg
[ 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" ]
commonCcWarninigArgs = when Validating $
args [ 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" ]
pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
pathArgs key path as =
map (\a -> key ++ toStandard (normaliseEx $ path </> a)) <$> arg as
map (\a -> key ++ toStandard (normaliseEx $ path </> a)) <$> args as
packageArgs :: Stage -> FilePath -> Args
packageArgs stage pathDist = do
usePackageKey <- SupportsPackageKey || stage /= Stage0
arg [ arg "-hide-all-packages"
, arg "-no-user-package-db"
, arg "-include-pkg-deps"
, when (stage == Stage0) $
arg "-package-db libraries/bootstrapping.conf"
, keyArgs usePackageKey ]
where
keyArgs True = productArgs "-this-package-key" (PackageKey pathDist) <>
productArgs "-package-key" (DepKeys pathDist)
keyArgs False = productArgs "-package-name" (PackageKey pathDist) <>
productArgs "-package" (Deps pathDist)
args [ arg "-hide-all-packages"
, arg "-no-user-package-db"
, arg "-include-pkg-deps"
, 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) ]
includeArgs :: FilePath -> FilePath -> Args
includeArgs path dist =
let pathDist = path </> dist
buildDir = toStandard $ pathDist </> "build"
in arg [ arg "-i"
, pathArgs "-i" path $ SrcDirs pathDist
, concatArgs ["-i", "-I"]
[buildDir, toStandard $ buildDir </> "autogen"]
, pathArgs "-I" path $ IncludeDirs pathDist
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, concatArgs "-optP" $
toStandard $ buildDir </> "autogen/cabal_macros.h" ]
in args [ arg "-i"
, pathArgs "-i" path $ SrcDirs pathDist
, concatArgs ["-i", "-I"]
[buildDir, toStandard $ buildDir </> "autogen"]
, pathArgs "-I" path $ IncludeDirs pathDist
, arg "-optP-include" -- TODO: Shall we also add -cpp?
, concatArgs "-optP" $
toStandard $ buildDir </> "autogen/cabal_macros.h" ]
pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
pkgHsSources path dist = do
let pathDist = path </> dist
dirs <- map (path </>) <$> arg (SrcDirs pathDist)
dirs <- map (path </>) <$> args (SrcDirs pathDist)
findModuleFiles pathDist dirs [".hs", ".lhs"]
-- Find objects we depend on (we don't want to depend on split objects)
......@@ -118,7 +117,7 @@ pkgDepObjects :: FilePath -> FilePath -> Way -> Action [FilePath]
pkgDepObjects path dist way = do
let pathDist = path </> dist
buildDir = pathDist </> "build"
dirs <- map (normaliseEx . (path </>)) <$> arg (SrcDirs pathDist)
dirs <- map (normaliseEx . (path </>)) <$> args (SrcDirs pathDist)
fmap concat $ forM dirs $ \d ->
map (toStandard . (buildDir ++) . (-<.> osuf way) . drop (length d))
<$> (findModuleFiles pathDist [d] [".hs", ".lhs"])
......@@ -137,7 +136,7 @@ pkgLibObjects path dist stage way = do
findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
findModuleFiles pathDist directories suffixes = do
modPaths <- map (replaceEq '.' pathSeparator) <$> arg (Modules pathDist)
modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
fileList <- forM directories $ \dir ->
forM modPaths $ \modPath ->
forM suffixes $ \suffix -> do
......
......@@ -15,19 +15,19 @@ ghcArgs :: Package -> TodoItem -> Way -> [FilePath] -> FilePath -> Args
ghcArgs (Package _ path _) (stage, dist, _) way srcs result =
let pathDist = path </> dist
buildDir = toStandard $ pathDist </> "build"
in arg [ suffixArgs way
, wayHcArgs way
, arg SrcHcArgs
, packageArgs stage pathDist
, includeArgs path dist
, concatArgs ["-optP"] $ CppOpts pathDist
, arg $ HsOpts pathDist
-- TODO: now we have both -O and -O2
-- <> arg ["-O2"]
, productArgs ["-odir", "-hidir", "-stubdir"] buildDir
, when (splitObjects stage) $ arg "-split-objs"
, arg ("-c":srcs)
, arg ["-o", result] ]
in args [ suffixArgs way
, wayHcArgs way
, args SrcHcArgs
, packageArgs stage pathDist
, includeArgs path dist
, concatArgs ["-optP"] $ CppArgs pathDist
, args $ HsArgs pathDist
-- TODO: now we have both -O and -O2
-- <> arg ["-O2"]
, productArgs ["-odir", "-hidir", "-stubdir"] buildDir
, when (splitObjects stage) $ arg "-split-objs"
, args ("-c":srcs)
, args ["-o", result] ]
buildRule :: Package -> TodoItem -> Rules ()
buildRule pkg @ (Package name path _) todo @ (stage, dist, _) =
......
{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Package.Data (buildPackageData) where
import Package.Base
......@@ -22,29 +22,29 @@ libraryArgs ways = do
configureArgs :: Stage -> Settings -> Args
configureArgs stage settings =
let conf key as = do
s <- unwords <$> arg as
s <- unwords <$> args as
unless (null s) $ arg $ "--configure-option=" ++ key ++ "=" ++ s
cflags = [ commonCcArgs `filterOut` "-Werror"
, arg $ ConfCcArgs stage
, args $ ConfCcArgs stage
, customCcArgs settings
, commonCcWarninigArgs ]
ldflags = [ commonLdArgs
, arg $ ConfGccLinkerArgs stage
, args $ ConfGccLinkerArgs stage
, customLdArgs settings ]
cppflags = [ commonCppArgs
, arg $ ConfCppArgs stage
, args $ ConfCppArgs stage
, customCppArgs settings ]
in arg [ conf "CFLAGS" cflags
, conf "LDFLAGS" ldflags
, conf "CPPFLAGS" cppflags
, arg $ concat <$> "--gcc-options=" <+> cflags <+> " " <+> ldflags
, conf "--with-iconv-includes" IconvIncludeDirs
, conf "--with-iconv-libraries" IconvLibDirs
, conf "--with-gmp-includes" GmpIncludeDirs
, conf "--with-gmp-libraries" GmpLibDirs
-- TODO: why TargetPlatformFull and not host?
, when CrossCompiling $ conf "--host" $ showArg TargetPlatformFull
, conf "--with-cc" $ showArg Gcc ]
in args [ conf "CFLAGS" cflags
, conf "LDFLAGS" ldflags
, conf "CPPFLAGS" cppflags
, arg $ concat <$> "--gcc-options=" <+> cflags <+> " " <+> ldflags
, conf "--with-iconv-includes" IconvIncludeDirs
, conf "--with-iconv-libraries" IconvLibDirs
, conf "--with-gmp-includes" GmpIncludeDirs
, conf "--with-gmp-libraries" GmpLibDirs
-- TODO: why TargetPlatformFull and not host?
, when CrossCompiling $ conf "--host" $ arg TargetPlatformFull
, conf "--with-cc" $ arg Gcc ]
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
-- 1) Drop lines containing '$'
......@@ -58,23 +58,24 @@ postProcessPackageData file = do
where
(prefix, suffix) = break (== '=') line
bootPkgConstraints :: FilePath -> Args
bootPkgConstraints pathDist = do
need [pathDist </> "package-data.mk"]
deps <- arg $ DepNames pathDist
let depsStage0 = filter ((`elem` deps) . takeBaseName)
$ libraryPackageNames Stage0
forM depsStage0 $ \dep -> do
let depPkg = libraryPackage dep [Stage0] defaultSettings
(_, depPkgDist, _) = head $ pkgTodo depPkg
depPathDist = pkgPath depPkg </> depPkgDist
[version] <- arg $ Version depPathDist
return $ "--constraint " ++ dep ++ " == " ++ version
bootPkgConstraints :: Args
bootPkgConstraints = args $ do
forM (libraryPackagesInStage Stage0) $ \name -> do
let path = pkgPath $ libraryPackage name [Stage0] defaultSettings
baseName = takeBaseName name
cabal = path </> baseName <.> "cabal"
need [cabal]
content <- lines <$> liftIO (readFile cabal)
let versionLines = filter (("ersion:" `isPrefixOf`) . drop 1) content
case versionLines of
[versionLine] -> args ["--constraint", baseName ++ " == "
++ dropWhile (not . isDigit) versionLine ]
_ -> redError $ "Cannot determine package version in '"
++ toStandard cabal ++ "'."
cabalArgs :: Package -> TodoItem -> Args
cabalArgs pkg @ (Package _ path _) todo @ (stage, dist, settings) = arg
[ arg ["configure", path, dist]
cabalArgs pkg @ (Package _ path _) todo @ (stage, dist, settings) = args
[ args ["configure", path, dist]
-- this is a positional argument, hence:
-- * if it is empty, we need to emit one empty string argument
-- * otherwise, we must collapse it into one space-separated string
......@@ -85,7 +86,7 @@ cabalArgs pkg @ (Package _ path _) todo @ (stage, dist, settings) = arg
, libraryArgs =<< ways settings
, when (specified HsColour) $ with HsColour
, configureArgs stage settings
, when (stage == Stage0) $ bootPkgConstraints $ path </> dist
, when (stage == Stage0) bootPkgConstraints
, with Gcc
, when (stage /= Stage0) $ with Ld
, with Ar
......
......@@ -11,15 +11,15 @@ ghcArgs (Package name path _) (stage, dist, settings) =
let pathDist = path </> dist
buildDir = toStandard $ pathDist </> "build"
depFile = buildDir </> takeBaseName name <.> "m"
in arg [ arg "-M"
, packageArgs stage pathDist
, includeArgs path dist
, concatArgs ["-optP"] $ CppOpts pathDist
, productArgs ["-odir", "-stubdir", "-hidir"] buildDir
, arg ["-dep-makefile", depFile <.> "new"]
, productArgs "-dep-suffix" $ map wayPrefix <$> ways settings
, arg $ HsOpts pathDist
, arg $ pkgHsSources path dist ]
in args [ arg "-M"
, packageArgs stage pathDist
, includeArgs path dist
, concatArgs ["-optP"] $ CppArgs pathDist
, productArgs ["-odir", "-stubdir", "-hidir"] buildDir
, args ["-dep-makefile", depFile <.> "new"]
, productArgs "-dep-suffix" $ map wayPrefix <$> ways settings
, args $ HsArgs pathDist
, args $ pkgHsSources path dist ]
buildRule :: Package -> TodoItem -> Rules ()
buildRule pkg @ (Package name path _) todo @ (stage, dist, settings) =
......
......@@ -7,9 +7,9 @@ argListDir :: FilePath
argListDir = "shake/arg/buildPackageLibrary"
arArgs :: [FilePath] -> FilePath -> Args
arArgs objs result = arg [ arg "q"
, arg result
, arg objs ]
arArgs objs result = args [ arg "q"
, arg result
, args objs ]
arRule :: Package -> TodoItem -> Rules ()
arRule pkg @ (Package _ path _) todo @ (stage, dist, _) =
......@@ -30,11 +30,11 @@ ldArgs :: Package -> TodoItem -> FilePath -> Args
ldArgs (Package _ path _) (stage, dist, _) result = do
depObjs <- pkgDepObjects path dist vanilla
need depObjs
arg [ arg $ ConfLdLinkerArgs stage
, arg "-r"
, arg "-o"
, arg result
, arg depObjs ]
args [ args $ ConfLdLinkerArgs stage
, arg "-r"
, arg "-o"
, arg result
, args depObjs ]
ldRule :: Package -> TodoItem -> Rules ()
ldRule pkg @ (Package name path _) todo @ (stage, dist, _) =
......
module Targets (libraryPackageNames) where
module Targets (libraryPackages, libraryPackagesInStage) where
import Base
-- These are the packages we build:
-- TODO: this should eventually be removed and replaced by the top-level
-- target, i.e. GHC (and perhaps, something else)
libraryPackageNames :: Stage -> [String]
libraryPackageNames Stage0 =
libraryPackagesInStage :: Stage -> [String]
libraryPackagesInStage Stage0 =
[ "bin-package-db"
, "binary"
, "hoopl"
, "hpc"
, "transformers" ]
libraryPackageNames Stage1 = libraryPackageNames Stage0 ++
[ "array"
, "deepseq"
, "Cabal/Cabal"
, "containers"
, "filepath"
, "parallel"
, "pretty"
, "stm"
, "template-haskell" ]
libraryPackageNames _ = error "Not implemented"
libraryPackagesInStage Stage1 = []
--[ "array"
--, "deepseq"
--, "Cabal/Cabal"
--, "containers"
--, "filepath"
--, "parallel"
--, "pretty"
--, "stm"
--, "template-haskell" ]
libraryPackagesInStage _ = []
libraryPackages :: [String]
libraryPackages = concatMap libraryPackagesInStage [Stage0 ..]
......@@ -3,7 +3,7 @@ module Util (
module System.Console.ANSI,
replaceIf, replaceEq, replaceSeparators,
chunksOfSize,
putColoured
putColoured, redError
) where
import Base
......@@ -42,3 +42,9 @@ putColoured intensity colour msg = do
putNormal msg
liftIO $ setSGR []
liftIO $ hFlush stdout
-- A more colourful version of error
redError :: String -> Action a
redError msg = do
putColoured Vivid Red msg
return $ error $ "GHC build system error: " ++ msg
......@@ -77,9 +77,9 @@ defaultWays stage = do
-- TODO: do '-ticky' in all debug ways?
wayHcArgs :: Way -> Args
wayHcArgs (Way _ units) = arg
wayHcArgs (Way _ units) = args
[ if (Dynamic `elem` units)
then arg ["-fPIC", "-dynamic"]
then args ["-fPIC", "-dynamic"]
else arg "-static"
, when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
, when (Debug `elem` units) $ arg "-optc-DDEBUG"
......@@ -88,7 +88,7 @@ wayHcArgs (Way _ units) = arg
, when (Parallel `elem` units) $ arg "-parallel"
, when (GranSim `elem` units) $ arg "-gransim"
, when (units == [Debug] || units == [Debug, Dynamic]) $
arg ["-ticky", "-DTICKY_TICKY"] ]
args ["-ticky", "-DTICKY_TICKY"] ]
wayPrefix :: Way -> String
wayPrefix way | way == vanilla = ""
......
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