[commit: ghc] ghc-7.10: ghc-pkg support query by package-key, fixes #9507 (36c3a51)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/36c3a51413baa531f40ccb7e039cb2077d56f121/ghc

>---------------------------------------------------------------

commit 36c3a51413baa531f40ccb7e039cb2077d56f121
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date:   Wed Jun 3 10:55:58 2015 -0700

    ghc-pkg support query by package-key, fixes #9507
    
    Signed-off-by: Edward Z. Yang <ezyang at cs.stanford.edu>
    
    Test Plan: validate
    
    Reviewers: austin
    
    Subscribers: bgamari, thomie
    
    Differential Revision: https://phabricator.haskell.org/D946
    
    GHC Trac Issues: #9507
    
    (cherry picked from commit c69b69d2cda890e6f3f6aa1fd4092421e6053b89)


>---------------------------------------------------------------

36c3a51413baa531f40ccb7e039cb2077d56f121
 utils/ghc-pkg/Main.hs | 42 ++++++++++++++++++++++++++++++------------
 1 file changed, 30 insertions(+), 12 deletions(-)

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 0493866..8a6d712 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -131,6 +131,7 @@ data Flag
   | FlagNoUserDb
   | FlagVerbosity (Maybe String)
   | FlagIPId
+  | FlagPackageKey
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -177,6 +178,8 @@ flags = [
         "ignore case for substring matching",
   Option [] ["ipid"] (NoArg FlagIPId)
         "interpret package arguments as installed package IDs",
+  Option [] ["package-key"] (NoArg FlagPackageKey)
+        "interpret package arguments as installed package keys",
   Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
         "verbosity level (0-2, default 1)"
   ]
@@ -313,6 +316,12 @@ substProg prog (c:xs) = c : substProg prog xs
 data Force = NoForce | ForceFiles | ForceAll | CannotForce
   deriving (Eq,Ord)
 
+-- | Enum flag representing argument type
+data AsPackageArg
+    = AsIpid
+    | AsPackageKey
+    | AsDefault
+
 -- | Represents how a package may be specified by a user on the command line.
 data PackageArg
     -- | A package identifier foo-0.1; the version might be a glob.
@@ -320,6 +329,9 @@ data PackageArg
     -- | An installed package ID foo-0.1-HASH.  This is guaranteed to uniquely
     -- match a single entry in the package database.
     | IPId InstalledPackageId
+    -- | A package key foo_HASH.  This is also guaranteed to uniquely match
+    -- a single entry in the package database
+    | PkgKey PackageKey
     -- | A glob against the package name.  The first string is the literal
     -- glob, the second is a function which returns @True@ if the the argument
     -- matches.
@@ -334,7 +346,9 @@ runit verbosity cli nonopts = do
           | FlagForce `elem` cli        = ForceAll
           | FlagForceFiles `elem` cli   = ForceFiles
           | otherwise                   = NoForce
-        as_ipid = FlagIPId `elem` cli
+        as_arg | FlagIPId        `elem` cli = AsIpid
+               | FlagPackageKey  `elem` cli = AsPackageKey
+               | otherwise                  = AsDefault
         auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
         multi_instance = FlagMultiInstance `elem` cli
         expand_env_vars= FlagExpandEnvVars `elem` cli
@@ -412,25 +426,25 @@ runit verbosity cli nonopts = do
                         auto_ghci_libs multi_instance
                         expand_env_vars True force
     ["unregister", pkgarg_str] -> do
-        pkgarg <- readPackageArg as_ipid pkgarg_str
+        pkgarg <- readPackageArg as_arg pkgarg_str
         unregisterPackage pkgarg verbosity cli force
     ["expose", pkgarg_str] -> do
-        pkgarg <- readPackageArg as_ipid pkgarg_str
+        pkgarg <- readPackageArg as_arg pkgarg_str
         exposePackage pkgarg verbosity cli force
     ["hide",   pkgarg_str] -> do
-        pkgarg <- readPackageArg as_ipid pkgarg_str
+        pkgarg <- readPackageArg as_arg pkgarg_str
         hidePackage pkgarg verbosity cli force
     ["trust",    pkgarg_str] -> do
-        pkgarg <- readPackageArg as_ipid pkgarg_str
+        pkgarg <- readPackageArg as_arg pkgarg_str
         trustPackage pkgarg verbosity cli force
     ["distrust", pkgarg_str] -> do
-        pkgarg <- readPackageArg as_ipid pkgarg_str
+        pkgarg <- readPackageArg as_arg pkgarg_str
         distrustPackage pkgarg verbosity cli force
     ["list"] -> do
         listPackages verbosity cli Nothing Nothing
     ["list", pkgarg_str] ->
         case substringCheck pkgarg_str of
-          Nothing -> do pkgarg <- readPackageArg as_ipid pkgarg_str
+          Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str
                         listPackages verbosity cli (Just pkgarg) Nothing
           Just m -> listPackages verbosity cli
                                  (Just (Substring pkgarg_str m)) Nothing
@@ -444,13 +458,13 @@ runit verbosity cli nonopts = do
         latestPackage verbosity cli pkgid
     ["describe", pkgid_str] -> do
         pkgarg <- case substringCheck pkgid_str of
-          Nothing -> readPackageArg as_ipid pkgid_str
+          Nothing -> readPackageArg as_arg pkgid_str
           Just m  -> return (Substring pkgid_str m)
         describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
         
     ["field", pkgid_str, fields] -> do
         pkgarg <- case substringCheck pkgid_str of
-          Nothing -> readPackageArg as_ipid pkgid_str
+          Nothing -> readPackageArg as_arg pkgid_str
           Just m  -> return (Substring pkgid_str m)
         describeField verbosity cli pkgarg
                       (splitFields fields) (fromMaybe True mexpand_pkgroot)
@@ -486,10 +500,12 @@ parseGlobPackageId =
       _ <- string "-*"
       return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
 
-readPackageArg :: Bool -> String -> IO PackageArg
-readPackageArg True str =
+readPackageArg :: AsPackageArg -> String -> IO PackageArg
+readPackageArg AsIpid str =
     parseCheck (IPId `fmap` parse) str "installed package id"
-readPackageArg False str = Id `fmap` readGlobPkgId str
+readPackageArg AsPackageKey str =
+    parseCheck (PkgKey `fmap` parse) str "package key"
+readPackageArg AsDefault str = Id `fmap` readGlobPkgId str
 
 -- globVersion means "all versions"
 globVersion :: Version
@@ -1310,6 +1326,7 @@ findPackagesByDB db_stack pkgarg
         ps -> return ps
   where
         pkg_msg (Id pkgid)           = display pkgid
+        pkg_msg (PkgKey pk)          = display pk
         pkg_msg (IPId ipid)          = display ipid
         pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 
@@ -1324,6 +1341,7 @@ realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
 
 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 (Id pid)        `matchesPkg` pkg = pid `matches` sourcePackageId pkg
+(PkgKey pk)     `matchesPkg` pkg = pk == packageKey pkg
 (IPId ipid)     `matchesPkg` pkg = ipid == installedPackageId pkg
 (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))