Suport using Stack's built-in GHC to build the helper

5 files changed, 82 insertions, 87 deletions

diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index 0190129..452bb91 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -54,6 +54,7 @@ module Distribution.Helper (
   , mkQueryEnv
   , qeReadProcess
   , qePrograms
+  , qeCompPrograms
   , qeProjLoc
   , qeDistDir
 
@@ -82,7 +83,6 @@ module Distribution.Helper (
 
   -- * Managing @dist/@
   , prepare
-  , reconfigure
   , writeAutogenFiles
 
   -- * Reexports
@@ -177,10 +177,11 @@ mkQueryEnv projloc distdir = do
   return $ QueryEnv
     { qeReadProcess = \mcwd exe args stdin ->
         readCreateProcess (proc exe args){ cwd = mcwd } stdin
-    , qePrograms    = defaultPrograms
-    , qeDistDir     = distdir
-    , qeCacheRef    = cr
+    , qePrograms     = defaultPrograms
+    , qeCompPrograms = defaultCompPrograms
     , qeProjLoc      = projloc
+    , qeDistDir      = distdir
+    , qeCacheRef     = cr
     }
 
 -- | Construct paths to project configuration files.
@@ -244,25 +245,6 @@ unitQuery u = Query $ \qe -> getUnitInfo qe u
 allUnits :: (UnitInfo -> a) -> Query pt [a]
 allUnits f = map f <$> (mapM unitQuery =<< projectUnits)
 
--- | Run @cabal configure@
-reconfigure :: MonadIO m
-            => (FilePath -> [String] -> String -> IO String)
-            -> Programs -- ^ Program paths
-            -> [String] -- ^ Command line arguments to be passed to @cabal@
-            -> m ()
-reconfigure readProc progs cabalOpts = do
-    let progOpts =
-            [ "--with-ghc=" ++ ghcProgram progs ]
-            -- Only pass ghc-pkg if it was actually set otherwise we
-            -- might break cabal's guessing logic
-            ++ if ghcPkgProgram progs /= "ghc-pkg"
-                 then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ]
-                 else []
-            ++ cabalOpts
-    _ <- liftIO $ readProc (cabalProgram progs) ("configure":progOpts) ""
-    return ()
-
-
 getProjInfo :: QueryEnv pt -> IO (ProjInfo pt)
 getProjInfo qe@QueryEnv{..} = do
   cache@QueryCache{qcProjInfo, qcUnitInfos} <- readIORef qeCacheRef
@@ -321,7 +303,7 @@ checkUpdateUnitInfo qe proj_info unit munit_info = do
   where
     reconf = do
       reconfigureUnit qe unit
-      helper <- wrapper proj_info qe
+      helper <- getHelperExe proj_info qe
       readUnitInfo qe helper unit
 
 -- | Restrict 'UnitInfo' cache to units that are still active
@@ -386,7 +368,7 @@ getFileModTime f = do
 
 readProjInfo
     :: QueryEnvI c pt -> ProjConf pt -> ProjConfModTimes -> IO (ProjInfo pt)
-readProjInfo qe pc pcm = join $ withVerbosity $ do
+readProjInfo qe pc pcm = withVerbosity $ do
   case (qeProjLoc qe, qeDistDir qe, pc) of
     ((,,)
      projloc
@@ -432,7 +414,12 @@ readProjInfo qe pc pcm = join $ withVerbosity $ do
       cabal_files <- Stack.listPackageCabalFiles qe
       units <- mapM (Stack.getUnit qe) cabal_files
       proj_paths <- Stack.projPaths qe
+      cprogs <-
+        guessCompProgramPaths $
+        Stack.patchCompPrograms proj_paths $
+        qeCompPrograms qe
       Just (cabalVer:_) <- runMaybeT $
+        let ?cprogs = cprogs in
         let ?progs  = qePrograms qe in
         listCabalVersions' (Just (sppGlobalPkgDb proj_paths))
       -- ^ See [Note Stack Cabal Version]
@@ -541,14 +528,14 @@ invokeHelper
 prepare :: QueryEnv pt -> IO ()
 prepare qe = do
   proj_info <- getProjInfo qe
-  void $ wrapper proj_info qe
+  void $ getHelperExe proj_info qe
 
 -- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files
 -- in the usual place. See 'Distribution.Simple.Build.initialBuildSteps'.
 writeAutogenFiles :: Unit -> Query pt ()
 writeAutogenFiles Unit{uCabalFile, uDistDir} = Query $ \qe -> do
   proj_info <- getProjInfo qe
-  exe <- wrapper proj_info qe
+  exe <- getHelperExe proj_info qe
   void $ invokeHelper qe exe uCabalFile uDistDir ["write-autogen-files"]
 
 -- | Get the path to the sandbox package-db in a project
@@ -570,16 +557,15 @@ buildPlatform = display Distribution.System.buildPlatform
 lookupEnv' :: String -> IO (Maybe String)
 lookupEnv' k = lookup k <$> getEnvironment
 
-guessProgramPaths :: (Verbose, Progs) => (Progs => IO a) -> IO a
-guessProgramPaths act = do
+-- | Determine ghc-pkg path from ghc path
+guessCompProgramPaths :: Verbose => CompPrograms -> IO CompPrograms
+guessCompProgramPaths progs = do
     let v | ?verbose  = deafening
           | otherwise = silent
-
-        mGhcPath0    | same ghcProgram ?progs dprogs = Nothing
-                     | otherwise = Just $ ghcProgram ?progs
-        mGhcPkgPath0 | same ghcPkgProgram ?progs dprogs = Nothing
-                     | otherwise = Just $ ghcPkgProgram ?progs
-
+        mGhcPath0    | same ghcProgram progs dprogs = Nothing
+                     | otherwise = Just $ ghcProgram progs
+        mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing
+                     | otherwise = Just $ ghcPkgProgram progs
     (_compiler, _mplatform, progdb)
         <- GHC.configure
                v
@@ -589,31 +575,31 @@ guessProgramPaths act = do
     let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb
         mghcPath1    = getProg ProgDb.ghcProgram
         mghcPkgPath1 = getProg ProgDb.ghcPkgProgram
+    return progs
+      { ghcProgram    = fromMaybe (ghcProgram progs) mghcPath1
+      , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1
+      }
 
-    let ?progs = ?progs
-          { ghcProgram    = fromMaybe (ghcProgram ?progs) mghcPath1
-          , ghcPkgProgram = fromMaybe (ghcProgram ?progs) mghcPkgPath1
-          }
-    act
- where
+  where
    same f o o'  = f o == f o'
-   dprogs = defaultPrograms
+   dprogs = defaultCompPrograms
 
-withVerbosity :: (Verbose => a) -> IO a
-withVerbosity a = do
+withVerbosity :: (Verbose => IO a) -> IO a
+withVerbosity act = do
   x <- lookup  "CABAL_HELPER_DEBUG" <$> getEnvironment
   let ?verbose =
         case x of
           Just xs | not (null xs) -> True
           _ -> False
-  return a
+  act
 
-wrapper
+getHelperExe
     :: ProjInfo pt -> QueryEnvI c pt -> IO FilePath
-wrapper proj_info QueryEnv{..} = do
-  join $ withVerbosity $ do
-    let ?progs = qePrograms
+getHelperExe proj_info QueryEnv{..} = do
+  withVerbosity $ do
     let comp = wrapper' qeProjLoc qeDistDir proj_info
+    let ?progs = qePrograms
+        ?cprogs = qeCompPrograms
     eexe <- compileHelper comp
     case eexe of
       Left rv ->
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index 3f8a771..431043b 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -326,9 +326,10 @@ cabalMinVersionMacro (Version (mj1:mj2:mi:_) _) =
 cabalMinVersionMacro _ =
     error "cabalMinVersionMacro: Version must have at least 3 components"
 
-invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath)
+invokeGhc
+    :: (Verbose, CProgs) => GhcInvocation -> IO (Either ExitCode FilePath)
 invokeGhc GhcInvocation {..} = do
-    rv <- callProcessStderr' Nothing (ghcProgram ?progs) $ concat
+    rv <- callProcessStderr' Nothing (ghcProgram ?cprogs) $ concat
       [ [ "-outputdir", giOutDir
         , "-o", giOutput
         ]
@@ -364,7 +365,7 @@ exeName CabalVersion {cabalVersion} = intercalate "-"
     , "Cabal" ++ showVersion cabalVersion
     ]
 
-readProcess' :: Env => FilePath -> [String] -> String -> IO String
+readProcess' :: Verbose => FilePath -> [String] -> String -> IO String
 readProcess' exe args inp = do
   vLog $ intercalate " " $ map formatProcessArg (exe:args)
   outp <- readProcess exe args inp
@@ -372,7 +373,7 @@ readProcess' exe args inp = do
   return outp
 
 callProcessStderr'
-    :: Env => Maybe FilePath -> FilePath -> [String] -> IO ExitCode
+    :: Verbose => Maybe FilePath -> FilePath -> [String] -> IO ExitCode
 callProcessStderr' mwd exe args = do
   let cd = case mwd of
              Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ]
@@ -381,7 +382,7 @@ callProcessStderr' mwd exe args = do
                                                 , cwd = mwd }
   waitForProcess h
 
-callProcessStderr :: Env => Maybe FilePath -> FilePath -> [String] -> IO ()
+callProcessStderr :: Verbose => Maybe FilePath -> FilePath -> [String] -> IO ()
 callProcessStderr mwd exe args = do
   rv <- callProcessStderr' mwd exe args
   case rv of
@@ -482,9 +483,9 @@ runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do
 
 withGHCProgramOptions :: Env => [String]
 withGHCProgramOptions =
-    concat [ [ "--with-ghc=" ++ oGhcProgram ]
-           , if oGhcProgram /= ghcPkgProgram defaultPrograms
-               then [ "--with-ghc-pkg=" ++ oGhcPkgProgram ]
+    concat [ [ "--with-ghc=" ++ ghcProgram ?cprogs ]
+           , if ghcProgram ?cprogs /= ghcPkgProgram defaultCompPrograms
+               then [ "--with-ghc-pkg=" ++ ghcPkgProgram ?cprogs ]
                else []
            ]
 
@@ -533,7 +534,7 @@ compileSetupHs db srcdir = do
 
       file = srcdir </> "Setup"
 
-  callProcessStderr (Just srcdir) oGhcProgram $ concat
+  callProcessStderr (Just srcdir) (ghcProgram ?cprogs) $ concat
     [ [ "--make"
       , "-package-conf", db
       ]
@@ -691,7 +692,7 @@ listCabalVersions' mdb = do
               args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
 
           catMaybes . map (fmap snd . parsePkgId . fromString) . words
-                   <$> readProcess' oGhcPkgProgram args ""
+                   <$> readProcess' (ghcProgram ?cprogs) args ""
 
 cabalVersionExistsInPkgDb :: Env => Version -> PackageDbDir -> IO Bool
 cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do
@@ -702,14 +703,14 @@ cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do
       vers <- listCabalVersions' (Just db)
       return $ cabalVer `elem` vers)
 
-ghcVersion :: Env => IO Version
+ghcVersion :: (Verbose, CProgs) => IO Version
 ghcVersion = do
-    parseVer . trim <$> readProcess' oGhcProgram ["--numeric-version"] ""
+  parseVer . trim <$> readProcess' (ghcProgram ?cprogs) ["--numeric-version"] ""
 
-ghcPkgVersion :: Env => IO Version
+ghcPkgVersion :: (Verbose, CProgs) => IO Version
 ghcPkgVersion =
   parseVer . trim . dropWhile (not . isDigit)
-    <$> readProcess' oGhcPkgProgram ["--version"] ""
+    <$> readProcess' (ghcPkgProgram ?cprogs) ["--version"] ""
 
 newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version }
 cabalInstallVersion :: Env => IO CabalInstallVersion
@@ -717,15 +718,15 @@ cabalInstallVersion = do
   CabalInstallVersion . parseVer . trim
     <$> readProcess' oCabalProgram ["--numeric-version"] ""
 
-createPkgDb :: Env => CabalVersion -> IO PackageDbDir
+createPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir
 createPkgDb cabalVer = do
   db@(PackageDbDir db_path) <- getPrivateCabalPkgDb cabalVer
   exists <- doesDirectoryExist db_path
   when (not exists) $
-       callProcessStderr Nothing oGhcPkgProgram ["init", db_path]
+       callProcessStderr Nothing (ghcPkgProgram ?cprogs) ["init", db_path]
   return db
 
-getPrivateCabalPkgDb :: Env => CabalVersion -> IO PackageDbDir
+getPrivateCabalPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir
 getPrivateCabalPkgDb cabalVer = do
   appdir <- appCacheDir
   ghcVer <- ghcVersion
diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs
index e7f280d..322ccaf 100644
--- a/src/CabalHelper/Compiletime/Program/Stack.hs
+++ b/src/CabalHelper/Compiletime/Program/Stack.hs
@@ -20,7 +20,7 @@ Description : Stack program interface
 License     : GPL-3
 -}
 
-{-# LANGUAGE GADTs, DataKinds #-}
+{-# LANGUAGE NamedFieldPuns, GADTs, DataKinds #-}
 
 module CabalHelper.Compiletime.Program.Stack where
 
@@ -64,6 +64,7 @@ projPaths qe@QueryEnv {qeProjLoc=ProjLocStackDir projdir} = do
     { sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:"
     , sppSnapPkgDb   = PackageDbDir $ look "snapshot-pkg-db:"
     , sppLocalPkgDb  = PackageDbDir $ look "local-pkg-db:"
+    , sppCompExe     = look "compiler-exe:"
     }
 
 paths :: QueryEnvI c 'Stack
@@ -85,3 +86,7 @@ listPackageCabalFiles qe@QueryEnv{qeProjLoc=ProjLocStackDir projdir} = do
 workdirArg :: QueryEnvI c 'Stack -> [String]
 workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} =
   maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir
+
+patchCompPrograms :: StackProjPaths -> CompPrograms -> CompPrograms
+patchCompPrograms StackProjPaths{sppCompExe} cprogs =
+  cprogs { ghcProgram = sppCompExe }
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index cc8561f..5ae712a 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -101,7 +101,10 @@ data QueryEnvI cache (proj_type :: ProjType) = QueryEnv
     -- processes. Useful if you need to, for example, redirect standard error
     -- output away from the user\'s terminal.
 
-    , qePrograms    :: Programs
+    , qePrograms     :: !Programs
+    -- ^ Field accessor for 'QueryEnv'.
+
+    , qeCompPrograms :: !CompPrograms
     -- ^ Field accessor for 'QueryEnv'.
 
     , qeProjLoc      :: !(ProjLoc proj_type)
@@ -232,15 +235,16 @@ data StackProjPaths = StackProjPaths
     { sppGlobalPkgDb :: !PackageDbDir
     , sppSnapPkgDb   :: !PackageDbDir
     , sppLocalPkgDb  :: !PackageDbDir
+    , sppCompExe     :: !FilePath
     }
 
+
+-- Beware: GHC 8.0.2 doesn't like these being recursively defined for some
+-- reason so just keep them unrolled.
 type Verbose = (?verbose :: Bool)
-type Progs = (?progs :: Programs)
--- TODO: rname to `CompEnv` or something
-type Env =
-    ( ?verbose :: Bool
-    , ?progs   :: Programs
-    )
+type Env     = (?cprogs :: CompPrograms, ?progs :: Programs, ?verbose :: Bool)
+type Progs   = (?cprogs :: CompPrograms, ?progs :: Programs)
+type CProgs  = (?cprogs :: CompPrograms)
 
 -- | Configurable paths to various programs we use.
 data Programs = Programs {
@@ -248,21 +252,25 @@ data Programs = Programs {
       cabalProgram  :: FilePath,
 
       -- | The path to the @stack@ program.
-      stackProgram  :: FilePath,
+      stackProgram  :: FilePath
+    } deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
-      -- | The path to the @ghc@ program.
-      ghcProgram    :: FilePath,
+data CompPrograms = CompPrograms
+    { ghcProgram    :: FilePath
+    -- ^ The path to the @ghc@ program.
 
-      -- | The path to the @ghc-pkg@ program. If
-      -- not changed it will be derived from the path to 'ghcProgram'.
-      ghcPkgProgram :: FilePath
+    , ghcPkgProgram :: FilePath
+    -- ^ The path to the @ghc-pkg@ program. If not changed it will be derived
+    -- from the path to 'ghcProgram'.
     } deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 -- | By default all programs use their unqualified names, i.e. they will be
 -- searched for on @PATH@.
 defaultPrograms :: Programs
-defaultPrograms = Programs "cabal" "stack" "ghc" "ghc-pkg"
+defaultPrograms = Programs "cabal" "stack"
 
+defaultCompPrograms :: CompPrograms
+defaultCompPrograms = CompPrograms "ghc" "ghc-pkg"
 
 data CompileOptions = CompileOptions
     { oVerbose       :: Bool
@@ -274,12 +282,6 @@ data CompileOptions = CompileOptions
 oCabalProgram :: Env => FilePath
 oCabalProgram = cabalProgram ?progs
 
-oGhcProgram :: Env => FilePath
-oGhcProgram = ghcProgram ?progs
-
-oGhcPkgProgram :: Env => FilePath
-oGhcPkgProgram = ghcPkgProgram ?progs
-
 defaultCompileOptions :: CompileOptions
 defaultCompileOptions =
     CompileOptions False Nothing Nothing defaultPrograms
diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs
index ef43734..26ec0e3 100644
--- a/tests/CompileTest.hs
+++ b/tests/CompileTest.hs
@@ -45,6 +45,7 @@ setupHOME = do
 main :: IO ()
 main = do
   let ?progs = defaultPrograms
+  let ?cprogs = defaultCompPrograms
   let ?opts = defaultCompileOptions { oVerbose = True }
   let ?verbose = True