aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/CabalHelper/Compiletime/Types.hs3
-rw-r--r--src/CabalHelper/Runtime/Compat.hs7
-rw-r--r--src/CabalHelper/Runtime/HelperMain.hs330
-rw-r--r--src/CabalHelper/Shared/InterfaceTypes.hs45
4 files changed, 42 insertions, 343 deletions
diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs
index 748b8d1..3871576 100644
--- a/src/CabalHelper/Compiletime/Types.hs
+++ b/src/CabalHelper/Compiletime/Types.hs
@@ -372,9 +372,6 @@ data UnitInfo = UnitInfo
, uiCompilerId :: !(String, Version)
-- ^ The version of GHC the unit is configured to use
- , uiPackageDbStack :: !([ChPkgDb])
- -- ^ List of package databases to use.
-
, uiPackageFlags :: !([(String, Bool)])
-- ^ Flag definitions from cabal file
diff --git a/src/CabalHelper/Runtime/Compat.hs b/src/CabalHelper/Runtime/Compat.hs
index 1673b7a..d3fe5e6 100644
--- a/src/CabalHelper/Runtime/Compat.hs
+++ b/src/CabalHelper/Runtime/Compat.hs
@@ -29,6 +29,7 @@ module CabalHelper.Runtime.Compat
, unUnqualComponentName'
, componentNameFromComponent
, componentOutDir
+ , internalPackageDBPath
) where
import System.FilePath
@@ -224,3 +225,9 @@ componentOutDir' lbi compName' =
let targetDir = (buildDir lbi) </> compName'
compDir = targetDir </> (compName' ++ "-tmp")
in compDir
+
+#if !CH_MIN_VERSION_Cabal(2,0,0)
+internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
+internalPackageDBPath lbi distPref =
+ distPref </> "package.conf.inplace"
+#endif
diff --git a/src/CabalHelper/Runtime/HelperMain.hs b/src/CabalHelper/Runtime/HelperMain.hs
index a3119e5..08cb9c5 100644
--- a/src/CabalHelper/Runtime/HelperMain.hs
+++ b/src/CabalHelper/Runtime/HelperMain.hs
@@ -160,9 +160,6 @@ import Distribution.Simple.LocalBuildInfo
( allLibModules
, componentBuildDir
)
-import Distribution.Simple.Register
- ( internalPackageDBPath
- )
import Distribution.Backpack
( OpenUnitId(..),
OpenModule(..)
@@ -235,7 +232,7 @@ usage = do
hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg
where
usageMsg = ""
- ++"PROJ_DIR DIST_DIR [--with-* ...]\n"
+ ++"PROJ_DIR DIST_DIR (v1|v2)\n"
++" ( version\n"
++" | flags\n"
++" | config-flags\n"
@@ -259,7 +256,7 @@ commands = [ "flags"
helper_main :: [String] -> IO [Maybe ChResponse]
helper_main args = do
- cfile : distdir : args'
+ cfile : distdir : pt : args'
<- case args of
[] -> usage >> exitFailure
_ -> return args
@@ -342,17 +339,8 @@ helper_main args = do
let CompilerId comp ver = compilerId $ compiler lbi
return $ Just $ ChResponseVersion $ (,) (show comp) (toDataVersion ver)
- "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
+ "component-info":[] -> do
+ res <- componentsInfo lvd pt
return $ Just $ ChResponseComponentsInfo res
"print-lbi":flags ->
@@ -365,64 +353,29 @@ helper_main args = do
_ ->
errMsg "Invalid usage!" >> usage >> exitFailure
+type ProjectType = String -- either "v1" or "v2"
componentsInfo
- :: [String]
- -> (LocalBuildInfo, Verbosity, FilePath)
- -> LocalBuildInfo
- -> Verbosity
- -> FilePath
+ :: (LocalBuildInfo, Verbosity, FilePath)
+ -> ProjectType
-> 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],
-
- ghcOptCppOptions = ghcOptCppOptions opts,
- ghcOptCppIncludePath = ghcOptCppIncludePath opts,
- ghcOptCppIncludes = ghcOptCppIncludes opts,
- ghcOptFfiIncludes = ghcOptFfiIncludes opts,
- ghcOptSourcePathClear = ghcOptSourcePathClear opts,
- ghcOptSourcePath = ghcOptSourcePath opts
- }
-
- ciGhcPkgOptions <- componentOptions lvd True flags $ \opts -> mempty {
- ghcOptPackageDBs = ghcOptPackageDBs opts,
- ghcOptPackages = ghcOptPackages opts,
- ghcOptHideAllPackages = ghcOptHideAllPackages opts
- }
-
- ciGhcLangOptions <- componentOptions lvd False flags $ \opts -> mempty {
- ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],
-
- ghcOptLanguage = ghcOptLanguage opts,
- ghcOptExtensions = ghcOptExtensions opts,
- ghcOptExtensionMap = ghcOptExtensionMap opts
- }
+componentsInfo lvd@(lbi, v, distdir) pt = do
+ let mod_ghc_opts opts
+ | pt == "v1" = opts {
+ ghcOptPackageDBs =
+ -- c.f. Simple/Build.hs createInternalPackageDB call
+ ghcOptPackageDBs opts ++
+ [SpecificPackageDB $ internalPackageDBPath lbi distdir]
+ }
+ | pt == "v2" = opts
+ | otherwise = error $ "Unknown project-type '"++pt++"'!"
+
+ ciGhcOptions <- componentOptions lvd mod_ghc_opts
ciSourceDirs <- componentsMap lbi v distdir $ \_ _ bi -> return $ hsSourceDirs bi
-#if CH_MIN_VERSION_Cabal(2,0,0)
- includeDirMap <- recursiveDepInfo lbi v distdir
- 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
ciEntrypoints <- componentsMap lbi v distdir $ \c _clbi _bi ->
return $ componentEntrypoints c
-#endif
-
-#if CH_MIN_VERSION_Cabal(2,0,0)
- ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c clbi _bi ->
- return $ needsBuildOutput includeDirMap (componentUnitId clbi)
-#else
- ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c _clbi _bi ->
- return $ NoBuildOutput
-#endif
let comp_name = map fst ciGhcOptions
uiComponents = Map.fromList
@@ -431,12 +384,8 @@ componentsInfo flags lvd lbi v distdir = do
$ 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)
return uiComponents
@@ -444,25 +393,6 @@ componentsInfo flags lvd lbi v distdir = do
flagName' :: Distribution.PackageDescription.Flag -> String
flagName' = unFlagName . flagName
--- getLibrary :: PackageDescription -> Library
--- getLibrary pd = unsafePerformIO $ do
--- lr <- newIORef (error "libraryMap: empty IORef")
--- withLib pd (writeIORef lr)
--- readIORef lr
-
-getLibraryClbi
- :: PackageDescription
- -> LocalBuildInfo
- -> Maybe (Library, ComponentLocalBuildInfo)
-getLibraryClbi pd lbi = unsafePerformIO $ do
- lr <- newIORef Nothing
-
- withLibLBI pd lbi $ \ lib clbi ->
- writeIORef lr $ Just (lib,clbi)
-
- readIORef lr
-
-
componentsMap :: LocalBuildInfo
-> Verbosity
-> FilePath
@@ -490,210 +420,27 @@ componentsMap lbi _v _distdir f = do
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)
- includeDirMap <- recursiveDepInfo lbi v distdir
-#endif
-
+componentOptions' (lbi, v, distdir) rf f = do
componentsMap lbi v distdir $ \c clbi bi ->
let
outdir = componentOutDir lbi c
- (clbi', adopts) = case flags of
- _ | not inplaceFlag -> (clbi, mempty)
- ["--with-inplace"] -> (clbi, mempty)
-#if CH_MIN_VERSION_Cabal(2,0,0)
- [] -> removeInplaceDeps v lbi pd clbi includeDirMap
-#else
- [] -> removeInplaceDeps v lbi pd clbi
-#endif
- _ -> error $ "invalid flags: " ++ show flags
- opts = componentGhcOptions normal lbi bi clbi' outdir
- opts' = f opts
+ opts = componentGhcOptions normal lbi bi clbi outdir
- in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts
+ in rf lbi v $ f opts
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
+componentOptions (lbi, v, distdir) f =
+ componentOptions' (lbi, v, distdir) renderGhcOptions' f
gmModuleName :: C.ModuleName -> ChModuleName
gmModuleName = ChModuleName . intercalate "." . components
-#if CH_MIN_VERSION_Cabal(2,0,0)
-removeInplaceDeps :: Verbosity
- -> LocalBuildInfo
- -> PackageDescription
- -> ComponentLocalBuildInfo
- -> Map.Map UnitId SubDeps
- -> (ComponentLocalBuildInfo, GhcOptions)
-removeInplaceDeps _v lbi pd clbi includeDirs = let
- removeInplace c =
- let
- (ideps, incs) = partition (isInplaceCompInc c) (componentIncludes c)
- hasIdeps' = not $ null ideps
- c' = c { componentPackageDeps = error "using deprecated field:componentPackageDeps"
- , componentInternalDeps = []
- , componentIncludes = incs }
- in (hasIdeps',c')
-
- needsBuild = needsBuildOutput includeDirs (componentUnitId clbi)
-
- cleanRecursiveOpts :: Component
- -> BuildInfo -> ComponentLocalBuildInfo -> GhcOptions
- cleanRecursiveOpts comp libbi libclbi =
- let
- liboutdir = componentOutDir lbi comp
- (_,libclbi') = removeInplace libclbi
- (extraIncludes,extraDeps',_ems) = recursiveIncludeDirs includeDirs (componentUnitId libclbi)
- (_,extraDeps) = partition (isInplaceCompInc libclbi) extraDeps'
- opts = (componentGhcOptions normal lbi libbi libclbi' liboutdir) {
- ghcOptPackageDBs = []
- }
-
- in
- opts { ghcOptSourcePath = ghcOptSourcePath opts <> toNubListR extraIncludes
- , ghcOptPackages = ghcOptPackages opts <> toNubListR extraDeps }
-
- libopts =
- case (getLibraryClbi pd lbi, getExeClbi pd lbi) of
- (Just (lib, libclbi),_) | hasIdeps ->
- let
- libbi = libBuildInfo lib
- opts = cleanRecursiveOpts (CLib lib) libbi libclbi
- in
- opts { ghcOptInputModules = ghcOptInputModules opts <> (toNubListR $ allLibModules lib libclbi) }
- (_,Just (exe,execlbi)) | hasIdeps ->
- let
- exebi = buildInfo exe
- in
- cleanRecursiveOpts (CExe exe) exebi execlbi
- _ -> mempty
-
- distDir = fromFlagOrDefault ("." </> "dist") (configDistPref $ configFlags lbi)
- packageDbDir = internalPackageDBPath lbi distDir
- (hasIdeps,clbi') = case needsBuild of
- NoBuildOutput -> removeInplace clbi
- ProduceBuildOutput -> (False, clbi)
- libopts' = case needsBuild of
- 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
- -> ComponentLocalBuildInfo
- -> (ComponentLocalBuildInfo, GhcOptions)
-removeInplaceDeps _v lbi pd clbi = let
- (ideps, deps) = partition (isInplaceDep lbi) (componentPackageDeps clbi)
- hasIdeps = not $ null ideps
- libopts =
- case getLibraryClbi pd lbi of
- Just (lib, libclbi) | hasIdeps ->
- let
- libbi = libBuildInfo lib
- liboutdir = componentOutDir lbi (CLib lib)
- in
- (componentGhcOptions normal lbi libbi libclbi liboutdir) {
- ghcOptPackageDBs = []
- }
- _ -> 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
- , ( SubDeps
- { sdComponentInternalDeps = componentInternalDeps clbi
- , sdHsSourceDirs = hsSourceDirs bi
- , sdComponentIncludes = componentIncludes clbi
- , sdComponentEntryPoints = componentEntrypoints c}) )
- return $ Map.fromList $ map snd includeDirs
-
-data SubDeps = SubDeps
- { sdComponentInternalDeps :: [UnitId]
- , sdHsSourceDirs :: [FilePath]
- , sdComponentIncludes :: [(OpenUnitId, ModuleRenaming)]
- , sdComponentEntryPoints :: ChEntrypoint
- }
-
-recursiveIncludeDirs :: Map.Map UnitId SubDeps
- -> UnitId -> ([FilePath], [(OpenUnitId, ModuleRenaming)]
- , ChEntrypoint)
-recursiveIncludeDirs includeDirs unit = go ([],[],Nothing) [unit]
- where
- go (afp,aci,Nothing ) [] = (afp,aci,error "recursiveIncludeDirs:no ChEntrypoint")
- go (afp,aci,Just amep) [] = (afp,aci,amep)
- go acc@(afp,aci,amep) (u:us) = case Map.lookup u includeDirs of
- Nothing -> go acc us
- Just (SubDeps us' sfp sci sep) -> go (afp++sfp,aci++sci,Just (combineEp amep sep)) (us++us')
-
-needsBuildOutput :: Map.Map UnitId SubDeps -> UnitId -> NeedsBuildOutput
-needsBuildOutput includeDirs unit = go [unit]
- where
- isIndef (IndefFullUnitId _ _) = True
- isIndef _ = False
- go [] = NoBuildOutput
- go (u:us) = case Map.lookup u includeDirs of
- Nothing -> go us
- Just (SubDeps us' _sfp sci _sep) ->
- if any (isIndef . fst) sci
- then ProduceBuildOutput
- else go (us++us')
-
--- | combineEP is used to combine the entrypoints when recursively chasing
--- through the dependencies of a given entry point. The first parameter is the
--- 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 (Just (ChExeEntrypoint mi os1)) (ChLibEntrypoint es2 os2 ss2) = (ChExeEntrypoint mi (nub $ os1++es2++os2++ss2))
-combineEp me e = error $ "combineEp: undhandled case: " ++ show (me, e)
-
--- 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`
-
-#endif
-
-
initialBuildStepsForAllComponents
:: FilePath
-> PackageDescription
@@ -756,35 +503,6 @@ componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _
componentEntrypoints (CBench Benchmark {})
= ChLibEntrypoint [] [] []
-#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
-#endif
-
-#if CH_MIN_VERSION_Cabal(2,0,0)
--- isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool
--- isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi
-#else
-isInplaceDep :: LocalBuildInfo -> (UnitId, PackageId) -> Bool
-# if CH_MIN_VERSION_Cabal(1,23,0)
--- CPP >= 1.23
-isInplaceDep lbi (ipid, _pid) = localUnitId lbi == ipid
-# else
--- CPP <= 1.22
-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
-nubPackageFlags opts = opts
-#else
-nubPackageFlags opts = opts { ghcOptPackages = nub $ ghcOptPackages opts }
-#endif
-
renderGhcOptions' :: LocalBuildInfo
-> Verbosity
-> GhcOptions
diff --git a/src/CabalHelper/Shared/InterfaceTypes.hs b/src/CabalHelper/Shared/InterfaceTypes.hs
index 87536a5..ed06045 100644
--- a/src/CabalHelper/Shared/InterfaceTypes.hs
+++ b/src/CabalHelper/Shared/InterfaceTypes.hs
@@ -39,10 +39,8 @@ import Data.Map.Strict (Map)
data ChResponse
= 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)
@@ -68,16 +66,6 @@ data ChComponentInfo = ChComponentInfo
, 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 @hs-source-dirs@ field, note that this only contains the
-- directories specified by the cabal file, however cabal also adds the
@@ -87,32 +75,21 @@ data ChComponentInfo = ChComponentInfo
, 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.
- -- TODO: This is a ghc-mod legacy thing and has to be removed
} deriving (Eq, Ord, Read, Show)
--- TODO: we know the source-dir now so we can resolve ChSetupEntrypoint
--- internally
-data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but
- -- @main-is@ could either be @"Setup.hs"@
- -- or @"Setup.lhs"@. Since we don't know
- -- where the source directory is you have
- -- to find these files.
- | ChLibEntrypoint { chExposedModules :: [ChModuleName]
- , chOtherModules :: [ChModuleName]
- , chSignatures :: [ChModuleName] -- backpack only
- }
- | ChExeEntrypoint { chMainIs :: FilePath
- , chOtherModules :: [ChModuleName]
- } deriving (Eq, Ord, Read, Show, Generic)
+data ChEntrypoint
+ = ChSetupEntrypoint
+ | ChLibEntrypoint
+ { chExposedModules :: [ChModuleName]
+ , chOtherModules :: [ChModuleName]
+ , chSignatures :: [ChModuleName] -- backpack only
+ }
+ | ChExeEntrypoint
+ { chMainIs :: FilePath
+ , chOtherModules :: [ChModuleName]
+ } deriving (Eq, Ord, Read, Show, Generic)
data ChPkgDb = ChPkgGlobal
| ChPkgUser
| ChPkgSpecific FilePath
deriving (Eq, Ord, Read, Show, Generic)
-
-data NeedsBuildOutput = ProduceBuildOutput | NoBuildOutput
- deriving (Eq, Ord, Read, Show, Generic)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-25 06:23:16 +0000