diff options
author | Thomas Miedema <thomasmiedema@gmail.com> | 2015-02-18 09:46:49 -0600 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2015-02-18 09:46:50 -0600 |
commit | 32d1a8a5817de8a444d7f50c0a2aebb6a9174326 (patch) | |
tree | 2b44b01ab21a99934fd189a5b962c8a41a250e04 /utils | |
parent | 6d17125dccda76b7aafe33181df822045ff5b9bf (diff) | |
download | haskell-32d1a8a5817de8a444d7f50c0a2aebb6a9174326.tar.gz |
Cleanup ghc-pkg
Summary:
* Delete dead code in ghc-pkg (not_yet ready since 2004)
* remove --auto-ghc-libs
Commit 78185538b (2011) mentions:
"Deprecate the ghc-pkg --auto-ghci-libs flag
It was never a universal solution. It only worked with the GNU linker.
It has not been used by Cabal for ages. GHCi can now load .a files so it will
not be needed in future."
"Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
Reviewers: austin
Reviewed By: austin
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D666
Diffstat (limited to 'utils')
-rw-r--r-- | utils/ghc-pkg/Main.hs | 149 |
1 files changed, 37 insertions, 112 deletions
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 53bc43b071..bf9de0fee9 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, RecordWildCards, - GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- @@ -26,7 +25,6 @@ import Distribution.Version import Distribution.Simple.Utils (fromUTF8, toUTF8) import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix -import System.Process import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, getModificationTime ) import Text.Printf @@ -86,6 +84,15 @@ import System.Console.Terminfo as Terminfo # endif #endif +-- | Short-circuit 'any' with a \"monadic predicate\". +anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM p (x:xs) = do + b <- p x + if b + then return True + else anyM p xs + -- ----------------------------------------------------------------------------- -- Entry point @@ -120,7 +127,6 @@ data Flag | FlagUserConfig FilePath | FlagForce | FlagForceFiles - | FlagAutoGHCiLibs | FlagMultiInstance | FlagExpandEnvVars | FlagExpandPkgroot @@ -155,8 +161,6 @@ flags = [ "ignore missing dependencies, directories, and libraries", Option [] ["force-files"] (NoArg FlagForceFiles) "ignore missing directories and libraries only", - Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) - "automatically build libs for GHCi (with register)", Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance) "allow registering multiple instances of the same package version", Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) @@ -335,7 +339,6 @@ runit verbosity cli nonopts = do | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce as_ipid = FlagIPId `elem` cli - auto_ghci_libs = FlagAutoGHCiLibs `elem` cli multi_instance = FlagMultiInstance `elem` cli expand_env_vars= FlagExpandEnvVars `elem` cli mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli @@ -405,11 +408,11 @@ runit verbosity cli nonopts = do initPackageDB filename verbosity cli ["register", filename] -> registerPackage filename verbosity cli - auto_ghci_libs multi_instance + multi_instance expand_env_vars False force ["update", filename] -> registerPackage filename verbosity cli - auto_ghci_libs multi_instance + multi_instance expand_env_vars True force ["unregister", pkgarg_str] -> do pkgarg <- readPackageArg as_ipid pkgarg_str @@ -919,13 +922,12 @@ initPackageDB filename verbosity _flags = do registerPackage :: FilePath -> Verbosity -> [Flag] - -> Bool -- auto_ghci_libs -> Bool -- multi_instance -> Bool -- expand_env_vars -> Bool -- update -> Force -> IO () -registerPackage input verbosity my_flags auto_ghci_libs multi_instance +registerPackage input verbosity my_flags multi_instance expand_env_vars update force = do (db_stack, Just to_modify, _flag_dbs) <- getPkgDatabases verbosity True{-modify-} True{-use user-} @@ -934,10 +936,6 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance let db_to_operate_on = my_head "register" $ filter ((== to_modify).location) db_stack - -- - when (auto_ghci_libs && verbosity >= Silent) $ - warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4" - -- s <- case input of "-" -> do @@ -971,7 +969,7 @@ registerPackage input verbosity my_flags auto_ghci_libs multi_instance -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. validatePackageConfig pkg_expanded verbosity truncated_stack - auto_ghci_libs multi_instance update force + multi_instance update force let -- In the normal mode, we only allow one version of each package, so we @@ -1441,7 +1439,7 @@ checkConsistency verbosity my_flags = do checkPackage p = do (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack - False True True + True True if null es then do when (not simple_output) $ do _ <- reportValidateErrors [] ws "" Nothing @@ -1554,27 +1552,25 @@ reportValidateErrors es ws prefix mb_force = do validatePackageConfig :: InstalledPackageInfo -> Verbosity -> PackageDBStack - -> Bool -- auto-ghc-libs -> Bool -- multi_instance -> Bool -- update, or check -> Force -> IO () -validatePackageConfig pkg verbosity db_stack auto_ghci_libs +validatePackageConfig pkg verbosity db_stack multi_instance update force = do (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack - auto_ghci_libs multi_instance update + multi_instance update ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) when (not ok) $ exitWith (ExitFailure 1) checkPackageConfig :: InstalledPackageInfo -> Verbosity -> PackageDBStack - -> Bool -- auto-ghc-libs -> Bool -- multi_instance -> Bool -- update, or check -> Validate () -checkPackageConfig pkg verbosity db_stack auto_ghci_libs +checkPackageConfig pkg verbosity db_stack multi_instance update = do checkInstalledPackageId pkg db_stack update checkPackageId pkg @@ -1591,7 +1587,7 @@ checkPackageConfig pkg verbosity db_stack auto_ghci_libs checkDuplicateModules pkg checkExposedModules db_stack pkg checkOtherModules pkg - mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) + mapM_ (checkHSLib verbosity (libraryDirs pkg)) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -1701,28 +1697,23 @@ checkDuplicateDepends deps where dups = [ p | (p:_:_) <- group (sort deps) ] -checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate () -checkHSLib verbosity dirs auto_ghci_libs lib = do - let batch_lib_file = "lib" ++ lib ++ ".a" - filenames = ["lib" ++ lib ++ ".a", +checkHSLib :: Verbosity -> [String] -> String -> Validate () +checkHSLib _verbosity dirs lib = do + let filenames = ["lib" ++ lib ++ ".a", "lib" ++ lib ++ ".p_a", "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".so", "lib" ++ lib ++ "-ghc" ++ Version.version ++ ".dylib", lib ++ "-ghc" ++ Version.version ++ ".dll"] - m <- liftIO $ doesFileExistOnPath filenames dirs - case m of - Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++ - " on library path") - Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs - -doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) -doesFileExistOnPath filenames paths = go fullFilenames - where fullFilenames = [ (path, path </> filename) + b <- liftIO $ doesFileExistOnPath filenames dirs + when (not b) $ + verror ForceFiles ("cannot find any of " ++ show filenames ++ + " on library path") + +doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO Bool +doesFileExistOnPath filenames paths = anyM doesFileExist fullFilenames + where fullFilenames = [ path </> filename | filename <- filenames , path <- paths ] - go [] = return Nothing - go ((p, fp) : xs) = do b <- doesFileExist fp - if b then return (Just p) else go xs -- | Perform validation checks (module file existence checks) on the -- @hidden-modules@ field. @@ -1749,8 +1740,8 @@ checkModuleFile pkg modl = unless (modl == ModuleName.fromString "GHC.Prim") $ do let files = [ ModuleName.toFilePath modl <.> extension | extension <- ["hi", "p_hi", "dyn_hi" ] ] - m <- liftIO $ doesFileExistOnPath files (importDirs pkg) - when (isNothing m) $ + b <- liftIO $ doesFileExistOnPath files (importDirs pkg) + when (not b) $ verror ForceFiles ("cannot find any of " ++ show files) -- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate @@ -1780,20 +1771,20 @@ checkOriginalModule :: String -> InstalledPackageInfo -> OriginalModule -> Validate () -checkOriginalModule fieldName db_stack pkg +checkOriginalModule field_name db_stack pkg (OriginalModule definingPkgId definingModule) = let mpkg = if definingPkgId == installedPackageId pkg then Just pkg else PackageIndex.lookupInstalledPackageId ipix definingPkgId in case mpkg of Nothing - -> verror ForceAll (fieldName ++ " refers to a non-existent " ++ + -> verror ForceAll (field_name ++ " refers to a non-existent " ++ "defining package: " ++ display definingPkgId) Just definingPkg | not (isIndirectDependency definingPkgId) - -> verror ForceAll (fieldName ++ " refers to a defining " ++ + -> verror ForceAll (field_name ++ " refers to a defining " ++ "package that is not a direct (or indirect) " ++ "dependency of this package: " ++ display definingPkgId) @@ -1802,12 +1793,12 @@ checkOriginalModule fieldName db_stack pkg -> case find ((==definingModule).exposedName) (exposedModules definingPkg) of Nothing -> - verror ForceAll (fieldName ++ " refers to a module " ++ + verror ForceAll (field_name ++ " refers to a module " ++ display definingModule ++ " " ++ "that is not exposed in the " ++ "defining package " ++ display definingPkgId) Just (ExposedModule {exposedReexport = Just _} ) -> - verror ForceAll (fieldName ++ " refers to a module " ++ + verror ForceAll (field_name ++ " refers to a module " ++ display definingModule ++ " " ++ "that is reexported but not defined in the " ++ "defining package " ++ display definingPkgId) @@ -1825,72 +1816,6 @@ checkOriginalModule fieldName db_stack pkg PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix) -checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO () -checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build - | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = return () - where - ghci_lib_file = lib <.> "o" - --- automatically build the GHCi version of a batch lib, --- using ld --whole-archive. - -autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO () -autoBuildGHCiLib verbosity dir batch_file ghci_file = do - let ghci_lib_file = dir ++ '/':ghci_file - batch_lib_file = dir ++ '/':batch_file - when (verbosity >= Normal) $ - info ("building GHCi library " ++ ghci_lib_file ++ "...") -#if defined(darwin_HOST_OS) - r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] -#elif defined(mingw32_HOST_OS) - execDir <- getLibDir - r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] -#else - r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] -#endif - when (r /= ExitSuccess) $ exitWith r - when (verbosity >= Normal) $ - infoLn (" done.") - --- ----------------------------------------------------------------------------- --- Searching for modules - -#if not_yet - -findModules :: [FilePath] -> IO [String] -findModules paths = - mms <- mapM searchDir paths - return (concat mms) - -searchDir path prefix = do - fs <- getDirectoryEntries path `catchIO` \_ -> return [] - searchEntries path prefix fs - -searchEntries path prefix [] = return [] -searchEntries path prefix (f:fs) - | looks_like_a_module = do - ms <- searchEntries path prefix fs - return (prefix `joinModule` f : ms) - | looks_like_a_component = do - ms <- searchDir (path </> f) (prefix `joinModule` f) - ms' <- searchEntries path prefix fs - return (ms ++ ms') - | otherwise - searchEntries path prefix fs - - where - (base,suffix) = splitFileExt f - looks_like_a_module = - suffix `elem` haskell_suffixes && - all okInModuleName base - looks_like_a_component = - null suffix && all okInModuleName base - -okInModuleName c - -#endif - -- --------------------------------------------------------------------------- -- expanding environment variables in the package configuration |