[commit: ghc] wip/nfs-locking: Simplify getSingleton, add comments (fbe22e6)

[git at git.haskell.org]

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

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/fbe22e6f83bb5e9f14960b63f1ad40dbbfdd7c86/ghc

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

commit fbe22e6f83bb5e9f14960b63f1ad40dbbfdd7c86
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Wed Oct 19 00:25:01 2016 +0100

    Simplify getSingleton, add comments


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

fbe22e6f83bb5e9f14960b63f1ad40dbbfdd7c86
 src/Expression.hs   | 19 ++++++++++---------
 src/Rules/Gmp.hs    |  6 +++---
 src/Rules/Libffi.hs |  6 +++---
 3 files changed, 16 insertions(+), 15 deletions(-)

diff --git a/src/Expression.hs b/src/Expression.hs
index a572c2c..45967c9 100644
--- a/src/Expression.hs
+++ b/src/Expression.hs
@@ -192,8 +192,8 @@ getInputs = asks inputs
 getInput :: Expr FilePath
 getInput = do
     target <- ask
-    getSingleton getInputs $
-        "getInput: exactly one input file expected in target " ++ show target
+    getSingleton ("Exactly one input file expected in " ++ show target)
+        <$> getInputs
 
 -- | Get the files produced by the current 'Target'.
 getOutputs :: Expr [FilePath]
@@ -203,10 +203,11 @@ getOutputs = asks outputs
 getOutput :: Expr FilePath
 getOutput = do
     target <- ask
-    getSingleton getOutputs $
-        "getOutput: exactly one output file expected in target " ++ show target
-
-getSingleton :: Monad m => m [a] -> String -> m a
-getSingleton expr msg = expr >>= \case
-    [res] -> return res
-    _     -> error msg
+    getSingleton ("Exactly one output file expected in " ++ show target)
+        <$> getOutputs
+
+-- | Extract a value from a singleton list, or raise an error if the list does
+-- not contain exactly one value.
+getSingleton :: String -> [a] -> a
+getSingleton _ [res] = res
+getSingleton msg _   = error msg
diff --git a/src/Rules/Gmp.hs b/src/Rules/Gmp.hs
index 3693ad4..412bea0 100644
--- a/src/Rules/Gmp.hs
+++ b/src/Rules/Gmp.hs
@@ -81,9 +81,9 @@ gmpRules = do
         -- gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents.
         -- That's because the doc/ directory contents are under the GFDL,
         -- which causes problems for Debian.
-        let tarballs = gmpBase -/- "tarball/gmp*.tar.bz2"
-        tarball <- unifyPath <$> getSingleton (getDirectoryFiles "" [tarballs])
-                                 "Exactly one GMP tarball is expected."
+        tarball <- unifyPath . getSingleton "Exactly one GMP tarball is expected"
+               <$> getDirectoryFiles "" [gmpBase -/- "tarball/gmp*.tar.bz2"]
+
         withTempDir $ \dir -> do
             let tmp = unifyPath dir
             need [tarball]
diff --git a/src/Rules/Libffi.hs b/src/Rules/Libffi.hs
index 6dd92bc..9560dbf 100644
--- a/src/Rules/Libffi.hs
+++ b/src/Rules/Libffi.hs
@@ -80,9 +80,9 @@ libffiRules = do
     libffiMakefile <.> "in" %> \mkIn -> do
         removeDirectory libffiBuildPath
         createDirectory $ buildRootPath -/- stageString Stage0
-        let tarballs = "libffi-tarballs/libffi*.tar.gz"
-        tarball <- unifyPath <$> getSingleton (getDirectoryFiles "" [tarballs])
-                                 "Exactly one LibFFI tarball is expected."
+        tarball <- unifyPath . getSingleton "Exactly one LibFFI tarball is expected"
+               <$> getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
+
         need [tarball]
         let libname = dropExtension . dropExtension $ takeFileName tarball