Refactor program build rules
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 29 Aug 2017 03:02:10 +0000 (04:02 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 29 Aug 2017 03:02:10 +0000 (04:02 +0100)
See #403

src/GHC.hs
src/Rules.hs
src/Rules/Install.hs
src/Rules/Program.hs
src/Rules/Wrappers.hs

index d7238f2..7a9ff56 100644 (file)
@@ -11,10 +11,10 @@ module GHC (
     ghcPackages, isGhcPackage, defaultPackages,
 
     -- * Package information
-    programName, nonCabalContext, nonHsMainPackage, autogenPath, installStages,
+    programName, nonCabalContext, nonHsMainPackage, autogenPath, installStage,
 
     -- * Miscellaneous
-    programPath, ghcSplitPath, stripCmdPath, inplaceInstallPath, buildDll0
+    programPath, ghcSplitPath, stripCmdPath, buildDll0
     ) where
 
 import Base
@@ -215,28 +215,38 @@ programName Context {..}
     | package == iservBin = "ghc-iserv"
     | otherwise           = pkgName package
 
--- | Given a 'Package' this action returns the sorted list of stages in which
--- the package build results are installed. For most GHC packages we install the
--- /latest/ build stage. The only exception is the GHC itself, whose binaries
--- are installed in all stages. User packages are not installed, hence the
--- resulting list is empty.
-installStages :: Package -> Action [Stage]
-installStages pkg
-    | not (isGhcPackage pkg) = return [] -- Only GHC packages are installed.
+-- | The build stage whose results are used when installing a package, or
+-- @Nothing@ if the package is not installed, e.g. because it is a user package.
+-- The current implementation installs the /latest/ build stage of a package.
+installStage :: Package -> Action (Maybe Stage)
+installStage pkg
+    | not (isGhcPackage pkg) = return Nothing -- Only GHC packages are installed
     | otherwise = do
         stages <- filterM (fmap (pkg `elem`) . defaultPackages) [Stage0 ..]
-        return $ if pkg == ghc then stages else takeEnd 1 stages
+        return $ if null stages then Nothing else Just (maximum stages)
 
-isInstallContext :: Context -> Action Bool
-isInstallContext Context {..} = (stage `elem`) <$> installStages package
+-- | Is the program corresponding to a given context built 'inplace', i.e. in
+-- the @inplace/bin@ directory? For most programs, only their /latest/ build
+-- stages are built 'inplace'. The only exception is the GHC itself, which is
+-- built 'inplace' in all stages. The function returns @False@ for libraries and
+-- all user packages.
+isBuiltInplace :: Context -> Action Bool
+isBuiltInplace Context {..}
+    | isLibrary package          = return False
+    | not (isGhcPackage package) = return False
+    | package == ghc             = return True
+    | otherwise                  = (Just stage ==) <$> installStage package
 
 -- | The 'FilePath' to a program executable in a given 'Context'.
 programPath :: Context -> Action FilePath
 programPath context@Context {..} = do
     path    <- buildPath context
-    install <- isInstallContext context
-    let contextPath = if install then inplaceInstallPath package else path
+    inplace <- isBuiltInplace context
+    let contextPath = if inplace then inplacePath else path
     return $ contextPath -/- programName context <.> exe
+  where
+    inplacePath | package `elem` [touchy, unlit, iservBin] = inplaceLibBinPath
+                | otherwise                                = inplaceBinPath
 
 -- | Some contexts are special: their packages do not have @.cabal@ metadata or
 -- we cannot run @ghc-cabal@ on them, e.g. because the latter hasn't been built
@@ -260,15 +270,6 @@ autogenPath context@Context {..}
   where
     autogen dir = buildPath context <&> (-/- dir -/- "autogen")
 
--- | Given a 'Package', return the path where the corresponding program is
--- installed. Most programs are installed in 'programInplacePath'.
-inplaceInstallPath :: Package -> FilePath
-inplaceInstallPath pkg
-    | pkg == touchy   = inplaceLibBinPath
-    | pkg == unlit    = inplaceLibBinPath
-    | pkg == iservBin = inplaceLibBinPath
-    | otherwise       = inplaceBinPath
-
 -- | @ghc-split@ is a Perl script used by GHC with @-split-objs@ flag. It is
 -- generated in "Rules.Generators.GhcSplit".
 ghcSplitPath :: FilePath
index c939d6f..09610d7 100644 (file)
@@ -96,13 +96,15 @@ packageRules = do
     let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic]
     forM_ dynamicContexts Rules.Library.buildDynamicLib
 
+    forM_ (filter isProgram knownPackages) $
+        Rules.Program.buildProgram readPackageDb
+
     forM_ vanillaContexts $ mconcat
         [ Rules.Data.buildPackageData
         , Rules.Dependencies.buildPackageDependencies readPackageDb
         , Rules.Documentation.buildPackageDocumentation
         , Rules.Library.buildPackageGhciLibrary
         , Rules.Generate.generatePackageCode
-        , Rules.Program.buildProgram readPackageDb
         , Rules.Register.registerPackage writePackageDb ]
 
 buildRules :: Rules ()
index 2ecd915..a1ad50d 100644 (file)
@@ -74,7 +74,7 @@ installLibExecs = do
     destDir <- getDestDir
     installDirectory (destDir ++ libExecDir)
     forM_ installBinPkgs $ \pkg -> do
-        withLatestInstallStage pkg $ \stage -> do
+        withInstallStage pkg $ \stage -> do
             context <- programContext stage pkg
             let bin = inplaceLibBinPath -/- programName context <.> exe
             installProgram bin (destDir ++ libExecDir)
@@ -94,7 +94,7 @@ installBins = do
     when win $
         copyDirectoryContents matchAll (destDir ++ libDir -/- "bin") (destDir ++ binDir)
     unless win $ forM_ installBinPkgs $ \pkg ->
-        withLatestInstallStage pkg $ \stage -> do
+        withInstallStage pkg $ \stage -> do
             context <- programContext stage pkg
             version <- setting ProjectVersion
             -- Name of the binary file
@@ -115,10 +115,12 @@ installBins = do
                         linkSymbolic (destDir ++ binDir -/- binName)
                                      (destDir ++ binDir -/- symName)
 
-withLatestInstallStage :: Package -> (Stage -> Action ()) -> Action ()
-withLatestInstallStage pkg m = do
-    stages <- installStages pkg
-    mapM_ m (takeEnd 1 stages)
+-- | Perform an action depending on the install stage or do nothing if the
+-- package is not installed.
+withInstallStage :: Package -> (Stage -> Action ()) -> Action ()
+withInstallStage pkg m = do
+    maybeStage <- installStage pkg
+    case maybeStage of { Just stage -> m stage; Nothing -> return () }
 
 pkgConfInstallPath :: Action FilePath
 pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) <&> (-/- "package.conf.install")
@@ -174,7 +176,7 @@ installPackages = do
 
     copyFile ghcBootPlatformHeader (pkgPath compiler -/- "ghc_boot_platform.h")
 
-    installPackages <- filterM ((not . null <$>) . installStages)
+    installPackages <- filterM ((isJust <$>) . installStage)
                                (knownPackages \\ [rts, libffi])
 
     installLibPkgs <- topsortPackages (filter isLibrary installPackages)
@@ -185,7 +187,7 @@ installPackages = do
     forM_ installLibPkgs $ \pkg -> do
         case pkgCabalFile pkg of
             Nothing -> error $ "Non-Haskell project in installLibPkgs" ++ show pkg
-            Just cabalFile -> withLatestInstallStage pkg $ \stage -> do
+            Just cabalFile -> withInstallStage pkg $ \stage -> do
                 let context = vanillaContext stage pkg
                 top <- topDirectory
                 installDistDir <- buildPath context
@@ -231,7 +233,7 @@ installPackages = do
                                    , confPath ]
 
     forM_ installLibPkgs $ \pkg -> do
-        withLatestInstallStage pkg $ \stage -> do
+        withInstallStage pkg $ \stage -> do
             let context = vanillaContext stage pkg
             top <- topDirectory
             installDistDir <- (top -/-) <$> buildPath context
index b13f8a2..13bfd34 100644 (file)
@@ -14,43 +14,44 @@ import Settings.Packages.Rts
 import Target
 import Utilities
 
--- TODO: Drop way in build rule generation?
-buildProgram :: [(Resource, Int)] -> Context -> Rules ()
-buildProgram rs context@Context {..} = when (isProgram package) $ do
-    let installStage = if package == ghc then return stage else do
-            stages <- installStages package
-            case stages of
-                [s] -> return s
-                _   -> error $ "Exactly one install stage expected for package "
-                    ++ quote (pkgName package) ++ " (got " ++ show stages ++ ")."
+buildProgram :: [(Resource, Int)] -> Package -> Rules ()
+buildProgram rs package = do
+    forM_ [Stage0 ..] $ \stage -> do
+        let context = vanillaContext stage package
 
-    "//" ++ contextDir context -/- programName context <.> exe %> \bin -> do
-        context' <- programContext stage package
-        buildBinaryAndWrapper rs context' bin
-
-    -- Rules for programs built in install directories
-    when (stage == Stage0 || package == ghc) $ do
-        -- Some binaries in inplace/bin are wrapped
-        inplaceBinPath -/- programName context <.> exe %> \bin -> do
+        -- Rules for programs built in 'buildRoot'
+        "//" ++ contextDir context -/- programName context <.> exe %> \bin -> do
             context' <- programContext stage package
-            binStage <- installStage
-            buildBinaryAndWrapper rs (context' { stage = binStage }) bin
+            buildBinaryAndWrapper rs context' bin
 
-        inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
-            binStage <- installStage
-            context' <- programContext stage package
+        -- Rules for the GHC package, which is built 'inplace'
+        when (package == ghc) $
+            inplaceBinPath -/- programName context <.> exe %> \bin -> do
+                context' <- programContext stage package
+                buildBinaryAndWrapper rs context' bin
+
+    -- Rules for other programs built in inplace directories
+    when (package /= ghc) $ do
+        let context0 = vanillaContext Stage0 package -- TODO: get rid of context0
+        inplaceBinPath -/- programName context0 <.> exe %> \bin -> do
+            stage   <- installStage package -- TODO: get rid of fromJust
+            context <- programContext (fromJust stage) package
+            buildBinaryAndWrapper rs context bin
+
+        inplaceLibBinPath -/- programName context0 <.> exe %> \bin -> do
+            stage   <- installStage package -- TODO: get rid of fromJust
+            context <- programContext (fromJust stage) package
             if package /= iservBin then
-                -- We *normally* build only unwrapped binaries in inplace/lib/bin,
-                buildBinary rs (context' { stage = binStage }) bin
+                -- We *normally* build only unwrapped binaries in inplace/lib/bin
+                buildBinary rs context bin
             else
-                -- build both binary and wrapper in inplace/lib/bin
-                -- for ghc-iserv on *nix platform now
-                buildBinaryAndWrapperLib rs (context' { stage = binStage }) bin
+                -- Build both binary and wrapper in inplace/lib/bin for iservBin
+                buildBinaryAndWrapperLib rs context bin
 
-        inplaceLibBinPath -/- programName context <.> "bin" %> \bin -> do
-            binStage <- installStage
-            context' <- programContext stage package
-            buildBinary rs (context' { stage = binStage }) bin
+        inplaceLibBinPath -/- programName context0 <.> "bin" %> \bin -> do
+            stage   <- installStage package -- TODO: get rid of fromJust
+            context <- programContext (fromJust stage) package
+            buildBinary rs context bin
 
 buildBinaryAndWrapperLib :: [(Resource, Int)] -> Context -> FilePath -> Action ()
 buildBinaryAndWrapperLib rs context bin = do
index 24d865c..20763a7 100644 (file)
@@ -118,13 +118,13 @@ iservBinWrapper :: WrappedBinary -> Expr String
 iservBinWrapper WrappedBinary{..} = do
     expr $ need [sourcePath -/- "Rules/Wrappers.hs"]
     stage <- getStage
-    activePackages <- expr $ filter isLibrary <$> stagePackages stage
+    stageLibraries <- expr $ filter isLibrary <$> stagePackages stage
     -- TODO: Figure our the reason of this hardcoded exclusion
-    let pkgs = activePackages \\ [ cabal, process, haskeline
+    let pkgs = stageLibraries \\ [ cabal, process, haskeline
                                  , terminfo, ghcCompact, hpc, compiler ]
     contexts <- expr $ concatForM pkgs $ \p -> do
-        ss <- installStages p
-        return [ vanillaContext s p | s <- ss ]
+        maybeStage <- installStage p
+        return [ vanillaContext s p | s <- maybeToList maybeStage ]
     buildPaths <- expr $ mapM buildPath contexts
     return $ unlines
         [ "#!/bin/bash"