WIP: Generalise hadrian to work with multi-componentwip/hadrian-multi-component

5 files changed, 119 insertions, 37 deletions

diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index dd95e88299..01e4c46878 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -77,6 +77,7 @@ executable hadrian
                        , Rules.Program
                        , Rules.Register
                        , Rules.Rts
+                       , Rules.ToolArgs
                        , Rules.Selftest
                        , Rules.SimpleTargets
                        , Rules.SourceDist
diff --git a/hadrian/hie-bios b/hadrian/hie-bios
index b6e5a471eb..4def2e8823 100755
--- a/hadrian/hie-bios
+++ b/hadrian/hie-bios
@@ -3,7 +3,5 @@
 # When run, this program will output a list of arguments which are necessary to
 # load the GHC library component into GHCi. The program is used by `ghcide` in
 # order to automatically set up the correct GHC API session for a project.
-TERM=dumb CABFLAGS=-v0 $PWD/hadrian/build-cabal tool-args -q --build-root=.hie-bios --flavour=ghc-in-ghci > $HIE_BIOS_OUTPUT
-echo -ighc >> $HIE_BIOS_OUTPUT
-echo "ghc/Main.hs" >> $HIE_BIOS_OUTPUT
+TERM=dumb CABFLAGS=-v0 $PWD/hadrian/build-cabal tool:$1 -q --build-root=.hie-bios --flavour=ghc-in-ghci > $HIE_BIOS_OUTPUT
 
diff --git a/hadrian/src/Rules.hs b/hadrian/src/Rules.hs
index f479ba679f..eee14161cd 100644
--- a/hadrian/src/Rules.hs
+++ b/hadrian/src/Rules.hs
@@ -24,43 +24,12 @@ import qualified Rules.Program
 import qualified Rules.Register
 import qualified Rules.Rts
 import qualified Rules.SimpleTargets
+import Rules.ToolArgs
 import Settings
 import Settings.Program (programContext)
 import Target
 import UserSettings
 
--- | @tool-args@ is used by tooling in order to get the arguments necessary
--- to set up a GHC API session which can compile modules from GHC. When
--- run, the target prints out the arguments that would be passed to @ghc@
--- during normal compilation to @stdout@.
---
--- This target is called by the `ghci` script in order to load all of GHC's
--- modules into GHCi.
-toolArgsTarget :: Rules ()
-toolArgsTarget = do
-  "tool-args" ~> do
-    -- We can't build DLLs on Windows (yet). Actually we should only
-    -- include the dynamic way when we have a dynamic host GHC, but just
-    -- checking for Windows seems simpler for now.
-    let fake_target = target (Context Stage0 compiler (if windowsHost then vanilla else dynamic))
-                             (Ghc ToolArgs Stage0) [] ["ignored"]
-
-    -- need the autogenerated files so that they are precompiled
-    includesDependencies Stage0 >>= need
-    interpret fake_target Rules.Generate.compilerDependencies >>= need
-
-    root <- buildRoot
-    let dir = buildDir (vanillaContext Stage0 compiler)
-    need [ root -/- dir -/- "Config.hs" ]
-    need [ root -/- dir -/- "Parser.hs" ]
-    need [ root -/- dir -/- "Lexer.hs" ]
-    need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ]
-    need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs"  ]
-
-    -- Find out the arguments that are needed to load a module into the
-    -- session
-    arg_list <- interpret fake_target getArgs
-    liftIO $ putStrLn (intercalate "\n" arg_list)
 
 allStages :: [Stage]
 allStages = [minBound .. maxBound]
diff --git a/hadrian/src/Rules/ToolArgs.hs b/hadrian/src/Rules/ToolArgs.hs
new file mode 100644
index 0000000000..1935174f9d
--- /dev/null
+++ b/hadrian/src/Rules/ToolArgs.hs
@@ -0,0 +1,111 @@
+module Rules.ToolArgs(toolArgsTarget) where
+
+import qualified Rules.Generate
+import Development.Shake
+import Target
+import Context
+import Stage
+import Expression
+
+import Packages
+import Settings
+import Hadrian.Oracles.Cabal
+import Hadrian.Haskell.Cabal.Type
+import System.Directory (canonicalizePath)
+
+-- | @tool-args@ is used by tooling in order to get the arguments necessary
+-- to set up a GHC API session which can compile modules from GHC. When
+-- run, the target prints out the arguments that would be passed to @ghc@
+-- during normal compilation to @stdout@.
+--
+-- This target is called by the `ghci.sh` script in order to load all of GHC's
+-- modules into GHCi.
+allDeps :: Action ()
+allDeps = do
+   do
+    -- We can't build DLLs on Windows (yet). Actually we should only
+    -- include the dynamic way when we have a dynamic host GHC, but just
+    -- checking for Windows seems simpler for now.
+    let fake_target = target (Context Stage0 compiler (if windowsHost then vanilla else dynamic))
+                             (Ghc ToolArgs Stage0) [] ["ignored"]
+
+    -- need the autogenerated files so that they are precompiled
+    includesDependencies Stage0 >>= need
+    interpret fake_target Rules.Generate.compilerDependencies >>= need
+
+    root <- buildRoot
+    let dir = buildDir (vanillaContext Stage0 compiler)
+    need [ root -/- dir -/- "Config.hs" ]
+    need [ root -/- dir -/- "Parser.hs" ]
+    need [ root -/- dir -/- "Lexer.hs" ]
+    need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ]
+    need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs"  ]
+
+    -- Find out the arguments that are needed to load a module into the
+    -- session
+
+
+toolTargets :: [Package]
+toolTargets = [ array
+             , bytestring
+             , templateHaskell
+             , containers
+             , deepseq
+             , directory
+             , exceptions
+             , filepath
+             , compiler
+             , ghcCompact
+             , ghcPrim
+             --, haskeline
+             , hp2ps
+             , hsc2hs
+             , pretty
+             , process
+             , rts
+             , stm
+             , time
+             , unlit
+             , xhtml ]
+
+dirMap :: Action [(FilePath, (Package, [String]))]
+dirMap =do
+  auto <- concatMapM go toolTargets
+  -- Mush the ghc executable into the compiler component so the whole of ghc is not built when
+  -- configuring
+  manual <- mkGhc
+  return (auto ++ [manual])
+
+  where
+    mkGhc = do
+      let c = (Context Stage0 compiler (if windowsHost then vanilla else dynamic))
+      cd <- readContextData c
+      fp <- liftIO $ canonicalizePath "ghc/"
+      return (fp, (compiler, "-ighc" : modules cd ++ otherModules cd ++ ["ghc/Main.hs"]))
+    go p = do
+      let c = (Context Stage0 p (if windowsHost then vanilla else dynamic))
+      cd <- readContextData c
+      ids <- liftIO $ mapM canonicalizePath [pkgPath p </> i | i <- srcDirs cd]
+      return $ map (,(p, modules cd ++ otherModules cd)) ids
+
+toolArgsTarget :: Rules ()
+toolArgsTarget = do
+  phonys (\s -> if "tool:" `isPrefixOf` s then Just (toolRuleBody (drop 5 s)) else Nothing)
+
+toolRuleBody :: FilePath -> Action ()
+toolRuleBody fp = do
+  mm <- dirMap
+  cfp <- liftIO $ canonicalizePath fp
+  case find (flip isPrefixOf cfp . fst) mm  of
+    Just (_, (p, extra)) -> mkToolTarget extra p
+    Nothing -> fail $ "No prefixes matched " ++ show fp ++ " IN\n " ++ show mm
+
+mkToolTarget :: [String] -> Package -> Action ()
+mkToolTarget es p = do
+    allDeps
+    let fake_target = target (Context Stage0 p (if windowsHost then vanilla else dynamic))
+                        (Ghc ToolArgs Stage0) [] ["ignored"]
+    arg_list <- interpret fake_target getArgs
+    liftIO $ putStrLn (intercalate "\n" (arg_list ++ es))
+
+
diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs
index 2549a63e39..d498a6236c 100644
--- a/hadrian/src/Settings/Builders/Ghc.hs
+++ b/hadrian/src/Settings/Builders/Ghc.hs
@@ -13,6 +13,7 @@ import Settings.Builders.Common
 import Settings.Warnings
 import qualified Context as Context
 import Rules.Libffi (libffiName)
+import System.Directory
 
 ghcBuilderArgs :: Args
 ghcBuilderArgs = mconcat [ compileAndLinkHs, compileC, findHsDependencies
@@ -215,17 +216,19 @@ includeGhcArgs :: Args
 includeGhcArgs = do
     pkg     <- getPackage
     path    <- getBuildPath
+    cpath <- exprIO $ canonicalizePath path
     context <- getContext
     srcDirs <- getContextData srcDirs
+    abSrcDirs <- exprIO $ mapM canonicalizePath [pkgPath pkg -/- dir | dir <- srcDirs ]
     autogen <- expr $ autogenPath context
     stage <- getStage
     libPath <- expr $ stageLibPath stage
     let cabalMacros = autogen -/- "cabal_macros.h"
     expr $ need [cabalMacros]
     mconcat [ arg "-i"
-            , arg $ "-i" ++ path
+            , arg $ "-i" ++ cpath
             , arg $ "-i" ++ autogen
-            , pure [ "-i" ++ pkgPath pkg -/- dir | dir <- srcDirs ]
+            , pure [ "-i" ++ d | d <- abSrcDirs ]
             , cIncludeArgs
             , arg $      "-I" ++ libPath
             , arg $ "-optc-I" ++ libPath