Move generators to a dedicated directory, and track their changes.

shaking-up-ghc.cabal

@@ -42,6 +42,9 @@ executable ghc-shake
                        , Rules.Dependencies
                        , Rules.Documentation
                        , Rules.Generate
+                       , Rules.Generators.ConfigHs
+                       , Rules.Generators.GhcPkgVersionHs
+                       , Rules.Generators.PlatformH
                        , Rules.Library
                        , Rules.Oracles
                        , Rules.Package

src/Base.hs

@@ -17,16 +17,17 @@ module Base (
     module Development.Shake.Util,
 
     -- * Paths
-    shakeFilesPath, configPath, programInplacePath,
+    shakeFilesPath, configPath, sourcePath, programInplacePath,
     bootPackageConstraints, packageDependencies,
 
     -- * Output
     putColoured, putOracle, putBuild, putSuccess, putError, renderBox,
     module System.Console.ANSI,
 
     -- * Miscellaneous utilities
-    bimap, minusOrd, intersectOrd, removeFileIfExists, replaceEq, chunksOfSize,
-    replaceSeparators, decodeModule, encodeModule, unifyPath, (-/-), versionToInt
+    bimap, minusOrd, intersectOrd, removeFileIfExists, replaceEq, quote,
+    chunksOfSize, replaceSeparators, decodeModule, encodeModule, unifyPath,
+    (-/-), versionToInt
     ) where
 
 import Control.Applicative
@@ -56,6 +57,11 @@ shakeFilesPath = shakePath -/- ".db"
 configPath :: FilePath
 configPath = shakePath -/- "cfg"
 
+-- | Path to source files of the build system, e.g. this file is located at
+-- sourcePath -/- "Base.hs". We use this to `need` some of the source files.
+sourcePath :: FilePath
+sourcePath = shakePath -/- "src"
+
 programInplacePath :: FilePath
 programInplacePath = "inplace/bin"
 
@@ -77,6 +83,10 @@ replaceSeparators = replaceIf isPathSeparator
 replaceIf :: (a -> Bool) -> a -> [a] -> [a]
 replaceIf p to = map (\from -> if p from then to else from)
 
+-- | Add quotes to a String
+quote :: String -> String
+quote s = "\"" ++ s ++ "\""
+
 -- | Given a version string such as "2.16.2" produce an integer equivalent
 versionToInt :: String -> Int
 versionToInt s = major * 1000 + minor * 10 + patch

src/Rules/Generate.hs

@@ -2,7 +2,9 @@ module Rules.Generate (generatePackageCode) where
 
 import Expression
 import GHC
-import Oracles
+import Rules.Generators.ConfigHs
+import Rules.Generators.GhcPkgVersionHs
+import Rules.Generators.PlatformH
 import Oracles.ModuleFiles
 import Rules.Actions
 import Rules.Resources (Resources)
@@ -78,165 +80,3 @@ generatePackageCode _ target @ (PartialTarget stage pkg) =
             when (pkg == runghc) $ buildPath -/- "Main.hs" %> \file -> do
                 copyFileChanged (pkgPath pkg -/- "runghc.hs") file
                 putBuild $ "| Successfully generated '" ++ file ++ "'."
-
-quote :: String -> String
-quote s = "\"" ++ s ++ "\""
-
--- TODO: do we need ghc-split? Always or is it platform specific?
--- TODO: add tracking by moving these functions to separate tracked files
-generateConfigHs :: Expr String
-generateConfigHs = do
-    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 == integerGmp    = "IntegerGMP"
-                            | integerLibrary == integerSimple = "IntegerSimple"
-                            | otherwise = error $ "Unknown integer library: "
-                                          ++ show integerLibrary ++ "."
-        yesNo = lift . fmap (\x -> if x then "YES" else "NO")
-    cSupportsSplitObjs         <- yesNo supportsSplitObjects
-    cGhcWithInterpreter        <- yesNo ghcWithInterpreter
-    cGhcWithNativeCodeGen      <- yesNo ghcWithNativeCodeGen
-    cGhcWithSMP                <- yesNo ghcWithSMP
-    cGhcEnableTablesNextToCode <- yesNo ghcEnableTablesNextToCode
-    cLeadingUnderscore         <- yesNo $ flag LeadingUnderscore
-    cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
-    cGHC_SPLIT_PGM             <- fmap takeBaseName $ getBuilderPath GhcSplit
-    cLibFFI                    <- lift 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          = " ++ quote cProjectName
-        , "cProjectGitCommitId   :: String"
-        , "cProjectGitCommitId   = " ++ quote cProjectGitCommitId
-        , "cProjectVersion       :: String"
-        , "cProjectVersion       = " ++ quote cProjectVersion
-        , "cProjectVersionInt    :: String"
-        , "cProjectVersionInt    = " ++ quote cProjectVersionInt
-        , "cProjectPatchLevel    :: String"
-        , "cProjectPatchLevel    = " ++ quote cProjectPatchLevel
-        , "cProjectPatchLevel1   :: String"
-        , "cProjectPatchLevel1   = " ++ quote cProjectPatchLevel1
-        , "cProjectPatchLevel2   :: String"
-        , "cProjectPatchLevel2   = " ++ quote cProjectPatchLevel2
-        , "cBooterVersion        :: String"
-        , "cBooterVersion        = " ++ quote cBooterVersion
-        , "cStage                :: String"
-        , "cStage                = show (STAGE :: Int)"
-        , "cIntegerLibrary       :: String"
-        , "cIntegerLibrary       = " ++ quote (pkgNameString integerLibrary)
-        , "cIntegerLibraryType   :: IntegerLibrary"
-        , "cIntegerLibraryType   = " ++ cIntegerLibraryType
-        , "cSupportsSplitObjs    :: String"
-        , "cSupportsSplitObjs    = " ++ quote cSupportsSplitObjs
-        , "cGhcWithInterpreter   :: String"
-        , "cGhcWithInterpreter   = " ++ quote cGhcWithInterpreter
-        , "cGhcWithNativeCodeGen :: String"
-        , "cGhcWithNativeCodeGen = " ++ quote cGhcWithNativeCodeGen
-        , "cGhcWithSMP           :: String"
-        , "cGhcWithSMP           = " ++ quote cGhcWithSMP
-        , "cGhcRTSWays           :: String"
-        , "cGhcRTSWays           = " ++ quote cGhcRTSWays
-        , "cGhcEnableTablesNextToCode :: String"
-        , "cGhcEnableTablesNextToCode = " ++ quote cGhcEnableTablesNextToCode
-        , "cLeadingUnderscore    :: String"
-        , "cLeadingUnderscore    = " ++ quote cLeadingUnderscore
-        , "cGHC_UNLIT_PGM        :: String"
-        , "cGHC_UNLIT_PGM        = " ++ quote cGHC_UNLIT_PGM
-        , "cGHC_SPLIT_PGM        :: String"
-        , "cGHC_SPLIT_PGM        = " ++ quote cGHC_SPLIT_PGM
-        , "cLibFFI               :: Bool"
-        , "cLibFFI               = " ++ show cLibFFI
-        , "cGhcThreaded :: Bool"
-        , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
-        , "cGhcDebugged :: Bool"
-        , "cGhcDebugged = " ++ show ghcDebugged
-        , "cGhcRtsWithLibdw :: Bool"
-        , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]
-
-generatePlatformH :: Expr String
-generatePlatformH = do
-    stage <- getStage
-    let cppify = replaceEq '-' '_' . replaceEq '.' '_'
-        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  " ++ quote buildPlatform
-        , "#define HostPlatform_NAME   " ++ quote hostPlatform
-        , "#define TargetPlatform_NAME " ++ quote 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 "  ++ quote buildArch
-        , "#define HOST_ARCH "   ++ quote hostArch
-        , "#define TARGET_ARCH " ++ quote targetArch
-        , ""
-        , "#define " ++ buildOs  ++ "_BUILD_OS 1"
-        , "#define " ++ hostOs   ++ "_HOST_OS 1"
-        , "#define " ++ targetOs ++ "_TARGET_OS 1"
-        , "#define BUILD_OS "  ++ quote buildOs
-        , "#define HOST_OS "   ++ quote hostOs
-        , "#define TARGET_OS " ++ quote targetOs
-        , ""
-        , "#define " ++ buildVendor  ++ "_BUILD_VENDOR 1"
-        , "#define " ++ hostVendor   ++ "_HOST_VENDOR 1"
-        , "#define " ++ targetVendor ++ "_TARGET_VENDOR  1"
-        , "#define BUILD_VENDOR "  ++ quote buildVendor
-        , "#define HOST_VENDOR "   ++ quote hostVendor
-        , "#define TARGET_VENDOR " ++ quote targetVendor
-        , ""
-        , "#endif /* __PLATFORM_H__ */" ]
-
-generateGhcPkgVersionHs :: Expr String
-generateGhcPkgVersionHs = do
-    projectVersion <- getSetting ProjectVersion
-    targetOs       <- getSetting TargetOs
-    targetArch     <- getSetting TargetArch
-    return $ unlines
-        [ "module Version where"
-        , "version, targetOS, targetARCH :: String"
-        , "version    = " ++ quote projectVersion
-        , "targetOS   = " ++ quote targetOs
-        , "targetARCH = " ++ quote targetArch ]

src/Rules/Generators/ConfigHs.hs

@@ -0,0 +1,102 @@
+module Rules.Generators.ConfigHs (generateConfigHs) where
+
+import Expression
+import GHC
+import Oracles
+import Settings
+
+-- TODO: do we need ghc-split? Always or is it platform specific?
+-- TODO: add tracking by moving these functions to separate tracked files
+generateConfigHs :: Expr String
+generateConfigHs = do
+    lift $ need [sourcePath -/- "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 == integerGmp    = "IntegerGMP"
+                            | integerLibrary == integerSimple = "IntegerSimple"
+                            | otherwise = error $ "Unknown integer library: "
+                                          ++ show integerLibrary ++ "."
+        yesNo = lift . fmap (\x -> if x then "YES" else "NO")
+    cSupportsSplitObjs         <- yesNo supportsSplitObjects
+    cGhcWithInterpreter        <- yesNo ghcWithInterpreter
+    cGhcWithNativeCodeGen      <- yesNo ghcWithNativeCodeGen
+    cGhcWithSMP                <- yesNo ghcWithSMP
+    cGhcEnableTablesNextToCode <- yesNo ghcEnableTablesNextToCode
+    cLeadingUnderscore         <- yesNo $ flag LeadingUnderscore
+    cGHC_UNLIT_PGM             <- fmap takeFileName $ getBuilderPath Unlit
+    cGHC_SPLIT_PGM             <- fmap takeBaseName $ getBuilderPath GhcSplit
+    cLibFFI                    <- lift 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          = " ++ quote cProjectName
+        , "cProjectGitCommitId   :: String"
+        , "cProjectGitCommitId   = " ++ quote cProjectGitCommitId
+        , "cProjectVersion       :: String"
+        , "cProjectVersion       = " ++ quote cProjectVersion
+        , "cProjectVersionInt    :: String"
+        , "cProjectVersionInt    = " ++ quote cProjectVersionInt
+        , "cProjectPatchLevel    :: String"
+        , "cProjectPatchLevel    = " ++ quote cProjectPatchLevel
+        , "cProjectPatchLevel1   :: String"
+        , "cProjectPatchLevel1   = " ++ quote cProjectPatchLevel1
+        , "cProjectPatchLevel2   :: String"
+        , "cProjectPatchLevel2   = " ++ quote cProjectPatchLevel2
+        , "cBooterVersion        :: String"
+        , "cBooterVersion        = " ++ quote cBooterVersion
+        , "cStage                :: String"
+        , "cStage                = show (STAGE :: Int)"
+        , "cIntegerLibrary       :: String"
+        , "cIntegerLibrary       = " ++ quote (pkgNameString integerLibrary)
+        , "cIntegerLibraryType   :: IntegerLibrary"
+        , "cIntegerLibraryType   = " ++ cIntegerLibraryType
+        , "cSupportsSplitObjs    :: String"
+        , "cSupportsSplitObjs    = " ++ quote cSupportsSplitObjs
+        , "cGhcWithInterpreter   :: String"
+        , "cGhcWithInterpreter   = " ++ quote cGhcWithInterpreter
+        , "cGhcWithNativeCodeGen :: String"
+        , "cGhcWithNativeCodeGen = " ++ quote cGhcWithNativeCodeGen
+        , "cGhcWithSMP           :: String"
+        , "cGhcWithSMP           = " ++ quote cGhcWithSMP
+        , "cGhcRTSWays           :: String"
+        , "cGhcRTSWays           = " ++ quote cGhcRTSWays
+        , "cGhcEnableTablesNextToCode :: String"
+        , "cGhcEnableTablesNextToCode = " ++ quote cGhcEnableTablesNextToCode
+        , "cLeadingUnderscore    :: String"
+        , "cLeadingUnderscore    = " ++ quote cLeadingUnderscore
+        , "cGHC_UNLIT_PGM        :: String"
+        , "cGHC_UNLIT_PGM        = " ++ quote cGHC_UNLIT_PGM
+        , "cGHC_SPLIT_PGM        :: String"
+        , "cGHC_SPLIT_PGM        = " ++ quote cGHC_SPLIT_PGM
+        , "cLibFFI               :: Bool"
+        , "cLibFFI               = " ++ show cLibFFI
+        , "cGhcThreaded :: Bool"
+        , "cGhcThreaded = " ++ show (threaded `elem` rtsWays)
+        , "cGhcDebugged :: Bool"
+        , "cGhcDebugged = " ++ show ghcDebugged
+        , "cGhcRtsWithLibdw :: Bool"
+        , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ]

src/Rules/Generators/GhcPkgVersionHs.hs

@@ -0,0 +1,17 @@
+module Rules.Generators.GhcPkgVersionHs (generateGhcPkgVersionHs) where
+
+import Expression
+import Oracles
+
+generateGhcPkgVersionHs :: Expr String
+generateGhcPkgVersionHs = do
+    lift $ need [sourcePath -/- "Rules/Generators/GhcPkgVersionHs.hs"]
+    projectVersion <- getSetting ProjectVersion
+    targetOs       <- getSetting TargetOs
+    targetArch     <- getSetting TargetArch
+    return $ unlines
+        [ "module Version where"
+        , "version, targetOS, targetARCH :: String"
+        , "version    = " ++ quote projectVersion
+        , "targetOS   = " ++ quote targetOs
+        , "targetARCH = " ++ quote targetArch ]