Refactor Builder.hs.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 18 Jan 2016 01:31:06 +0000 (01:31 +0000)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 18 Jan 2016 01:31:06 +0000 (01:31 +0000)
Fix #124.

cfg/system.config.in
src/Builder.hs
src/GHC.hs
src/Settings.hs
src/Settings/Default.hs
src/Settings/Paths.hs
src/Settings/User.hs

index dfde8e3..e117293 100644 (file)
@@ -5,62 +5,42 @@
 # Paths to builders:\r
 #===================\r
 \r
-system-ghc       = @WithGhc@\r
-ghc-stage1       = inplace/bin/ghc-stage1\r
-ghc-stage2       = inplace/bin/ghc-stage2\r
-ghc-stage3       = inplace/bin/ghc-stage3\r
-\r
-system-gcc       = @CC_STAGE0@\r
-gcc              = @WhatGccIsCalled@\r
-\r
-system-ghc-pkg   = @GhcPkgCmd@\r
-ghc-pkg          = inplace/bin/ghc-pkg\r
-\r
-ghc-cabal        = inplace/bin/ghc-cabal\r
-\r
-haddock          = inplace/bin/haddock\r
-\r
-hsc2hs           = inplace/bin/hsc2hs\r
-\r
-genprimopcode    = inplace/bin/genprimopcode\r
-genapply         = inplace/bin/genapply\r
-derive-constants = inplace/bin/deriveConstants\r
-\r
-hs-cpp           = @HaskellCPPCmd@\r
-hs-cpp-args      = @HaskellCPPArgs@\r
-\r
-unlit            = inplace/lib/bin/unlit\r
-\r
-alex             = @AlexCmd@\r
-ar               = @ArCmd@\r
-happy            = @HappyCmd@\r
-hscolour         = @HSCOLOUR@\r
-ld               = @LdCmd@\r
-make             = @MakeCmd@\r
-nm               = @NmCmd@\r
-objdump          = @ObjdumpCmd@\r
-ranlib           = @REAL_RANLIB_CMD@\r
-tar              = @TarCmd@\r
-patch            = @PatchCmd@\r
-perl             = @PerlCmd@\r
+alex           = @AlexCmd@\r
+ar             = @ArCmd@\r
+gcc            = @WhatGccIsCalled@\r
+happy          = @HappyCmd@\r
+hs-cpp         = @HaskellCPPCmd@\r
+hscolour       = @HSCOLOUR@\r
+ld             = @LdCmd@\r
+make           = @MakeCmd@\r
+nm             = @NmCmd@\r
+objdump        = @ObjdumpCmd@\r
+ranlib         = @REAL_RANLIB_CMD@\r
+system-gcc     = @CC_STAGE0@\r
+system-ghc     = @WithGhc@\r
+system-ghc-pkg = @GhcPkgCmd@\r
+tar            = @TarCmd@\r
+patch          = @PatchCmd@\r
+perl           = @PerlCmd@\r
 \r
 # Information about builders:\r
 #============================\r
 \r
-gcc-is-clang        = @GccIsClang@\r
-gcc-lt-46           = @GccLT46@\r
 ar-supports-at-file = @ArSupportsAtFile@\r
-cc-llvm-backend     = @CC_LLVM_BACKEND@\r
 cc-clang-backend    = @CC_CLANG_BACKEND@\r
+cc-llvm-backend     = @CC_LLVM_BACKEND@\r
+gcc-is-clang        = @GccIsClang@\r
+gcc-lt-46           = @GccLT46@\r
+hs-cpp-args         = @HaskellCPPArgs@\r
 \r
 # Build options:\r
 #===============\r
 \r
-solaris-broken-shld   = @SOLARIS_BROKEN_SHLD@\r
-split-objects-broken  = @SplitObjsBroken@\r
-ghc-unregisterised    = @Unregisterised@\r
-ghc-source-path       = @hardtop@\r
-leading-underscore    = @LeadingUnderscore@\r
+solaris-broken-shld  = @SOLARIS_BROKEN_SHLD@\r
+split-objects-broken = @SplitObjsBroken@\r
+ghc-unregisterised   = @Unregisterised@\r
+ghc-source-path      = @hardtop@\r
+leading-underscore   = @LeadingUnderscore@\r
 \r
 # Information about build, host and target systems:\r
 #==================================================\r
@@ -98,7 +78,6 @@ project-patch-level1  = @ProjectPatchLevel1@
 project-patch-level2  = @ProjectPatchLevel2@\r
 project-git-commit-id = @ProjectGitCommitId@\r
 \r
-\r
 # Compilation and linking flags:\r
 #===============================\r
 \r
@@ -127,7 +106,6 @@ iconv-lib-dirs     = @ICONV_LIB_DIRS@
 gmp-include-dirs   = @GMP_INCLUDE_DIRS@\r
 gmp-lib-dirs       = @GMP_LIB_DIRS@\r
 \r
-\r
 # Optional Dependencies:\r
 #=======================\r
 \r
index 560f734..22723a5 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, LambdaCase #-}
 module Builder (
     Builder (..), isStaged, builderPath, getBuilderPath, specified, needBuilder
     ) where
@@ -6,8 +6,10 @@ module Builder (
 import Control.Monad.Trans.Reader
 
 import Base
+import GHC
 import GHC.Generics (Generic)
 import Oracles
+import Package
 import Stage
 
 -- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
@@ -24,13 +26,13 @@ data Builder = Alex
              | Ar
              | DeriveConstants
              | Gcc Stage
-             | GccM Stage
+             | GccM Stage         -- synonym for 'Gcc -MM'
              | GenApply
              | GenPrimopCode
              | Ghc Stage
              | GhcCabal
-             | GhcCabalHsColour
-             | GhcM Stage
+             | GhcCabalHsColour   -- synonym for 'GhcCabal hscolour'
+             | GhcM Stage         -- synonym for 'Ghc -M'
              | GhcPkg Stage
              | Haddock
              | Happy
@@ -48,61 +50,71 @@ data Builder = Alex
              | Unlit
              deriving (Show, Eq, Generic)
 
-isStaged :: Builder -> Bool
-isStaged (Gcc    _) = True
-isStaged (GccM   _) = True
-isStaged (Ghc    _) = True
-isStaged (GhcM   _) = True
-isStaged (GhcPkg _) = True
-isStaged _          = False
+-- | Some builders are built by this very build system, in which case
+-- 'builderProvenance' returns the corresponding 'Stage' and GHC 'Package'.
+builderProvenance :: Builder -> Maybe (Stage, Package)
+builderProvenance = \case
+    DeriveConstants  -> Just (Stage0, deriveConstants)
+    GenApply         -> Just (Stage0, genapply)
+    GenPrimopCode    -> Just (Stage0, genprimopcode)
+    Ghc stage        -> if stage > Stage0 then Just (pred stage, ghc) else Nothing
+    GhcM stage       -> builderProvenance $ Ghc stage
+    GhcCabal         -> Just (Stage0, ghcCabal)
+    GhcCabalHsColour -> builderProvenance $ GhcCabal
+    GhcPkg stage     -> if stage > Stage0 then Just (Stage0, ghcPkg) else Nothing
+    Haddock          -> Just (Stage2, haddock)
+    Hsc2Hs           -> Just (Stage0, hsc2hs)
+    Unlit            -> Just (Stage0, unlit)
+    _                -> Nothing
+
+isInternal :: Builder -> Bool
+isInternal = isJust . builderProvenance
 
--- Configuration files refer to Builders as follows:
-builderKey :: Builder -> String
-builderKey builder = case builder of
-    Alex             -> "alex"
-    Ar               -> "ar"
-    DeriveConstants  -> "derive-constants"
-    Gcc Stage0       -> "system-gcc"
-    Gcc _            -> "gcc"
-    GccM stage       -> builderKey $ Gcc stage -- synonym for 'Gcc -MM'
-    GenApply         -> "genapply"
-    GenPrimopCode    -> "genprimopcode"
-    Ghc Stage0       -> "system-ghc"
-    Ghc Stage1       -> "ghc-stage1"
-    Ghc Stage2       -> "ghc-stage2"
-    Ghc Stage3       -> "ghc-stage3"
-    GhcM stage       -> builderKey $ Ghc stage -- synonym for 'Ghc -M'
-    GhcCabal         -> "ghc-cabal"
-    GhcCabalHsColour -> builderKey $ GhcCabal -- synonym for 'GhcCabal hscolour'
-    GhcPkg Stage0    -> "system-ghc-pkg"
-    GhcPkg _         -> "ghc-pkg"
-    Happy            -> "happy"
-    Haddock          -> "haddock"
-    HsColour         -> "hscolour"
-    Hsc2Hs           -> "hsc2hs"
-    HsCpp            -> "hs-cpp"
-    Ld               -> "ld"
-    Make             -> "make"
-    Nm               -> "nm"
-    Objdump          -> "objdump"
-    Patch            -> "patch"
-    Perl             -> "perl"
-    Ranlib           -> "ranlib"
-    Tar              -> "tar"
-    Unlit            -> "unlit"
+isStaged :: Builder -> Bool
+isStaged = \case
+    (Gcc    _) -> True
+    (GccM   _) -> True
+    (Ghc    _) -> True
+    (GhcM   _) -> True
+    (GhcPkg _) -> True
+    _          -> False
 
+-- TODO: get rid of fromJust
 -- | Determine the location of a 'Builder'
--- TODO: Paths to some builders should be determined using 'defaultProgramPath'
 builderPath :: Builder -> Action FilePath
-builderPath builder = do
-    path <- askConfigWithDefault (builderKey builder) . putError $
-        "\nCannot find path to '" ++ (builderKey builder)
-        ++ "' in configuration files. Have you forgot to run configure?"
-    windows <- windowsHost
-    case (path, windows) of
-        ("", _)    -> return path
-        (p, True)  -> fixAbsolutePathOnWindows (p -<.> exe)
-        (p, False) -> lookupInPath (p -<.> exe)
+builderPath builder = case builderProvenance builder of
+    Just (stage, pkg) -> return . fromJust $ programPath stage pkg
+    Nothing -> do
+        let builderKey = case builder of
+                Alex          -> "alex"
+                Ar            -> "ar"
+                Gcc Stage0    -> "system-gcc"
+                Gcc _         -> "gcc"
+                GccM Stage0   -> "system-gcc"
+                GccM _        -> "gcc"
+                Ghc Stage0    -> "system-ghc"
+                GhcM Stage0   -> "system-ghc"
+                GhcPkg Stage0 -> "system-ghc-pkg"
+                Happy         -> "happy"
+                HsColour      -> "hscolour"
+                HsCpp         -> "hs-cpp"
+                Ld            -> "ld"
+                Make          -> "make"
+                Nm            -> "nm"
+                Objdump       -> "objdump"
+                Patch         -> "patch"
+                Perl          -> "perl"
+                Ranlib        -> "ranlib"
+                Tar           -> "tar"
+                _ -> error $ "Cannot determine builderKey for " ++ show builder
+        path <- askConfigWithDefault builderKey . putError $
+            "\nCannot find path to '" ++ builderKey
+            ++ "' in configuration files. Have you forgot to run configure?"
+        windows <- windowsHost
+        case (path, windows) of
+            ("", _)    -> return path
+            (p, True)  -> fixAbsolutePathOnWindows (p -<.> exe)
+            (p, False) -> lookupInPath (p -<.> exe)
 
 getBuilderPath :: Builder -> ReaderT a Action FilePath
 getBuilderPath = lift . builderPath
@@ -114,14 +126,14 @@ specified = fmap (not . null) . builderPath
 -- If 'laxDependencies' is True then we do not rebuild GHC even if it is out of
 -- date (can save a lot of build time when changing GHC).
 needBuilder :: Bool -> Builder -> Action ()
-needBuilder laxDependencies builder = whenM (specified builder) $ do
+needBuilder laxDependencies builder = when (isInternal builder) $ do
     path <- builderPath builder
     if laxDependencies && allowOrderOnlyDependency builder
     then orderOnly [path]
     else need      [path]
   where
     allowOrderOnlyDependency :: Builder -> Bool
-    allowOrderOnlyDependency b = case b of
+    allowOrderOnlyDependency = \case
         Ghc  _ -> True
         GhcM _ -> True
         _      -> False
index c0013ad..4dfeab9 100644 (file)
@@ -8,10 +8,12 @@ module GHC (
     primitive, process, rts, runGhc, stm, templateHaskell, terminfo, time,
     touchy, transformers, unlit, unix, win32, xhtml,
 
-    defaultKnownPackages
+    defaultKnownPackages, programPath, targetDirectory
     ) where
 
+import Base
 import Package
+import Stage
 
 -- | These are all GHC packages we know about. Build rules will be generated for
 -- all of them. However, not all of these packages will be built. For example,
@@ -97,3 +99,34 @@ ghcSplit = "inplace/lib/bin/ghc-split"
 -- they seem to be unused or unrelated to the build process: checkUniques,
 -- completion, count_lines, coverity, debugNGC, describe-unexpected, genargs,
 -- lndir, mkdirhier, testremove, vagrant
+
+-- TODO: move to buildRootPath, see #113
+-- TODO: simplify, add programInplaceLibPath
+-- | The relative path to the program executable
+programPath :: Stage -> Package -> Maybe FilePath
+programPath stage pkg
+    | pkg == ghc = Just . inplaceProgram $ "ghc-stage" ++ show (fromEnum stage + 1)
+    | pkg == haddock || pkg == ghcTags = case stage of
+        Stage2 -> Just . inplaceProgram $ pkgNameString pkg
+        _      -> Nothing
+    | pkg `elem` [touchy, unlit] = case stage of
+        Stage0 -> Just $ "inplace/lib/bin" -/- pkgNameString pkg <.> exe
+        _      -> Nothing
+    | isProgram pkg = case stage of
+        Stage0 -> Just . inplaceProgram $ pkgNameString pkg
+        _      -> Just . installProgram $ pkgNameString pkg
+    | otherwise = Nothing
+  where
+    inplaceProgram name = programInplacePath -/- name <.> exe
+    installProgram name = pkgPath pkg -/- targetDirectory stage pkg
+                                      -/- "build/tmp" -/- name <.> exe
+
+-- | GHC build results will be placed into target directories with the
+-- following typical structure:
+
+-- * @build/@ contains compiled object code
+-- * @doc/@ is produced by haddock
+-- * @package-data.mk@ contains output of ghc-cabal applied to pkgCabal
+targetDirectory :: Stage -> Package -> FilePath
+targetDirectory stage _ = stageString stage
+
index 12830ca..f40a464 100644 (file)
@@ -3,7 +3,7 @@ module Settings (
     module Settings.Paths,
     module Settings.User,
     module Settings.Ways,
-    getPkgData, getPkgDataList, getTopDirectory, programPath, isLibrary,
+    getPkgData, getPkgDataList, getTopDirectory, isLibrary,
     getPackagePath, getTargetDirectory, getTargetPath, getPackageSources
     ) where
 
@@ -34,9 +34,6 @@ getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
 getTopDirectory :: Expr FilePath
 getTopDirectory = lift topDirectory
 
-programPath :: Stage -> Package -> Maybe FilePath
-programPath = userProgramPath
-
 -- | Find all Haskell source files for the current target
 getPackageSources :: Expr [FilePath]
 getPackageSources = do
index 270aeac..c448a6f 100644 (file)
@@ -1,6 +1,4 @@
-module Settings.Default (
-    defaultSplitObjects, defaultTargetDirectory, defaultProgramPath
-    ) where
+module Settings.Default (defaultSplitObjects) where
 
 import Base
 import Expression
@@ -8,36 +6,6 @@ import GHC
 import Oracles.Config.Flag
 import Predicates (notStage0)
 
--- | GHC build results will be placed into target directories with the
--- following typical structure:
-
--- * @build/@ contains compiled object code
--- * @doc/@ is produced by haddock
--- * @package-data.mk@ contains output of ghc-cabal applied to pkgCabal
-defaultTargetDirectory :: Stage -> Package -> FilePath
-defaultTargetDirectory stage _ = stageString stage
-
--- TODO: move to buildRootPath, see #113
--- TODO: simplify, add programInplaceLibPath
--- | The relative path to the program executable
-defaultProgramPath :: Stage -> Package -> Maybe FilePath
-defaultProgramPath stage pkg
-    | pkg == ghc = Just . inplaceProgram $ "ghc-stage" ++ show (fromEnum stage + 1)
-    | pkg == haddock || pkg == ghcTags = case stage of
-        Stage2 -> Just . inplaceProgram $ pkgNameString pkg
-        _      -> Nothing
-    | pkg `elem` [touchy, unlit] = case stage of
-        Stage0 -> Just $ "inplace/lib/bin" -/- pkgNameString pkg <.> exe
-        _      -> Nothing
-    | isProgram pkg = case stage of
-        Stage0 -> Just . inplaceProgram $ pkgNameString pkg
-        _      -> Just . installProgram $ pkgNameString pkg
-    | otherwise = Nothing
-  where
-    inplaceProgram name = programInplacePath -/- name <.> exe
-    installProgram name = pkgPath pkg -/- defaultTargetDirectory stage pkg
-                                      -/- "build/tmp" -/- name <.> exe
-
 defaultSplitObjects :: Predicate
 defaultSplitObjects = do
     goodStage <- notStage0 -- We don't split bootstrap (stage 0) packages
index 0513d6c..4ceff3d 100644 (file)
@@ -6,12 +6,9 @@ module Settings.Paths (
 
 import Base
 import Expression
+import GHC
 import Settings.User
 
--- User can override the default target directory settings given below
-targetDirectory :: Stage -> Package -> FilePath
-targetDirectory = userTargetDirectory
-
 -- Path to the target directory from GHC source root
 targetPath :: Stage -> Package -> FilePath
 targetPath stage pkg = buildRootPath -/- targetDirectory stage pkg -/- pkgPath pkg
index f57a2ac..fb6ffb6 100644 (file)
@@ -1,29 +1,19 @@
 module Settings.User (
-    buildRootPath, userTargetDirectory, userProgramPath, trackBuildSystem,
+    buildRootPath, trackBuildSystem, compileInterfaceFilesSeparately,
     userArgs, userPackages, userLibraryWays, userRtsWays, userKnownPackages,
     integerLibrary, buildHaddock, validating, ghciWithDebugger, ghcProfiled,
     ghcDebugged, dynamicGhcPrograms, laxDependencies, buildSystemConfigFile,
-    verboseCommands, turnWarningsIntoErrors, splitObjects,
-    compileInterfaceFilesSeparately
+    verboseCommands, turnWarningsIntoErrors, splitObjects
     ) where
 
 import GHC
 import Expression
 import Predicates
-import Settings.Default
 
 -- | All build artefacts are stored in 'buildRootPath' directory.
 buildRootPath :: FilePath
 buildRootPath = ".build"
 
--- | Control where build results go (see GHC.hs for defaults)
-userTargetDirectory :: Stage -> Package -> FilePath
-userTargetDirectory = defaultTargetDirectory
-
--- Control how built programs are called (see GHC.hs for defaults)
-userProgramPath :: Stage -> Package -> Maybe FilePath
-userProgramPath = defaultProgramPath
-
 -- Control user-specific settings
 userArgs :: Args
 userArgs = builderGhc ? remove ["-Wall", "-fwarn-tabs"]