From 842de542f71616b6d828ea2f993f227e59f1ebc5 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sat, 15 Dec 2018 23:50:15 +0100 Subject: Refactor Compile (for v2-install) --- src/CabalHelper/Compiletime/Cabal.hs | 83 +++++-- src/CabalHelper/Compiletime/Compile.hs | 258 ++++++++++++++------- .../Compiletime/Program/CabalInstall.hs | 107 ++++++--- src/CabalHelper/Compiletime/Program/GHC.hs | 65 ++++-- src/CabalHelper/Compiletime/Sandbox.hs | 8 +- src/CabalHelper/Compiletime/Types.hs | 1 + 6 files changed, 366 insertions(+), 156 deletions(-) (limited to 'src') diff --git a/src/CabalHelper/Compiletime/Cabal.hs b/src/CabalHelper/Compiletime/Cabal.hs index 8f55473..9d0d00a 100644 --- a/src/CabalHelper/Compiletime/Cabal.hs +++ b/src/CabalHelper/Compiletime/Cabal.hs @@ -20,10 +20,13 @@ Description : cabal-install program interface License : GPL-3 -} +{-# LANGUAGE DeriveFunctor #-} + module CabalHelper.Compiletime.Cabal where import Control.Exception (bracket) import Control.Monad.IO.Class +import Data.Char import Data.List import Data.Maybe import Data.Version @@ -34,30 +37,40 @@ import System.FilePath import CabalHelper.Compiletime.Types import CabalHelper.Compiletime.Process import CabalHelper.Shared.Common (trim, replace) -import Paths_cabal_helper (version) + +type UnpackedCabalVersion = CabalVersion' (CommitId, CabalSourceDir) +type ResolvedCabalVersion = CabalVersion' CommitId +type CabalVersion = CabalVersion' () + +unpackedToResolvedCabalVersion :: UnpackedCabalVersion -> ResolvedCabalVersion +unpackedToResolvedCabalVersion (CabalHEAD (commit, _)) = CabalHEAD commit +unpackedToResolvedCabalVersion (CabalVersion ver) = CabalVersion ver -- | Cabal library version we're compiling the helper exe against. -data CabalVersion - = CabalHEAD { cvCommitId :: CommitId } - | CabalVersion { cabalVersion :: Version } +data CabalVersion' a + = CabalHEAD a + | CabalVersion { cvVersion :: Version } + deriving (Eq, Ord, Functor) newtype CommitId = CommitId { unCommitId :: String } -showCabalVersion :: CabalVersion -> String -showCabalVersion (CabalHEAD commitid) = +showUnpackedCabalVersion :: UnpackedCabalVersion -> String +showUnpackedCabalVersion (CabalHEAD (commitid, _)) = "HEAD-" ++ unCommitId commitid -showCabalVersion CabalVersion {cabalVersion} = - showVersion cabalVersion +showUnpackedCabalVersion CabalVersion {cvVersion} = + showVersion cvVersion -exeName :: CabalVersion -> String -exeName (CabalHEAD commitid) = intercalate "--" - [ "cabal-helper-" ++ showVersion version - , "Cabal-HEAD" ++ unCommitId commitid - ] -exeName CabalVersion {cabalVersion} = intercalate "--" - [ "cabal-helper-" ++ showVersion version - , "Cabal-" ++ showVersion cabalVersion - ] +showResolvedCabalVersion :: ResolvedCabalVersion -> String +showResolvedCabalVersion (CabalHEAD commitid) = + "HEAD-" ++ unCommitId commitid +showResolvedCabalVersion CabalVersion {cvVersion} = + showVersion cvVersion + +showCabalVersion :: CabalVersion -> String +showCabalVersion (CabalHEAD ()) = + "HEAD" +showCabalVersion CabalVersion {cvVersion} = + showVersion cvVersion data CabalPatchDescription = CabalPatchDescription { cpdVersions :: [Version] @@ -123,23 +136,41 @@ patchyCabalVersions = [ unpackPatchedCabal :: Env => Version -> FilePath -> IO CabalSourceDir unpackPatchedCabal cabalVer tmpdir = do - res@(CabalSourceDir dir) <- unpackCabal cabalVer tmpdir variant + res@(CabalSourceDir dir) <- unpackCabalHackage cabalVer tmpdir variant patch dir return res where CabalPatchDescription _ variant patch = fromMaybe nopCabalPatchDescription $ find ((cabalVer `elem`) . cpdVersions) patchyCabalVersions +-- legacy, for `installCabalLib` v1 +unpackCabalV1 + :: Env + => UnpackedCabalVersion + -> FilePath + -> IO CabalSourceDir +unpackCabalV1 (CabalVersion ver) tmpdir = do + csdir <- unpackPatchedCabal ver tmpdir + return csdir +unpackCabalV1 (CabalHEAD (_commit, csdir)) _tmpdir = + return csdir + +unpackCabal :: Env => CabalVersion -> FilePath -> IO UnpackedCabalVersion +unpackCabal (CabalVersion ver) _tmpdir = do + return $ CabalVersion ver +unpackCabal (CabalHEAD ()) tmpdir = do + (commit, csdir) <- unpackCabalHEAD tmpdir + return $ CabalHEAD (commit, csdir) data UnpackCabalVariant = Pristine | LatestRevision newtype CabalSourceDir = CabalSourceDir { unCabalSourceDir :: FilePath } -unpackCabal +unpackCabalHackage :: (Verbose, Progs) => Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir -unpackCabal cabalVer tmpdir variant = do +unpackCabalHackage cabalVer tmpdir variant = do let cabal = "Cabal-" ++ showVersion cabalVer dir = tmpdir cabal variant_opts = case variant of Pristine -> [ "--pristine" ]; _ -> [] @@ -147,14 +178,14 @@ unpackCabal cabalVer tmpdir variant = do callProcessStderr (Just tmpdir) (cabalProgram ?progs) args return $ CabalSourceDir dir -unpackCabalHEAD :: Env => FilePath -> IO (CabalSourceDir, CommitId) +unpackCabalHEAD :: Env => FilePath -> IO (CommitId, CabalSourceDir) unpackCabalHEAD tmpdir = do let dir = tmpdir "cabal-head.git" url = "https://github.com/haskell/cabal.git" ExitSuccess <- rawSystem "git" [ "clone", "--depth=1", url, dir] commit <- withDirectory_ dir $ trim <$> readProcess' "git" ["rev-parse", "HEAD"] "" - return (CabalSourceDir $ dir "Cabal", CommitId commit) + return (CommitId commit, CabalSourceDir $ dir "Cabal") where withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ dir action = @@ -163,6 +194,14 @@ unpackCabalHEAD tmpdir = do (liftIO . setCurrentDirectory) (\_ -> liftIO (setCurrentDirectory dir) >> action) +resolveCabalVersion :: Verbose => CabalVersion -> IO ResolvedCabalVersion +resolveCabalVersion (CabalVersion ver) = return $ CabalVersion ver +resolveCabalVersion (CabalHEAD ()) = do + out <- readProcess' "git" + [ "ls-remote", "https://github.com/haskell/cabal.git", "-h", "master" ] "" + let commit = takeWhile isHexDigit out + return $ CabalHEAD $ CommitId commit + findCabalFile :: FilePath -> IO FilePath findCabalFile pkgdir = do [cfile] <- filter isCabalFile <$> getDirectoryContents pkgdir diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index 2f4b0a9..78c052e 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -43,6 +43,7 @@ import System.Directory import System.FilePath import System.Exit import System.IO +import System.IO.Temp import Prelude import qualified Data.Text as Text @@ -64,15 +65,17 @@ import CabalHelper.Compiletime.Types import CabalHelper.Shared.Common +import Paths_cabal_helper (version) + + data Compile = CompileWithCabalSource { compCabalSourceDir :: CabalSourceDir , compCabalSourceVersion :: Version } | CompileWithCabalPackage - { compPackageDb :: Maybe PackageDbDir - , compCabalVersion :: CabalVersion - , compPackageDeps :: [String] + { compPackageSource :: GhcPackageSource + , compCabalVersion :: ResolvedCabalVersion , compProductTarget :: CompilationProductScope } @@ -88,100 +91,170 @@ data CompPaths = CompPaths -- executable. data CompilationProductScope = CPSGlobal | CPSProject -data CompHelperEnv = CompHelperEnv - { cheCabalVer :: Version - , chePkgDb :: Maybe PackageDbDir - , cheProjDir :: FilePath - , cheNewstyle :: Maybe (PlanJson, FilePath) - , cheCacheDir :: FilePath +type CompHelperEnv = CompHelperEnv' CabalVersion +data CompHelperEnv' cv = CompHelperEnv + { cheCabalVer :: !cv + , chePkgDb :: !(Maybe PackageDbDir) + -- ^ A package-db where we are guaranteed to find Cabal-`cheCabalVer`. + , cheProjDir :: !FilePath + , chePlanJson :: !(Maybe PlanJson) + , cheDistV2 :: !(Maybe FilePath) + , cheProjLocalCacheDir :: FilePath } -compileHelper :: Env => CompHelperEnv -> IO (Either ExitCode FilePath) -compileHelper CompHelperEnv{..} = do - ghcVer <- ghcVersion - Just (prepare, comp) <- runMaybeT $ msum $ - case chePkgDb of - Nothing -> - [ compileCabalSource - , compileNewBuild ghcVer - , compileSandbox ghcVer - , compileGlobal - , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb - ] - Just db -> - [ pure $ (pure (), compileWithPkg (Just db) cheCabalVer CPSProject) - ] - - appdir <- appCacheDir - - let cp@CompPaths {compExePath} = compPaths appdir cheCacheDir comp - exists <- doesFileExist compExePath - if exists - then do - vLog $ "helper already compiled, using exe: "++compExePath - return (Right compExePath) - else do - vLog $ "helper exe does not exist, compiling "++compExePath - prepare >> compile comp cp +compileHelper + :: Env => CompHelperEnv -> IO (Either ExitCode FilePath) +compileHelper che@CompHelperEnv {cheCabalVer} = do + withSystemTempDirectory "cabal-helper.compile-tmp" $ \tmpdir -> do + ucv <- unpackCabal cheCabalVer tmpdir + compileHelper' che { cheCabalVer = ucv } + +compileHelper' + :: Env + => CompHelperEnv' UnpackedCabalVersion + -> IO (Either ExitCode FilePath) +compileHelper' CompHelperEnv {..} = do + ghcVer <- ghcVersion + Just (prepare, comp) <- case cheCabalVer of + cabalVer@CabalHEAD {} -> do + Just <$> compileWithCabalInPrivatePkgDb' ghcVer cabalVer + CabalVersion cabalVerPlain -> do + runMaybeT $ msum $ map (\f -> f ghcVer cabalVerPlain) $ + case chePkgDb of + Nothing -> + [ compileWithCabalV2Inplace + , compileWithCabalV2GhcEnv + , compileCabalSource + , compileSandbox + , compileGlobal + , compileWithCabalInPrivatePkgDb + ] + Just db -> + [ ((.).(.)) liftIO (compilePkgDb db) + ] + appdir <- appCacheDir + let cp@CompPaths {compExePath} = compPaths appdir cheProjLocalCacheDir comp + helper_exists <- doesFileExist compExePath + rv <- if helper_exists + then do + vLog $ "helper already compiled, using exe: "++compExePath + return (Right compExePath) + else do + vLog $ "helper exe does not exist, compiling "++compExePath + prepare >> compile cp comp + + return rv + where logMsg = "using helper compiled with Cabal from " -- for relaxed deps: find (sameMajorVersionAs cheCabalVer) . reverse . sort + compilePkgDb db _ghcVer cabalVer = return $ + (,) + (pure ()) + CompileWithCabalPackage + { compPackageSource = GPSPackageDBs [db] + , compCabalVersion = CabalVersion cabalVer + , compProductTarget = CPSProject + } + -- | Check if this version is globally available - compileGlobal :: Env => MaybeT IO (IO (), Compile) - compileGlobal = do + compileGlobal :: Env => gv -> Version -> MaybeT IO (IO (), Compile) + compileGlobal _ghcVer cabalVer = do cabal_versions <- listCabalVersions Nothing - ver <- MaybeT $ return $ find (== cheCabalVer) cabal_versions + _ <- MaybeT $ return $ find (== cabalVer) cabal_versions vLog $ logMsg ++ "user/global package-db" - return $ (return (), compileWithPkg Nothing ver CPSGlobal) + return $ (return (), compileWithPkg GPSAmbient cabalVer CPSGlobal) -- | Check if this version is available in the project sandbox - compileSandbox :: Env => Version -> MaybeT IO (IO (), Compile) - compileSandbox ghcVer = do + compileSandbox :: Env => GhcVersion -> Version -> MaybeT IO (IO (), Compile) + compileSandbox ghcVer cabalVer = do let mdb_path = getSandboxPkgDb (display buildPlatform) ghcVer cheProjDir sandbox <- PackageDbDir <$> MaybeT mdb_path cabal_versions <- listCabalVersions (Just sandbox) - ver <- MaybeT $ return $ find (== cheCabalVer) cabal_versions + _ <- MaybeT $ return $ find (== cabalVer) cabal_versions vLog $ logMsg ++ "sandbox package-db" - return $ (return (), compileWithPkg (Just sandbox) ver CPSProject) - - compileNewBuild :: Env => Version -> MaybeT IO (IO (), Compile) - compileNewBuild ghcVer = do - (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure cheNewstyle + return $ (return (), compileWithPkg (GPSPackageDBs [sandbox]) cabalVer CPSProject) + + -- | Check if the requested Cabal version is available in a v2-build + -- project's inplace package-db. + -- + -- This is likely only the case if Cabal was vendored by this project or if + -- we're operating on Cabal itself! + compileWithCabalV2Inplace :: Env => GhcVersion -> Version -> MaybeT IO (IO (), Compile) + compileWithCabalV2Inplace ghcVer cabalVer = do + PlanJson {pjUnits} <- maybe mzero pure chePlanJson + distdir_newstyle <- maybe mzero pure cheDistV2 let cabal_pkgid = - PkgId (PkgName (Text.pack "Cabal")) - (Ver $ versionBranch cheCabalVer) + PkgId (PkgName (Text.pack "Cabal")) (Ver $ versionBranch cabalVer) mcabal_unit = listToMaybe $ Map.elems $ Map.filter (\CP.Unit{..} -> uPId == cabal_pkgid) pjUnits CP.Unit {} <- maybe mzero pure mcabal_unit let inplace_db_path = distdir_newstyle - "packagedb" ("ghc-" ++ showVersion ghcVer) + "packagedb" ("ghc-" ++ showGhcVersion ghcVer) inplace_db = PackageDbDir inplace_db_path cabal_versions <- listCabalVersions (Just inplace_db) - ver <- MaybeT $ return $ find (== cheCabalVer) cabal_versions + _ <- MaybeT $ return $ find (== cabalVer) cabal_versions vLog $ logMsg ++ "v2-build package-db " ++ inplace_db_path - return $ (return (), compileWithPkg (Just inplace_db) ver CPSProject) + return $ (return (), compileWithPkg (GPSPackageDBs [inplace_db]) cabalVer CPSProject) + + -- | If this is a v2-build project it makes sense to use @v2-install@ for + -- installing Cabal as this will use the @~/.cabal/store@. We use + -- @--package-env@ to instruct cabal to not meddle with the user's package + -- environment. + compileWithCabalV2GhcEnv :: Env => GhcVersion -> Version -> MaybeT IO (IO (), Compile) + compileWithCabalV2GhcEnv ghcVer cabalVer = do + _ <- maybe mzero pure cheDistV2 -- bail if this isn't a v2-build project + CabalInstallVersion instVer <- liftIO cabalInstallVersion + guard $ instVer >= (Version [2,4,1,0] []) + -- ^ didn't test with older versions + env@(PackageEnvFile env_file) + <- liftIO $ getPrivateCabalPkgEnv ghcVer cabalVer + vLog $ logMsg ++ "v2-build package-env " ++ env_file + return $ (prepare env, compileWithPkg (GPSPackageEnv env) cabalVer CPSGlobal) + where + prepare env = do + -- exists_in_env <- liftIO $ cabalVersionExistsInPkgDb cheCabalVer db + void $ installCabalLibV2 ghcVer cheCabalVer env `E.catch` + \(SomeException _) -> + case cheCabalVer of + CabalHEAD _ -> panicIO "Installing Cabal HEAD failed." + CabalVersion ver -> errorInstallCabal (CabalVersion ver) + + + + compileWithCabalInPrivatePkgDb + :: (Env, MonadIO m) => GhcVersion -> Version -> m (IO (), Compile) + compileWithCabalInPrivatePkgDb ghcVer cabalVer = + liftIO $ compileWithCabalInPrivatePkgDb' ghcVer (CabalVersion cabalVer) -- | Compile the requested Cabal version into an isolated package-db if it's -- not there already - compileWithCabalInPrivatePkgDb :: Env => IO (IO (), Compile) - compileWithCabalInPrivatePkgDb = do + compileWithCabalInPrivatePkgDb' + :: Env => GhcVersion -> UnpackedCabalVersion -> IO (IO (), Compile) + compileWithCabalInPrivatePkgDb' ghcVer cabalVer = do db@(PackageDbDir db_path) - <- getPrivateCabalPkgDb (CabalVersion cheCabalVer) + <- getPrivateCabalPkgDb $ unpackedToResolvedCabalVersion cabalVer vLog $ logMsg ++ "private package-db in " ++ db_path - return (prepare db, compileWithPkg (Just db) cheCabalVer CPSGlobal) + return $ (,) + (prepare db) + CompileWithCabalPackage + { compPackageSource = GPSPackageDBs [db] + , compCabalVersion = unpackedToResolvedCabalVersion cabalVer + , compProductTarget = CPSGlobal + } where prepare db = do - db_exists <- liftIO $ cabalVersionExistsInPkgDb cheCabalVer db + db_exists <- liftIO $ cabalVersionExistsInPkgDb cabalVer db when (not db_exists) $ - void $ installCabalLib (Right cheCabalVer) `E.catch` - \(SomeException _) -> errorInstallCabal cheCabalVer + void (installCabalLibV1 ghcVer cabalVer) `E.catch` + \(SomeException _) -> errorInstallCabal cabalVer -- | See if we're in a cabal source tree - compileCabalSource :: Env => MaybeT IO (IO (), Compile) - compileCabalSource = do +-- compileCabalSource :: Env => MaybeT IO (IO (), Compile) + compileCabalSource _ghcVer _cabalVer = do let cabalFile = cheProjDir "Cabal.cabal" cabalSrc <- liftIO $ doesFileExist cabalFile let projdir = CabalSourceDir cheProjDir @@ -208,18 +281,15 @@ compileHelper CompHelperEnv{..} = do , compCabalSourceVersion = ver } - compileWithPkg mdb ver target = + compileWithPkg pkg_src ver target = CompileWithCabalPackage - { compPackageDb = mdb + { compPackageSource = pkg_src , compCabalVersion = CabalVersion ver - , compPackageDeps = [cabalPkgId ver] , compProductTarget = target } - cabalPkgId v = "Cabal-" ++ showVersion v - -compile :: Env => Compile -> CompPaths -> IO (Either ExitCode FilePath) -compile comp paths@CompPaths {..} = do +compile :: Env => CompPaths -> Compile -> IO (Either ExitCode FilePath) +compile paths@CompPaths {..} comp = do createDirectoryIfMissing True compOutDir createHelperSources compBuildDir @@ -230,30 +300,45 @@ compile comp paths@CompPaths {..} = do invokeGhc $ compGhcInvocation comp paths compPaths :: FilePath -> FilePath -> Compile -> CompPaths -compPaths appdir cachedir c = - case c of - CompileWithCabalPackage {compProductTarget=CPSGlobal,..} -> CompPaths {..} +compPaths appdir proj_local_cachedir c = + case c of + CompileWithCabalPackage + { compProductTarget=CPSGlobal + , compCabalVersion + } -> CompPaths {..} where - compBuildDir = appdir exeName compCabalVersion ++ "--" ++ sourceHash <.> "build" + compBuildDir = + appdir exeName compCabalVersion ++ "--" ++ sourceHash <.> "build" compOutDir = compBuildDir compExePath = compBuildDir "cabal-helper" - - CompileWithCabalPackage {compProductTarget=CPSProject,..} -> cachedirPaths - CompileWithCabalSource {..} -> cachedirPaths + CompileWithCabalPackage {compProductTarget=CPSProject} -> + projLocalCachedirPaths + CompileWithCabalSource {} -> + projLocalCachedirPaths where - cachedirPaths = CompPaths {..} + projLocalCachedirPaths = CompPaths {..} where - compBuildDir = cachedir "cabal-helper" + compBuildDir = proj_local_cachedir "cabal-helper" compOutDir = compBuildDir compExePath = compOutDir "cabal-helper" +exeName :: ResolvedCabalVersion -> String +exeName (CabalHEAD commitid) = intercalate "--" + [ "cabal-helper-" ++ showVersion version + , "Cabal-HEAD" ++ unCommitId commitid + ] +exeName CabalVersion {cvVersion} = intercalate "--" + [ "cabal-helper-" ++ showVersion version + , "Cabal-" ++ showVersion cvVersion + ] + compGhcInvocation :: Compile -> CompPaths -> GhcInvocation compGhcInvocation comp CompPaths {..} = case comp of CompileWithCabalSource {..} -> GhcInvocation { giIncludeDirs = [compBuildDir, unCabalSourceDir compCabalSourceDir] - , giPackageDBs = [] + , giPackageSource = GPSAmbient , giHideAllPackages = False , giPackages = [] , giCPPOptions = cppOptions compCabalSourceVersion @@ -263,7 +348,7 @@ compGhcInvocation comp CompPaths {..} = CompileWithCabalPackage {..} -> GhcInvocation { giIncludeDirs = [compBuildDir] - , giPackageDBs = maybeToList compPackageDb + , giPackageSource = compPackageSource , giHideAllPackages = True , giPackages = [ "base" @@ -273,7 +358,10 @@ compGhcInvocation comp CompPaths {..} = , "process" , "bytestring" , "ghc-prim" - ] ++ compPackageDeps + , case compCabalVersion of + CabalHEAD {} -> "Cabal" + CabalVersion ver -> "Cabal-" ++ showVersion ver + ] , giCPPOptions = cppOptions (unCabalVersion compCabalVersion) , .. } @@ -319,9 +407,11 @@ Otherwise we might be able to use the shipped Setup.hs -} -errorInstallCabal :: Version -> IO a -errorInstallCabal cabalVer = panicIO $ printf "\ -\Installing Cabal version %s failed.\n\ +errorInstallCabal :: CabalVersion' a -> IO b +errorInstallCabal (CabalHEAD _) = + error "cabal-helper: Installing Cabal HEAD failed." +errorInstallCabal (CabalVersion cabalVer) = panicIO $ printf "\ +\cabal-helper: Installing Cabal version %s failed.\n\ \\n\ \You have the following choices to fix this:\n\ \\n\ 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 diff --git a/src/CabalHelper/Compiletime/Sandbox.hs b/src/CabalHelper/Compiletime/Sandbox.hs index 5af226a..7a757c4 100644 --- a/src/CabalHelper/Compiletime/Sandbox.hs +++ b/src/CabalHelper/Compiletime/Sandbox.hs @@ -33,11 +33,13 @@ import Prelude import qualified Data.Traversable as T import CabalHelper.Shared.Common +import CabalHelper.Compiletime.Program.GHC + ( GhcVersion (..), showGhcVersion ) -- | Get the path to the sandbox package-db in a project getSandboxPkgDb :: String -- ^ Cabal build platform, i.e. @buildPlatform@ - -> Version + -> GhcVersion -- ^ GHC version (@cProjectVersion@ is your friend) -> FilePath -- ^ Path to the cabal package root directory (containing the @@ -54,9 +56,9 @@ getSandboxPkgDb platform ghcVer projdir = do True -> dir False -> takeDirectory dir ghcSandboxPkgDbDir platform ghcVer -ghcSandboxPkgDbDir :: String -> Version -> String +ghcSandboxPkgDbDir :: String -> GhcVersion -> String ghcSandboxPkgDbDir platform ghcVer = - platform ++ "-ghc-" ++ showVersion ghcVer ++ "-packages.conf.d" + platform ++ "-ghc-" ++ showGhcVersion ghcVer ++ "-packages.conf.d" -- | Extract the sandbox package db directory from the cabal.sandbox.config -- file. Exception is thrown if the sandbox config file is broken. diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 60b0f4d..491c205 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -301,3 +301,4 @@ defaultCompileOptions = CompileOptions False Nothing Nothing defaultPrograms newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath } +newtype PackageEnvFile = PackageEnvFile { unPackageEnvFile :: FilePath } -- cgit v1.2.3