Refactor Compile (for v2-install)

2 files changed, 125 insertions, 47 deletions

diff --git a/src/CabalHelper/Compiletime/Program/CabalInstall.hs b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
index afc3f1a..49bc7f2 100644
--- a/src/CabalHelper/Compiletime/Program/CabalInstall.hs
+++ b/src/CabalHelper/Compiletime/Program/CabalInstall.hs
@@ -25,7 +25,6 @@ License     : GPL-3
 module CabalHelper.Compiletime.Program.CabalInstall where
 
 import qualified Cabal.Plan as CP
-import Control.Arrow
 import Control.Monad
 import Data.Coerce
 import Data.Either
@@ -33,6 +32,7 @@ import Data.Maybe
 import Data.Version
 import System.IO
 import System.IO.Temp
+import System.Directory
 import System.Environment
 import System.FilePath
 import Text.Printf
@@ -45,9 +45,9 @@ import qualified Data.Text as Text
 import qualified CabalHelper.Compiletime.Cabal as Cabal
 import CabalHelper.Compiletime.Types
 import CabalHelper.Compiletime.Program.GHC
-  ( ghcVersion, createPkgDb )
+  ( GhcVersion(..), createPkgDb )
 import CabalHelper.Compiletime.Cabal
-  ( CabalSourceDir(..), CabalVersion(..), unpackCabalHEAD, unpackPatchedCabal )
+  ( CabalSourceDir(..), UnpackedCabalVersion, CabalVersion'(..), unpackCabalV1 )
 import CabalHelper.Compiletime.Process
 import CabalHelper.Shared.Common
   ( parseVer, trim, appCacheDir, panicIO )
@@ -61,10 +61,11 @@ cabalInstallVersion = do
   CabalInstallVersion . parseVer . trim
     <$> readProcess' (cabalProgram ?progs) ["--numeric-version"] ""
 
-installCabalLib :: Env => Either HEAD Version -> IO (PackageDbDir, CabalVersion)
-installCabalLib ever = do
+installCabalLibV1 :: Env => GhcVersion -> UnpackedCabalVersion -> IO PackageDbDir
+installCabalLibV1 ghcVer cabalVer = do
   appdir <- appCacheDir
-  let message ver = do
+  let message (CabalHEAD {}) = return ()
+      message (CabalVersion ver) = do
       let sver = showVersion ver
       hPutStr stderr $ printf "\
 \cabal-helper: Installing a private copy of Cabal because we couldn't\n\
@@ -79,23 +80,29 @@ installCabalLib ever = do
 \    $ cabal install Cabal --constraint \"Cabal == %s\"\n\
 \\n\
 \Installing Cabal %s ...\n" appdir sver sver sver
-  withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do
-    (srcdir, cabalVer) <- case ever of
-      Left HEAD -> do
-        second CabalHEAD <$> unpackCabalHEAD tmpdir
-      Right ver -> do
-        message ver
-        (,) <$> unpackPatchedCabal ver tmpdir <*> pure (CabalVersion ver)
+  withSystemTempDirectory "cabal-helper.install-cabal-tmp" $ \tmpdir -> do
+    message cabalVer
+    srcdir <- unpackCabalV1 cabalVer tmpdir
 
     db <- createPkgDb cabalVer
 
-    callCabalInstall db srcdir ever
+    callCabalInstall db srcdir ghcVer cabalVer
 
-    return (db, cabalVer)
+    return db
 
 callCabalInstall
-    :: Env => PackageDbDir -> CabalSourceDir -> Either HEAD Version-> IO ()
-callCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do
+    :: Env
+    => PackageDbDir
+    -> CabalSourceDir
+    -> GhcVersion
+    -> UnpackedCabalVersion
+    -> IO ()
+callCabalInstall
+  (PackageDbDir db)
+  (CabalSourceDir srcdir)
+  ghcVer
+  unpackedCabalVer
+  = do
   civ@CabalInstallVersion {..} <- cabalInstallVersion
   cabal_opts <- return $ concat
       [
@@ -117,30 +124,34 @@ callCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do
 
   callProcessStderr (Just "/") (cabalProgram ?progs) cabal_opts
 
-  runSetupHs db srcdir ever civ
+  runSetupHs ghcVer db srcdir unpackedCabalVer civ
 
   hPutStrLn stderr "done"
 
 runSetupHs
     :: Env
-    => FilePath
+    => GhcVersion
+    -> FilePath
     -> FilePath
-    -> Either HEAD Version
+    -> UnpackedCabalVersion
     -> CabalInstallVersion
     -> IO ()
-runSetupHs db srcdir ever CabalInstallVersion {..}
+runSetupHs ghcVer db srcdir iCabalVer CabalInstallVersion {..}
     | cabalInstallVer >= parseVer "1.24" = do
       go $ \args -> callProcessStderr (Just srcdir) (cabalProgram ?progs) $
         [ "act-as-setup", "--" ] ++ args
     | otherwise = do
-      SetupProgram {..} <- compileSetupHs db srcdir
+      SetupProgram {..} <- compileSetupHs ghcVer db srcdir
       go $ callProcessStderr (Just srcdir) setupProgram
   where
     parmake_opt :: Maybe Int -> [String]
     parmake_opt nproc'
-        | Left _ <- ever = ["-j"++nproc]
-        | Right ver <- ever,  ver >= Version [1,20] [] = ["-j"++nproc]
-        | otherwise = []
+        | CabalHEAD _ <- iCabalVer =
+            ["-j"++nproc]
+        | CabalVersion ver <- iCabalVer,  ver >= Version [1,20] [] =
+            ["-j"++nproc]
+        | otherwise =
+            []
       where
         nproc = fromMaybe "" $ show <$> nproc'
     go :: ([String] -> IO ()) -> IO ()
@@ -153,12 +164,11 @@ runSetupHs db srcdir ever CabalInstallVersion {..}
       run [ "register" ]
 
 newtype SetupProgram = SetupProgram { setupProgram :: FilePath }
-compileSetupHs :: Env => FilePath -> FilePath -> IO SetupProgram
-compileSetupHs db srcdir = do
-  ver <- ghcVersion
+compileSetupHs :: Env => GhcVersion -> FilePath -> FilePath -> IO SetupProgram
+compileSetupHs (GhcVersion ghcVer) db srcdir = do
   let no_version_macros
-        | ver >= Version [8] [] = [ "-fno-version-macros" ]
-        | otherwise             = []
+        | ghcVer >= Version [8] [] = [ "-fno-version-macros" ]
+        | otherwise                = []
 
       file = srcdir </> "Setup"
 
@@ -183,6 +193,43 @@ cabalWithGHCProgOpts = concat
       else []
   ]
 
+installCabalLibV2 :: Env => GhcVersion -> UnpackedCabalVersion -> PackageEnvFile -> IO ()
+installCabalLibV2 _ (CabalHEAD _) _ = error "TODO: `installCabalLibV2 _ CabalHEAD _` is unimplemented"
+installCabalLibV2 _ghcVer (CabalVersion cabalVer) (PackageEnvFile env_file) = do
+  exists <- doesFileExist env_file
+  if exists
+    then return ()
+    else do
+    CabalInstallVersion {..} <- cabalInstallVersion
+    cabal_opts <- return $ concat
+        [ if cabalInstallVer >= Version [1,20] []
+             then ["--no-require-sandbox"]
+             else []
+        , [ if cabalInstallVer >= Version [2,4] []
+              then "v2-install"
+              else "new-install"
+          ]
+        , cabalV2WithGHCProgOpts
+        , [ "--package-env=" ++ env_file
+          , "--lib"
+          , "Cabal-"++showVersion cabalVer
+          ]
+        , if ?verbose
+            then ["-v"]
+            else []
+        ]
+    tmp <- getTemporaryDirectory
+    callProcessStderr (Just tmp) (cabalProgram ?progs) cabal_opts
+    hPutStrLn stderr "done"
+
+cabalV2WithGHCProgOpts :: Progs => [String]
+cabalV2WithGHCProgOpts = concat
+  [ [ "--with-compiler=" ++ ghcProgram ?cprogs ]
+  , if ghcPkgProgram ?cprogs /= ghcPkgProgram defaultCompPrograms
+      then error "cabalV2WithGHCProgOpts: ghc-pkg path was changed from default but cabal v2-install does not support passing --with-ghc-pkg!"
+      else []
+  ]
+
 planUnits :: CP.PlanJson -> IO [Unit 'V2]
 planUnits plan = do
     units <- fmap catMaybes $ mapM takeunit $ Map.elems $ CP.pjUnits plan
diff --git a/src/CabalHelper/Compiletime/Program/GHC.hs b/src/CabalHelper/Compiletime/Program/GHC.hs
index 8c77f62..4565a37 100644
--- a/src/CabalHelper/Compiletime/Program/GHC.hs
+++ b/src/CabalHelper/Compiletime/Program/GHC.hs
@@ -38,24 +38,35 @@ import CabalHelper.Shared.Common
   (parseVer, trim, appCacheDir, parsePkgId)
 import CabalHelper.Compiletime.Types
 import CabalHelper.Compiletime.Cabal
-  (CabalVersion(..), showCabalVersion)
+  ( ResolvedCabalVersion, showResolvedCabalVersion, UnpackedCabalVersion
+  , unpackedToResolvedCabalVersion, CabalVersion'(..) )
 import CabalHelper.Compiletime.Process
 import CabalHelper.Compiletime.Log
 
+data GhcPackageSource
+    = GPSAmbient
+    | GPSPackageDBs ![PackageDbDir]
+    | GPSPackageEnv !PackageEnvFile
+
 data GhcInvocation = GhcInvocation
     { giOutDir          :: FilePath
     , giOutput          :: FilePath
     , giCPPOptions      :: [String]
-    , giPackageDBs      :: [PackageDbDir]
     , giIncludeDirs     :: [FilePath]
     , giHideAllPackages :: Bool
     , giPackages        :: [String]
     , giWarningFlags    :: [String]
     , giInputs          :: [String]
+    , giPackageSource   :: !GhcPackageSource
     }
 
-ghcVersion :: (Verbose, CProgs) => IO Version
-ghcVersion =
+newtype GhcVersion = GhcVersion { unGhcVersion :: Version }
+
+showGhcVersion :: GhcVersion -> String
+showGhcVersion (GhcVersion v) = showVersion v
+
+ghcVersion :: (Verbose, CProgs) => IO GhcVersion
+ghcVersion = GhcVersion .
   parseVer . trim <$> readProcess' (ghcProgram ?cprogs) ["--numeric-version"] ""
 
 ghcPkgVersion :: (Verbose, CProgs) => IO Version
@@ -63,23 +74,33 @@ ghcPkgVersion =
   parseVer . trim . dropWhile (not . isDigit)
     <$> readProcess' (ghcPkgProgram ?cprogs) ["--version"] ""
 
-createPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir
+createPkgDb :: (Verbose, CProgs) => UnpackedCabalVersion -> IO PackageDbDir
 createPkgDb cabalVer = do
-  db@(PackageDbDir db_path) <- getPrivateCabalPkgDb cabalVer
+  db@(PackageDbDir db_path)
+    <- getPrivateCabalPkgDb $ unpackedToResolvedCabalVersion cabalVer
   exists <- doesDirectoryExist db_path
   when (not exists) $
        callProcessStderr Nothing (ghcPkgProgram ?cprogs) ["init", db_path]
   return db
 
-getPrivateCabalPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir
+getPrivateCabalPkgDb :: (Verbose, CProgs) => ResolvedCabalVersion -> IO PackageDbDir
 getPrivateCabalPkgDb cabalVer = do
   appdir <- appCacheDir
   ghcVer <- ghcVersion
   let db_path =
-        appdir </> "ghc-" ++ showVersion ghcVer ++ ".package-db"
-               </> "Cabal-" ++ showCabalVersion cabalVer
+        appdir </> "ghc-" ++ showGhcVersion ghcVer ++ ".package-dbs"
+               </> "Cabal-" ++ showResolvedCabalVersion cabalVer
   return $ PackageDbDir db_path
 
+getPrivateCabalPkgEnv
+    :: Verbose => GhcVersion -> Version -> IO PackageEnvFile
+getPrivateCabalPkgEnv ghcVer cabalVer = do
+  appdir <- appCacheDir
+  let env_path =
+        appdir </> "ghc-" ++ showGhcVersion ghcVer ++ ".package-envs"
+               </> "Cabal-" ++ showVersion cabalVer ++ ".package-env"
+  return $ PackageEnvFile env_path
+
 listCabalVersions
     :: (Verbose, Progs) => Maybe PackageDbDir -> MaybeT IO [Version]
 listCabalVersions mdb = do
@@ -95,14 +116,21 @@ listCabalVersions mdb = do
     _ -> mzero
 
 cabalVersionExistsInPkgDb
-    :: (Verbose, Progs) => Version -> PackageDbDir -> IO Bool
+    :: (Verbose, Progs) => CabalVersion' a -> PackageDbDir -> IO Bool
 cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do
-  exists <- doesDirectoryExist db_path
-  case exists of
-    False -> return False
-    True -> fromMaybe False <$> runMaybeT (do
-      vers <- listCabalVersions (Just db)
-      return $ cabalVer `elem` vers)
+  fromMaybe False <$> runMaybeT (do
+    vers <- listCabalVersions (Just db)
+    return $
+      case (cabalVer, vers) of
+        (CabalVersion ver, _) -> ver `elem` vers
+        (CabalHEAD _, [_headver]) -> True
+        (CabalHEAD _, _) ->
+          error $ msg ++ db_path)
+  where
+    msg = "\
+\Multiple Cabal versions in a HEAD package-db!\n\
+\This shouldn't happen. However you can manually delete the following\n\
+\directory to resolve this:\n    "
 
 invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath)
 invokeGhc GhcInvocation {..} = do
@@ -111,7 +139,10 @@ invokeGhc GhcInvocation {..} = do
         , "-o", giOutput
         ]
       , map ("-optP"++) giCPPOptions
-      , map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs
+      , case giPackageSource of
+          GPSAmbient -> []
+          GPSPackageDBs dbs -> map ("-package-conf="++) $ unPackageDbDir <$> dbs
+          GPSPackageEnv env -> [ "-package-env=" ++ unPackageEnvFile env ]
       , map ("-i"++) $ nub $ "" : giIncludeDirs
       , if giHideAllPackages then ["-hide-all-packages"] else []
       , concatMap (\p -> ["-package", p]) giPackages