[commit: packages/Cabal] ghc-head: Improve an error message. (551fb7b)

[git at git.haskell.org]

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

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/Cabal.git;a=commit;h=551fb7b96707859e90f6e2da542577670dca81e3

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

commit 551fb7b96707859e90f6e2da542577670dca81e3
Author: Mikhail Glushenkov <mikhail.glushenkov at gmail.com>
Date:   Wed May 29 06:24:32 2013 +0200

    Improve an error message.


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

551fb7b96707859e90f6e2da542577670dca81e3
 cabal-install/Distribution/Client/Sandbox.hs |   25 ++++++++++++++++++++++---
 1 file changed, 22 insertions(+), 3 deletions(-)

diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs
index a8c6e5d..85a8cd4 100644
--- a/cabal-install/Distribution/Client/Sandbox.hs
+++ b/cabal-install/Distribution/Client/Sandbox.hs
@@ -187,12 +187,32 @@ tryGetIndexFilePath' globalFlags = do
     checkConfiguration = "Please check your configuration ('"
                          ++ userPackageEnvironmentFile ++ "')."
 
+-- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error
+-- message than just pattern-matching.
+getSandboxPackageDB :: ConfigFlags -> IO PackageDB
+getSandboxPackageDB configFlags = do
+  case configPackageDBs configFlags of
+    [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB
+    -- TODO: should we allow multiple package DBs (e.g. with 'inherit')?
+
+    []                                     ->
+      die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt
+    [_]                                    ->
+      die $ "Unexpected contents of the 'package-db' field. "
+            ++ sandboxConfigCorrupt
+    _                                      ->
+      die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt
+
+  where
+    sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt."
+
+
 -- | Which packages are installed in the sandbox package DB?
 getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags
                                  -> Compiler -> ProgramConfiguration
                                  -> IO InstalledPackageIndex.PackageIndex
 getInstalledPackagesInSandbox verbosity configFlags comp conf = do
-    let [Just sandboxDB@(SpecificPackageDB _)] = configPackageDBs configFlags
+    sandboxDB <- getSandboxPackageDB configFlags
     getPackageDBContents verbosity comp sandboxDB conf
 
 -- | Temporarily add $SANDBOX_DIR/bin to $PATH.
@@ -224,8 +244,7 @@ initPackageDBIfNeeded :: Verbosity -> ConfigFlags
                          -> Compiler -> ProgramConfiguration
                          -> IO ()
 initPackageDBIfNeeded verbosity configFlags comp conf = do
-  -- TODO: Is pattern-matching here really safe?
-  let [Just (SpecificPackageDB dbPath)] = configPackageDBs configFlags
+  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags
   packageDBExists <- doesDirectoryExist dbPath
   unless packageDBExists $
     Register.initPackageDB verbosity comp conf dbPath