Split template-haskell into template-haskell-syntax and template-haskell

WIP

11 files changed, 107 insertions, 34 deletions

diff --git a/hadrian/src/Hadrian/Haskell/Cabal.hs b/hadrian/src/Hadrian/Haskell/Cabal.hs
index f5864b6297..67b2a88873 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal.hs
@@ -15,11 +15,20 @@ module Hadrian.Haskell.Cabal (
     ) where
 
 import Development.Shake
-import Distribution.PackageDescription (GenericPackageDescription)
+import Distribution.PackageDescription (GenericPackageDescription, ConfVar (Impl, PackageFlag), mkFlagName)
 
 import Hadrian.Haskell.Cabal.Type
 import Hadrian.Oracles.Cabal
 import Hadrian.Package
+import Stage
+import Oracles.Setting
+import Data.Version.Extra
+import qualified Distribution.Types.CondTree as C
+import qualified Distribution.Types.Dependency as C
+import qualified Distribution.Types.Condition as C
+import Data.Maybe
+import Data.List.Extra
+import qualified Distribution.Simple                           as C
 
 -- | Read a Cabal file and return the package version. The Cabal file is tracked.
 pkgVersion :: Package -> Action String
@@ -47,8 +56,47 @@ pkgDescription = fmap description . readPackageData
 -- The current version does not take care of Cabal conditionals and therefore
 -- returns a crude overapproximation of actual dependencies. The Cabal file is
 -- tracked.
-pkgDependencies :: Package -> Action [PackageName]
-pkgDependencies = fmap (map pkgName . packageDependencies) . readPackageData
+pkgDependencies :: Stage -> Package -> Action [PackageName]
+pkgDependencies st pkg =  do
+  ghc_ver <- readVersion <$> ghcVersionStage st
+  deps <- packageDependenciesConds <$> readPackageData pkg
+  let dep_pkgs = resolve_package (C.mkVersion' ghc_ver) deps
+  return dep_pkgs
+
+  where
+    resolve_package ghc_ver deps =
+        let
+          allDeps = collectDeps deps
+          sorted :: [PackageName]
+          sorted  = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ]
+          final_deps = nubOrd sorted \\ [pkgName pkg]
+        in final_deps
+
+      where
+        -- Collect an overapproximation of dependencies by ignoring conditionals
+        collectDeps :: C.CondTree ConfVar [C.Dependency] a -> [C.Dependency]
+        collectDeps ct = simplifyCondTreeAccum resolveConf ct
+
+        resolveConf (Impl C.GHC vr) = Right (C.withinRange ghc_ver vr)
+        resolveConf v@(PackageFlag fn) = if fn == mkFlagName "template-haskell-quotes" then (Right (st >= Stage1)) else Left v
+        resolveConf v = Left v
+
+-- | Flatten a CondTree.  This will resolve the CondTree by taking all
+-- cannot be evaluated, both branches are returned
+simplifyCondTreeAccum :: (Show v, Monoid d) =>
+                    (v -> Either v Bool)
+                 -> C.CondTree v d a
+                 -> d
+simplifyCondTreeAccum env (C.CondNode _a d ifs) =
+    foldl (<>) d $ mapMaybe simplifyIf ifs
+  where
+    simplifyIf (C.CondBranch cnd t me) =
+        case C.simplifyCondition cnd env of
+          (C.Lit True, _) -> Just $ simplifyCondTreeAccum env t
+          (C.Lit False, _) -> fmap (simplifyCondTreeAccum env) me
+          _ -> Just $ (simplifyCondTreeAccum env t) <>
+                        fromMaybe mempty (fmap (simplifyCondTreeAccum env) me)
+
 
 -- | Read a Cabal file and return the 'GenericPackageDescription'. The Cabal
 -- file is tracked.
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
index b14edd035c..d2a67562e2 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -73,23 +73,23 @@ parsePackageData pkg = do
         pkgId   = C.package pd
         name    = C.unPackageName (C.pkgName pkgId)
         version = C.display (C.pkgVersion pkgId)
-        libDeps = collectDeps (C.condLibrary gpd)
-        exeDeps = map (collectDeps . Just . snd) (C.condExecutables gpd)
-        allDeps = concat (libDeps : exeDeps)
-        sorted  = sort [ C.unPackageName p | C.Dependency p _ _ <- allDeps ]
-        deps    = nubOrd sorted \\ [name]
-        depPkgs = catMaybes $ map findPackageByName deps
+        libDeps = fmap (const ()) <$> (C.condLibrary gpd)
+        exeDeps = map (fmap (const ()) . snd) (C.condExecutables gpd)
+        allDeps = mconcat (fromMaybe mempty libDeps : exeDeps)
     return $ PackageData name version
                          (C.fromShortText (C.synopsis pd))
                          (C.fromShortText (C.description pd))
-                         depPkgs gpd
+                         allDeps gpd
   where
-    -- Collect an overapproximation of dependencies by ignoring conditionals
-    collectDeps :: Maybe (C.CondTree v [C.Dependency] a) -> [C.Dependency]
-    collectDeps Nothing = []
-    collectDeps (Just (C.CondNode _ deps ifs)) = deps ++ concatMap f ifs
-      where
-        f (C.CondBranch _ t mt) = collectDeps (Just t) ++ collectDeps mt
+
+instance (Semigroup a, Semigroup c) => Semigroup (C.CondTree v c a) where
+   (C.CondNode a c bs) <> (C.CondNode a' c' bs') = C.CondNode (a <> a') (c <> c') (bs <> bs')
+
+instance (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (C.CondTree v c a) where
+   mappend = (<>)
+   mempty = C.CondNode mempty mempty mempty
+
+
 
 -- | Parse the package identifier from a Cabal file.
 parseCabalPkgId :: FilePath -> IO String
@@ -125,7 +125,7 @@ configurePackage :: Context -> Action ()
 configurePackage context@Context {..} = do
     putProgressInfo $ "| Configure package " ++ quote (pkgName package)
     gpd     <- pkgGenericDescription package
-    depPkgs <- packageDependencies <$> readPackageData package
+    depPkgs <- mapMaybe findPackageByName <$> pkgDependencies stage package
 
     -- Stage packages are those we have in this stage.
     stagePkgs <- stagePackages stage
diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs
index 756f5082bf..09579d1574 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs
@@ -16,6 +16,9 @@ import Distribution.PackageDescription
 import GHC.Generics
 
 import Hadrian.Package as Hadrian
+import Data.Version
+import Stage
+import qualified Distribution.Types.CondTree as C
 
 -- | Haskell package metadata extracted from a Cabal file without performing
 -- the resolution of package configuration flags and associated conditionals,
@@ -29,10 +32,11 @@ data PackageData = PackageData
     , version                   :: String
     , synopsis                  :: String
     , description               :: String
-    , packageDependencies       :: [Package]
+    , packageDependenciesConds  :: C.CondTree ConfVar [Dependency] ()
     , genericPackageDescription :: GenericPackageDescription
     } deriving (Eq, Generic, Show, Typeable)
 
+
 -- | Haskell package metadata obtained after resolving package configuration
 -- flags and associated conditionals according to the current build context.
 -- See 'PackageData' for metadata that can be obtained without resolving package
diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs
index 2cba0d2118..90f4958ce3 100644
--- a/hadrian/src/Packages.hs
+++ b/hadrian/src/Packages.hs
@@ -8,7 +8,7 @@ module Packages (
     ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline,
     hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
     libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts,
-    runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy,
+    runGhc, stm, templateHaskell, templateHaskellSyntax, terminfo, text, time, timeout, touchy,
     transformers, unlit, unix, win32, xhtml,
     lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
     ghcPackages, isGhcPackage,
@@ -39,7 +39,7 @@ ghcPackages =
     , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh
     , ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs
     , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl
-    , parsec, pretty, process, rts, runGhc, stm, templateHaskell
+    , parsec, pretty, process, rts, runGhc, stm, templateHaskell, templateHaskellSyntax
     , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
     , timeout
     , lintersCommon
@@ -55,7 +55,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
   exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
   ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs,
   hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, libiserv, mtl,
-  parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell,
+  parsec, pretty, primitive, process, rts, runGhc, stm, templateHaskell, templateHaskellSyntax,
   terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
   timeout,
   lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
@@ -113,6 +113,7 @@ rts                 = top  "rts"
 runGhc              = util "runghc"
 stm                 = lib  "stm"
 templateHaskell     = lib  "template-haskell"
+templateHaskellSyntax = lib  "template-haskell-syntax"
 terminfo            = lib  "terminfo"
 text                = lib  "text"
 time                = lib  "time"
diff --git a/hadrian/src/Rules/CabalReinstall.hs b/hadrian/src/Rules/CabalReinstall.hs
index c34362171a..c74ba0569e 100644
--- a/hadrian/src/Rules/CabalReinstall.hs
+++ b/hadrian/src/Rules/CabalReinstall.hs
@@ -24,7 +24,7 @@ The libdir of the reinstalled GHC points to the libdir of the stage 2 compiler (
 
 -- | We don't support reinstalling these
 cabalExcludedPackages :: [Package]
-cabalExcludedPackages = [array, base, deepseq, filepath, ghcBignum, ghcBootTh, ghcPrim, integerGmp, integerSimple, pretty, templateHaskell]
+cabalExcludedPackages = [array, base, deepseq, filepath, ghcBignum, ghcBootTh, ghcPrim, integerGmp, integerSimple, pretty, templateHaskellSyntax]
 
 findCabalPackageDb :: String -> FilePath
 findCabalPackageDb env = go $ map (\l -> (words l, l)) (lines env)
diff --git a/hadrian/src/Rules/Selftest.hs b/hadrian/src/Rules/Selftest.hs
index eae902013f..cccfb7c432 100644
--- a/hadrian/src/Rules/Selftest.hs
+++ b/hadrian/src/Rules/Selftest.hs
@@ -57,10 +57,10 @@ testDependencies :: Action ()
 testDependencies = do
     putBuild "==== pkgDependencies"
     let pkgs = ghcPackages \\ [libffi] -- @libffi@ does not have a Cabal file.
-    depLists <- mapM pkgDependencies pkgs
+    depLists <- mapM (pkgDependencies Stage1) pkgs
     test $ and [ deps == sort deps | deps <- depLists ]
     putBuild "==== Dependencies of the 'ghc-bin' binary"
-    ghcDeps <- pkgDependencies ghc
+    ghcDeps <- pkgDependencies Stage1 ghc
     test $ pkgName compiler `elem` ghcDeps
     stage0Deps <- contextDependencies (vanillaContext stage0InTree ghc)
     stage1Deps <- contextDependencies (vanillaContext Stage1 ghc)
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 154496cf1c..4a173f5c13 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -7,7 +7,6 @@ import Base
 import CommandLine
 import Expression
 import Flavour
-import Hadrian.Haskell.Cabal.Type (packageDependencies)
 import Hadrian.Oracles.Cabal (readPackageData)
 import Oracles.Setting
 import Oracles.TestSettings
@@ -20,6 +19,7 @@ import Target
 import Utilities
 import Context.Type
 import qualified System.Directory as IO
+import Hadrian.Haskell.Cabal
 
 checkPprProgPath, checkPprSourcePath :: FilePath
 checkPprProgPath = "test/bin/check-ppr" <.> exe
@@ -146,7 +146,8 @@ testRules = do
             -- otherwise, build it by directly invoking ghc
               Nothing -> do
                 top <- topDirectory
-                depsPkgs <- mod_pkgs . packageDependencies <$> readPackageData progPkg
+                -- TODO, this is not correct.. should be the version of the out of tree compiler.
+                depsPkgs <- mod_pkgs . mapMaybe findPackageByName <$> pkgDependencies Stage2 progPkg
                 bindir <- getBinaryDirectory testGhc
                 test_args <- outOfTreeCompilerArgs
                 let dynPrograms = hasDynamic test_args
diff --git a/hadrian/src/Rules/ToolArgs.hs b/hadrian/src/Rules/ToolArgs.hs
index 3eabb3ffb7..3b871c16e4 100644
--- a/hadrian/src/Rules/ToolArgs.hs
+++ b/hadrian/src/Rules/ToolArgs.hs
@@ -15,6 +15,9 @@ import Hadrian.Haskell.Cabal.Type
 import System.Directory (canonicalizePath)
 import System.Environment (lookupEnv)
 import qualified Data.Set as Set
+import Oracles.ModuleFiles
+import Utilities
+import Hadrian.Haskell.Cabal
 
 -- | @tool:@ 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
@@ -66,8 +69,7 @@ multiSetup pkg_s = do
     resp_file root p = root </> "multi" </> pkgName p
 
     pkg_deps pkg = do
-      deps <- readPackageData pkg
-      let immediate_deps = filter (`elem` toolTargets) (packageDependencies deps)
+      immediate_deps <- filter (`elem` toolTargets) . mapMaybe findPackageByName <$> pkgDependencies stage0InTree pkg
       trans_deps <- Set.unions <$> mapM pkg_deps immediate_deps
       return (Set.fromList immediate_deps `Set.union` trans_deps)
 
@@ -176,6 +178,7 @@ toolTargets = [ binary
               , parsec
               , time
               , templateHaskell
+              , templateHaskellSyntax
               , text
               , transformers
 --            , unlit  # executable
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 6aad1648fd..d006329d5a 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -96,6 +96,7 @@ stage0Packages = do
              , parsec
              , time
              , templateHaskell
+             , templateHaskellSyntax
              , text
              , transformers
              , unlit
diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs
index 0eb887e662..1dabb346a3 100644
--- a/hadrian/src/Settings/Packages.hs
+++ b/hadrian/src/Settings/Packages.hs
@@ -40,6 +40,15 @@ packageArgs = do
           -- See: https://github.com/snowleopard/hadrian/issues/259.
           , builder (Ghc CompileCWithGhc) ? arg "-optc-O2" ]
 
+        , package bytestring ? mconcat
+          [ builder (Cabal Flags) ? notStage0 `cabalFlag` "template-haskell-quotes"]
+
+        , package exceptions ? mconcat
+          [ builder (Cabal Flags) ? notStage0 `cabalFlag` "template-haskell-quotes"]
+
+        , package text ? mconcat
+          [ builder (Cabal Flags) ? notStage0 `cabalFlag` "template-haskell-quotes"]
+
         --------------------------------- cabal --------------------------------
         -- Cabal is a large library and slow to compile. Moreover, we build it
         -- for Stage0 only so we can link ghc-pkg against it, so there is little
@@ -144,8 +153,17 @@ packageArgs = do
               (andM [cross, bootCross] `cabalFlag` "internal-interpreter")
               (arg "internal-interpreter")
 
+
+
+
           ]
 
+        , package templateHaskellSyntax ? notStage0
+            ? mconcat
+              [ builder Ghc ? arg "-this-unit-id template-haskell-syntax"
+              , builder (Cabal Setup) ? arg "--ghc-options=\"-this-unit-id template-haskell-syntax\""
+              ]
+
         --------------------------------- iserv --------------------------------
         -- Add -Wl,--export-dynamic enables GHCi to load dynamic objects that
         -- refer to the RTS.  This is harmless if you don't use it (adds a bit
@@ -213,11 +231,6 @@ packageArgs = do
         , package hpcBin
           ? builder (Cabal Flags) ? arg "-build-tool-depends"
 
-        --------------------------------- template-haskell ----------------------------------
-
-        , package templateHaskell
-            ? mconcat [ builder (Cabal Flags) ? notStage0 ? arg "+vendor-filepath"
-                      , builder Ghc ? notStage0 ? arg ("-i" <> (root </> pkgPath filepath)) ]
         ]
 
 ghcBignumArgs :: Args
diff --git a/hadrian/src/Utilities.hs b/hadrian/src/Utilities.hs
index 419d505bd8..88cc2c4447 100644
--- a/hadrian/src/Utilities.hs
+++ b/hadrian/src/Utilities.hs
@@ -43,7 +43,9 @@ contextDependencies Context {..} = do
         let newPkgs = nubOrd $ sort (deps ++ pkgs)
         if pkgs == newPkgs then return pkgs else go newPkgs
     step pkg = do
-        deps   <- pkgDependencies pkg
+        --MP: Using pkgDependencies here is wrong as it's an overapproximation, it should be using readContextData
+        -- which is after configuring and hence has resolved all conditionals.
+        deps   <- pkgDependencies stage pkg
         active <- sort <$> stagePackages stage
         return $ intersectOrd (compare . pkgName) active deps