aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper/Compiletime/Program
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2018-12-15 23:50:15 +0100
committerDaniel Gröber <dxld@darkboxed.org>2019-01-22 03:06:51 +0100
commit842de542f71616b6d828ea2f993f227e59f1ebc5 (patch)
treeaa157c6864ea303f1abbf847dc4d500ede81e5c1 /src/CabalHelper/Compiletime/Program
parentf844fb50da753332f2f37d4907336d7e7c2a04f2 (diff)
Refactor Compile (for v2-install)
Diffstat (limited to 'src/CabalHelper/Compiletime/Program')
-rw-r--r--src/CabalHelper/Compiletime/Program/CabalInstall.hs107
-rw-r--r--src/CabalHelper/Compiletime/Program/GHC.hs65
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