diff options
| -rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 267 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Data.hs | 9 | ||||
| -rw-r--r-- | tests/CompileTest.hs | 48 |
3 files changed, 206 insertions, 118 deletions
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index a96ded8..7af3cf1 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -12,7 +12,8 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, +GADTs #-} {-| Module : CabalHelper.Compiletime.Compile @@ -28,7 +29,6 @@ import Control.Exception as E import Control.Monad import Control.Monad.Trans.Maybe import Control.Monad.IO.Class -import Data.Traversable import Data.Char import Data.List import Data.Maybe @@ -55,13 +55,29 @@ import CabalHelper.Compiletime.Types import CabalHelper.Shared.Common import CabalHelper.Shared.Sandbox (getSandboxPkgDb) -data Compile = Compile { - compCabalSourceDir :: Maybe CabalSourceDir, - compPackageDb :: Maybe PackageDbDir, - compCabalVersion :: CabalVersion, - compPackageDeps :: [String] +data Compile + = CompileWithCabalSource + { compCabalSourceDir :: CabalSourceDir + } + | CompileWithCabalPackage + { compPackageDb :: Maybe PackageDbDir + , compCabalVersion :: CabalVersion + , compPackageDeps :: [String] + , compProductTarget :: CompilationProductScope + } + +data CompPaths = CompPaths + { compSrcDir :: FilePath + , compOutDir :: FilePath + , compExePath :: FilePath } +-- | The Helper executable we produce as a compilation product can either be +-- placed in a per-project location, or a per-user/global location in the user's +-- home directory. This type controls where the compilation process places the +-- executable. +data CompilationProductScope = CPSGlobal | CPSProject + compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath) compileHelper opts hdrCabalVersion projdir distdir = do case oCabalPkgDb opts of @@ -70,12 +86,12 @@ compileHelper opts hdrCabalVersion projdir distdir = do , Right <$> MaybeT (cachedExe (CabalVersion hdrCabalVersion)) , compileSandbox , compileGlobal - , cachedCabalPkg + , compileWithCachedCabalPkg , MaybeT (Just <$> compilePrivatePkgDb) ] mdb -> run [ Right <$> MaybeT (cachedExe (CabalVersion hdrCabalVersion)) - , liftIO $ compileWithPkg mdb hdrCabalVersion + , liftIO $ compileWithPkg mdb hdrCabalVersion CPSProject ] where @@ -90,7 +106,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do compileGlobal = do ver <- MaybeT $ find (== hdrCabalVersion) <$> listCabalVersions opts vLog opts $ logMsg ++ "user/global package-db" - liftIO $ compileWithPkg Nothing ver + liftIO $ compileWithPkg Nothing ver CPSGlobal -- | Check if this version is available in the project sandbox compileSandbox :: MaybeT IO (Either ExitCode FilePath) @@ -101,13 +117,13 @@ compileHelper opts hdrCabalVersion projdir distdir = do ver <- MaybeT $ logIOError opts "compileSandbox" $ find (== hdrCabalVersion) <$> listCabalVersions' opts (Just sandbox) vLog opts $ logMsg ++ "sandbox package-db" - liftIO $ compileWithPkg (Just sandbox) ver + liftIO $ compileWithPkg (Just sandbox) ver CPSProject -- | Check if we already compiled this version of cabal into a private -- package-db - cachedCabalPkg :: MaybeT IO (Either ExitCode FilePath) - cachedCabalPkg = do + compileWithCachedCabalPkg :: MaybeT IO (Either ExitCode FilePath) + compileWithCachedCabalPkg = do db_exists <- liftIO $ cabalVersionExistsInPkgDb opts hdrCabalVersion case db_exists of False -> mzero @@ -115,7 +131,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do db@(PackageDbDir db_path) <- liftIO $ getPrivateCabalPkgDb opts (CabalVersion hdrCabalVersion) vLog opts $ logMsg ++ "private package-db in " ++ db_path - liftIO $ compileWithPkg (Just db) hdrCabalVersion + liftIO $ compileWithPkg (Just db) hdrCabalVersion CPSGlobal -- | See if we're in a cabal source tree compileCabalSource :: MaybeT IO (Either ExitCode FilePath) @@ -126,113 +142,160 @@ compileHelper opts hdrCabalVersion projdir distdir = do case cabalSrc of False -> mzero True -> liftIO $ do - vLog opts $ "directory above distdir looks like cabal source tree (Cabal.cabal exists)" - ver <- cabalFileVersion <$> readFile cabalFile + vLog opts $ "projdir looks like Cabal source tree (Cabal.cabal exists)" + -- ver <- cabalFileVersion <$> readFile cabalFile vLog opts $ "compiling helper with local Cabal source tree" - compileWithCabalTree ver projdir' + compileWithCabalSource projdir' -- | Compile the requested cabal version into an isolated package-db compilePrivatePkgDb :: IO (Either ExitCode FilePath) compilePrivatePkgDb = do db <- fst <$> installCabal opts (Right hdrCabalVersion) `E.catch` \(SomeException _) -> errorInstallCabal hdrCabalVersion distdir - compileWithPkg (Just db) hdrCabalVersion - - compileWithCabalTree ver srcDir = - compile distdir opts $ Compile { - compCabalSourceDir = Just srcDir, - compPackageDb = Nothing, - compCabalVersion = CabalVersion ver, - compPackageDeps = [] - } - - compileWithPkg mdb ver = - compile distdir opts $ Compile { - compCabalSourceDir = Nothing, - compPackageDb = mdb, - compCabalVersion = CabalVersion ver, - compPackageDeps = [cabalPkgId ver] - } + compileWithPkg (Just db) hdrCabalVersion CPSGlobal + + compileWithCabalSource srcDir = + compile CompileWithCabalSource + { compCabalSourceDir = srcDir + } distdir opts + + compileWithPkg mdb ver target = + compile CompileWithCabalPackage + { compPackageDb = mdb + , compCabalVersion = CabalVersion ver + , compPackageDeps = [cabalPkgId ver] + , compProductTarget = target + } distdir opts cabalPkgId v = "Cabal-" ++ showVersion v -compile :: FilePath -> Options -> Compile -> IO (Either ExitCode FilePath) -compile distdir opts@Options {..} Compile {..} = do - cnCabalSourceDir - <- (canonicalizePath . unCabalSourceDir) `traverse` compCabalSourceDir +compile :: Compile -> FilePath -> Options -> IO (Either ExitCode FilePath) +compile comp distdir opts@Options {..} = do appdir <- appCacheDir - let (outdir, exedir, exe, mchsrcdir) = - case cnCabalSourceDir of - Nothing -> ( exeName compCabalVersion <.> "build" - , appdir - , appdir </> exeName compCabalVersion - , Nothing - ) - Just _ -> ( distdir </> "cabal-helper" - , distdir - , distdir </> "cabal-helper" </> "cabal-helper" - , Just $ distdir </> "cabal-helper" - ) - - createDirectoryIfMissing True outdir - createDirectoryIfMissing True exedir - - withHelperSources mchsrcdir $ \compCabalHelperSourceDir -> do - - vLog opts $ "sourcedir: " ++ compCabalHelperSourceDir - vLog opts $ "outdir: " ++ outdir - vLog opts $ "exe: " ++ exe - - let (mj1:mj2:mi:_) = case compCabalVersion of - CabalHEAD _commitid -> [10000000, 0, 0] - CabalVersion (Version vs _) -> vs - let ghc_opts = concat [ - [ "-outputdir", outdir - , "-o", exe - , "-optP-DCABAL_HELPER=1" - , "-optP-DCH_MIN_VERSION_Cabal(major1,major2,minor)=(\ - \ (major1) < "++show mj1++" \ - \|| (major1) == "++show mj1++" && (major2) < "++show mj2++"\ - \|| (major1) == "++show mj1++" && (major2) == "++show mj2++" && (minor) <= "++show mi++")" - ], - maybeToList $ ("-package-conf="++) <$> unPackageDbDir <$> compPackageDb, - map ("-i"++) $ nub $ "":compCabalHelperSourceDir:maybeToList cnCabalSourceDir, - - if isNothing cnCabalSourceDir - then [ "-hide-all-packages" - , "-package", "base" - , "-package", "containers" - , "-package", "directory" - , "-package", "filepath" - , "-package", "process" - , "-package", "bytestring" - , "-package", "ghc-prim" - ] - else [], - - concatMap (\p -> ["-package", p]) compPackageDeps, - [ "--make" - , compCabalHelperSourceDir</>"CabalHelper"</>"Runtime"</>"Main.hs" - ] - ] + let paths@CompPaths {..} = compPaths appdir distdir comp + + createDirectoryIfMissing True compOutDir + createHelperSources compSrcDir - rv <- callProcessStderr' opts Nothing oGhcProgram ghc_opts - return $ case rv of - ExitSuccess -> Right exe - e@(ExitFailure _) -> Left e + vLog opts $ "compSrcDir: " ++ compSrcDir + vLog opts $ "compOutDir: " ++ compOutDir + vLog opts $ "compExePath: " ++ compExePath + invokeGhc opts $ compGhcInvocation comp paths + +compPaths :: FilePath -> FilePath -> Compile -> CompPaths +compPaths appdir distdir c = + case c of + CompileWithCabalPackage {compProductTarget=CPSGlobal,..} -> CompPaths {..} + where + compSrcDir = appdir </> exeName compCabalVersion <.> "build" + compOutDir = compSrcDir + compExePath = appdir </> exeName compCabalVersion + + CompileWithCabalPackage {compProductTarget=CPSProject,..} -> distdirPaths + CompileWithCabalSource {..} -> distdirPaths + where + distdirPaths = CompPaths {..} + where + compSrcDir = distdir </> "cabal-helper" + compOutDir = compSrcDir + compExePath = compOutDir </> "cabal-helper" + +data GhcInvocation = GhcInvocation + { giOutDir :: FilePath + , giOutput :: FilePath + , giCPPOptions :: [String] + , giPackageDBs :: [PackageDbDir] + , giIncludeDirs :: [FilePath] + , giHideAllPackages :: Bool + , giPackages :: [String] + , giInputs :: [String] + } + +compGhcInvocation :: Compile -> CompPaths -> GhcInvocation +compGhcInvocation comp CompPaths {..} = + case comp of + CompileWithCabalSource {..} -> + GhcInvocation + { giIncludeDirs = [compSrcDir, unCabalSourceDir compCabalSourceDir] + , giPackageDBs = [] + , giPackages = [] + , .. + } + CompileWithCabalPackage {..} -> + GhcInvocation + { giIncludeDirs = [compSrcDir] + , giPackageDBs = maybeToList compPackageDb + , giPackages = + [ "base" + , "containers" + , "directory" + , "filepath" + , "process" + , "bytestring" + , "ghc-prim" + ] ++ compPackageDeps + , .. + } + where + (mj1:mj2:mi:_) = + case compCabalVersion comp of + CabalHEAD _commit -> [10000000, 0, 0] + CabalVersion (Version vs _) -> vs + + giOutDir = compOutDir + giOutput = compExePath + giCPPOptions = + [ "-DCABAL_HELPER=1" + , minVersionMacro (mj1,mj2,mi) + ] + giHideAllPackages = True + giInputs = [compSrcDir</>"CabalHelper"</>"Runtime"</>"Main.hs"] + + +minVersionMacro :: (Int, Int, Int) -> String +minVersionMacro (mj1,mj2,mi) = + "-DCH_MIN_VERSION_Cabal(major1,major2,minor)=\ + \( (major1) < "++show mj1++" \ + \|| (major1) == "++show mj1++" && (major2) < "++show mj2++" \ + \|| (major1) == "++show mj1++" && (major2) == "++show mj2++" && (minor) <= "++show mi++ + ")" + +invokeGhc :: Options -> GhcInvocation -> IO (Either ExitCode FilePath) +invokeGhc opts@Options {..} GhcInvocation {..} = do + rv <- callProcessStderr' opts Nothing oGhcProgram $ concat + [ [ "-outputdir", giOutDir + , "-o", giOutput + ] + , map ("-optP"++) giCPPOptions + , map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs + , map ("-i"++) $ nub $ "" : giIncludeDirs + , if giHideAllPackages then ["-hide-all-packages"] else [] + , concatMap (\p -> ["-package", p]) giPackages + , ["--make"] + , giInputs + ] + return $ + case rv of + ExitSuccess -> Right giOutput + e@(ExitFailure _) -> Left e + + +-- | Cabal library version we're compiling the helper exe against. data CabalVersion - = CabalHEAD { cvCommitId :: String } + = CabalHEAD { cvCommitId :: CommitId } | CabalVersion { cabalVersion :: Version } +newtype CommitId = CommitId { unCommitId :: String } + exeName :: CabalVersion -> String exeName (CabalHEAD commitid) = intercalate "-" - [ "cabal-helper" ++ showVersion version -- our ver - , "CabalHEAD" ++ commitid + [ "cabal-helper" ++ showVersion version + , "CabalHEAD" ++ unCommitId commitid ] exeName CabalVersion {cabalVersion} = intercalate "-" - [ "cabal-helper" ++ showVersion version -- our ver + [ "cabal-helper" ++ showVersion version , "Cabal" ++ showVersion cabalVersion ] @@ -486,14 +549,14 @@ unpackCabal opts cabalVer tmpdir variant = do callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args return $ CabalSourceDir dir -unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, String) +unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, CommitId) 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", commit) + return (CabalSourceDir $ dir </> "Cabal", CommitId commit) where withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ dir action = diff --git a/src/CabalHelper/Compiletime/Data.hs b/src/CabalHelper/Compiletime/Data.hs index ca291e9..4e512db 100644 --- a/src/CabalHelper/Compiletime/Data.hs +++ b/src/CabalHelper/Compiletime/Data.hs @@ -49,8 +49,8 @@ withSystemTempDirectoryEnv tpl f = do tmpdir <- getCanonicalTemporaryDirectory f =<< createTempDirectory tmpdir tpl -withHelperSources :: Maybe FilePath -> (FilePath -> IO a) -> IO a -withHelperSources mdir action = withDir mdir $ \dir -> do +createHelperSources :: FilePath -> IO () +createHelperSources dir = do let chdir = dir </> "CabalHelper" liftIO $ do createDirectoryIfMissing True $ chdir </> "Runtime" @@ -70,11 +70,6 @@ withHelperSources mdir action = withDir mdir $ \dir -> do BS.writeFile path $ UTF8.fromString src setFileTimes path modtime modtime - action dir - where - withDir (Just dir) = \f -> f dir - withDir Nothing = withSystemTempDirectoryEnv "cabal-helper-source" - sourceFiles :: [(FilePath, String)] sourceFiles = diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs index 0f5bf34..e65de8d 100644 --- a/tests/CompileTest.hs +++ b/tests/CompileTest.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, GADTs #-} +import System.Environment (getArgs) +import System.Directory +import System.FilePath import System.Process import System.Exit import System.IO @@ -33,14 +36,34 @@ withinRange'CH v r = where v' = either (const $ parseVer "1000000000") id v +setupHOME :: IO () +setupHOME = do + tmp <- fromMaybe "/tmp" <$> lookupEnv "TMPDIR" + let home = tmp </> "compile-test-home" + _ <- rawSystem "rm" ["-r", home] + createDirectory home + setEnv "HOME" home + main :: IO () main = do - setEnv "HOME" =<< fromMaybe "/tmp" <$> lookupEnv "TMPDIR" + args <- getArgs + + let action + | null args = testAllCabalVersions + | otherwise = testCabalVersions $ map parseVer' args + + setupHOME + _ <- rawSystem "cabal" ["update"] - let parseVer' "HEAD" = Left HEAD - parseVer' v = Right $ parseVer v + action +parseVer' :: String -> Either HEAD Version +parseVer' "HEAD" = Left HEAD +parseVer' v = Right $ parseVer v + +testAllCabalVersions :: IO () +testAllCabalVersions = do let cabal_versions :: [Either HEAD Version] cabal_versions = map parseVer' -- "1.14.0" -- not supported at runtime @@ -105,7 +128,11 @@ main = do relevant_cabal_versions = reverse $ filter (flip withinRange'CH constraint) cabal_versions - rvs <- forM relevant_cabal_versions $ \ver -> do + testCabalVersions relevant_cabal_versions + +testCabalVersions :: [Either HEAD Version] -> 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 @@ -118,9 +145,9 @@ main = do Left rvc -> "failed (exit code "++show rvc++")" - let drvs = relevant_cabal_versions `zip` rvs + let drvs = versions `zip` rvs - mapM_ printStatus (relevant_cabal_versions `zip` rvs) + mapM_ printStatus drvs if any isLeft' $ map snd $ filter ((/=Left HEAD) . fst) drvs then exitFailure else exitSuccess @@ -143,8 +170,11 @@ compileWithPkg :: Maybe PackageDbDir -> CabalVersion -> IO (Either ExitCode FilePath) compileWithPkg mdb cabalVer = - compile "/does-not-exist" defaultOptions { oVerbose = True } $ - Compile Nothing mdb cabalVer [cabalPkgId cabalVer] + compile + (CompileWithCabalPackage mdb cabalVer [cabalPkgId cabalVer] CPSGlobal) + "/does-not-exist" + defaultOptions { oVerbose = True } + cabalPkgId :: CabalVersion -> String cabalPkgId (CabalHEAD _commitid) = "Cabal" |