diff options
author | Daniel Gröber <dxld@darkboxed.org> | 2018-10-14 03:33:38 +0200 |
---|---|---|
committer | Daniel Gröber <dxld@darkboxed.org> | 2018-10-27 19:53:16 +0200 |
commit | 807354f7dc6644fec15dfa1e534c69c14d219628 (patch) | |
tree | 49ca70cb413edece5c6448a74a552a5ca1a1bfbd /src | |
parent | 69e4efe5286e8955743c64034a2c7eb69e7e4a6a (diff) |
Start refactoring to support cabal v2-build
Diffstat (limited to 'src')
-rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 70 | ||||
-rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 29 | ||||
-rw-r--r-- | src/CabalHelper/Runtime/Compat.hs | 4 | ||||
-rw-r--r-- | src/CabalHelper/Runtime/Main.hs | 252 | ||||
-rw-r--r-- | src/CabalHelper/Shared/InterfaceTypes.hs | 54 |
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 |