From 807354f7dc6644fec15dfa1e534c69c14d219628 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 14 Oct 2018 03:33:38 +0200 Subject: Start refactoring to support cabal v2-build --- src/CabalHelper/Runtime/Main.hs | 252 ++++++++++++++++++++++------------------ 1 file changed, 136 insertions(+), 116 deletions(-) (limited to 'src/CabalHelper/Runtime/Main.hs') 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 . -{-# 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 -- cgit v1.2.3