diff options
Diffstat (limited to 'src/CabalHelper/Compiletime')
| -rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 316 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Log.hs | 45 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 56 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Wrapper.hs | 227 |
4 files changed, 212 insertions, 432 deletions
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index 8da426f..2b80b2f 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. {-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, -GADTs #-} + GADTs, ImplicitParams, ConstraintKinds #-} {-| Module : CabalHelper.Compiletime.Compile @@ -58,7 +58,6 @@ import Distribution.Text (display) import Paths_cabal_helper (version) import CabalHelper.Compiletime.Data -import CabalHelper.Compiletime.Log import CabalHelper.Compiletime.Types import CabalHelper.Shared.Common import CabalHelper.Shared.Sandbox (getSandboxPkgDb) @@ -87,33 +86,41 @@ data CompPaths = CompPaths -- executable. data CompilationProductScope = CPSGlobal | CPSProject -compileHelper :: Options -> Version -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> IO (Either ExitCode FilePath) +compileHelper + :: CompileOptions + -> Version + -> FilePath + -> Maybe (PlanJson, FilePath) + -> FilePath + -> IO (Either ExitCode FilePath) compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do - ghcVer <- ghcVersion opts - Just (prepare, comp) <- runMaybeT $ msum $ - case oCabalPkgDb opts of - Nothing -> - [ compileCabalSource - , compileNewBuild ghcVer - , compileSandbox ghcVer - , compileGlobal - , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb - ] - Just db -> - [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject) - ] - - appdir <- appCacheDir - - let cp@CompPaths {compExePath} = compPaths appdir distdir comp - exists <- doesFileExist compExePath - if exists - then do - vLog opts $ "helper already compiled, using exe: "++compExePath - return (Right compExePath) - else do - vLog opts $ "helper exe does not exist, compiling "++compExePath - prepare >> compile comp cp opts + let ?opts = opts + + ghcVer <- ghcVersion + Just (prepare, comp) <- runMaybeT $ msum $ + case oCabalPkgDb opts of + Nothing -> + [ compileCabalSource + , compileNewBuild ghcVer + , compileSandbox ghcVer + , compileGlobal + , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb + ] + Just db -> + [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject) + ] + + appdir <- appCacheDir + + let cp@CompPaths {compExePath} = compPaths appdir distdir 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 where logMsg = "using helper compiled with Cabal from " @@ -121,24 +128,24 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do -- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort -- | Check if this version is globally available - compileGlobal :: MaybeT IO (IO (), Compile) + compileGlobal :: Env => MaybeT IO (IO (), Compile) compileGlobal = do - cabal_versions <- listCabalVersions opts + cabal_versions <- listCabalVersions ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions - vLog opts $ logMsg ++ "user/global package-db" + vLog $ logMsg ++ "user/global package-db" return $ (return (), compileWithPkg Nothing ver CPSGlobal) -- | Check if this version is available in the project sandbox - compileSandbox :: Version -> MaybeT IO (IO (), Compile) + compileSandbox :: Env => Version -> MaybeT IO (IO (), Compile) compileSandbox ghcVer = do - let mdb_path = getSandboxPkgDb projdir (display buildPlatform) ghcVer + let mdb_path = getSandboxPkgDb (display buildPlatform) ghcVer projdir sandbox <- PackageDbDir <$> MaybeT mdb_path - cabal_versions <- listCabalVersions' opts (Just sandbox) + cabal_versions <- listCabalVersions' (Just sandbox) ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions - vLog opts $ logMsg ++ "sandbox package-db" + vLog $ logMsg ++ "sandbox package-db" return $ (return (), compileWithPkg (Just sandbox) ver CPSProject) - compileNewBuild :: Version -> MaybeT IO (IO (), Compile) + compileNewBuild :: Env => Version -> MaybeT IO (IO (), Compile) compileNewBuild ghcVer = do (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle let cabal_pkgid = @@ -150,28 +157,28 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do let inplace_db_path = distdir_newstyle </> "packagedb" </> ("ghc-" ++ showVersion ghcVer) inplace_db = PackageDbDir inplace_db_path - cabal_versions <- listCabalVersions' opts (Just inplace_db) + cabal_versions <- listCabalVersions' (Just inplace_db) ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions - vLog opts $ logMsg ++ "v2-build package-db " ++ inplace_db_path + vLog $ logMsg ++ "v2-build package-db " ++ inplace_db_path return $ (return (), compileWithPkg (Just inplace_db) ver CPSProject) -- | Compile the requested Cabal version into an isolated package-db if it's -- not there already - compileWithCabalInPrivatePkgDb :: IO (IO (), Compile) + compileWithCabalInPrivatePkgDb :: Env => IO (IO (), Compile) compileWithCabalInPrivatePkgDb = do db@(PackageDbDir db_path) - <- getPrivateCabalPkgDb opts (CabalVersion hdrCabalVersion) - vLog opts $ logMsg ++ "private package-db in " ++ db_path + <- getPrivateCabalPkgDb (CabalVersion hdrCabalVersion) + vLog $ logMsg ++ "private package-db in " ++ db_path return (prepare db, compileWithPkg (Just db) hdrCabalVersion CPSGlobal) where prepare db = do - db_exists <- liftIO $ cabalVersionExistsInPkgDb opts hdrCabalVersion db + db_exists <- liftIO $ cabalVersionExistsInPkgDb hdrCabalVersion db when (not db_exists) $ - void $ installCabal opts (Right hdrCabalVersion) `E.catch` + void $ installCabal (Right hdrCabalVersion) `E.catch` \(SomeException _) -> errorInstallCabal hdrCabalVersion distdir -- | See if we're in a cabal source tree - compileCabalSource :: MaybeT IO (IO (), Compile) + compileCabalSource :: Env => MaybeT IO (IO (), Compile) compileCabalSource = do let cabalFile = projdir </> "Cabal.cabal" cabalSrc <- liftIO $ doesFileExist cabalFile @@ -179,17 +186,17 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do case cabalSrc of False -> mzero True -> do - vLog opts $ "projdir looks like Cabal source tree (Cabal.cabal exists)" + vLog $ "projdir looks like Cabal source tree (Cabal.cabal exists)" cf <- liftIO $ readFile cabalFile let buildType = cabalFileBuildType cf ver = cabalFileVersion cf case buildType of "simple" -> do - vLog opts $ "Cabal source tree is build-type:simple, moving on" + vLog $ "Cabal source tree is build-type:simple, moving on" mzero "custom" -> do - vLog opts $ "compiling helper with local Cabal source tree" + vLog $ "compiling helper with local Cabal source tree" return $ (return (), compileWithCabalSource projdir' ver) _ -> error $ "compileCabalSource: unknown build-type: '"++buildType++"'" @@ -209,16 +216,16 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do cabalPkgId v = "Cabal-" ++ showVersion v -compile :: Compile -> CompPaths -> Options -> IO (Either ExitCode FilePath) -compile comp paths@CompPaths {..} opts@Options {..} = do +compile :: Env => Compile -> CompPaths -> IO (Either ExitCode FilePath) +compile comp paths@CompPaths {..} = do createDirectoryIfMissing True compOutDir createHelperSources compSrcDir - vLog opts $ "compSrcDir: " ++ compSrcDir - vLog opts $ "compOutDir: " ++ compOutDir - vLog opts $ "compExePath: " ++ compExePath + vLog $ "compSrcDir: " ++ compSrcDir + vLog $ "compOutDir: " ++ compOutDir + vLog $ "compExePath: " ++ compExePath - invokeGhc opts $ compGhcInvocation comp paths + invokeGhc $ compGhcInvocation comp paths compPaths :: FilePath -> FilePath -> Compile -> CompPaths compPaths appdir distdir c = @@ -309,25 +316,27 @@ cabalMinVersionMacro (Version (mj1:mj2:mi:_) _) = cabalMinVersionMacro _ = error "cabalMinVersionMacro: Version must have at least 3 components" -invokeGhc :: Options -> GhcInvocation -> IO (Either ExitCode FilePath) -invokeGhc opts@Options {..} GhcInvocation {..} = do - rv <- callProcessStderr' opts Nothing oGhcProgram $ concat - [ [ "-outputdir", giOutDir - , "-o", giOutput +invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath) +invokeGhc GhcInvocation {..} = do + rv <- callProcessStderr' 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 + , giWarningFlags + , ["--make"] + , giInputs ] - , map ("-optP"++) giCPPOptions - , map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs - , map ("-i"++) $ nub $ "" : giIncludeDirs - , if giHideAllPackages then ["-hide-all-packages"] else [] - , concatMap (\p -> ["-package", p]) giPackages - , giWarningFlags - , ["--make"] - , giInputs - ] - return $ - case rv of - ExitSuccess -> Right giOutput - e@(ExitFailure _) -> Left e + return $ + case rv of + ExitSuccess -> Right giOutput + e@(ExitFailure _) -> Left e + where + CompileOptions {..} = ?opts -- | Cabal library version we're compiling the helper exe against. @@ -347,26 +356,26 @@ exeName CabalVersion {cabalVersion} = intercalate "-" , "Cabal" ++ showVersion cabalVersion ] -readProcess' :: Options -> FilePath -> [String] -> String -> IO String -readProcess' opts@Options{..} exe args inp = do - vLog opts $ intercalate " " $ map formatProcessArg (oGhcPkgProgram:args) +readProcess' :: Env => FilePath -> [String] -> String -> IO String +readProcess' exe args inp = do + vLog $ intercalate " " $ map formatProcessArg (exe:args) outp <- readProcess exe args inp - vLog opts $ unlines $ map ("=> "++) $ lines outp + vLog $ unlines $ map ("=> "++) $ lines outp return outp callProcessStderr' - :: Options -> Maybe FilePath -> FilePath -> [String] -> IO ExitCode -callProcessStderr' opts mwd exe args = do + :: Env => Maybe FilePath -> FilePath -> [String] -> IO ExitCode +callProcessStderr' mwd exe args = do let cd = case mwd of Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ] - vLog opts $ intercalate " " $ cd ++ map formatProcessArg (exe:args) + vLog $ intercalate " " $ cd ++ map formatProcessArg (exe:args) (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr , cwd = mwd } waitForProcess h -callProcessStderr :: Options -> Maybe FilePath -> FilePath -> [String] -> IO () -callProcessStderr opts mwd exe args = do - rv <- callProcessStderr' opts mwd exe args +callProcessStderr :: Env => 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 @@ -387,8 +396,8 @@ formatProcessArg xs data HEAD = HEAD deriving (Eq, Show) -installCabal :: Options -> Either HEAD Version -> IO (PackageDbDir, CabalVersion) -installCabal opts ever = do +installCabal :: Env => Either HEAD Version -> IO (PackageDbDir, CabalVersion) +installCabal ever = do appdir <- appCacheDir let message ver = do let sver = showVersion ver @@ -409,16 +418,16 @@ installCabal opts ever = do withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do (srcdir, cabalVer) <- case ever of Left HEAD -> do - second CabalHEAD <$> unpackCabalHEAD opts tmpdir + second CabalHEAD <$> unpackCabalHEAD tmpdir Right ver -> do message ver let patch = fromMaybe nopCabalPatchDescription $ find ((ver`elem`) . cpdVersions) patchyCabalVersions - (,) <$> unpackPatchedCabal opts ver tmpdir patch <*> pure (CabalVersion ver) + (,) <$> unpackPatchedCabal ver tmpdir patch <*> pure (CabalVersion ver) - db <- createPkgDb opts cabalVer + db <- createPkgDb cabalVer - runCabalInstall opts db srcdir ever + runCabalInstall db srcdir ever return (db, cabalVer) @@ -436,9 +445,9 @@ Otherwise we might be able to use the shipped Setup.hs -} runCabalInstall - :: Options -> PackageDbDir -> CabalSourceDir -> Either HEAD Version-> IO () -runCabalInstall opts (PackageDbDir db) (CabalSourceDir srcdir) ever = do - civ@CabalInstallVersion {..} <- cabalInstallVersion opts + :: Env => PackageDbDir -> CabalSourceDir -> Either HEAD Version-> IO () +runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do + civ@CabalInstallVersion {..} <- cabalInstallVersion cabal_opts <- return $ concat [ [ "--package-db=clear" @@ -446,45 +455,45 @@ runCabalInstall opts (PackageDbDir db) (CabalSourceDir srcdir) ever = do , "--package-db=" ++ db , "--prefix=" ++ db </> "prefix" ] - , withGHCProgramOptions opts + , withGHCProgramOptions , if cabalInstallVer >= Version [1,20,0,0] [] then ["--no-require-sandbox"] else [] , [ "install", srcdir ] - , if oVerbose opts + , if oVerbose ?opts then ["-v"] else [] , [ "--only-dependencies" ] ] - callProcessStderr opts (Just "/") (oCabalProgram opts) cabal_opts + callProcessStderr (Just "/") oCabalProgram cabal_opts - runSetupHs opts db srcdir ever civ + runSetupHs db srcdir ever civ hPutStrLn stderr "done" -withGHCProgramOptions :: Options -> [String] -withGHCProgramOptions opts = - concat [ [ "--with-ghc=" ++ oGhcProgram opts ] - , if oGhcPkgProgram opts /= oGhcPkgProgram defaultOptions - then [ "--with-ghc-pkg=" ++ oGhcPkgProgram opts ] +withGHCProgramOptions :: Env => [String] +withGHCProgramOptions = + concat [ [ "--with-ghc=" ++ oGhcProgram ] + , if oGhcProgram /= ghcPkgProgram defaultPrograms + then [ "--with-ghc-pkg=" ++ oGhcPkgProgram ] else [] ] runSetupHs - :: Options - -> FilePath + :: Env + => FilePath -> FilePath -> Either HEAD Version -> CabalInstallVersion -> IO () -runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..} +runSetupHs db srcdir ever CabalInstallVersion {..} | cabalInstallVer >= parseVer "1.24" = do - go $ \args -> callProcessStderr opts (Just srcdir) oCabalProgram $ + go $ \args -> callProcessStderr (Just srcdir) oCabalProgram $ [ "act-as-setup", "--" ] ++ args | otherwise = do - SetupProgram {..} <- compileSetupHs opts db srcdir - go $ callProcessStderr opts (Just srcdir) setupProgram + SetupProgram {..} <- compileSetupHs db srcdir + go $ callProcessStderr (Just srcdir) setupProgram where parmake_opt :: Maybe Int -> [String] parmake_opt nproc' @@ -497,7 +506,7 @@ runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..} go :: ([String] -> IO ()) -> IO () go run = do run $ [ "configure", "--package-db", db, "--prefix", db </> "prefix" ] - ++ withGHCProgramOptions opts + ++ withGHCProgramOptions mnproc <- join . fmap readMaybe <$> lookupEnv "NPROC" run $ [ "build" ] ++ parmake_opt mnproc run [ "copy" ] @@ -507,16 +516,16 @@ runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..} newtype SetupProgram = SetupProgram { setupProgram :: FilePath } -compileSetupHs :: Options -> FilePath -> FilePath -> IO SetupProgram -compileSetupHs opts db srcdir = do - ver <- ghcVersion opts +compileSetupHs :: Env => FilePath -> FilePath -> IO SetupProgram +compileSetupHs db srcdir = do + ver <- ghcVersion let no_version_macros | ver >= Version [8] [] = [ "-fno-version-macros" ] | otherwise = [] file = srcdir </> "Setup" - callProcessStderr opts (Just srcdir) (oGhcProgram opts) $ concat + callProcessStderr (Just srcdir) oGhcProgram $ concat [ [ "--make" , "-package-conf", db ] @@ -588,35 +597,35 @@ patchyCabalVersions = [ renameFile versionFileTmp versionFile unpackPatchedCabal - :: Options - -> Version + :: Env + => Version -> FilePath -> CabalPatchDescription -> IO CabalSourceDir -unpackPatchedCabal opts cabalVer tmpdir (CabalPatchDescription _ variant patch) = do - res@(CabalSourceDir dir) <- unpackCabal opts cabalVer tmpdir variant +unpackPatchedCabal cabalVer tmpdir (CabalPatchDescription _ variant patch) = do + res@(CabalSourceDir dir) <- unpackCabal cabalVer tmpdir variant patch dir return res data UnpackCabalVariant = Pristine | LatestRevision newtype CabalSourceDir = CabalSourceDir { unCabalSourceDir :: FilePath } unpackCabal - :: Options -> Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir -unpackCabal opts cabalVer tmpdir variant = do + :: Env => Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir +unpackCabal cabalVer tmpdir variant = do let cabal = "Cabal-" ++ showVersion cabalVer dir = tmpdir </> cabal variant_opts = case variant of Pristine -> [ "--pristine" ]; _ -> [] args = [ "get", cabal ] ++ variant_opts - callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args + callProcessStderr (Just tmpdir) oCabalProgram args return $ CabalSourceDir dir -unpackCabalHEAD :: Options -> FilePath -> IO (CabalSourceDir, CommitId) -unpackCabalHEAD opts tmpdir = do +unpackCabalHEAD :: Env => 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' opts "git" ["rev-parse", "HEAD"] "" + withDirectory_ dir $ trim <$> readProcess' "git" ["rev-parse", "HEAD"] "" return (CabalSourceDir $ dir </> "Cabal", CommitId commit) where withDirectory_ :: FilePath -> IO a -> IO a @@ -661,58 +670,60 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\ where sver = showVersion cabalVer -listCabalVersions :: Options -> MaybeT IO [Version] -listCabalVersions opts = listCabalVersions' opts Nothing +listCabalVersions :: Env => MaybeT IO [Version] +listCabalVersions = listCabalVersions' Nothing -listCabalVersions' :: Options -> Maybe PackageDbDir -> MaybeT IO [Version] -listCabalVersions' opts@Options {..} mdb = do +listCabalVersions' :: Env => Maybe PackageDbDir -> MaybeT IO [Version] +listCabalVersions' mdb = do case mdb of Nothing -> mzero Just (PackageDbDir db_path) -> do exists <- liftIO $ doesDirectoryExist db_path case exists of False -> mzero - True -> MaybeT $ logIOError opts "listCabalVersions'" $ Just <$> do + True -> MaybeT $ logIOError "listCabalVersions'" $ Just <$> do let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess' opts oGhcPkgProgram args "" + <$> readProcess' oGhcPkgProgram args "" -cabalVersionExistsInPkgDb :: Options -> Version -> PackageDbDir -> IO Bool -cabalVersionExistsInPkgDb opts cabalVer db@(PackageDbDir db_path) = do +cabalVersionExistsInPkgDb :: Env => Version -> 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' opts (Just db) + vers <- listCabalVersions' (Just db) return $ cabalVer `elem` vers) -ghcVersion :: Options -> IO Version -ghcVersion opts@Options {..} = do - parseVer . trim <$> readProcess' opts oGhcProgram ["--numeric-version"] "" +ghcVersion :: Env => IO Version +ghcVersion = do + parseVer . trim <$> readProcess' oGhcProgram ["--numeric-version"] "" -ghcPkgVersion :: Options -> IO Version -ghcPkgVersion opts@Options {..} = do - parseVer . trim . dropWhile (not . isDigit) <$> readProcess' opts oGhcPkgProgram ["--version"] "" +ghcPkgVersion :: Env => IO Version +ghcPkgVersion = + parseVer . trim . dropWhile (not . isDigit) + <$> readProcess' oGhcPkgProgram ["--version"] "" newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version } -cabalInstallVersion :: Options -> IO CabalInstallVersion -cabalInstallVersion opts@Options {..} = do - CabalInstallVersion . parseVer . trim - <$> readProcess' opts oCabalProgram ["--numeric-version"] "" - -createPkgDb :: Options -> CabalVersion -> IO PackageDbDir -createPkgDb opts@Options {..} cabalVer = do - db@(PackageDbDir db_path) <- getPrivateCabalPkgDb opts cabalVer +cabalInstallVersion :: Env => IO CabalInstallVersion +cabalInstallVersion = do + CabalInstallVersion . parseVer . trim + <$> readProcess' oCabalProgram ["--numeric-version"] "" + +createPkgDb :: Env => CabalVersion -> IO PackageDbDir +createPkgDb cabalVer = do + db@(PackageDbDir db_path) <- getPrivateCabalPkgDb cabalVer exists <- doesDirectoryExist db_path - when (not exists) $ callProcessStderr opts Nothing oGhcPkgProgram ["init", db_path] + when (not exists) $ + callProcessStderr Nothing oGhcPkgProgram ["init", db_path] return db -getPrivateCabalPkgDb :: Options -> CabalVersion -> IO PackageDbDir -getPrivateCabalPkgDb opts cabalVer = do +getPrivateCabalPkgDb :: Env => CabalVersion -> IO PackageDbDir +getPrivateCabalPkgDb cabalVer = do appdir <- appCacheDir - ghcVer <- ghcVersion opts + ghcVer <- ghcVersion let db_path = appdir </> exeName cabalVer ++ "-ghc" ++ showVersion ghcVer ++ ".package-db" @@ -734,3 +745,14 @@ cabalFileTopField field cabalFile = value Just value = extract <$> find ((field++":") `isPrefixOf`) ls ls = map (map toLower) $ lines cabalFile extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) + +vLog :: (Env, MonadIO m) => String -> m () +vLog msg | CompileOptions { oVerbose = True } <- ?opts = + liftIO $ hPutStrLn stderr msg +vLog _ = return () + +logIOError :: Env => String -> IO (Maybe a) -> IO (Maybe a) +logIOError label a = do + a `catchIOError` \ex -> do + vLog $ label ++ ": " ++ show ex + return Nothing diff --git a/src/CabalHelper/Compiletime/Log.hs b/src/CabalHelper/Compiletime/Log.hs deleted file mode 100644 index a329c54..0000000 --- a/src/CabalHelper/Compiletime/Log.hs +++ /dev/null @@ -1,45 +0,0 @@ --- cabal-helper: Simple interface to Cabal's configuration state --- Copyright (C) 2017-2018 Daniel Gröber <cabal-helper@dxld.at> --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU 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 General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see <http://www.gnu.org/licenses/>. - -{-# LANGUAGE ScopedTypeVariables #-} - -{-| -Module : CabalHelper.Compiletime.Log -Description : Basic logging facilities -License : GPL-3 --} - -module CabalHelper.Compiletime.Log where - -import Control.Monad -import Control.Monad.IO.Class -import Control.Exception as E -import Data.String -import System.IO -import Prelude - -import CabalHelper.Compiletime.Types - -vLog :: MonadIO m => Options -> String -> m () -vLog Options { oVerbose = True } msg = - liftIO $ hPutStrLn stderr msg -vLog _ _ = return () - -logIOError :: Options -> String -> IO (Maybe a) -> IO (Maybe a) -logIOError opts label a = do - a `E.catch` \(ex :: IOError) -> do - vLog opts $ label ++ ": " ++ show ex - return Nothing diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 77c3255..10fe916 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -14,7 +14,8 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures, + KindSignatures, ImplicitParams, ConstraintKinds #-} {-| Module : CabalHelper.Compiletime.Types @@ -25,18 +26,47 @@ License : GPL-3 module CabalHelper.Compiletime.Types where import Data.Version +import Data.Typeable +import GHC.Generics -data Options = Options { - oHelp :: Bool - , oVerbose :: Bool - , oGhcProgram :: FilePath - , oGhcPkgProgram :: FilePath - , oCabalProgram :: FilePath - , oCabalVersion :: Maybe Version - , oCabalPkgDb :: Maybe PackageDbDir -} +type Env = (?opts :: CompileOptions) -newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath } +-- | Paths or names of various programs we need. +data Programs = Programs { + -- | The path to the @cabal@ program. + cabalProgram :: FilePath, + + -- | The path to the @ghc@ program. + ghcProgram :: FilePath, + + -- | The path to the @ghc-pkg@ program. If + -- not changed it will be derived from the path to 'ghcProgram'. + ghcPkgProgram :: FilePath + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +-- | Default all programs to their unqualified names, i.e. they will be searched +-- for on @PATH@. +defaultPrograms :: Programs +defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" + +data CompileOptions = CompileOptions + { oVerbose :: Bool + , oCabalPkgDb :: Maybe PackageDbDir + , oCabalVersion :: Maybe Version + , oPrograms :: Programs + } -defaultOptions :: Options -defaultOptions = Options False False "ghc" "ghc-pkg" "cabal" Nothing Nothing +oCabalProgram :: Env => FilePath +oCabalProgram = cabalProgram $ oPrograms ?opts + +oGhcProgram :: Env => FilePath +oGhcProgram = ghcProgram $ oPrograms ?opts + +oGhcPkgProgram :: Env => FilePath +oGhcPkgProgram = ghcPkgProgram $ oPrograms ?opts + +defaultCompileOptions :: CompileOptions +defaultCompileOptions = + CompileOptions False Nothing Nothing defaultPrograms + +newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath } diff --git a/src/CabalHelper/Compiletime/Wrapper.hs b/src/CabalHelper/Compiletime/Wrapper.hs deleted file mode 100644 index 461ef96..0000000 --- a/src/CabalHelper/Compiletime/Wrapper.hs +++ /dev/null @@ -1,227 +0,0 @@ --- cabal-helper: Simple interface to Cabal's configuration state --- Copyright (C) 2015-2018 Daniel Gröber <cabal-helper@dxld.at> --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU 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 General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE RecordWildCards, NamedFieldPuns, FlexibleContexts, ViewPatterns #-} -module Main where - -import Cabal.Plan -import Control.Applicative -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import Data.String -import Text.Printf -import Text.Show.Pretty -import System.Console.GetOpt -import System.Environment -import System.Directory -import System.FilePath -import System.Process -import System.Exit -import System.IO -import Prelude - -import qualified Data.Text as Text -import qualified Data.Map.Strict as Map - -import Distribution.System (buildPlatform) -import Distribution.Text (display) -import Distribution.Verbosity (silent, deafening) -import Distribution.Package (packageName, packageVersion) -import Distribution.Simple.GHC as GHC (configure) - -import Paths_cabal_helper (version) -import CabalHelper.Compiletime.Compat.ProgramDb - ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram) -import CabalHelper.Compiletime.Compat.Version -import CabalHelper.Compiletime.Compile -import CabalHelper.Compiletime.Types -import CabalHelper.Shared.Common -import CabalHelper.Shared.InterfaceTypes - -usage :: IO () -usage = do - prog <- getProgName - hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg - where - usageMsg = "\ -\( print-appcachedir\n\ -\| print-build-platform\n\ -\| [--verbose]\n\ -\ [--with-ghc=GHC_PATH]\n\ -\ [--with-ghc-pkg=GHC_PKG_PATH]\n\ -\ [--with-cabal=CABAL_PATH]\n\ -\ [--with-cabal-version=VERSION]\n\ -\ [--with-cabal-pkg-db=PKG_DB]\n\ -\ v1-style PROJ_DIR DIST_DIR \n\ -\ ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\ -\ v2-style PROJ_DIR DIST_NEWSTYLE_DIR DIST_DIR\n\ -\ ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\ -\)\n" - -globalArgSpec :: [OptDescr (Options -> Options)] -globalArgSpec = - [ option "h" ["help"] "Display help message" $ - NoArg $ \o -> o { oHelp = True } - , option "" ["verbose"] "Be more verbose" $ - NoArg $ \o -> o { oVerbose = True } - - , option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> o { oGhcProgram = p } - - , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ - reqArg "PROG" $ \p o -> o { oGhcPkgProgram = p } - - , option "" ["with-cabal"] "cabal-install executable to use" $ - reqArg "PROG" $ \p o -> o { oCabalProgram = p } - - , option "" ["with-cabal-version"] "Cabal library version to use" $ - reqArg "VERSION" $ \p o -> o { oCabalVersion = Just $ parseVer p } - - , option "" ["with-cabal-pkg-db"] "package database to look for Cabal library in" $ - reqArg "PKG_DB" $ \p o -> o { oCabalPkgDb = Just (PackageDbDir p) } - - ] - where - option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a - option s l udsc dsc = Option s l dsc udsc - - reqArg :: String -> (String -> a) -> ArgDescr a - reqArg udsc dsc = ReqArg dsc udsc - -parseCommandArgs :: Options -> [String] -> (Options, [String]) -parseCommandArgs opts argv - = case getOpt RequireOrder globalArgSpec argv of - (o,r,[]) -> (foldr id opts o, r) - (_,_,errs) -> - panic $ "Parsing command options failed:\n" ++ concat errs - -guessProgramPaths :: Options -> IO Options -guessProgramPaths opts = do - let v | oVerbose opts = deafening - | otherwise = silent - - mGhcPath0 | same oGhcProgram opts dopts = Nothing - | otherwise = Just $ oGhcProgram opts - mGhcPkgPath0 | same oGhcPkgProgram opts dopts = Nothing - | otherwise = Just $ oGhcPkgProgram opts - - (_compiler, _mplatform, progdb) - <- GHC.configure - v - mGhcPath0 - mGhcPkgPath0 - defaultProgramDb - - let mghcPath1 = programPath <$> lookupProgram ghcProgram progdb - mghcPkgPath1 = programPath <$> lookupProgram ghcPkgProgram progdb - - return $ opts { oGhcProgram = fromMaybe (oGhcProgram opts) mghcPath1 - , oGhcPkgProgram = fromMaybe (oGhcProgram opts) mghcPkgPath1 - } - where - same f o o' = f o == f o' - dopts = defaultOptions - -overrideVerbosityEnvVar :: Options -> IO Options -overrideVerbosityEnvVar opts = do - x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment - return $ case x of - Just _ -> opts { oVerbose = True } - Nothing -> opts - -main :: IO () -main = handlePanic $ do - (opts', args) <- parseCommandArgs defaultOptions <$> getArgs - opts <- overrideVerbosityEnvVar =<< guessProgramPaths opts' - case args of - _ | oHelp opts -> usage - [] -> usage - "help":[] -> usage - "version":[] -> putStrLn $ showVersion version - "print-appdatadir":[] -> putStrLn =<< appCacheDir - "print-appcachedir":[] -> putStrLn =<< appCacheDir - "print-build-platform":[] -> putStrLn $ display buildPlatform - - _:projdir:_distdir:"package-id":[] -> do - let v | oVerbose opts = deafening - | otherwise = silent - -- ghc-mod will catch multiple cabal files existing before we get here - [cfile] <- filter isCabalFile <$> getDirectoryContents projdir - gpd <- readPackageDescription v (projdir </> cfile) - putStrLn $ show $ - [Just $ ChResponseVersion (display (packageName gpd)) (toDataVersion $ packageVersion gpd)] - - "v2-style":projdir:distdir_newstyle:unitid':args' -> do - let unitid = UnitId $ Text.pack unitid' - let plan_path = distdir_newstyle </> "cache" </> "plan.json" - plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } - <- decodePlanJson plan_path - case oCabalVersion opts of - Just ver | pjCabalLibVersion /= ver -> let - sver = showVersion ver - spjVer = showVersion pjCabalLibVersion - in panic $ printf "\ -\Cabal version %s was requested but plan.json was written by version %s" sver spjVer - _ -> case Map.lookup unitid $ pjUnits plan of - Just u@Unit {uType} | uType /= UnitTypeLocal -> do - panic $ "\ -\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u - Just Unit {uDistDir=Nothing} -> panic $ printf "\ -\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'" - Just Unit {uType=UnitTypeLocal, uDistDir=Just distdir} -> - runHelper opts projdir (Just (plan, distdir_newstyle)) distdir pjCabalLibVersion args' - _ -> let - units = map (\(UnitId u) -> Text.unpack u) - $ Map.keys - $ Map.filter ((==UnitTypeLocal) . uType) - $ pjUnits plan - - units_list = unlines $ map (" "++) units - in - panic $ "\ -\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list - - "v1-style":projdir:distdir:args' -> do - cfgf <- canonicalizePath (distdir </> "setup-config") - mhdr <- getCabalConfigHeader cfgf - case (mhdr, oCabalVersion opts) of - (Nothing, _) -> panic $ printf "\ -\Could not read Cabal's persistent setup configuration header\n\ -\- Check first line of: %s\n\ -\- Maybe try: $ cabal configure" cfgf - (Just (hdrCabalVersion, _), Just ver) - | hdrCabalVersion /= ver -> panic $ printf "\ -\Cabal version %s was requested but setup configuration was\n\ -\written by version %s" (showVersion ver) (showVersion hdrCabalVersion) - (Just (hdrCabalVersion, _), _) -> - runHelper opts projdir Nothing distdir hdrCabalVersion args' - _ -> do - hPutStrLn stderr "Invalid command line!" - usage - exitWith $ ExitFailure 1 - -runHelper :: Options -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> DataVersion -> [String] -> IO () -runHelper opts projdir mnewstyle distdir cabal_ver args' = do - eexe <- compileHelper opts cabal_ver projdir mnewstyle distdir - case eexe of - Left e -> exitWith e - Right exe -> do - case args' of - "print-exe":_ -> putStrLn exe - _ -> do - (_,_,_,h) <- createProcess $ proc exe $ projdir : distdir : args' - exitWith =<< waitForProcess h |