Re haskell#7714: export ignoreSigPipe from D.Simple.Utils for `cabal …

…man`
andreasabel · Jan 20, 2022 · 94b2342 · 94b2342
1 parent e5b148b
commit 94b2342
Show file tree

Hide file tree

Showing 3 changed files with 12 additions and 7 deletions.
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -362,6 +362,7 @@ library
     GeneralizedNewtypeDeriving
     ImplicitParams
     KindSignatures
+    LambdaCase
     NondecreasingIndentation
     OverloadedStrings
     RankNTypes

diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -42,6 +43,7 @@ module Distribution.Simple.Utils (
 
         -- * exceptions
         handleDoesNotExist,
+        ignoreSigPipe,
 
         -- * running programs
         rawSystemExit,
@@ -944,11 +946,13 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $
         Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))
         Nothing  -> throwIO exc
 
-    ignoreSigPipe :: IO () -> IO ()
-    ignoreSigPipe = Exception.handle $ \e -> case e of
-        GHC.IOError { GHC.ioe_type  = GHC.ResourceVanished, GHC.ioe_errno = Just ioe }
-            | Errno ioe == ePIPE -> return ()
-        _ -> throwIO e
+-- | Ignore SIGPIPE in a subcomputation.
+--
+ignoreSigPipe :: IO () -> IO ()
+ignoreSigPipe = Exception.handle $ \case
+    GHC.IOError { GHC.ioe_type  = GHC.ResourceVanished, GHC.ioe_errno = Just ioe }
+        | Errno ioe == ePIPE -> return ()
+    e -> throwIO e
 
 -- | Look for a program and try to find it's version number. It can accept
 -- either an absolute path or the name of a program binary, in which case we

diff --git a/cabal-install/src/Distribution/Client/Manpage.hs b/cabal-install/src/Distribution/Client/Manpage.hs
@@ -31,7 +31,7 @@ import Distribution.Client.Setup        (globalCommand)
 import Distribution.Simple.Command
 import Distribution.Simple.Flag         (fromFlagOrDefault)
 import Distribution.Simple.Utils
-  ( IOData(..), IODataMode(..), createProcessWithEnv, rawSystemStdInOut )
+  ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut )
 import qualified Distribution.Verbosity as Verbosity
 import System.IO                        (hClose, hPutStr)
 
@@ -54,7 +54,7 @@ manpageCmd pname commands flags
     | fromFlagOrDefault False (manpageRaw flags)
     = putStrLn contents
     | otherwise
-    = do
+    = ignoreSigPipe $ do
         -- 2021-10-08, issue #7714
         -- @cabal man --raw | man -l -@ does not work on macOS/BSD,
         -- because BSD-man does not support option @-l@, rather would