Commit 8e97252e authored by Andrey Mokhov's avatar Andrey Mokhov

Merge all generators into a single file, factor our common functionality into the library.

See #347
parent df8e5aa8
......@@ -49,14 +49,6 @@ executable hadrian
, Rules.Dependencies
, Rules.Documentation
, Rules.Generate
, Rules.Generators.Common
, Rules.Generators.ConfigHs
, Rules.Generators.GhcAutoconfH
, Rules.Generators.GhcBootPlatformH
, Rules.Generators.GhcPlatformH
, Rules.Generators.GhcSplit
, Rules.Generators.GhcVersionH
, Rules.Generators.VersionHs
, Rules.Gmp
, Rules.Install
, Rules.Libffi
......
......@@ -17,8 +17,8 @@ module Base (
configPath, configFile, sourcePath,
-- * Miscellaneous utilities
minusOrd, intersectOrd, lookupAll, replaceEq, replaceSeparators, unifyPath,
quote, (-/-), matchVersionedFilePath, matchGhcVersionedFilePath, putColoured
unifyPath, quote, (-/-), matchVersionedFilePath, matchGhcVersionedFilePath,
putColoured
) where
import Control.Applicative
......@@ -58,53 +58,6 @@ configFile = configPath -/- "system.config"
sourcePath :: FilePath
sourcePath = hadrianPath -/- "src"
-- | Find and replace all occurrences of a value in a list.
replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from = replaceWhen (== from)
-- | Find and replace all occurrences of path separators in a String with a Char.
replaceSeparators :: Char -> String -> String
replaceSeparators = replaceWhen isPathSeparator
replaceWhen :: (a -> Bool) -> a -> [a] -> [a]
replaceWhen p to = map (\from -> if p from then to else from)
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd :: Ord a => [a] -> [a] -> [a]
minusOrd [] _ = []
minusOrd xs [] = xs
minusOrd (x:xs) (y:ys) = case compare x y of
LT -> x : minusOrd xs (y:ys)
EQ -> minusOrd xs ys
GT -> minusOrd (x:xs) ys
-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
-- | Intersection of two ordered lists by a predicate.
intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
where
loop [] _ = []
loop _ [] = []
loop (x:xs) (y:ys) = case cmp x y of
LT -> loop xs (y:ys)
EQ -> x : loop xs (y:ys)
GT -> loop (x:xs) ys
-- | Lookup all elements of a given sorted list in a given sorted dictionary.
-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
--
-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
lookupAll [] _ = []
lookupAll (_:xs) [] = Nothing : lookupAll xs []
lookupAll (x:xs) (y:ys) = case compare x (fst y) of
LT -> Nothing : lookupAll xs (y:ys)
EQ -> Just (snd y) : lookupAll xs (y:ys)
GT -> lookupAll (x:xs) ys
-- | Given a @prefix@ and a @suffix@ check whether a @filePath@ matches the
-- template @prefix ++ version ++ suffix@ where @version@ is an arbitrary string
-- comprising digits (@0-9@), dashes (@-@), and dots (@.@). Examples:
......
......@@ -13,7 +13,7 @@ module Expression (
-- * Convenient accessors
getContext, getStage, getPackage, getBuilder, getOutputs, getInputs, getWay,
getInput, getOutput, getSingleton, getSetting, getSettingList, getFlag,
getInput, getOutput, getSetting, getSettingList, getFlag,
-- * Re-exports
module Data.Semigroup,
......
......@@ -11,7 +11,7 @@ module Hadrian.Expression (
interpret, interpretInContext,
-- * Convenient accessors
getContext, getBuilder, getOutputs, getInputs, getInput, getOutput, getSingleton
getContext, getBuilder, getOutputs, getInputs, getInput, getOutput
) where
import Control.Monad.Trans
......@@ -20,6 +20,7 @@ import Data.Semigroup
import Development.Shake
import Hadrian.Target
import Hadrian.Utilities
-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
-- and can read parameters of the current build 'Target' @c b@.
......@@ -106,7 +107,7 @@ getInputs = Expr $ asks inputs
getInput :: (Show b, Show c) => Expr c b FilePath
getInput = Expr $ do
target <- ask
getSingleton ("Exactly one input file expected in " ++ show target) <$> asks inputs
fromSingleton ("Exactly one input file expected in " ++ show target) <$> asks inputs
-- | Get the files produced by the current 'Target'.
getOutputs :: Expr c b [FilePath]
......@@ -116,10 +117,4 @@ getOutputs = Expr $ asks outputs
getOutput :: (Show b, Show c) => Expr c b FilePath
getOutput = Expr $ do
target <- ask
getSingleton ("Exactly one output file expected in " ++ show target) <$> asks outputs
-- | Extract a value from a singleton list, or raise an error if the list does
-- not contain exactly one value.
getSingleton :: String -> [a] -> a
getSingleton _ [res] = res
getSingleton msg _ = error msg
fromSingleton ("Exactly one output file expected in " ++ show target) <$> asks outputs
module Hadrian.Utilities (
-- * List manipulation
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll,
-- * String manipulation
quote,
quote, yesNo,
-- * FilePath manipulation
unifyPath, (-/-)
......@@ -9,10 +12,61 @@ module Hadrian.Utilities (
import Development.Shake.FilePath
-- | Extract a value from a singleton list, or terminate with an error message
-- if the list does not contain exactly one value.
fromSingleton :: String -> [a] -> a
fromSingleton _ [res] = res
fromSingleton msg _ = error msg
-- | Find and replace all occurrences of a value in a list.
replaceEq :: Eq a => a -> a -> [a] -> [a]
replaceEq from to = map (\cur -> if cur == from then to else cur)
-- Explicit definition to avoid dependency on Data.List.Ordered
-- | Difference of two ordered lists.
minusOrd :: Ord a => [a] -> [a] -> [a]
minusOrd [] _ = []
minusOrd xs [] = xs
minusOrd (x:xs) (y:ys) = case compare x y of
LT -> x : minusOrd xs (y:ys)
EQ -> minusOrd xs ys
GT -> minusOrd (x:xs) ys
-- Explicit definition to avoid dependency on Data.List.Ordered. TODO: add tests
-- | Intersection of two ordered lists by a predicate.
intersectOrd :: (a -> b -> Ordering) -> [a] -> [b] -> [a]
intersectOrd cmp = loop
where
loop [] _ = []
loop _ [] = []
loop (x:xs) (y:ys) = case cmp x y of
LT -> loop xs (y:ys)
EQ -> x : loop xs (y:ys)
GT -> loop (x:xs) ys
-- | Lookup all elements of a given sorted list in a given sorted dictionary.
-- @lookupAll list dict@ is equivalent to @map (flip lookup dict) list@ but has
-- linear complexity O(|list| + |dist|) instead of quadratic O(|list| * |dict|).
--
-- > lookupAll ["b", "c"] [("a", 1), ("c", 3), ("d", 4)] == [Nothing, Just 3]
-- > list & dict are sorted: lookupAll list dict == map (flip lookup dict) list
lookupAll :: Ord a => [a] -> [(a, b)] -> [Maybe b]
lookupAll [] _ = []
lookupAll (_:xs) [] = Nothing : lookupAll xs []
lookupAll (x:xs) (y:ys) = case compare x (fst y) of
LT -> Nothing : lookupAll xs (y:ys)
EQ -> Just (snd y) : lookupAll xs (y:ys)
GT -> lookupAll (x:xs) ys
-- | Add single quotes around a String.
quote :: String -> String
quote s = "'" ++ s ++ "'"
-- | Pretty-print a 'Bool' as a @"YES"@ or @"NO"@ string.
yesNo :: Bool -> String
yesNo True = "YES"
yesNo False = "NO"
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
unifyPath = toStandard . normaliseEx
......
......@@ -5,6 +5,7 @@ module Oracles.Dependencies (
) where
import qualified Data.HashMap.Strict as Map
import Hadrian.Utilities
import Base
import Context
......
......@@ -4,6 +4,7 @@ module Oracles.ModuleFiles (
) where
import qualified Data.HashMap.Strict as Map
import Hadrian.Utilities
import Base
import Context
......
......@@ -7,7 +7,7 @@ import Builder
import CmdLineFlag
import Context
import GHC
import Rules.Generators.GhcAutoconfH
import Settings.Path
import Stage
import Target
import UserSettings
......
......@@ -3,20 +3,17 @@ module Rules.Generate (
copyRules, includesDependencies, generatedDependencies
) where
import Hadrian.Utilities
import Base
import Context hiding (package)
import Expression
import Flavour
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Oracles.ModuleFiles
import Predicate
import Rules.Generators.ConfigHs
import Rules.Generators.GhcAutoconfH
import Rules.Generators.GhcBootPlatformH
import Rules.Generators.GhcPlatformH
import Rules.Generators.GhcSplit
import Rules.Generators.GhcVersionH
import Rules.Generators.VersionHs
import Rules.Libffi
import Settings
import Settings.Path
......@@ -24,6 +21,10 @@ import Target
import UserSettings
import Util
-- | Track this file to rebuild generated files whenever it changes.
trackGenerateHs :: Expr ()
trackGenerateHs = expr $ need [sourcePath -/- "Rules/Generate.hs"]
primopsSource :: FilePath
primopsSource = "compiler/prelude/primops.txt.pp"
......@@ -171,3 +172,298 @@ generateRules = do
emptyTarget :: Context
emptyTarget = vanillaContext (error "Rules.Generate.emptyTarget: unknown stage")
(error "Rules.Generate.emptyTarget: unknown package")
-- Generators
-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' is a valid C preprocessor identifier.
cppify :: String -> String
cppify = replaceEq '-' '_' . replaceEq '.' '_'
ghcSplitSource :: FilePath
ghcSplitSource = "driver/split/ghc-split.pl"
-- ref: rules/build-perl.mk
-- | Generate the @ghc-split@ Perl script.
generateGhcSplit :: Expr String
generateGhcSplit = do
trackGenerateHs
targetPlatform <- getSetting TargetPlatform
ghcEnableTNC <- expr $ yesNo <$> ghcEnableTablesNextToCode
perlPath <- getBuilderPath Perl
contents <- expr $ readFileLines ghcSplitSource
return . unlines $
[ "#!" ++ perlPath
, "my $TARGETPLATFORM = " ++ show targetPlatform ++ ";"
-- I don't see where the ghc-split tool uses TNC, but
-- it's in the build-perl macro.
, "my $TABLES_NEXT_TO_CODE = " ++ show ghcEnableTNC ++ ";"
] ++ contents
-- | Generate @ghcplatform.h@ header.
generateGhcPlatformH :: Expr String
generateGhcPlatformH = do
trackGenerateHs
hostPlatform <- getSetting HostPlatform
hostArch <- getSetting HostArch
hostOs <- getSetting HostOs
hostVendor <- getSetting HostVendor
targetPlatform <- getSetting TargetPlatform
targetArch <- getSetting TargetArch
targetOs <- getSetting TargetOs
targetVendor <- getSetting TargetVendor
ghcUnreg <- getFlag GhcUnregisterised
return . unlines $
[ "#ifndef __GHCPLATFORM_H__"
, "#define __GHCPLATFORM_H__"
, ""
, "#define BuildPlatform_TYPE " ++ cppify hostPlatform
, "#define HostPlatform_TYPE " ++ cppify targetPlatform
, ""
, "#define " ++ cppify hostPlatform ++ "_BUILD 1"
, "#define " ++ cppify targetPlatform ++ "_HOST 1"
, ""
, "#define " ++ hostArch ++ "_BUILD_ARCH 1"
, "#define " ++ targetArch ++ "_HOST_ARCH 1"
, "#define BUILD_ARCH " ++ show hostArch
, "#define HOST_ARCH " ++ show targetArch
, ""
, "#define " ++ hostOs ++ "_BUILD_OS 1"
, "#define " ++ targetOs ++ "_HOST_OS 1"
, "#define BUILD_OS " ++ show hostOs
, "#define HOST_OS " ++ show targetOs
, ""
, "#define " ++ hostVendor ++ "_BUILD_VENDOR 1"
, "#define " ++ targetVendor ++ "_HOST_VENDOR 1"
, "#define BUILD_VENDOR " ++ show hostVendor
, "#define HOST_VENDOR " ++ show targetVendor
, ""
, "/* These TARGET macros are for backwards compatibility... DO NOT USE! */"
, "#define TargetPlatform_TYPE " ++ cppify targetPlatform
, "#define " ++ cppify targetPlatform ++ "_TARGET 1"
, "#define " ++ targetArch ++ "_TARGET_ARCH 1"
, "#define TARGET_ARCH " ++ show targetArch
, "#define " ++ targetOs ++ "_TARGET_OS 1"
, "#define TARGET_OS " ++ show targetOs
, "#define " ++ targetVendor ++ "_TARGET_VENDOR 1" ]
++
[ "#define UnregisterisedCompiler 1" | ghcUnreg ]
++
[ "\n#endif /* __GHCPLATFORM_H__ */" ]
-- | Generate @Config.hs@ files.
generateConfigHs :: Expr String
generateConfigHs = do
trackGenerateHs
cProjectName <- getSetting ProjectName
cProjectGitCommitId <- getSetting ProjectGitCommitId
cProjectVersion <- getSetting ProjectVersion
cProjectVersionInt <- getSetting ProjectVersionInt
cProjectPatchLevel <- getSetting ProjectPatchLevel
cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
cBooterVersion <- getSetting GhcVersion
let cIntegerLibraryType
| integerLibrary flavour == integerGmp = "IntegerGMP"
| integerLibrary flavour == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: " ++ integerLibraryName
cSupportsSplitObjs <- expr $ yesNo <$> supportsSplitObjects
cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter
cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen
cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP
cGhcEnableTablesNextToCode <- expr $ yesNo <$> ghcEnableTablesNextToCode
cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore
cGHC_UNLIT_PGM <- fmap takeFileName $ getBuilderPath Unlit
cLibFFI <- expr useLibFFIForAdjustors
rtsWays <- getRtsWays
cGhcRtsWithLibdw <- getFlag WithLibdw
let cGhcRTSWays = unwords $ map show rtsWays
return $ unlines
[ "{-# LANGUAGE CPP #-}"
, "module Config where"
, ""
, "#include \"ghc_boot_platform.h\""
, ""
, "data IntegerLibrary = IntegerGMP"
, " | IntegerSimple"
, " deriving Eq"
, ""
, "cBuildPlatformString :: String"
, "cBuildPlatformString = BuildPlatform_NAME"
, "cHostPlatformString :: String"
, "cHostPlatformString = HostPlatform_NAME"
, "cTargetPlatformString :: String"
, "cTargetPlatformString = TargetPlatform_NAME"
, ""
, "cProjectName :: String"
, "cProjectName = " ++ show cProjectName
, "cProjectGitCommitId :: String"
, "cProjectGitCommitId = " ++ show cProjectGitCommitId
, "cProjectVersion :: String"
, "cProjectVersion = " ++ show cProjectVersion
, "cProjectVersionInt :: String"
, "cProjectVersionInt = " ++ show cProjectVersionInt
, "cProjectPatchLevel :: String"
, "cProjectPatchLevel = " ++ show cProjectPatchLevel
, "cProjectPatchLevel1 :: String"
, "cProjectPatchLevel1 = " ++ show cProjectPatchLevel1
, "cProjectPatchLevel2 :: String"
, "cProjectPatchLevel2 = " ++ show cProjectPatchLevel2
, "cBooterVersion :: String"
, "cBooterVersion = " ++ show cBooterVersion
, "cStage :: String"
, "cStage = show (STAGE :: Int)"
, "cIntegerLibrary :: String"
, "cIntegerLibrary = " ++ show integerLibraryName
, "cIntegerLibraryType :: IntegerLibrary"
, "cIntegerLibraryType = " ++ cIntegerLibraryType
, "cSupportsSplitObjs :: String"
, "cSupportsSplitObjs = " ++ show cSupportsSplitObjs
, "cGhcWithInterpreter :: String"
, "cGhcWithInterpreter = " ++ show cGhcWithInterpreter
, "cGhcWithNativeCodeGen :: String"
, "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen
, "cGhcWithSMP :: String"
, "cGhcWithSMP = " ++ show cGhcWithSMP
, "cGhcRTSWays :: String"
, "cGhcRTSWays = " ++ show cGhcRTSWays
, "cGhcEnableTablesNextToCode :: String"
, "cGhcEnableTablesNextToCode = " ++ show cGhcEnableTablesNextToCode
, "cLeadingUnderscore :: String"
, "cLeadingUnderscore = " ++ show cLeadingUnderscore
, "cGHC_UNLIT_PGM :: String"
, "cGHC_UNLIT_PGM = " ++ show cGHC_UNLIT_PGM
, "cGHC_SPLIT_PGM :: String"
, "cGHC_SPLIT_PGM = " ++ show "ghc-split"
, "cLibFFI :: Bool"
, "cLibFFI = " ++ show cLibFFI
, "cGhcThreaded :: Bool"
, "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
, "cGhcDebugged :: Bool"
, "cGhcDebugged = " ++ show (ghcDebugged flavour)
, "cGhcRtsWithLibdw :: Bool"
, "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
-- | Generate @ghcautoconf.h@ header.
generateGhcAutoconfH :: Expr String
generateGhcAutoconfH = do
trackGenerateHs
configHContents <- expr $ map undefinePackage <$> readFileLines configH
tablesNextToCode <- expr ghcEnableTablesNextToCode
ghcUnreg <- getFlag GhcUnregisterised
ccLlvmBackend <- getSetting CcLlvmBackend
ccClangBackend <- getSetting CcClangBackend
return . unlines $
[ "#ifndef __GHCAUTOCONF_H__"
, "#define __GHCAUTOCONF_H__" ]
++ configHContents ++
[ "\n#define TABLES_NEXT_TO_CODE 1" | tablesNextToCode && not ghcUnreg ]
++
[ "\n#define llvm_CC_FLAVOR 1" | ccLlvmBackend == "1" ]
++
[ "\n#define clang_CC_FLAVOR 1" | ccClangBackend == "1" ]
++
[ "#endif /* __GHCAUTOCONF_H__ */" ]
where
undefinePackage s
| "#define PACKAGE_" `isPrefixOf` s
= "/* #undef " ++ takeWhile (/=' ') (drop 8 s) ++ " */"
| otherwise = s
-- | Generate @ghc_boot_platform.h@ headers.
generateGhcBootPlatformH :: Expr String
generateGhcBootPlatformH = do
trackGenerateHs
stage <- getStage
let chooseSetting x y = getSetting $ if stage == Stage0 then x else y
buildPlatform <- chooseSetting BuildPlatform HostPlatform
buildArch <- chooseSetting BuildArch HostArch
buildOs <- chooseSetting BuildOs HostOs
buildVendor <- chooseSetting BuildVendor HostVendor
hostPlatform <- chooseSetting HostPlatform TargetPlatform
hostArch <- chooseSetting HostArch TargetArch
hostOs <- chooseSetting HostOs TargetOs
hostVendor <- chooseSetting HostVendor TargetVendor
targetPlatform <- getSetting TargetPlatform
targetArch <- getSetting TargetArch
targetOs <- getSetting TargetOs
targetVendor <- getSetting TargetVendor
return $ unlines
[ "#ifndef __PLATFORM_H__"
, "#define __PLATFORM_H__"
, ""
, "#define BuildPlatform_NAME " ++ show buildPlatform
, "#define HostPlatform_NAME " ++ show hostPlatform
, "#define TargetPlatform_NAME " ++ show targetPlatform
, ""
, "#define " ++ cppify buildPlatform ++ "_BUILD 1"
, "#define " ++ cppify hostPlatform ++ "_HOST 1"
, "#define " ++ cppify targetPlatform ++ "_TARGET 1"
, ""
, "#define " ++ buildArch ++ "_BUILD_ARCH 1"
, "#define " ++ hostArch ++ "_HOST_ARCH 1"
, "#define " ++ targetArch ++ "_TARGET_ARCH 1"
, "#define BUILD_ARCH " ++ show buildArch
, "#define HOST_ARCH " ++ show hostArch
, "#define TARGET_ARCH " ++ show targetArch
, ""
, "#define " ++ buildOs ++ "_BUILD_OS 1"
, "#define " ++ hostOs ++ "_HOST_OS 1"
, "#define " ++ targetOs ++ "_TARGET_OS 1"
, "#define BUILD_OS " ++ show buildOs
, "#define HOST_OS " ++ show hostOs
, "#define TARGET_OS " ++ show targetOs
, ""
, "#define " ++ buildVendor ++ "_BUILD_VENDOR 1"
, "#define " ++ hostVendor ++ "_HOST_VENDOR 1"
, "#define " ++ targetVendor ++ "_TARGET_VENDOR 1"
, "#define BUILD_VENDOR " ++ show buildVendor
, "#define HOST_VENDOR " ++ show hostVendor
, "#define TARGET_VENDOR " ++ show targetVendor
, ""
, "#endif /* __PLATFORM_H__ */" ]
-- | Generate @ghcversion.h@ header.
generateGhcVersionH :: Expr String
generateGhcVersionH = do
trackGenerateHs
version <- getSetting ProjectVersionInt
patchLevel1 <- getSetting ProjectPatchLevel1
patchLevel2 <- getSetting ProjectPatchLevel2
return . unlines $
[ "#ifndef __GHCVERSION_H__"
, "#define __GHCVERSION_H__"
, ""
, "#ifndef __GLASGOW_HASKELL__"
, "# define __GLASGOW_HASKELL__ " ++ version
, "#endif"
, ""]
++
[ "#define __GLASGOW_HASKELL_PATCHLEVEL1__ " ++ patchLevel1 | patchLevel1 /= "" ]
++
[ "#define __GLASGOW_HASKELL_PATCHLEVEL2__ " ++ patchLevel2 | patchLevel2 /= "" ]
++
[ ""
, "#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\\"
, " ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \\"
, " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
, " && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \\"
, " ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \\"
, " && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \\"
, " && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )"
, ""
, "#endif /* __GHCVERSION_H__ */" ]
-- | Generate @Version.hs@ files.
generateVersionHs :: Expr String
generateVersionHs = do
trackGenerateHs
projectVersion <- getSetting ProjectVersion
targetOs <- getSetting TargetOs
targetArch <- getSetting TargetArch
return $ unlines
[ "module Version where"
, "version, targetOS, targetARCH :: String"
, "version = " ++ show projectVersion
, "targetOS = " ++ show targetOs
, "targetARCH = " ++ show targetArch ]
module Rules.Generators.Common (trackSource, yesNo, cppify) where
import Base
import Expression
-- | Track a given source file when constructing an expression.
trackSource :: FilePath -> Expr ()
trackSource file = expr $ need [ sourcePath -/- file ]
-- | Turn a 'Bool' computed by an 'Action' into a 'String' expression returning
-- "YES" (when the Boolean is 'True') or "NO" (when the Boolean is 'False').
yesNo :: Action Bool -> Expr String
yesNo = expr . fmap (\x -> if x then "YES" else "NO")
-- | Given a 'String' replace charaters '.' and '-' by underscores ('_') so that
-- the resulting 'String' becomes a valid C identifier.
cppify :: String -> String
cppify = replaceEq '-' '_' . replaceEq '.' '_'
module Rules.Generators.ConfigHs (generateConfigHs) where
import Base
import Expression
import Flavour
import GHC
import Oracles.Config.Flag
import Oracles.Config.Setting
import Rules.Generators.Common
import Settings
generateConfigHs :: Expr String
generateConfigHs = do
trackSource "Rules/Generators/ConfigHs.hs"
cProjectName <- getSetting ProjectName
cProjectGitCommitId <- getSetting ProjectGitCommitId
cProjectVersion <- getSetting ProjectVersion
cProjectVersionInt <- getSetting ProjectVersionInt
cProjectPatchLevel <- getSetting ProjectPatchLevel
cProjectPatchLevel1 <- getSetting ProjectPatchLevel1
cProjectPatchLevel2 <- getSetting ProjectPatchLevel2
cBooterVersion <- getSetting GhcVersion
let cIntegerLibraryType
| integerLibrary flavour == integerGmp = "IntegerGMP"
| integerLibrary flavour == integerSimple = "IntegerSimple"
| otherwise = error $ "Unknown integer library: " ++ integerLibraryName