diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs --- a/CabalHelper/Common.hs +++ b/CabalHelper/Common.hs @@ -30,6 +30,8 @@ import System.Environment import System.IO import System.Exit +import System.Directory +import System.FilePath import Text.ParserCombinators.ReadP import Prelude @@ -95,3 +97,6 @@ runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of (a,""):[] -> a _ -> error $ "Error parsing: " ++ show i + +appDataDir :: IO FilePath +appDataDir = ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" diff --git a/CabalHelper/Compile.hs b/CabalHelper/Compile.hs new file mode 100644 --- /dev/null +++ b/CabalHelper/Compile.hs @@ -0,0 +1,368 @@ +-- cabal-helper: Simple interface to Cabal's configuration state +-- Copyright (C) 2015 Daniel Gröber +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE RecordWildCards, FlexibleContexts #-} +module CabalHelper.Compile where + +import Control.Applicative +import Control.Arrow +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 +import Data.String +import Data.Version +import Text.Printf +import System.Directory +import System.FilePath +import System.Process +import System.Exit +import System.IO +import Prelude + +import Distribution.System (buildPlatform) +import Distribution.Text (display) + +import Paths_cabal_helper (version) +import CabalHelper.Data +import CabalHelper.Common +import CabalHelper.Sandbox (getSandboxPkgDb) +import CabalHelper.Types +import CabalHelper.Log + +compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath) +compileHelper opts cabalVer projdir distdir = withHelperSources $ \chdir -> do + run [ compileCabalSource chdir -- TODO: here ghc's caching fails and it always + -- recompiles, probably because we write the + -- sources to a tempdir and they always look + -- newer than the Cabal sources, not sure if we + -- can fix this + , Right <$> MaybeT (cachedExe cabalVer) + , compileSandbox chdir + , compileGlobal chdir + , cachedCabalPkg chdir + , MaybeT (Just <$> compilePrivatePkgDb chdir) + ] + + where + run actions = fromJust <$> runMaybeT (msum actions) + + logMsg = "compiling helper with Cabal from " + + +-- for relaxed deps: find (sameMajorVersionAs cabalVer) . reverse . sort + + -- | Check if this version is globally available + compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath) + compileGlobal chdir = do + -- TODO: add option to let user specify custom package-db, relevant when + -- using a Cabal compiled from git! + + ver <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts + vLog opts $ logMsg ++ "user/global package-db" + liftIO $ compileWithPkg chdir Nothing ver + + -- | Check if this version is available in the project sandbox + compileSandbox :: FilePath -> MaybeT IO (Either ExitCode FilePath) + compileSandbox chdir = do + sandbox <- MaybeT $ getSandboxPkgDb projdir (display buildPlatform) =<< ghcVersion opts + ver <- MaybeT $ find (== cabalVer) <$> listCabalVersions' opts (Just sandbox) + vLog opts $ logMsg ++ "sandbox package-db" + liftIO $ compileWithPkg chdir (Just sandbox) ver + + + -- | Check if we already compiled this version of cabal into a private + -- package-db + cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath) + cachedCabalPkg chdir = do + db_exists <- liftIO $ cabalPkgDbExists opts cabalVer + case db_exists of + False -> mzero + True -> do + db <- liftIO $ cabalPkgDb opts cabalVer + vLog opts $ logMsg ++ "private package-db in " ++ db + liftIO $ compileWithPkg chdir (Just db) cabalVer + + -- | See if we're in a cabal source tree + compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath) + compileCabalSource chdir = do + let cabalFile = projdir "Cabal.cabal" + isCabalMagicVer = cabalVer == Version [1,9999] [] + cabalSrc <- liftIO $ doesFileExist cabalFile + + when isCabalMagicVer $ + vLog opts $ "cabal magic version (1.9999) found" + + when cabalSrc $ + vLog opts $ "directory above distdir looks like cabal source tree (Cabal.cabal exists)" + + case isCabalMagicVer || cabalSrc of + False -> mzero + True -> liftIO $ do + ver <- cabalFileVersion <$> readFile cabalFile + vLog opts $ "compiling helper with local Cabal source tree" + compileWithCabalTree chdir ver projdir + + -- | Compile the requested cabal version into an isolated package-db + compilePrivatePkgDb :: FilePath -> IO (Either ExitCode FilePath) + compilePrivatePkgDb chdir = do + db <- installCabal opts cabalVer `E.catch` + \(SomeException _) -> errorInstallCabal cabalVer distdir + compileWithPkg chdir (Just db) cabalVer + + compileWithCabalTree chdir ver srcDir = + compile distdir opts $ Compile chdir (Just srcDir) Nothing ver [] + + compileWithPkg chdir mdb ver = + compile distdir opts $ Compile chdir Nothing mdb ver [cabalPkgId ver] + + cabalPkgId v = "Cabal-" ++ showVersion v + +data Compile = Compile { + cabalHelperSourceDir :: FilePath, + cabalSourceDir :: Maybe FilePath, + packageDb :: Maybe FilePath, + cabalVersion :: Version, + packageDeps :: [String] + } + +compile :: FilePath -> Options -> Compile -> IO (Either ExitCode FilePath) +compile distdir opts@Options {..} Compile {..} = do + cCabalSourceDir <- canonicalizePath `traverse` cabalSourceDir + appdir <- appDataDir + + let outdir' = maybe appdir (const $ distdir "cabal-helper") cCabalSourceDir + createDirectoryIfMissing True outdir' + outdir <- canonicalizePath outdir' + + let exedir' = maybe outdir (const distdir) cCabalSourceDir + createDirectoryIfMissing True exedir' + exedir <- canonicalizePath exedir' + exe <- exePath' cabalVersion <$> canonicalizePath exedir + + vLog opts $ "outdir: " ++ outdir + vLog opts $ "exedir: " ++ exedir + + let Version (mj:mi:_) _ = cabalVersion + let ghc_opts = + concat [ + [ "-outputdir", outdir + , "-o", exe + , "-optP-DCABAL_HELPER=1" + , "-optP-DCABAL_MAJOR=" ++ show mj + , "-optP-DCABAL_MINOR=" ++ show mi + ], + maybeToList $ ("-package-conf="++) <$> packageDb, + map ("-i"++) $ nub $ ".":maybeToList cCabalSourceDir, + + if isNothing cCabalSourceDir + then [ "-hide-all-packages" + , "-package", "base" + , "-package", "directory" + , "-package", "filepath" + , "-package", "process" + , "-package", "bytestring" + , "-package", "ghc-prim" + ] + else [], + + concatMap (\p -> ["-package", p]) packageDeps, + [ "--make", "CabalHelper/Main.hs" ] + ] + + vLog opts $ intercalate " " $ map (("\""++) . (++"\"")) $ ghcProgram:ghc_opts + + -- TODO: touch exe after, ghc doesn't do that if the input files didn't + -- actually change + rv <- callProcessStderr' (Just cabalHelperSourceDir) ghcProgram ghc_opts + return $ case rv of + ExitSuccess -> Right exe + e@(ExitFailure _) -> Left e + +exePath :: Version -> IO FilePath +exePath cabalVersion = do + exePath' cabalVersion <$> appDataDir + +exePath' :: Version-> FilePath -> FilePath +exePath' cabalVersion outdir = + outdir "cabal-helper-" ++ showVersion version -- our ver + ++ "-Cabal-" ++ showVersion cabalVersion + +callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode +callProcessStderr' mwd exe args = do + (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr + , cwd = mwd } + waitForProcess h + +callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO () +callProcessStderr mwd exe args = do + rv <- callProcessStderr' mwd exe args + case rv of + ExitSuccess -> return () + ExitFailure v -> processFailedException "callProcessStderr" exe args v + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + panic $ concat [fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] + +installCabal :: Options -> Version -> IO FilePath +installCabal opts ver = do + appdir <- appDataDir + let sver = showVersion ver + hPutStr stderr $ printf "\ +\cabal-helper-wrapper: Installing a private copy of Cabal because we couldn't\n\ +\find the right version in your global/user package-db, this might take a\n\ +\while but will only happen once per Cabal version you're using.\n\ +\\n\ +\If anything goes horribly wrong just delete this directory and try again:\n\ +\ %s\n\ +\\n\ +\If you want to avoid this automatic installation altogether install\n\ +\version %s of Cabal manually (into your user or global package-db):\n\ +\ $ cabal install Cabal --constraint \"Cabal == %s\"\n\ +\\n\ +\Installing Cabal %s ...\n" appdir sver sver sver + + db <- createPkgDb opts ver + cabalInstallVer <- cabalInstallVersion opts + cabal_opts <- return $ concat + [ + [ "--package-db=clear" + , "--package-db=global" + , "--package-db=" ++ db + , "--prefix=" ++ db "prefix" + , "--with-ghc=" ++ ghcProgram opts + ] + , if cabalInstallVer >= Version [1,20,0,0] [] + then ["--no-require-sandbox"] + else [] + , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions + then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] + else [] + , [ "install", "Cabal", "--constraint" + , "Cabal == " ++ showVersion ver ] + ] + + vLog opts $ intercalate " " $ map (("\""++) . (++"\"")) $ cabalProgram opts:cabal_opts + + callProcessStderr (Just "/") (cabalProgram opts) cabal_opts + hPutStrLn stderr "done" + return db + +errorInstallCabal :: Version -> FilePath -> a +errorInstallCabal cabalVer _distdir = panic $ printf "\ +\Installing Cabal version %s failed.\n\ +\\n\ +\You have the following choices to fix this:\n\ +\\n\ +\- The easiest way to try and fix this is just reconfigure the project and try\n\ +\ again:\n\ +\ $ cabal clean && cabal configure\n\ +\\n\ +\- If that fails you can try to install the version of Cabal mentioned above\n\ +\ into your global/user package-db somehow, you'll probably have to fix\n\ +\ something otherwise it wouldn't have failed above:\n\ +\ $ cabal install Cabal --constraint 'Cabal == %s'\n\ +\\n\ +\- If you're using `Build-Type: Simple`:\n\ +\ - You can see if you can reinstall your cabal-install executable while\n\ +\ having it linked to a version of Cabal that's available in you\n\ +\ package-dbs or can be built automatically:\n\ +\ $ ghc-pkg list | grep Cabal # find an available Cabal version\n\ +\ Cabal-W.X.Y.Z\n\ +\ $ cabal install cabal-install --constraint 'Cabal == W.X.*'\n\ +\ Afterwards you'll have to reconfigure your project:\n\ +\ $ cabal clean && cabal configure\n\ +\\n\ +\- If you're using `Build-Type: Custom`:\n\ +\ - Have cabal-install rebuild your Setup.hs executable with a version of the\n\ +\ Cabal library that you have available in your global/user package-db:\n\ +\ $ cabal clean && cabal configure\n\ +\ You might also have to install some version of the Cabal to do this:\n\ +\ $ cabal install Cabal\n\ +\\n" sver sver + where + sver = showVersion cabalVer + +cachedExe :: Version -> IO (Maybe FilePath) +cachedExe cabalVersion = do + exe <- exePath cabalVersion + exists <- doesFileExist exe + return $ if exists then Just exe else Nothing + +listCabalVersions :: Options -> IO [Version] +listCabalVersions opts = listCabalVersions' opts Nothing + +-- TODO: Include sandbox? Probably only relevant for build-type:custom projects. +listCabalVersions' :: Options -> Maybe FilePath -> IO [Version] +listCabalVersions' Options {..} mdb = do + let mdbopt = ("--package-conf="++) <$> mdb + opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt + + catMaybes . map (fmap snd . parsePkgId . fromString) . words + <$> readProcess ghcPkgProgram opts "" + +cabalPkgDbExists :: Options -> Version -> IO Bool +cabalPkgDbExists opts ver = do + db <- cabalPkgDb opts ver + dexists <- doesDirectoryExist db + case dexists of + False -> return False + True -> do + vers <- listCabalVersions' opts (Just db) + return $ ver `elem` vers + + +ghcVersion :: Options -> IO Version +ghcVersion Options {..} = do + parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] "" + +ghcPkgVersion :: Options -> IO Version +ghcPkgVersion Options {..} = do + parseVer . trim . dropWhile (not . isDigit) <$> readProcess ghcPkgProgram ["--version"] "" + +cabalInstallVersion :: Options -> IO Version +cabalInstallVersion Options {..} = do + parseVer . trim <$> readProcess cabalProgram ["--numeric-version"] "" + +trim :: String -> String +trim = dropWhileEnd isSpace + +createPkgDb :: Options -> Version -> IO FilePath +createPkgDb opts@Options {..} ver = do + db <- cabalPkgDb opts ver + exists <- doesDirectoryExist db + when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db] + return db + +cabalPkgDb :: Options -> Version -> IO FilePath +cabalPkgDb opts ver = do + appdir <- appDataDir + ghcVer <- ghcVersion opts + return $ appdir "Cabal-" ++ showVersion ver ++ "-db-" ++ showVersion ghcVer + +-- | Find @version: XXX@ delcaration in a cabal file +cabalFileVersion :: String -> Version +cabalFileVersion cabalFile = + fromJust $ parseVer . extract <$> find ("version:" `isPrefixOf`) ls + where + ls = map (map toLower) $ lines cabalFile + extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) diff --git a/CabalHelper/Log.hs b/CabalHelper/Log.hs new file mode 100644 --- /dev/null +++ b/CabalHelper/Log.hs @@ -0,0 +1,14 @@ +module CabalHelper.Log where + +import Control.Monad +import Control.Monad.IO.Class +import Data.String +import System.IO +import Prelude + +import CabalHelper.Types + +vLog :: MonadIO m => Options -> String -> m () +vLog Options { verbose = True } msg = + liftIO $ hPutStrLn stderr msg +vLog _ _ = return () diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -81,7 +81,7 @@ import CabalHelper.Sandbox import CabalHelper.Common -import CabalHelper.Types +import CabalHelper.Types hiding (Options(..)) usage = do prog <- getProgName @@ -201,10 +201,9 @@ ghcOptPackages = ghcOptPackages opts }) - let res' = res { ghcOptPackageDBs = withPackageDB lbi - , ghcOptHideAllPackages = Flag True - , ghcOptPackages = nub $ ghcOptPackages res - } + let res' = nubPackageFlags $ res { ghcOptPackageDBs = withPackageDB lbi + , ghcOptHideAllPackages = Flag True + } Just . ChResponseList <$> renderGhcOptions' lbi v res' @@ -375,7 +374,12 @@ isInplaceDep :: (InstalledPackageId, PackageId) -> Bool isInplaceDep (ipid, pid) = inplacePackageId pid == ipid +#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22 +-- >= 1.22 uses NubListR +nubPackageFlags opts = opts +#else nubPackageFlags opts = opts { ghcOptPackages = nub $ ghcOptPackages opts } +#endif renderGhcOptions' lbi v opts = do #if CABAL_MAJOR == 1 && CABAL_MINOR < 20 diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -55,3 +55,13 @@ | ChPkgUser | ChPkgSpecific FilePath deriving (Eq, Ord, Read, Show, Generic) + +data Options = Options { + verbose :: Bool + , ghcProgram :: FilePath + , ghcPkgProgram :: FilePath + , cabalProgram :: FilePath +} + +defaultOptions :: Options +defaultOptions = Options False "ghc" "ghc-pkg" "cabal" diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -13,17 +13,11 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . - {-# LANGUAGE RecordWildCards, FlexibleContexts #-} module Main where import Control.Applicative -import Control.Arrow -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 @@ -43,10 +37,10 @@ import Distribution.Text (display) import Paths_cabal_helper (version) -import CabalHelper.Data import CabalHelper.Common import CabalHelper.GuessGhc -import CabalHelper.Sandbox (getSandboxPkgDb) +import CabalHelper.Compile +import CabalHelper.Types usage :: IO () usage = do @@ -62,16 +56,6 @@ \ [--with-cabal=CABAL_PATH]\n\ \ PROJ_DIR DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" -data Options = Options { - verbose :: Bool - , ghcProgram :: FilePath - , ghcPkgProgram :: FilePath - , cabalProgram :: FilePath -} - -defaultOptions :: Options -defaultOptions = Options False "ghc" "ghc-pkg" "cabal" - globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = [ option "" ["verbose"] "Be more verbose" $ @@ -142,332 +126,3 @@ (_,_,_,h) <- createProcess $ proc exe args exitWith =<< waitForProcess h _ -> error "invalid command line" - -appDataDir :: IO FilePath -appDataDir = ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" - -compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath) -compileHelper opts cabalVer projdir distdir = withHelperSources $ \chdir -> do - run [ compileCabalSource chdir -- TODO: here ghc's caching fails and it always - -- recompiles, probably because we write the - -- sources to a tempdir and they always look - -- newer than the Cabal sources, not sure if we - -- can fix this - , Right <$> MaybeT (cachedExe cabalVer) - , compileSandbox chdir - , compileGlobal chdir - , cachedCabalPkg chdir - , MaybeT (Just <$> compilePrivatePkgDb chdir) - ] - - where - run actions = fromJust <$> runMaybeT (msum actions) - - logMsg = "compiling helper with Cabal from " - - --- for relaxed deps: find (sameMajorVersionAs cabalVer) . reverse . sort - - -- | Check if this version is globally available - compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath) - compileGlobal chdir = do - -- TODO: add option to let user specify custom package-db, relevant when - -- using a Cabal compiled from git! - - ver <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts - vLog opts $ logMsg ++ "user/global package-db" - liftIO $ compileWithPkg chdir Nothing ver - - -- | Check if this version is available in the project sandbox - compileSandbox :: FilePath -> MaybeT IO (Either ExitCode FilePath) - compileSandbox chdir = do - sandbox <- MaybeT $ getSandboxPkgDb projdir (display buildPlatform) =<< ghcVersion opts - ver <- MaybeT $ find (== cabalVer) <$> listCabalVersions' opts (Just sandbox) - vLog opts $ logMsg ++ "sandbox package-db" - liftIO $ compileWithPkg chdir (Just sandbox) ver - - - -- | Check if we already compiled this version of cabal into a private - -- package-db - cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath) - cachedCabalPkg chdir = do - db_exists <- liftIO $ cabalPkgDbExists opts cabalVer - case db_exists of - False -> mzero - True -> do - db <- liftIO $ cabalPkgDb opts cabalVer - vLog opts $ logMsg ++ "private package-db in " ++ db - liftIO $ compileWithPkg chdir (Just db) cabalVer - - -- | See if we're in a cabal source tree - compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath) - compileCabalSource chdir = do - let cabalFile = projdir "Cabal.cabal" - isCabalMagicVer = cabalVer == Version [1,9999] [] - cabalSrc <- liftIO $ doesFileExist cabalFile - - when isCabalMagicVer $ - vLog opts $ "cabal magic version (1.9999) found" - - when cabalSrc $ - vLog opts $ "directory above distdir looks like cabal source tree (Cabal.cabal exists)" - - case isCabalMagicVer || cabalSrc of - False -> mzero - True -> liftIO $ do - ver <- cabalFileVersion <$> readFile cabalFile - vLog opts $ "compiling helper with local Cabal source tree" - compileWithCabalTree chdir ver projdir - - -- | Compile the requested cabal version into an isolated package-db - compilePrivatePkgDb :: FilePath -> IO (Either ExitCode FilePath) - compilePrivatePkgDb chdir = do - db <- installCabal opts cabalVer `E.catch` - \(SomeException _) -> errorInstallCabal cabalVer distdir - compileWithPkg chdir (Just db) cabalVer - - compileWithCabalTree chdir ver srcDir = - compile distdir opts $ Compile chdir (Just srcDir) Nothing ver [] - - compileWithPkg chdir mdb ver = - compile distdir opts $ Compile chdir Nothing mdb ver [cabalPkgId ver] - - cabalPkgId v = "Cabal-" ++ showVersion v - -errorInstallCabal :: Version -> FilePath -> a -errorInstallCabal cabalVer _distdir = panic $ printf "\ -\Installing Cabal version %s failed.\n\ -\\n\ -\You have the following choices to fix this:\n\ -\\n\ -\- The easiest way to try and fix this is just reconfigure the project and try\n\ -\ again:\n\ -\ $ cabal clean && cabal configure\n\ -\\n\ -\- If that fails you can try to install the version of Cabal mentioned above\n\ -\ into your global/user package-db somehow, you'll probably have to fix\n\ -\ something otherwise it wouldn't have failed above:\n\ -\ $ cabal install Cabal --constraint 'Cabal == %s'\n\ -\\n\ -\- If you're using `Build-Type: Simple`:\n\ -\ - You can see if you can reinstall your cabal-install executable while\n\ -\ having it linked to a version of Cabal that's available in you\n\ -\ package-dbs or can be built automatically:\n\ -\ $ ghc-pkg list | grep Cabal # find an available Cabal version\n\ -\ Cabal-W.X.Y.Z\n\ -\ $ cabal install cabal-install --constraint 'Cabal == W.X.*'\n\ -\ Afterwards you'll have to reconfigure your project:\n\ -\ $ cabal clean && cabal configure\n\ -\\n\ -\- If you're using `Build-Type: Custom`:\n\ -\ - Have cabal-install rebuild your Setup.hs executable with a version of the\n\ -\ Cabal library that you have available in your global/user package-db:\n\ -\ $ cabal clean && cabal configure\n\ -\ You might also have to install some version of the Cabal to do this:\n\ -\ $ cabal install Cabal\n\ -\\n" sver sver - where - sver = showVersion cabalVer - - -data Compile = Compile { - cabalHelperSourceDir :: FilePath, - cabalSourceDir :: Maybe FilePath, - packageDb :: Maybe FilePath, - cabalVersion :: Version, - packageDeps :: [String] - } - -compile :: FilePath -> Options -> Compile -> IO (Either ExitCode FilePath) -compile distdir opts@Options {..} Compile {..} = do - cCabalSourceDir <- canonicalizePath `traverse` cabalSourceDir - appdir <- appDataDir - - let outdir' = maybe appdir (const $ distdir "cabal-helper") cCabalSourceDir - createDirectoryIfMissing True outdir' - outdir <- canonicalizePath outdir' - - let exedir' = maybe outdir (const distdir) cCabalSourceDir - createDirectoryIfMissing True exedir' - exedir <- canonicalizePath exedir' - exe <- exePath' cabalVersion <$> canonicalizePath exedir - - vLog opts $ "outdir: " ++ outdir - vLog opts $ "exedir: " ++ exedir - - let Version (mj:mi:_) _ = cabalVersion - let ghc_opts = - concat [ - [ "-outputdir", outdir - , "-o", exe - , "-optP-DCABAL_HELPER=1" - , "-optP-DCABAL_MAJOR=" ++ show mj - , "-optP-DCABAL_MINOR=" ++ show mi - ], - maybeToList $ ("-package-conf="++) <$> packageDb, - map ("-i"++) $ nub $ ".":maybeToList cCabalSourceDir, - - if isNothing cCabalSourceDir - then [ "-hide-all-packages" - , "-package", "base" - , "-package", "directory" - , "-package", "filepath" - , "-package", "process" - , "-package", "bytestring" - , "-package", "ghc-prim" - ] - else [], - - concatMap (\p -> ["-package", p]) packageDeps, - [ "--make", "CabalHelper/Main.hs" ] - ] - - vLog opts $ intercalate " " $ map (("\""++) . (++"\"")) $ ghcProgram:ghc_opts - - -- TODO: touch exe after, ghc doesn't do that if the input files didn't - -- actually change - rv <- callProcessStderr' (Just cabalHelperSourceDir) ghcProgram ghc_opts - return $ case rv of - ExitSuccess -> Right exe - e@(ExitFailure _) -> Left e - -exePath :: Version -> IO FilePath -exePath cabalVersion = do - exePath' cabalVersion <$> appDataDir - -exePath' :: Version-> FilePath -> FilePath -exePath' cabalVersion outdir = - outdir "cabal-helper-" ++ showVersion version -- our ver - ++ "-Cabal-" ++ showVersion cabalVersion - -cachedExe :: Version -> IO (Maybe FilePath) -cachedExe cabalVersion = do - exe <- exePath cabalVersion - exists <- doesFileExist exe - return $ if exists then Just exe else Nothing - -callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode -callProcessStderr' mwd exe args = do - (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr - , cwd = mwd } - waitForProcess h - -callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO () -callProcessStderr mwd exe args = do - rv <- callProcessStderr' mwd exe args - case rv of - ExitSuccess -> return () - ExitFailure v -> processFailedException "callProcessStderr" exe args v - -processFailedException :: String -> String -> [String] -> Int -> IO a -processFailedException fn exe args rv = - panic $ concat [fn, ": ", exe, " " - , intercalate " " (map show args) - , " (exit " ++ show rv ++ ")"] - -installCabal :: Options -> Version -> IO FilePath -installCabal opts ver = do - appdir <- appDataDir - let sver = showVersion ver - hPutStr stderr $ printf "\ -\cabal-helper-wrapper: Installing a private copy of Cabal because we couldn't\n\ -\find the right version in your global/user package-db, this might take a\n\ -\while but will only happen once per Cabal version you're using.\n\ -\\n\ -\If anything goes horribly wrong just delete this directory and try again:\n\ -\ %s\n\ -\\n\ -\If you want to avoid this automatic installation altogether install\n\ -\version %s of Cabal manually (into your user or global package-db):\n\ -\ $ cabal install Cabal --constraint \"Cabal == %s\"\n\ -\\n\ -\Installing Cabal %s ...\n" appdir sver sver sver - - db <- createPkgDb opts ver - cabalInstallVer <- cabalInstallVersion opts - cabal_opts <- return $ concat - [ - [ "--package-db=clear" - , "--package-db=global" - , "--package-db=" ++ db - , "--prefix=" ++ db "prefix" - , "--with-ghc=" ++ ghcProgram opts - ] - , if cabalInstallVer >= Version [1,20,0,0] [] - then ["--no-require-sandbox"] - else [] - , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions - then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] - else [] - , [ "install", "Cabal", "--constraint" - , "Cabal == " ++ showVersion ver ] - ] - - vLog opts $ intercalate " " $ map (("\""++) . (++"\"")) $ cabalProgram opts:cabal_opts - - callProcessStderr (Just "/") (cabalProgram opts) cabal_opts - hPutStrLn stderr "done" - return db - -ghcVersion :: Options -> IO Version -ghcVersion Options {..} = do - parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] "" - -ghcPkgVersion :: Options -> IO Version -ghcPkgVersion Options {..} = do - parseVer . trim . dropWhile (not . isDigit) <$> readProcess ghcPkgProgram ["--version"] "" - -cabalInstallVersion :: Options -> IO Version -cabalInstallVersion Options {..} = do - parseVer . trim <$> readProcess cabalProgram ["--numeric-version"] "" - -trim :: String -> String -trim = dropWhileEnd isSpace - -createPkgDb :: Options -> Version -> IO FilePath -createPkgDb opts@Options {..} ver = do - db <- cabalPkgDb opts ver - exists <- doesDirectoryExist db - when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db] - return db - -cabalPkgDb :: Options -> Version -> IO FilePath -cabalPkgDb opts ver = do - appdir <- appDataDir - ghcVer <- ghcVersion opts - return $ appdir "Cabal-" ++ showVersion ver ++ "-db-" ++ showVersion ghcVer - -cabalPkgDbExists :: Options -> Version -> IO Bool -cabalPkgDbExists opts ver = do - db <- cabalPkgDb opts ver - dexists <- doesDirectoryExist db - case dexists of - False -> return False - True -> do - vers <- listCabalVersions' opts (Just db) - return $ ver `elem` vers - -listCabalVersions :: Options -> IO [Version] -listCabalVersions opts = listCabalVersions' opts Nothing - --- TODO: Include sandbox? Probably only relevant for build-type:custom projects. -listCabalVersions' :: Options -> Maybe FilePath -> IO [Version] -listCabalVersions' Options {..} mdb = do - let mdbopt = ("--package-conf="++) <$> mdb - opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt - - catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess ghcPkgProgram opts "" - --- | Find @version: XXX@ delcaration in a cabal file -cabalFileVersion :: String -> Version -cabalFileVersion cabalFile = - fromJust $ parseVer . extract <$> find ("version:" `isPrefixOf`) ls - where - ls = map (map toLower) $ lines cabalFile - extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) - -vLog :: MonadIO m => Options -> String -> m () -vLog Options { verbose = True } msg = - liftIO $ hPutStrLn stderr msg -vLog _ _ = return () diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -81,7 +81,7 @@ import Prelude import Paths_cabal_helper (getLibexecDir) -import CabalHelper.Types +import CabalHelper.Types hiding (Options(..)) import CabalHelper.Sandbox -- | Paths or names of various programs we need. diff --git a/cabal-helper.cabal b/cabal-helper.cabal --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -1,5 +1,5 @@ name: cabal-helper -version: 0.5.2.0 +version: 0.5.3.0 synopsis: Simple interface to some of Cabal's configuration state used by ghc-mod description: @cabal-helper@ provides a library which wraps the internal use of @@ -66,6 +66,8 @@ CabalHelper.Common CabalHelper.GuessGhc CabalHelper.Data + CabalHelper.Compile + CabalHelper.Log GHC-Options: -Wall X-Install-Target: $libexecdir Build-Depends: base >= 4.5 && < 5 @@ -78,16 +80,27 @@ , template-haskell , temporary , utf8-string - + , ghc-prim Test-Suite spec Default-Language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: Spec.hs - Hs-Source-Dirs: tests + Hs-Source-Dirs: tests, . GHC-Options: -Wall Build-Depends: base >= 4.5 && < 5 , cabal-helper , extra , unix + , Cabal >= 1.14 && < 1.23 + , data-default + , directory + , filepath + , transformers + , mtl , process + , ghc-prim + , bytestring + , utf8-string + , template-haskell + , temporary diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -2,10 +2,83 @@ import System.Environment.Extra (lookupEnv) import System.Posix.Env (setEnv) import System.Process +import System.Exit import Data.Maybe +import Data.Version import Data.Functor +import Control.Exception as E +import Control.Arrow +import CabalHelper.Common +import CabalHelper.Compile +import CabalHelper.Types + main :: IO () main = do flip (setEnv "HOME") True =<< fromMaybe "/tmp" <$> lookupEnv "TMPDIR" writeAutogenFiles readProcess "." "./dist" + + _ <- system "cabal update" + + let vers :: [(Version, [Version])] + vers = map (parseVer *** map parseVer) [ + ("7.4", [ "1.14.0" + ]), + + ("7.6", [ "1.16.0" + , "1.16.0.1" + , "1.16.0.2" + , "1.16.0.3" + ]), + + ("7.8", [ +-- "1.18.0" +-- , "1.18.1" + "1.18.1.1" +-- , "1.18.1.2" + , "1.18.1.3" + , "1.18.1.4" + , "1.18.1.5" + , "1.18.1.6" + + , "1.20.0.0" + , "1.20.0.1" + , "1.20.0.2" + , "1.20.0.3" + , "1.22.0.0" + , "1.22.1.0" + , "1.22.1.1" + ]), + + ("7.10", [ + "1.22.2.0" + , "1.22.3.0" + , "1.22.4.0" + ]) + ] + + ghcVer <- ghcVersion defaultOptions + + let cabalVers = concat $ map snd $ dropWhile (( IO (Either ExitCode FilePath) +compilePrivatePkgDb cabalVer = do + db <- installCabal defaultOptions cabalVer `E.catch` + \(SomeException _) -> errorInstallCabal cabalVer "dist" + compileWithPkg "." (Just db) cabalVer + +compileWithPkg :: FilePath -> Maybe FilePath -> Version -> IO (Either ExitCode FilePath) +compileWithPkg chdir mdb ver = + compile "dist" defaultOptions $ Compile chdir Nothing mdb ver [cabalPkgId ver] + +cabalPkgId :: Version -> String +cabalPkgId v = "Cabal-" ++ showVersion v