aboutsummaryrefslogtreecommitdiff
path: root/lib/Distribution/Helper.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Distribution/Helper.hs')
-rw-r--r--lib/Distribution/Helper.hs365
1 files changed, 169 insertions, 196 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs
index 1d93b84..622972a 100644
--- a/lib/Distribution/Helper.hs
+++ b/lib/Distribution/Helper.hs
@@ -14,10 +14,9 @@
-- 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 CPP, RecordWildCards, FlexibleContexts, ConstraintKinds,
+{-# LANGUAGE RecordWildCards, FlexibleContexts, ConstraintKinds,
GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor,
- NamedFieldPuns, OverloadedStrings
- #-}
+ NamedFieldPuns, OverloadedStrings, ViewPatterns #-}
{-|
Module : Distribution.Helper
@@ -80,7 +79,7 @@ module Distribution.Helper (
, NeedsBuildOutput(..)
-- * General information
- , buildPlatform
+ , Distribution.Helper.buildPlatform
-- * Stuff that cabal-install really should export
, Distribution.Helper.getSandboxPkgDb
@@ -90,10 +89,6 @@ module Distribution.Helper (
, reconfigure
, writeAutogenFiles
- -- * $libexec related error handling
- , LibexecNotFoundError(..)
- , libexecNotFoundError
-
-- * Reexports
, module Data.Functor.Apply
) where
@@ -105,46 +100,40 @@ import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.Reader
import Control.Exception as E
-import Data.Char
import Data.List
import Data.Maybe
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
import Data.Version
-import Data.Typeable
+import qualified Data.Text as Text
import Data.Function
import Data.Functor.Apply
-import Distribution.System (buildOS, OS(Windows))
import System.Environment
import System.FilePath hiding ((<.>))
-import qualified System.FilePath as FP
import System.Directory
import System.Process
-import System.IO.Unsafe
import Text.Printf
-import GHC.Generics
+import Text.Show.Pretty
import Prelude
-import Paths_cabal_helper (getLibexecDir)
+
+import CabalHelper.Compiletime.Compile
+import CabalHelper.Compiletime.Types
import CabalHelper.Shared.InterfaceTypes
import CabalHelper.Shared.Sandbox
--- | 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,
+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 qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb
+ ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram)
+import CabalHelper.Compiletime.Compat.Version
+import CabalHelper.Shared.Common
- -- | 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"
-- | Environment for running a 'Query'. The real constructor is not exposed,
-- the field accessors are however. See below. Use the 'mkQueryEnv' smart
@@ -353,35 +342,41 @@ reconfigure readProc progs cabalOpts = do
readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse]
readHelper args = ask >>= \qe -> liftIO $ do
- out <- either error id <$> invokeHelper qe args
+ out <- invokeHelper qe args
let res = read out
liftIO $ evaluate res `E.catch` \se@(SomeException _) -> do
md <- lookupEnv' "CABAL_HELPER_DEBUG"
let msg = "readHelper: exception: '" ++ show se ++ "'"
- error $ msg ++ case md of
+ panicIO $ msg ++ case md of
Nothing -> ", for more information set the environment variable CABAL_HELPER_DEBUG"
Just _ -> ", output: '"++ out ++"'"
-invokeHelper :: QueryEnv -> [String] -> IO (Either String String)
-invokeHelper QueryEnv {..} args = do
- let progArgs = [ "--with-ghc=" ++ ghcProgram qePrograms
- , "--with-ghc-pkg=" ++ ghcPkgProgram qePrograms
- , "--with-cabal=" ++ cabalProgram qePrograms
- ]
- exe <- findLibexecExe
- let args' = progArgs ++ "v1-style":qeProjectDir:qeDistDir:args
- out <- qeReadProcess exe args' ""
- (Right <$> evaluate out) `E.catch` \(SomeException _) ->
- return $ Left $ concat
- ["invokeHelper", ": ", exe, " "
- , intercalate " " (map show args')
- , " failed"
- ]
-
-getPackageId :: MonadQuery m => m (String, Version)
-getPackageId = ask >>= \QueryEnv {..} -> do
- [ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ]
- return (pkgName, pkgVer)
+invokeHelper :: QueryEnv -> [String] -> IO String
+invokeHelper QueryEnv {..} args0 = do
+ let opts = defaultCompileOptions
+ { oPrograms = qePrograms
+ , oCabalPkgDb = PackageDbDir <$> qeCabalPkgDb }
+
+ opts' <- overrideVerbosityEnvVar =<< guessProgramPaths opts
+
+ exe <- wrapperV1 opts' qeProjectDir qeDistDir
+
+ let args1 = qeProjectDir : qeDistDir : args0
+
+ out <- qeReadProcess exe args1 ""
+ evaluate out `E.catch` \(SomeException _) ->
+ panicIO $ concat
+ ["invokeHelper", ": ", exe, " "
+ , intercalate " " (map show args1)
+ , " failed!"
+ ]
+
+getPackageId :: (MonadQuery m, MonadIO m) => m (String, Version)
+getPackageId = ask >>= \QueryEnv {..} -> liftIO $ do
+ let v = silent
+ [cfile] <- filter isCabalFile <$> getDirectoryContents qeProjectDir
+ gpd <- readPackageDescription v (qeProjectDir </> cfile)
+ return $ (display (packageName gpd), toDataVersion (packageVersion gpd))
getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
getSomeConfigState = ask >>= \QueryEnv {..} -> do
@@ -439,151 +434,129 @@ writeAutogenFiles qe =
liftIO $ void $ invokeHelper qe ["write-autogen-files"]
-- | Get the path to the sandbox package-db in a project
-getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String)
- -> String
- -- ^ Cabal build platform, i.e. @buildPlatform@
- -> Version
- -- ^ GHC version (@cProjectVersion@ is your friend)
- -> IO (Maybe FilePath)
-getSandboxPkgDb readProc =
- CabalHelper.Shared.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc
-
-buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String
-buildPlatform readProc = do
- exe <- findLibexecExe
- CabalHelper.Shared.Sandbox.dropWhileEnd isSpace <$> readProc exe ["print-build-platform"] ""
-
--- | This exception is thrown by all 'runQuery' functions if the internal
--- wrapper executable cannot be found. You may catch this and present the user
--- an appropriate error message however the default is to print
--- 'libexecNotFoundError'.
-data LibexecNotFoundError = LibexecNotFoundError String FilePath
- deriving (Typeable)
-instance Exception LibexecNotFoundError
-instance Show LibexecNotFoundError where
- show (LibexecNotFoundError exe dir) =
- libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues"
-
-findLibexecExe :: IO FilePath
-findLibexecExe = do
- libexecdir <- getLibexecDir
- let exeName = "cabal-helper-wrapper"
- exe = libexecdir </> exeName FP.<.> exeExtension'
-
- exists <- doesFileExist exe
-
- if exists
- then return exe
- else do
- mdir <- tryFindCabalHelperTreeDistDir
- dir <- case mdir of
- Nothing ->
- throwIO $ LibexecNotFoundError exeName libexecdir
- Just dir ->
- return dir
-
- return $ dir </> "build" </> exeName </> exeName
-
-findPlanJson :: FilePath -> IO (Maybe FilePath)
-findPlanJson base =
- findFile (map (</> "cache") $ parents base) "plan.json"
-
-parents :: FilePath -> [FilePath]
-parents path = takeWhile (not . (`elem` ["", "."]) . dropDrive) dirs
- where dirs = iterate takeDirectory path
-
-data DistDir = DistDir { ddType :: DistDirType, unDistDir :: FilePath }
- deriving (Eq, Ord, Read, Show)
-data DistDirType = NewBuildDist | OldBuildDist
- deriving (Eq, Ord, Read, Show)
-
-tryFindCabalHelperTreeDistDir :: IO (Maybe FilePath)
-tryFindCabalHelperTreeDistDir = do
- exe <- canonicalizePath =<< getExecutablePath'
- mplan <- findPlanJson exe
- let mdistdir = takeDirectory . takeDirectory <$> mplan
- cwd <- getCurrentDirectory
-
- let candidates = sortBy (compare `on` ddType) $ concat
- [ maybeToList $ DistDir NewBuildDist <$> mdistdir
- , [ DistDir OldBuildDist $ (!!3) $ iterate takeDirectory exe ]
- , if takeFileName exe == "ghc" -- we're probably in ghci; try CWD
- then [ DistDir NewBuildDist $ cwd </> "dist-newstyle"
- , DistDir NewBuildDist $ cwd </> "dist"
- , DistDir OldBuildDist $ cwd </> "dist"
- ]
- else []
- ]
-
- distdirs
- <- filterM isDistDir candidates
- >>= mapM toOldBuildDistDir
-
- return $ fmap unDistDir $ join $ listToMaybe $ distdirs
-
-isCabalHelperSourceDir :: FilePath -> IO Bool
-isCabalHelperSourceDir dir =
- doesFileExist $ dir </> "cabal-helper.cabal"
-
-isDistDir :: DistDir -> IO Bool
-isDistDir (DistDir NewBuildDist dir) =
- doesFileExist (dir </> "cache" </> "plan.json")
-isDistDir (DistDir OldBuildDist dir) =
- doesFileExist (dir </> "setup-config")
-
-toOldBuildDistDir :: DistDir -> IO (Maybe DistDir)
-toOldBuildDistDir (DistDir NewBuildDist dir) = do
- PlanJson {pjUnits} <- decodePlanJson $ dir </> "cache" </> "plan.json"
- let munit = find isCabalHelperUnit $ Map.elems pjUnits
- return $ DistDir OldBuildDist <$> join ((\Unit { uDistDir = mdistdir } -> mdistdir) <$> munit)
- where
- isCabalHelperUnit
- Unit { uPId = PkgId (PkgName n) _
- , uType = UnitTypeLocal
- , uComps
- } | n == "cabal-helper" &&
- Map.member (CompNameExe "cabal-helper-wrapper") uComps
- = True
- isCabalHelperUnit _ = False
-toOldBuildDistDir x = return $ Just x
-
-
-
-
-libexecNotFoundError :: String -- ^ Name of the executable we were trying to
- -- find
- -> FilePath -- ^ Path to @$libexecdir@
- -> String -- ^ URL the user will be directed towards to
- -- report a bug.
- -> String
-libexecNotFoundError exe dir reportBug = printf
- ( "Could not find $libexecdir/%s\n"
- ++"\n"
- ++"If you are a cabal-helper developer you can set the environment variable\n"
- ++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n"
- ++"work in the cabal-helper source tree:\n"
- ++"\n"
- ++" $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n"
- ++"\n"
- ++"[1]: %s\n"
- ++"\n"
- ++"If you don't know what I'm talking about something went wrong with your\n"
- ++"installation. Please report this problem here:\n"
- ++"\n"
- ++" %s") exe exe dir reportBug
-
-getExecutablePath' :: IO FilePath
-getExecutablePath' =
-#if MIN_VERSION_base(4,6,0)
- getExecutablePath
-#else
- getProgName
-#endif
+getSandboxPkgDb
+ :: String
+ -- ^ Cabal build platform, i.e. @buildPlatform@
+ -> Version
+ -- ^ GHC version (@cProjectVersion@ is your friend)
+ -> FilePath
+ -- ^ Path to the project directory, i.e. a directory containing a
+ -- @cabal.sandbox.config@ file
+ -> IO (Maybe FilePath)
+getSandboxPkgDb buildPlat ghc_ver projdir =
+ CabalHelper.Shared.Sandbox.getSandboxPkgDb buildPlat ghc_ver projdir
+
+buildPlatform :: String
+buildPlatform = display Distribution.System.buildPlatform
lookupEnv' :: String -> IO (Maybe String)
lookupEnv' k = lookup k <$> getEnvironment
-exeExtension' :: FilePath
-exeExtension'
- | Windows <- buildOS = "exe"
- | otherwise = ""
+
+guessProgramPaths :: CompileOptions -> IO CompileOptions
+guessProgramPaths opts = do
+ let v | oVerbose opts = deafening
+ | otherwise = silent
+
+ mGhcPath0 | same ghcProgram progs dprogs = Nothing
+ | otherwise = Just $ ghcProgram progs
+ mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing
+ | otherwise = Just $ ghcPkgProgram progs
+
+ (_compiler, _mplatform, progdb)
+ <- GHC.configure
+ v
+ mGhcPath0
+ mGhcPkgPath0
+ ProgDb.defaultProgramDb
+ let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb
+ mghcPath1 = getProg ProgDb.ghcProgram
+ mghcPkgPath1 = getProg ProgDb.ghcPkgProgram
+
+ progs' = progs
+ { ghcProgram = fromMaybe (ghcProgram progs) mghcPath1
+ , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1
+ }
+ return opts { oPrograms = progs' }
+ where
+ same f o o' = f o == f o'
+ progs = oPrograms opts
+ dprogs = defaultPrograms
+
+overrideVerbosityEnvVar :: CompileOptions -> IO CompileOptions
+overrideVerbosityEnvVar opts = do
+ x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment
+ return $ case x of
+ Just _ -> opts { oVerbose = True }
+ Nothing -> opts
+
+wrapperV1
+ :: CompileOptions
+ -> FilePath
+ -> FilePath
+ -> IO FilePath
+wrapperV1 opts projdir distdir = do
+ cfgf <- canonicalizePath (distdir </> "setup-config")
+ mhdr <- getCabalConfigHeader cfgf
+ case (mhdr, oCabalVersion opts) of
+ (Nothing, _) -> panicIO $ 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 -> panicIO $ printf "\
+\Cabal version %s was requested but setup configuration was\n\
+\written by version %s" (showVersion ver) (showVersion hdrCabalVersion)
+ (Just (hdrCabalVersion, _), _) -> do
+ compileHelper' opts hdrCabalVersion projdir Nothing distdir
+
+wrapperV2
+ :: CompileOptions
+ -> FilePath
+ -> FilePath
+ -> UnitId
+ -> IO (FilePath, FilePath)
+wrapperV2 opts projdir distdir unitid@(UnitId (Text.unpack -> unitid')) = do
+ let plan_path = distdir </> "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 panicIO $ 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
+ panicIO $ "\
+\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u
+ Just Unit {uDistDir=Nothing} -> panicIO $ printf "\
+\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'"
+ Just Unit {uType=UnitTypeLocal, uDistDir=Just distdirv1} -> do
+ exe <- compileHelper' opts pjCabalLibVersion projdir (Just (plan, distdir)) distdirv1
+ return (exe, distdirv1)
+ _ -> let
+ units = map (\(UnitId u) -> Text.unpack u)
+ $ Map.keys
+ $ Map.filter ((==UnitTypeLocal) . uType)
+ $ pjUnits plan
+ units_list = unlines $ map (" "++) units
+ in
+ panicIO $ "\
+\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list
+
+
+compileHelper'
+ :: CompileOptions
+ -> Version
+ -> FilePath
+ -> Maybe (PlanJson, FilePath)
+ -> FilePath
+ -> IO FilePath
+compileHelper' opts pjCabalLibVersion projdir mnewstyle distdirv1 = do
+ eexe <- compileHelper opts pjCabalLibVersion projdir mnewstyle distdirv1
+ case eexe of
+ Left rv ->
+ panicIO $ "compileHelper': compiling helper failed! (exit code "++ show rv
+ Right exe ->
+ return exe
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 01:21:22 +0000