1 files changed, 77 insertions, 0 deletions
diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs
new file mode 100644
index 0000000000..f5be21a2e3
--- /dev/null
+++ b/hadrian/src/Rules/Program.hs
@@ -0,0 +1,77 @@
+module Rules.Program (buildProgram) where
+
+import Hadrian.Haskell.Cabal
+import Hadrian.Haskell.Cabal.Type
+
+import Base
+import Context
+import Expression hiding (stage, way)
+import Oracles.Flag
+import Oracles.ModuleFiles
+import Packages
+import Settings
+import Settings.Default
+import Target
+import Utilities
+
+-- | TODO: Drop code duplication
+buildProgram :: [(Resource, Int)] -> Rules ()
+buildProgram rs = do
+    root <- buildRootRules
+    forM_ [Stage0 ..] $ \stage ->
+        [ root -/- stageString stage -/- "bin"     -/- "*"
+        , root -/- stageString stage -/- "lib/bin" -/- "*" ] |%> \bin -> do
+            -- This is quite inefficient, but we can't access 'programName' from
+            -- 'Rules', because it is an 'Action' depending on an oracle.
+            sPackages <- filter isProgram <$> stagePackages stage
+            tPackages <- testsuitePackages
+            -- TODO: Shall we use Stage2 for testsuite packages instead?
+            let allPackages = sPackages
+                           ++ if stage == Stage1 then tPackages else []
+            nameToCtxList <- forM allPackages $ \pkg -> do
+                let ctx = vanillaContext stage pkg
+                name <- programName ctx
+                return (name <.> exe, ctx)
+
+            case lookup (takeFileName bin) nameToCtxList of
+                Nothing -> error $ "Unknown program " ++ show bin
+                Just (Context {..}) -> do
+                    -- Custom dependencies: this should be modeled better in the
+                    -- Cabal file somehow.
+                    -- TODO: Is this still needed? See 'runtimeDependencies'.
+                    when (package == hsc2hs) $ do
+                        -- 'Hsc2hs' needs the @template-hsc.h@ file.
+                        template <- templateHscPath stage
+                        need [template]
+                    when (package == ghc) $ do
+                        -- GHC depends on @settings@, @platformConstants@,
+                        -- @llvm-targets@, @ghc-usage.txt@, @ghci-usage.txt@,
+                        -- @llvm-passes@.
+                        need =<< ghcDeps stage
+
+                    cross <- flag CrossCompiling
+                    -- For cross compiler, copy @stage0/bin/<pgm>@ to @stage1/bin/@.
+                    case (cross, stage) of
+                        (True, s) | s > Stage0 -> do
+                            srcDir <- buildRoot <&> (-/- (stageString Stage0 -/- "bin"))
+                            copyFile (srcDir -/- takeFileName bin) bin
+                        (False, s) | s > Stage0 && (package `elem` [touchy, unlit]) -> do
+                            srcDir <- stageLibPath Stage0 <&> (-/- "bin")
+                            copyFile (srcDir -/- takeFileName bin) bin
+                        _ -> buildBinary rs bin =<< programContext stage package
+
+buildBinary :: [(Resource, Int)] -> FilePath -> Context -> Action ()
+buildBinary rs bin context@Context {..} = do
+    needLibrary =<< contextDependencies context
+    when (stage > Stage0) $ do
+        ways <- interpretInContext context (getLibraryWays <> getRtsWays)
+        needLibrary [ rtsContext { way = w } | w <- ways ]
+    cSrcs  <- interpretInContext context (getContextData cSrcs)
+    cObjs  <- mapM (objectPath context) cSrcs
+    hsObjs <- hsObjects context
+    let binDeps = cObjs ++ hsObjs
+    need binDeps
+    buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
+    synopsis <- pkgSynopsis package
+    putSuccess $ renderProgram
+        (quote (pkgName package) ++ " (" ++ show stage ++ ").") bin synopsis