aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper/Compiletime
diff options
context:
space:
mode:
Diffstat (limited to 'src/CabalHelper/Compiletime')
-rw-r--r--src/CabalHelper/Compiletime/Compat/Version.hs8
-rw-r--r--src/CabalHelper/Compiletime/Compile.hs101
-rw-r--r--src/CabalHelper/Compiletime/Wrapper.hs85
3 files changed, 142 insertions, 52 deletions
diff --git a/src/CabalHelper/Compiletime/Compat/Version.hs b/src/CabalHelper/Compiletime/Compat/Version.hs
index 853aca5..af17bcb 100644
--- a/src/CabalHelper/Compiletime/Compat/Version.hs
+++ b/src/CabalHelper/Compiletime/Compat/Version.hs
@@ -4,6 +4,7 @@ module CabalHelper.Compiletime.Compat.Version
, toDataVersion
, fromDataVersion
, Data.Version.showVersion
+ , makeDataVersion
) where
import qualified Data.Version
@@ -23,3 +24,10 @@ fromDataVersion (Data.Version.Version vs _) = Distribution.Version.mkVersion vs
toDataVersion = id
fromDataVersion = id
#endif
+
+makeDataVersion :: [Int] -> Data.Version.Version
+#if MIN_VERSION_base(4,8,0)
+makeDataVersion = Data.Version.makeVersion
+#else
+makeDataVersion xs = Data.Version.Version xs []
+#endif
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index b39e86f..571240d 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -23,6 +23,7 @@ License : AGPL-3
module CabalHelper.Compiletime.Compile where
+import Cabal.Plan
import Control.Applicative
import Control.Arrow
import Control.Exception as E
@@ -47,6 +48,10 @@ import System.IO.Error
import System.IO.Temp
import Prelude
+
+import qualified Data.Text as Text
+import qualified Data.Map.Strict as Map
+
import Distribution.System (buildPlatform)
import Distribution.Text (display)
@@ -81,13 +86,15 @@ data CompPaths = CompPaths
-- executable.
data CompilationProductScope = CPSGlobal | CPSProject
-compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath)
-compileHelper opts hdrCabalVersion projdir distdir = do
+compileHelper :: Options -> 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
- , compileSandbox
+ , compileNewBuild ghcVer
+ , compileSandbox ghcVer
, compileGlobal
, MaybeT $ Just <$> compileWithCabalInPrivatePkgDb
]
@@ -104,7 +111,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do
vLog opts $ "helper already compiled, using exe: "++compExePath
return (Right compExePath)
else do
- vLog opts $ "helper exe does not exist, compiling"++compExePath
+ vLog opts $ "helper exe does not exist, compiling "++compExePath
prepare >> compile comp cp opts
where
@@ -115,21 +122,38 @@ compileHelper opts hdrCabalVersion projdir distdir = do
-- | Check if this version is globally available
compileGlobal :: MaybeT IO (IO (), Compile)
compileGlobal = do
- ver <- MaybeT $ find (== hdrCabalVersion) <$> listCabalVersions opts
+ cabal_versions <- listCabalVersions opts
+ ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
vLog opts $ logMsg ++ "user/global package-db"
return $ (return (), compileWithPkg Nothing ver CPSGlobal)
-- | Check if this version is available in the project sandbox
- compileSandbox :: MaybeT IO (IO (), Compile)
- compileSandbox = do
- let ghcVer = ghcVersion opts
- mdb_path = getSandboxPkgDb projdir (display buildPlatform) =<< ghcVer
+ compileSandbox :: Version -> MaybeT IO (IO (), Compile)
+ compileSandbox ghcVer = do
+ let mdb_path = getSandboxPkgDb projdir (display buildPlatform) ghcVer
sandbox <- PackageDbDir <$> MaybeT mdb_path
- ver <- MaybeT $ logIOError opts "compileSandbox" $
- find (== hdrCabalVersion) <$> listCabalVersions' opts (Just sandbox)
+ cabal_versions <- listCabalVersions' opts (Just sandbox)
+ ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
vLog opts $ logMsg ++ "sandbox package-db"
return $ (return (), compileWithPkg (Just sandbox) ver CPSProject)
+ compileNewBuild :: Version -> MaybeT IO (IO (), Compile)
+ compileNewBuild ghcVer = do
+ (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle
+ let cabal_pkgid =
+ PkgId (PkgName (Text.pack "Cabal"))
+ (Ver $ versionBranch hdrCabalVersion)
+ mcabal_unit = listToMaybe $
+ Map.elems $ Map.filter (\Unit {..} -> uPId == cabal_pkgid) pjUnits
+ Unit {} <- maybe mzero pure mcabal_unit
+ let inplace_db_path = distdir_newstyle
+ </> "packagedb" </> ("ghc-" ++ showVersion ghcVer)
+ inplace_db = PackageDbDir inplace_db_path
+ cabal_versions <- listCabalVersions' opts (Just inplace_db)
+ ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
+ vLog opts $ 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)
@@ -322,6 +346,13 @@ 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)
+ outp <- readProcess exe args inp
+ vLog opts $ unlines $ map ("=> "++) $ lines outp
+ return outp
+
callProcessStderr'
:: Options -> Maybe FilePath -> FilePath -> [String] -> IO ExitCode
callProcessStderr' opts mwd exe args = do
@@ -377,7 +408,7 @@ installCabal opts ever = do
withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do
(srcdir, cabalVer) <- case ever of
Left HEAD -> do
- second CabalHEAD <$> unpackCabalHEAD tmpdir
+ second CabalHEAD <$> unpackCabalHEAD opts tmpdir
Right ver -> do
message ver
let patch = fromMaybe nopCabalPatchDescription $
@@ -578,13 +609,13 @@ unpackCabal opts cabalVer tmpdir variant = do
callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args
return $ CabalSourceDir dir
-unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, CommitId)
-unpackCabalHEAD tmpdir = do
+unpackCabalHEAD :: Options -> FilePath -> IO (CabalSourceDir, CommitId)
+unpackCabalHEAD opts 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"] ""
+ withDirectory_ dir $ trim <$> readProcess' opts "git" ["rev-parse", "HEAD"] ""
return (CabalSourceDir $ dir </> "Cabal", CommitId commit)
where
withDirectory_ :: FilePath -> IO a -> IO a
@@ -629,40 +660,46 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\
where
sver = showVersion cabalVer
-listCabalVersions :: Options -> IO [Version]
+listCabalVersions :: Options -> MaybeT IO [Version]
listCabalVersions opts = listCabalVersions' opts Nothing
--- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
-listCabalVersions' :: Options -> Maybe PackageDbDir -> IO [Version]
-listCabalVersions' Options {..} mdb = do
- let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb
- opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
-
- catMaybes . map (fmap snd . parsePkgId . fromString) . words
- <$> readProcess oGhcPkgProgram opts ""
+listCabalVersions' :: Options -> Maybe PackageDbDir -> MaybeT IO [Version]
+listCabalVersions' opts@Options {..} 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
+ let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb
+ args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
+
+ catMaybes . map (fmap snd . parsePkgId . fromString) . words
+ <$> readProcess' opts oGhcPkgProgram args ""
cabalVersionExistsInPkgDb :: Options -> Version -> PackageDbDir -> IO Bool
cabalVersionExistsInPkgDb opts cabalVer db@(PackageDbDir db_path) = do
exists <- doesDirectoryExist db_path
case exists of
False -> return False
- True -> do
+ True -> fromMaybe False <$> runMaybeT (do
vers <- listCabalVersions' opts (Just db)
- return $ cabalVer `elem` vers
+ return $ cabalVer `elem` vers)
ghcVersion :: Options -> IO Version
-ghcVersion Options {..} = do
- parseVer . trim <$> readProcess oGhcProgram ["--numeric-version"] ""
+ghcVersion opts@Options {..} = do
+ parseVer . trim <$> readProcess' opts oGhcProgram ["--numeric-version"] ""
ghcPkgVersion :: Options -> IO Version
-ghcPkgVersion Options {..} = do
- parseVer . trim . dropWhile (not . isDigit) <$> readProcess oGhcPkgProgram ["--version"] ""
+ghcPkgVersion opts@Options {..} = do
+ parseVer . trim . dropWhile (not . isDigit) <$> readProcess' opts oGhcPkgProgram ["--version"] ""
newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version }
cabalInstallVersion :: Options -> IO CabalInstallVersion
-cabalInstallVersion Options {..} = do
+cabalInstallVersion opts@Options {..} = do
CabalInstallVersion . parseVer . trim
- <$> readProcess oCabalProgram ["--numeric-version"] ""
+ <$> readProcess' opts oCabalProgram ["--numeric-version"] ""
createPkgDb :: Options -> CabalVersion -> IO PackageDbDir
createPkgDb opts@Options {..} cabalVer = do
diff --git a/src/CabalHelper/Compiletime/Wrapper.hs b/src/CabalHelper/Compiletime/Wrapper.hs
index ae936f3..cd92219 100644
--- a/src/CabalHelper/Compiletime/Wrapper.hs
+++ b/src/CabalHelper/Compiletime/Wrapper.hs
@@ -13,9 +13,10 @@
--
-- 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 #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, FlexibleContexts, ViewPatterns #-}
module Main where
+import Cabal.Plan
import Control.Applicative
import Control.Monad
import Data.Char
@@ -23,6 +24,7 @@ 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
@@ -32,6 +34,9 @@ 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)
@@ -61,7 +66,11 @@ usage = do
\ [--with-cabal=CABAL_PATH]\n\
\ [--with-cabal-version=VERSION]\n\
\ [--with-cabal-pkg-db=PKG_DB]\n\
-\ PROJ_DIR DIST_DIR ( print-exe | package-id | [CABAL_HELPER_ARGS...] ) )\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 =
@@ -147,7 +156,7 @@ main = handlePanic $ do
"print-appcachedir":[] -> putStrLn =<< appCacheDir
"print-build-platform":[] -> putStrLn $ display buildPlatform
- projdir:_distdir:"package-id":[] -> do
+ "oldstyle":projdir:_distdir:"package-id":[] -> do
let v | oVerbose opts = deafening
| otherwise = silent
-- ghc-mod will catch multiple cabal files existing before we get here
@@ -156,27 +165,63 @@ main = handlePanic $ do
putStrLn $ show $
[Just $ ChResponseVersion (display (packageName gpd)) (toDataVersion $ packageVersion gpd)]
- projdir:distdir:args' -> do
+ "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 of
- Nothing -> panic $ printf "\
+ 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, _) -> do
- case oCabalVersion opts of
- Just ver | hdrCabalVersion /= ver -> panic $ printf "\
+ (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)
- _ -> do
- eexe <- compileHelper opts hdrCabalVersion projdir distdir
- case eexe of
- Left e -> exitWith e
- Right exe ->
- case args' of
- "print-exe":_ -> putStrLn exe
- _ -> do
- (_,_,_,h) <- createProcess $ proc exe args
- exitWith =<< waitForProcess h
- _ -> error "invalid command line"
+ (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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-25 18:14:09 +0000