1 files changed, 112 insertions, 0 deletions
diff --git a/hadrian/src/Rules/CabalReinstall.hs b/hadrian/src/Rules/CabalReinstall.hs
new file mode 100644
index 0000000000..c34362171a
--- /dev/null
+++ b/hadrian/src/Rules/CabalReinstall.hs
@@ -0,0 +1,112 @@
+module Rules.CabalReinstall where
+
+import Context
+import Expression
+import Oracles.Flag
+import Packages
+import Settings
+import Target
+import Utilities
+import qualified System.Directory.Extra as IO
+import Data.Either
+import Rules.BinaryDist
+import Hadrian.Haskell.Cabal (pkgIdentifier)
+
+{-
+Note [Testing reinstallable GHC]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To test the reinstallable GHC configuration, we install a GHC to <build root>/stage-cabal/bin
+along with appropriate wrapper scripts.
+
+The libdir of the reinstalled GHC points to the libdir of the stage 2 compiler (in <build root>/stage1)
+-}
+
+
+-- | We don't support reinstalling these
+cabalExcludedPackages :: [Package]
+cabalExcludedPackages = [array, base, deepseq, filepath, ghcBignum, ghcBootTh, ghcPrim, integerGmp, integerSimple, pretty, templateHaskell]
+
+findCabalPackageDb :: String -> FilePath
+findCabalPackageDb env = go $ map (\l -> (words l, l)) (lines env)
+  where
+    go [] = error $ "Couldn't find installed package db in " ++ show env
+    go (("package-db":_, l):_) = drop 11 l
+    go (_:xs) = go xs
+
+
+cabalBuildRules :: Rules ()
+cabalBuildRules = do
+    root <- buildRootRules
+    root -/- "stage-cabal" -/- "cabal-packages" %> \_ -> do
+      -- Always rerun to pass onto cabal's own recompilation logic
+      alwaysRerun
+      all_pkgs <- stagePackages Stage1
+      forM_ (filter (not . (`elem` cabalExcludedPackages)) all_pkgs) $ \pkg -> do
+        withVerbosity Diagnostic $
+          buildWithCmdOptions [] $
+            target (vanillaContext Stage2 pkg) (Cabal Install Stage2) [] []
+
+    phony "build-cabal" $ need [root -/- "stage-cabal" -/- "bin" -/- ".stamp"]
+
+    root -/- "stage-cabal" -/- "bin" -/- "*" %> \_ -> need [root -/- "stage-cabal" -/- "bin" -/- ".stamp"]
+
+    priority 2.0 $ root -/- "stage-cabal" -/- "bin" -/- ".stamp" %> \stamp -> do
+        -- We 'need' all binaries and libraries
+        all_pkgs <- stagePackages Stage1
+        (lib_targets, bin_targets) <- partitionEithers <$> mapM pkgTarget all_pkgs
+        cross <- flag CrossCompiling
+        iserv_targets <- if cross then pure [] else iservBins
+        need (lib_targets ++ (map (\(_, p) -> p) (bin_targets ++ iserv_targets)))
+
+        distDir        <- Context.distDir Stage1
+        rtsDir         <- pkgIdentifier rts
+
+        let ghcBuildDir      = root -/- stageString Stage1
+            rtsIncludeDir    = ghcBuildDir -/- "lib" -/- distDir -/- rtsDir
+                               -/- "include"
+
+        libdir  <- liftIO . IO.makeAbsolute =<< stageLibPath Stage1
+        work_dir <- liftIO $ IO.makeAbsolute $ root -/- "stage-cabal"
+        let outputDir = work_dir -/- "bin"
+        includeDir <- liftIO $ IO.makeAbsolute rtsIncludeDir
+
+        createDirectory outputDir
+
+        need [root -/- "stage-cabal" -/- "cabal-packages"]
+        env <- liftIO $ readFile $ root -/- "stage-cabal" -/- "cabal-packages"
+        let cabal_package_db = findCabalPackageDb env
+
+        forM_ (filter ((/= iserv) . fst) bin_targets) $ \(bin_pkg,_bin_path) -> do
+            let pgmName pkg
+                  | pkg == ghc    = "ghc"
+                  | pkg == hpcBin = "hpc"
+                  | otherwise     = pkgName pkg
+            let cabal_bin_out = work_dir -/- "cabal-bin" -/- (pgmName bin_pkg)
+            needed_wrappers <- pkgToWrappers bin_pkg
+            forM_ needed_wrappers $ \wrapper_name -> do
+              let wrapper_prefix = unlines
+                    ["#!/usr/bin/env sh"
+                    ,"executablename="++show cabal_bin_out
+                    ,"libdir="++show libdir
+                    ,"bindir="++show outputDir
+                    ,"exedir="++show outputDir
+                    ,"includedir="++show includeDir
+                    ,"export GHC_PACKAGE_PATH="++show cabal_package_db++":"
+                    ]
+                  output_file = outputDir -/- wrapper_name
+              wrapper_content <- wrapper wrapper_name
+              writeFile' output_file (wrapper_prefix ++ wrapper_content)
+              makeExecutable output_file
+              pure ()
+
+        -- Just symlink these for now
+        -- TODO: build these with cabal as well
+        forM_ iserv_targets $ \(_bin_pkg,bin_path') -> do
+            bin_path <- liftIO $ IO.makeAbsolute bin_path'
+            let orig_filename = takeFileName bin_path
+                output_file = outputDir -/- orig_filename
+            liftIO $ do
+              IO.removeFile output_file <|> pure ()
+              IO.createFileLink bin_path output_file
+            pure ()
+        writeFile' stamp "OK"