diff options
-rw-r--r-- | lib/Distribution/Helper.hs | 24 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Cabal.hs | 83 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 258 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Program/CabalInstall.hs | 107 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Program/GHC.hs | 65 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Sandbox.hs | 8 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 1 | ||||
-rw-r--r-- | tests/CompileTest.hs | 88 |
8 files changed, 424 insertions, 210 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index ba8c2dd..bafe3ca 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -123,6 +123,7 @@ import CabalHelper.Compiletime.Compile import qualified CabalHelper.Compiletime.Program.Stack as Stack import qualified CabalHelper.Compiletime.Program.GHC as GHC import qualified CabalHelper.Compiletime.Program.CabalInstall as CabalInstall +import CabalHelper.Compiletime.Cabal import CabalHelper.Compiletime.Sandbox import CabalHelper.Compiletime.Types import CabalHelper.Compiletime.Types.RelativePath @@ -517,7 +518,7 @@ writeAutogenFiles Unit{uCabalFile, uDistDir} = Query $ \qe -> do getSandboxPkgDb :: String -- ^ Cabal build platform, i.e. @buildPlatform@ - -> Version + -> GHC.GhcVersion -- ^ GHC version (@cProjectVersion@ is your friend) -> FilePath -- ^ Path to the project directory, i.e. a directory containing a @@ -593,22 +594,24 @@ wrapper' (DistDirV1 distdir) ProjInfo{piCabalVersion} = CompHelperEnv - { cheCabalVer = piCabalVersion + { cheCabalVer = CabalVersion piCabalVersion , cheProjDir = plV1Dir projloc - , cheCacheDir = distdir + , cheProjLocalCacheDir = distdir , chePkgDb = Nothing - , cheNewstyle = Nothing + , chePlanJson = Nothing + , cheDistV2 = Nothing } wrapper' (ProjLocV2Dir projdir) (DistDirV2 distdir) ProjInfo{piImpl=ProjInfoV2{piV2Plan=plan}} = CompHelperEnv - { cheCabalVer = makeDataVersion pjCabalLibVersion + { cheCabalVer = CabalVersion $ makeDataVersion pjCabalLibVersion , cheProjDir = projdir - , cheCacheDir = distdir </> "cache" + , cheProjLocalCacheDir = distdir </> "cache" , chePkgDb = Nothing - , cheNewstyle = Just (plan, distdir) + , chePlanJson = Just plan + , cheDistV2 = Just distdir } where PlanJson {pjCabalLibVersion=Ver pjCabalLibVersion } = plan @@ -624,9 +627,10 @@ wrapper' } = let workdir = fromMaybe ".stack-work" $ unRelativePath <$> mworkdir in CompHelperEnv - { cheCabalVer = piCabalVersion + { cheCabalVer = CabalVersion $ piCabalVersion , cheProjDir = projdir - , cheCacheDir = projdir </> workdir + , cheProjLocalCacheDir = projdir </> workdir , chePkgDb = Just sppGlobalPkgDb - , cheNewstyle = Nothing + , chePlanJson = Nothing + , cheDistV2 = Nothing } 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 } diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs index da16a1a..33254b2 100644 --- a/tests/CompileTest.hs +++ b/tests/CompileTest.hs @@ -11,7 +11,7 @@ import System.FilePath import System.Process import System.Exit import System.IO -import Control.Exception as E +import System.IO.Temp import Data.List import Data.Maybe import Data.Version @@ -20,6 +20,7 @@ import Data.Function import Distribution.Version (VersionRange, withinRange) import Control.Arrow import Control.Monad +import Control.Monad.Trans.Maybe import Prelude import CabalHelper.Compiletime.Compat.Environment @@ -27,7 +28,7 @@ import CabalHelper.Compiletime.Compat.Version import CabalHelper.Compiletime.Compat.Parsec import CabalHelper.Compiletime.Cabal import CabalHelper.Compiletime.Compile -import CabalHelper.Compiletime.Program.CabalInstall +--import CabalHelper.Compiletime.Program.CabalInstall import CabalHelper.Compiletime.Program.GHC import CabalHelper.Compiletime.Types import CabalHelper.Shared.Common @@ -56,7 +57,7 @@ main = do "list-versions":[] -> do mapM_ print =<< (allCabalVersions <$> ghcVersion) "list-versions":ghc_ver_str:[] -> - mapM_ print $ allCabalVersions (parseVer ghc_ver_str) + mapM_ print $ allCabalVersions (GhcVersion (parseVer ghc_ver_str)) _ -> test args @@ -72,12 +73,12 @@ test args = do action -parseVer' :: String -> Either HEAD Version -parseVer' "HEAD" = Left HEAD -parseVer' v = Right $ parseVer v +parseVer' :: String -> CabalVersion +parseVer' "HEAD" = CabalHEAD () +parseVer' v = CabalVersion $ parseVer v -allCabalVersions :: Version -> [Version] -allCabalVersions ghc_ver = let +allCabalVersions :: GhcVersion -> [Version] +allCabalVersions (GhcVersion ghc_ver) = let cabal_versions :: [Version] cabal_versions = map parseVer -- , "1.18.0" @@ -143,17 +144,44 @@ testAllCabalVersions :: Env => IO () testAllCabalVersions = do ghc_ver <- ghcVersion let relevant_cabal_versions = allCabalVersions ghc_ver - testCabalVersions $ map Right relevant_cabal_versions ++ [Left HEAD] + testCabalVersions $ map CabalVersion relevant_cabal_versions ++ [CabalHEAD ()] -testCabalVersions :: Env => [Either HEAD Version] -> IO () +testCabalVersions :: Env => [CabalVersion] -> IO () testCabalVersions versions = do - rvs <- forM versions $ \ver -> do - let sver = either show showVersion ver - hPutStrLn stderr $ "\n\n\n\n\n\n====== Compiling with Cabal-" ++ sver - compilePrivatePkgDb ver +-- ghcVer <- ghcVersion + rvs <- forM versions $ \cv -> do + withSystemTempDirectory "cabal-helper.proj-local-tmp" $ \tmpdir -> do + + let sver = showCabalVersion cv + hPutStrLn stderr $ "\n\n\n\n\n\n====== Compiling with Cabal-" ++ sver + + let che0 = \icv db -> CompHelperEnv + { cheCabalVer = icv + , chePkgDb = db + , cheProjDir = tmpdir + , chePlanJson = Nothing + , cheDistV2 = Just $ tmpdir </> "dist-newstyle" + , cheProjLocalCacheDir = + tmpdir </> "dist-newstyle" </> "cache" + } + + che <- case cv of + CabalHEAD () -> do + rcv <- resolveCabalVersion cv + db <- getPrivateCabalPkgDb rcv + mcabalVersions <- runMaybeT $ listCabalVersions (Just db) + case mcabalVersions of + Just [hdver] -> + return $ che0 (CabalVersion hdver) (Just db) + _ -> + return $ che0 (CabalHEAD ()) Nothing + (CabalVersion ver) -> + return $ che0 (CabalVersion ver) Nothing + + compileHelper che let printStatus (cv, rv) = putStrLn $ "- Cabal "++ver++" "++status - where ver = case cv of Left _ -> "HEAD"; Right v -> showVersion v + where ver = showCabalVersion cv status = case rv of Right _ -> "succeeded" @@ -163,38 +191,10 @@ testCabalVersions versions = do let drvs = versions `zip` rvs mapM_ printStatus drvs - if any isLeft' $ map snd $ filter ((/=Left HEAD) . fst) drvs + if any isLeft' $ map snd $ filter ((/=(CabalHEAD ())) . fst) drvs then exitFailure else exitSuccess where isLeft' (Left _) = True isLeft' (Right _) = False - -compilePrivatePkgDb - :: Env => Either HEAD Version -> IO (Either ExitCode FilePath) -compilePrivatePkgDb eCabalVer = do - res <- E.try $ installCabalLib eCabalVer - case res of - Right (db, cabalVer) -> - compileWithPkg db cabalVer - Left (ioe :: IOException) -> do - print ioe - return $ Left (ExitFailure 1) - -compileWithPkg :: Env - => PackageDbDir - -> CabalVersion - -> IO (Either ExitCode FilePath) -compileWithPkg db cabalVer = do - appdir <- appCacheDir - let comp = - CompileWithCabalPackage (Just db) cabalVer [cabalPkgId cabalVer] CPSGlobal - compile - comp - (compPaths appdir (error "compile-test: distdir not available") comp) - - -cabalPkgId :: CabalVersion -> String -cabalPkgId (CabalHEAD _commitid) = "Cabal" -cabalPkgId (CabalVersion v) = "Cabal-" ++ showVersion v |