aboutsummaryrefslogtreecommitdiff
path: root/src/CabalHelper
diff options
context:
space:
mode:
Diffstat (limited to 'src/CabalHelper')
-rw-r--r--src/CabalHelper/Compiletime/Compile.hs70
-rw-r--r--src/CabalHelper/Compiletime/Types.hs29
-rw-r--r--src/CabalHelper/Runtime/Compat.hs4
-rw-r--r--src/CabalHelper/Runtime/Main.hs252
-rw-r--r--src/CabalHelper/Shared/InterfaceTypes.hs54
5 files changed, 239 insertions, 170 deletions
diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs
index 305c11c..3126128 100644
--- a/src/CabalHelper/Compiletime/Compile.hs
+++ b/src/CabalHelper/Compiletime/Compile.hs
@@ -13,8 +13,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 RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor,
- GADTs, ImplicitParams, ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts, DeriveFunctor, GADTs, ConstraintKinds,
+ ImplicitParams, NamedFieldPuns, RecordWildCards #-}
{-|
Module : CabalHelper.Compiletime.Compile
@@ -24,7 +24,9 @@ License : GPL-3
module CabalHelper.Compiletime.Compile where
+import qualified Cabal.Plan as CP
import Cabal.Plan
+ ( PlanJson(..), PkgId(..), PkgName(..), Ver(..), uPId)
import Control.Applicative
import Control.Arrow
import Control.Exception as E
@@ -49,16 +51,24 @@ 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)
+import Distribution.System
+ ( buildPlatform )
+import Distribution.Text
+ ( display )
+
+import Paths_cabal_helper
+ ( version )
-import Paths_cabal_helper (version)
+--import CabalHelper.Compiletime.Cabal
import CabalHelper.Compiletime.Data
+--import CabalHelper.Compiletime.Log
+--import CabalHelper.Compiletime.Program.GHC
+--import CabalHelper.Compiletime.Program.CabalInstall
import CabalHelper.Compiletime.Types
+
import CabalHelper.Shared.Common
import CabalHelper.Shared.Sandbox (getSandboxPkgDb)
@@ -87,18 +97,17 @@ data CompPaths = CompPaths
data CompilationProductScope = CPSGlobal | CPSProject
compileHelper
- :: CompileOptions
- -> Version
+ :: Env
+ => Version
+ -> Maybe PackageDbDir
-> FilePath
-> Maybe (PlanJson, FilePath)
-> FilePath
-> IO (Either ExitCode FilePath)
-compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do
- let ?opts = opts
-
+compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do
ghcVer <- ghcVersion
Just (prepare, comp) <- runMaybeT $ msum $
- case oCabalPkgDb opts of
+ case cabalPkgDb of
Nothing ->
[ compileCabalSource
, compileNewBuild ghcVer
@@ -107,7 +116,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do
, MaybeT $ Just <$> compileWithCabalInPrivatePkgDb
]
Just db ->
- [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject)
+ [ pure $ (pure (), compileWithPkg (Just db) hdrCabalVersion CPSProject)
]
appdir <- appCacheDir
@@ -122,7 +131,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do
vLog $ "helper exe does not exist, compiling "++compExePath
prepare >> compile comp cp
- where
+ where
logMsg = "using helper compiled with Cabal from "
-- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort
@@ -130,7 +139,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do
-- | Check if this version is globally available
compileGlobal :: Env => MaybeT IO (IO (), Compile)
compileGlobal = do
- cabal_versions <- listCabalVersions
+ cabal_versions <- listCabalVersions' Nothing
ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions
vLog $ logMsg ++ "user/global package-db"
return $ (return (), compileWithPkg Nothing ver CPSGlobal)
@@ -150,10 +159,10 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do
(PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle
let cabal_pkgid =
PkgId (PkgName (Text.pack "Cabal"))
- (Ver $ versionBranch hdrCabalVersion)
+ (Ver $ versionBranch hdrCabalVersion)
mcabal_unit = listToMaybe $
- Map.elems $ Map.filter (\Unit {..} -> uPId == cabal_pkgid) pjUnits
- Unit {} <- maybe mzero pure mcabal_unit
+ Map.elems $ Map.filter (\CP.Unit{..} -> uPId == cabal_pkgid) pjUnits
+ CP.Unit {} <- maybe mzero pure mcabal_unit
let inplace_db_path = distdir_newstyle
</> "packagedb" </> ("ghc-" ++ showVersion ghcVer)
inplace_db = PackageDbDir inplace_db_path
@@ -175,7 +184,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do
db_exists <- liftIO $ cabalVersionExistsInPkgDb hdrCabalVersion db
when (not db_exists) $
void $ installCabal (Right hdrCabalVersion) `E.catch`
- \(SomeException _) -> errorInstallCabal hdrCabalVersion cachedir
+ \(SomeException _) -> errorInstallCabal hdrCabalVersion
-- | See if we're in a cabal source tree
compileCabalSource :: Env => MaybeT IO (IO (), Compile)
@@ -318,7 +327,7 @@ cabalMinVersionMacro _ =
invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath)
invokeGhc GhcInvocation {..} = do
- rv <- callProcessStderr' Nothing oGhcProgram $ concat
+ rv <- callProcessStderr' Nothing (ghcProgram ?progs) $ concat
[ [ "-outputdir", giOutDir
, "-o", giOutput
]
@@ -335,8 +344,6 @@ invokeGhc GhcInvocation {..} = do
case rv of
ExitSuccess -> Right giOutput
e@(ExitFailure _) -> Left e
- where
- CompileOptions {..} = ?opts
-- | Cabal library version we're compiling the helper exe against.
@@ -460,7 +467,7 @@ runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do
then ["--no-require-sandbox"]
else []
, [ "install", srcdir ]
- , if oVerbose ?opts
+ , if ?verbose
then ["-v"]
else []
, [ "--only-dependencies" ]
@@ -635,8 +642,8 @@ unpackCabalHEAD tmpdir = do
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
-errorInstallCabal :: Version -> FilePath -> IO a
-errorInstallCabal cabalVer _distdir = panicIO $ printf "\
+errorInstallCabal :: Version -> IO a
+errorInstallCabal cabalVer = panicIO $ printf "\
\Installing Cabal version %s failed.\n\
\\n\
\You have the following choices to fix this:\n\
@@ -670,9 +677,6 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\
where
sver = showVersion cabalVer
-listCabalVersions :: Env => MaybeT IO [Version]
-listCabalVersions = listCabalVersions' Nothing
-
listCabalVersions' :: Env => Maybe PackageDbDir -> MaybeT IO [Version]
listCabalVersions' mdb = do
case mdb of
@@ -746,12 +750,12 @@ cabalFileTopField field cabalFile = value
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 ()
+vLog :: (MonadIO m, Verbose) => String -> m ()
+vLog msg
+ | ?verbose = liftIO $ hPutStrLn stderr msg
+ | otherwise = return ()
-logIOError :: Env => String -> IO (Maybe a) -> IO (Maybe a)
+logIOError :: Verbose => String -> IO (Maybe a) -> IO (Maybe a)
logIOError label a = do
a `catchIOError` \ex -> do
vLog $ label ++ ": " ++ show ex
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 10fe916..843a886 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -15,7 +15,8 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures,
- KindSignatures, ImplicitParams, ConstraintKinds #-}
+ StandaloneDeriving, GADTs, DataKinds, KindSignatures, ImplicitParams,
+ ConstraintKinds, RankNTypes #-}
{-|
Module : CabalHelper.Compiletime.Types
@@ -25,13 +26,25 @@ License : GPL-3
module CabalHelper.Compiletime.Types where
+import Cabal.Plan
+ ( PlanJson )
+import Data.IORef
import Data.Version
import Data.Typeable
+import Data.Map.Strict (Map)
import GHC.Generics
+import System.Posix.Types
+import CabalHelper.Shared.InterfaceTypes
-type Env = (?opts :: CompileOptions)
+type Verbose = (?verbose :: Bool)
+type Progs = (?progs :: Programs)
+-- TODO: rname to `CompEnv` or something
+type Env =
+ ( ?verbose :: Bool
+ , ?progs :: Programs
+ )
--- | Paths or names of various programs we need.
+-- | Configurable paths to various programs we use.
data Programs = Programs {
-- | The path to the @cabal@ program.
cabalProgram :: FilePath,
@@ -44,8 +57,8 @@ data Programs = Programs {
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@.
+-- | By default all programs use their unqualified names, i.e. they will be
+-- searched for on @PATH@.
defaultPrograms :: Programs
defaultPrograms = Programs "cabal" "ghc" "ghc-pkg"
@@ -57,13 +70,13 @@ data CompileOptions = CompileOptions
}
oCabalProgram :: Env => FilePath
-oCabalProgram = cabalProgram $ oPrograms ?opts
+oCabalProgram = cabalProgram ?progs
oGhcProgram :: Env => FilePath
-oGhcProgram = ghcProgram $ oPrograms ?opts
+oGhcProgram = ghcProgram ?progs
oGhcPkgProgram :: Env => FilePath
-oGhcPkgProgram = ghcPkgProgram $ oPrograms ?opts
+oGhcPkgProgram = ghcPkgProgram ?progs
defaultCompileOptions :: CompileOptions
defaultCompileOptions =
diff --git a/src/CabalHelper/Runtime/Compat.hs b/src/CabalHelper/Runtime/Compat.hs
index cafbfc3..8c32adf 100644
--- a/src/CabalHelper/Runtime/Compat.hs
+++ b/src/CabalHelper/Runtime/Compat.hs
@@ -151,9 +151,9 @@ type UnitId = InstalledPackageId
componentNameToCh :: ComponentName -> ChComponentName
-componentNameToCh CLibName = ChLibName
+componentNameToCh CLibName = ChLibName ChMainLibName
#if CH_MIN_VERSION_Cabal(2,0,0)
-componentNameToCh (CSubLibName n) = ChSubLibName (unUnqualComponentName' n)
+componentNameToCh (CSubLibName n) = ChLibName $ ChSubLibName (unUnqualComponentName' n)
componentNameToCh (CFLibName n) = ChFLibName (unUnqualComponentName' n)
#endif
componentNameToCh (CExeName n) = ChExeName (unUnqualComponentName' n)
diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs
index ecdbc2a..3a363a3 100644
--- a/src/CabalHelper/Runtime/Main.hs
+++ b/src/CabalHelper/Runtime/Main.hs
@@ -14,7 +14,11 @@
-- 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, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns #-}
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns,
+ TupleSections #-}
+
+{- # OPTIONS_GHC -Wno-missing-signatures #-}
+{- # OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#ifdef MIN_VERSION_Cabal
#undef CH_MIN_VERSION_Cabal
@@ -34,7 +38,7 @@ import Distribution.PackageDescription
( PackageDescription
, GenericPackageDescription(..)
, Flag(..)
- , FlagName(..)
+ , FlagName
, FlagAssignment
, Executable(..)
, Library(..)
@@ -65,7 +69,7 @@ import Distribution.Simple.LocalBuildInfo
, ComponentLocalBuildInfo(..)
, componentBuildInfo
, externalPackageDeps
- , withComponentsLBI
+ , withAllComponentsInBuildOrder
, withLibLBI
, withExeLBI
)
@@ -141,7 +145,13 @@ import Distribution.Types.ForeignLib
( ForeignLib(..)
)
import Distribution.Types.UnqualComponentName
- ( unUnqualComponentName
+ ( UnqualComponentName
+ , unUnqualComponentName
+ )
+#else
+-- <1.25
+import Distribution.PackageDescription
+ ( FlagName(FlagName)
)
#endif
@@ -198,12 +208,12 @@ import Distribution.Types.GenericPackageDescription
)
#endif
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), (<*>), ZipList(..))
import Control.Arrow (first, second, (&&&))
import Control.Monad
import Control.Exception (catch, PatternMatchFail(..))
import Data.List
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Monoid
import Data.IORef
@@ -227,42 +237,26 @@ usage = do
hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg
where
usageMsg = ""
- ++"PROJ_DIR DIST_DIR [--with-* ...] (\n"
- ++" version\n"
- ++" | print-lbi [--human]\n"
- ++" | package-id\n"
+ ++"PROJ_DIR DIST_DIR [--with-* ...]\n"
+ ++" ( version\n"
++" | flags\n"
++" | config-flags\n"
++" | non-default-config-flags\n"
++" | write-autogen-files\n"
++" | compiler-version\n"
- ++" | ghc-options [--with-inplace]\n"
- ++" | ghc-src-options [--with-inplace]\n"
- ++" | ghc-pkg-options [--with-inplace]\n"
- ++" | ghc-merged-pkg-options [--with-inplace]\n"
- ++" | ghc-lang-options [--with-inplace]\n"
- ++" | package-db-stack\n"
- ++" | entrypoints\n"
- ++" | needs-build-output\n"
- ++" | source-dirs\n"
+ ++" | component-info\n"
+ ++" | print-lbi [--human]\n"
++" ) ...\n"
commands :: [String]
-commands = [ "print-lbi"
- , "package-id"
- , "flags"
+commands = [ "flags"
, "config-flags"
, "non-default-config-flags"
, "write-autogen-files"
, "compiler-version"
- , "ghc-options"
- , "ghc-src-options"
- , "ghc-pkg-options"
- , "ghc-lang-options"
, "package-db-stack"
- , "entrypoints"
- , "needs-build-output"
- , "source-dirs"
+ , "component-info"
+ , "print-lbi"
]
main :: IO ()
@@ -352,12 +346,41 @@ main = do
let CompilerId comp ver = compilerId $ compiler lbi
return $ Just $ ChResponseVersion (show comp) (toDataVersion ver)
- "ghc-options":flags -> do
- res <- componentOptions lvd True flags id
- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])
+ "package-db-stack":[] -> do
+ let
+ pkgDb GlobalPackageDB = ChPkgGlobal
+ pkgDb UserPackageDB = ChPkgUser
+ pkgDb (SpecificPackageDB s) = ChPkgSpecific s
+
+ -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478
+ return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi
+
+ "component-info":flags -> do
+ res <- componentsInfo flags lvd lbi v distdir
+ return $ Just $ ChResponseComponentsInfo res
+
+ "print-lbi":flags ->
+ case flags of
+ ["--human"] -> print lbi >> return Nothing
+ [] -> return $ Just $ ChResponseLbi $ show lbi
- "ghc-src-options":flags -> do
- res <- componentOptions lvd False flags $ \opts -> mempty {
+ cmd:_ | not (cmd `elem` commands) ->
+ errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure
+ _ ->
+ errMsg "Invalid usage!" >> usage >> exitFailure
+
+
+componentsInfo
+ :: [String]
+ -> (LocalBuildInfo, Verbosity, FilePath)
+ -> LocalBuildInfo
+ -> Verbosity
+ -> FilePath
+ -> IO (Map.Map ChComponentName ChComponentInfo)
+componentsInfo flags lvd lbi v distdir = do
+ ciGhcOptions <- componentOptions lvd True flags id
+
+ ciGhcSrcOptions <- componentOptions lvd False flags $ \opts -> mempty {
-- Not really needed but "unexpected package db stack: []"
ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],
@@ -368,90 +391,61 @@ main = do
ghcOptSourcePathClear = ghcOptSourcePathClear opts,
ghcOptSourcePath = ghcOptSourcePath opts
}
- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])
- "ghc-pkg-options":flags -> do
- res <- componentOptions lvd True flags $ \opts -> mempty {
+ ciGhcPkgOptions <- componentOptions lvd True flags $ \opts -> mempty {
ghcOptPackageDBs = ghcOptPackageDBs opts,
ghcOptPackages = ghcOptPackages opts,
ghcOptHideAllPackages = ghcOptHideAllPackages opts
}
- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])
-
- "ghc-merged-pkg-options":flags -> do
- res <- mconcat . map snd <$> (componentOptions' lvd True flags (\_ _ o -> return o) $ \opts -> mempty {
- ghcOptPackageDBs = [],
- ghcOptHideAllPackages = NoFlag,
- ghcOptPackages = ghcOptPackages opts
- })
-
- let res' = nubPackageFlags $ res { ghcOptPackageDBs = withPackageDB lbi
- , ghcOptHideAllPackages = Flag True
- }
-
- Just . ChResponseList <$> renderGhcOptions' lbi v res'
- "ghc-lang-options":flags -> do
- res <- componentOptions lvd False flags $ \opts -> mempty {
+ ciGhcLangOptions <- componentOptions lvd False flags $ \opts -> mempty {
ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],
ghcOptLanguage = ghcOptLanguage opts,
ghcOptExtensions = ghcOptExtensions opts,
ghcOptExtensionMap = ghcOptExtensionMap opts
}
- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])
- "package-db-stack":[] -> do
- let
- pkgDb GlobalPackageDB = ChPkgGlobal
- pkgDb UserPackageDB = ChPkgUser
- pkgDb (SpecificPackageDB s) = ChPkgSpecific s
+ ciSourceDirs <- componentsMap lbi v distdir $ \_ _ bi -> return $ hsSourceDirs bi
- -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478
- return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi
-
- "entrypoints":[] -> do
#if CH_MIN_VERSION_Cabal(2,0,0)
includeDirMap <- recursiveDepInfo lbi v distdir
- eps <- componentsMap lbi v distdir $ \c clbi _bi -> do
+ ciEntrypoints <- componentsMap lbi v distdir $ \c clbi _bi -> do
case needsBuildOutput includeDirMap (componentUnitId clbi) of
ProduceBuildOutput -> return $ componentEntrypoints c
NoBuildOutput -> return seps
where (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi)
#else
- eps <- componentsMap lbi v distdir $ \c _clbi _bi ->
+ ciEntrypoints <- componentsMap lbi v distdir $ \c _clbi _bi ->
return $ componentEntrypoints c
#endif
- -- MUST append Setup component at the end otherwise CabalHelper gets
- -- confused
- let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)]
- return $ Just $ ChResponseEntrypoints eps'
- "needs-build-output":[] -> do
#if CH_MIN_VERSION_Cabal(2,0,0)
- includeDirMap <- recursiveDepInfo lbi v distdir
- nbs <- componentsMap lbi v distdir $ \c clbi _bi ->
+ ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c clbi _bi ->
return $ needsBuildOutput includeDirMap (componentUnitId clbi)
#else
- nbs <- componentsMap lbi v distdir $ \c _clbi _bi ->
+ ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c _clbi _bi ->
return $ NoBuildOutput
#endif
- return $ Just $ ChResponseNeedsBuild nbs
- "source-dirs":[] -> do
- res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi
- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])
+ let comp_name = map fst ciGhcOptions
+ uiComponents = Map.fromList
+ $ map (ciComponentName &&& id)
+ $ getZipList
+ $ ChComponentInfo
+ <$> ZipList comp_name
+ <*> ZipList (map snd ciGhcOptions)
+ <*> ZipList (map snd ciGhcSrcOptions)
+ <*> ZipList (map snd ciGhcPkgOptions)
+ <*> ZipList (map snd ciGhcLangOptions)
+ <*> ZipList (map snd ciSourceDirs)
+ <*> ZipList (map snd ciEntrypoints)
+ <*> ZipList (map snd ciNeedsBuildOutput)
- "print-lbi":flags ->
- case flags of
- ["--human"] -> print lbi >> return Nothing
- [] -> return $ Just $ ChResponseLbi $ show lbi
+ return uiComponents
- cmd:_ | not (cmd `elem` commands) ->
- errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure
- _ ->
- errMsg "Invalid usage!" >> usage >> exitFailure
+flagName' :: Distribution.PackageDescription.Flag -> String
flagName' = unFlagName . flagName
-- getLibrary :: PackageDescription -> Library
@@ -460,6 +454,10 @@ flagName' = unFlagName . flagName
-- withLib pd (writeIORef lr)
-- readIORef lr
+getLibraryClbi
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> Maybe (Library, ComponentLocalBuildInfo)
getLibraryClbi pd lbi = unsafePerformIO $ do
lr <- newIORef Nothing
@@ -469,15 +467,6 @@ getLibraryClbi pd lbi = unsafePerformIO $ do
readIORef lr
-getExeClbi pd lbi = unsafePerformIO $ do
- lr <- newIORef Nothing
-
- withExeLBI pd lbi $ \ exe clbi ->
- writeIORef lr $ Just (exe,clbi)
-
- readIORef lr
-
-
componentsMap :: LocalBuildInfo
-> Verbosity
-> FilePath
@@ -493,20 +482,23 @@ componentsMap lbi _v _distdir f = do
-- withComponentsLBI is deprecated but also exists in very old versions
-- it's equivalent to withAllComponentsInBuildOrder in newer versions
- withComponentsLBI pd lbi $ \c clbi -> do
+ withAllComponentsInBuildOrder pd lbi $ \c clbi -> do
let bi = componentBuildInfo c
- name = componentNameFromComponent c
+ name = componentNameToCh $ componentNameFromComponent c
l' <- readIORef lr
r <- f c clbi bi
-#if CH_MIN_VERSION_Cabal(2,0,0)
- writeIORef lr $ (componentNameToCh name, r):l'
-#else
- writeIORef lr $ (componentNameToCh name, r):l'
-#endif
+ writeIORef lr $ (name, r) : l'
reverse <$> readIORef lr
+componentOptions'
+ :: (LocalBuildInfo, Verbosity, FilePath)
+ -> Bool
+ -> [String]
+ -> (LocalBuildInfo -> Verbosity -> GhcOptions -> IO a)
+ -> (GhcOptions -> GhcOptions)
+ -> IO [(ChComponentName, a)]
componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do
let pd = localPkgDescr lbi
#if CH_MIN_VERSION_Cabal(2,0,0)
@@ -529,12 +521,18 @@ componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do
in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts
+componentOptions :: (LocalBuildInfo, Verbosity, FilePath)
+ -> Bool
+ -> [String]
+ -> (GhcOptions -> GhcOptions)
+ -> IO [(ChComponentName, [String])]
componentOptions (lbi, v, distdir) inplaceFlag flags f =
componentOptions' (lbi, v, distdir) inplaceFlag flags renderGhcOptions' f
gmModuleName :: C.ModuleName -> ChModuleName
gmModuleName = ChModuleName . intercalate "." . components
+
#if CH_MIN_VERSION_Cabal(2,0,0)
removeInplaceDeps :: Verbosity
-> LocalBuildInfo
@@ -571,7 +569,7 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let
, ghcOptPackages = ghcOptPackages opts <> toNubListR extraDeps }
libopts =
- case (getLibraryClbi pd lbi,getExeClbi pd lbi) of
+ case (getLibraryClbi pd lbi, getExeClbi pd lbi) of
(Just (lib, libclbi),_) | hasIdeps ->
let
libbi = libBuildInfo lib
@@ -594,7 +592,21 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let
NoBuildOutput -> libopts
ProduceBuildOutput -> mempty { ghcOptPackageDBs = [SpecificPackageDB packageDbDir] }
in (clbi', libopts')
+
+getExeClbi
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> Maybe (Executable, ComponentLocalBuildInfo)
+getExeClbi pd lbi = unsafePerformIO $ do
+ lr <- newIORef Nothing
+
+ withExeLBI pd lbi $ \ exe clbi ->
+ writeIORef lr $ Just (exe,clbi)
+
+ readIORef lr
+
#else
+
removeInplaceDeps :: Verbosity
-> LocalBuildInfo
-> PackageDescription
@@ -616,10 +628,16 @@ removeInplaceDeps _v lbi pd clbi = let
_ -> mempty
clbi' = clbi { componentPackageDeps = deps }
in (clbi', libopts)
+
#endif
#if CH_MIN_VERSION_Cabal(2,0,0)
+recursiveDepInfo
+ :: LocalBuildInfo
+ -> Verbosity
+ -> FilePath
+ -> IO (Map.Map UnitId SubDeps)
recursiveDepInfo lbi v distdir = do
includeDirs <- componentsMap lbi v distdir $ \c clbi bi -> do
return (componentUnitId clbi
@@ -656,7 +674,7 @@ needsBuildOutput includeDirs unit = go [unit]
go [] = NoBuildOutput
go (u:us) = case Map.lookup u includeDirs of
Nothing -> go us
- Just (SubDeps us' sfp sci sep) ->
+ Just (SubDeps us' _sfp sci _sep) ->
if any (isIndef . fst) sci
then ProduceBuildOutput
else go (us++us')
@@ -666,31 +684,32 @@ needsBuildOutput includeDirs unit = go [unit]
-- current accumulated value, and the second one is the current sub-dependency
-- being considered. So the bias should be to preserve the type of entrypoint
-- from the first parameter.
+combineEp :: Maybe ChEntrypoint -> ChEntrypoint -> ChEntrypoint
combineEp Nothing e = e
combineEp (Just ChSetupEntrypoint) e = e
combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChLibEntrypoint es2 os2 ss2) = (ChLibEntrypoint (nub $ es2++es1) (nub $ os2++os1) (nub $ ss2++ss1))
-combineEp _ e@(ChExeEntrypoint mi os2) = error $ "combineEP: cannot have a sub exe:" ++ show e
+combineEp _ e@(ChExeEntrypoint _mi _os2) = error $ "combineEP: cannot have a sub exe:" ++ show e
combineEp (Just (ChExeEntrypoint mi os1)) (ChLibEntrypoint es2 os2 ss2) = (ChExeEntrypoint mi (nub $ os1++es2++os2++ss2))
-- no, you unconditionally always wrap the result in Just, so instead of `f x = Just y; f x = Just z` do `f x = y; f x = z` and use f as `Just . f`
-
-
-instantiatedGhcPackage :: (ModuleName,OpenModule) -> [(OpenUnitId, ModuleRenaming)]
-instantiatedGhcPackage (_,OpenModule oui@(DefiniteUnitId _) _) = [(oui,DefaultRenaming)]
-instantiatedGhcPackage (_, _) = []
#endif
+
+initialBuildStepsForAllComponents
+ :: FilePath
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Verbosity
+ -> IO ()
initialBuildStepsForAllComponents distdir pd lbi v =
initialBuildSteps distdir pd lbi v
-
-
-
#if !CH_MIN_VERSION_Cabal(1,25,0)
-- CPP < 1.25
+unFlagName :: FlagName -> String
unFlagName (FlagName n) = n
-- mkFlagName n = FlagName n
#endif
@@ -742,14 +761,14 @@ componentEntrypoints (CBench Benchmark {})
#if CH_MIN_VERSION_Cabal(2,0,0)
isInplaceCompInc :: ComponentLocalBuildInfo -> (OpenUnitId, ModuleRenaming) -> Bool
isInplaceCompInc clbi (DefiniteUnitId uid, _mr) = unDefUnitId uid `elem` componentInternalDeps clbi
-isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = False
+isInplaceCompInc _clbi (IndefFullUnitId _uid _, _mmr) = False
#endif
#if CH_MIN_VERSION_Cabal(2,0,0)
-isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool
-isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi
+-- isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool
+-- isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi
#else
-isInplaceDep :: LocalBuildInfo -> (InstalledPackageId, PackageId) -> Bool
+isInplaceDep :: LocalBuildInfo -> (UnitId, PackageId) -> Bool
# if CH_MIN_VERSION_Cabal(1,23,0)
-- CPP >= 1.23
isInplaceDep lbi (ipid, _pid) = localUnitId lbi == ipid
@@ -759,6 +778,7 @@ isInplaceDep _lbi (ipid, pid) = inplacePackageId pid == ipid
# endif
#endif
+nubPackageFlags :: GhcOptions -> GhcOptions
#if CH_MIN_VERSION_Cabal(1,22,0)
-- CPP >= 1.22
-- >= 1.22 uses NubListR
diff --git a/src/CabalHelper/Shared/InterfaceTypes.hs b/src/CabalHelper/Shared/InterfaceTypes.hs
index a108c72..0539b96 100644
--- a/src/CabalHelper/Shared/InterfaceTypes.hs
+++ b/src/CabalHelper/Shared/InterfaceTypes.hs
@@ -34,31 +34,63 @@ module CabalHelper.Shared.InterfaceTypes where
import GHC.Generics
import Data.Version
+import Data.Map.Strict (Map)
data ChResponse
- = ChResponseCompList [(ChComponentName, [String])]
- | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)]
- | ChResponseNeedsBuild [(ChComponentName, NeedsBuildOutput)]
- | ChResponseList [String]
- | ChResponsePkgDbs [ChPkgDb]
- | ChResponseLbi String
- | ChResponseVersion String Version
- | ChResponseLicenses [(String, [(String, Version)])]
- | ChResponseFlags [(String, Bool)]
+ = ChResponseComponentsInfo (Map ChComponentName ChComponentInfo)
+ | ChResponseList [String]
+ | ChResponsePkgDbs [ChPkgDb]
+ | ChResponseLbi String
+ | ChResponseVersion String Version
+ | ChResponseLicenses [(String, [(String, Version)])]
+ | ChResponseFlags [(String, Bool)]
deriving (Eq, Ord, Read, Show, Generic)
data ChComponentName = ChSetupHsName
- | ChLibName
- | ChSubLibName String
+ | ChLibName ChLibraryName
| ChFLibName String
| ChExeName String
| ChTestName String
| ChBenchName String
deriving (Eq, Ord, Read, Show, Generic)
+data ChLibraryName = ChMainLibName
+ | ChSubLibName String
+ deriving (Eq, Ord, Read, Show, Generic)
+
newtype ChModuleName = ChModuleName String
deriving (Eq, Ord, Read, Show, Generic)
+data ChComponentInfo = ChComponentInfo
+ { ciComponentName :: ChComponentName
+ -- ^ The component\'s type and name
+
+ , ciGhcOptions :: [String]
+ -- ^ Full set of GHC options, ready for loading this component into GHCi.
+
+ , ciGhcSrcOptions :: [String]
+ -- ^ Only search path related GHC options.
+
+ , ciGhcPkgOptions :: [String]
+ -- ^ Only package related GHC options, sufficient for things don't need to
+ -- access any home modules.
+
+ , ciGhcLangOptions :: [String]
+ -- ^ Only Haskell language extension related options, i.e. @-XSomeExtension@
+
+ , ciSourceDirs :: [String]
+ -- ^ A component's @source-dirs@ field, beware since if this is empty
+ -- implicit behaviour in GHC kicks in which you might have to emulate.
+
+ , ciEntrypoints :: ChEntrypoint
+ -- ^ Modules or files Cabal would have the compiler build directly. Can be
+ -- used to compute the home module closure for a component.
+
+ , ciNeedsBuildOutput :: NeedsBuildOutput
+ -- ^ If a component has a non-default module renaming (backpack) it cannot
+ -- be built in memory and instead needs proper build output.
+ } deriving (Eq, Ord, Read, Show)
+
data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but
-- @main-is@ could either be @"Setup.hs"@
-- or @"Setup.lhs"@. Since we don't know
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 17:55:35 +0000