{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# language TemplateHaskell #-}

-- | call an external solver as  separate process,
-- communicate via pipes.

module Satchmo.SAT.External

( SAT
, fresh
, emit
, solve
-- , solve_with_timeout
)

where

import Satchmo.Data
import Satchmo.Boolean hiding ( not )
import Satchmo.Code
-- import Satchmo.MonadSAT

import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
-- import Control.Monad.IO.Class
import System.IO
import Lens.Micro
import Lens.Micro.TH
import Lens.Micro.Mtl
import Control.Applicative

import Control.Concurrent
import Control.DeepSeq (rnf)

import Foreign.C
-- import System.Exit (ExitCode(..))
import System.Process
-- import System.IO.Error
-- import System.Posix.Types
import Control.Exception
import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
-- import System.Posix.Signals

import qualified Control.Exception as C
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map.Strict as M
import Data.List (isPrefixOf)

tracing :: Bool
tracing = Bool
False
report :: String -> IO ()
report String
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tracing (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s

data S = S
       { S -> Int
_next_variable :: !Int 
       , S -> Handle
_solver_input :: !Handle 
       }

$(makeLenses ''S)

newtype SAT a = SAT (StateT S IO a)
  deriving ((forall a b. (a -> b) -> SAT a -> SAT b)
-> (forall a b. a -> SAT b -> SAT a) -> Functor SAT
forall a b. a -> SAT b -> SAT a
forall a b. (a -> b) -> SAT a -> SAT b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SAT a -> SAT b
fmap :: forall a b. (a -> b) -> SAT a -> SAT b
$c<$ :: forall a b. a -> SAT b -> SAT a
<$ :: forall a b. a -> SAT b -> SAT a
Functor, Functor SAT
Functor SAT =>
(forall a. a -> SAT a)
-> (forall a b. SAT (a -> b) -> SAT a -> SAT b)
-> (forall a b c. (a -> b -> c) -> SAT a -> SAT b -> SAT c)
-> (forall a b. SAT a -> SAT b -> SAT b)
-> (forall a b. SAT a -> SAT b -> SAT a)
-> Applicative SAT
forall a. a -> SAT a
forall a b. SAT a -> SAT b -> SAT a
forall a b. SAT a -> SAT b -> SAT b
forall a b. SAT (a -> b) -> SAT a -> SAT b
forall a b c. (a -> b -> c) -> SAT a -> SAT b -> SAT c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> SAT a
pure :: forall a. a -> SAT a
$c<*> :: forall a b. SAT (a -> b) -> SAT a -> SAT b
<*> :: forall a b. SAT (a -> b) -> SAT a -> SAT b
$cliftA2 :: forall a b c. (a -> b -> c) -> SAT a -> SAT b -> SAT c
liftA2 :: forall a b c. (a -> b -> c) -> SAT a -> SAT b -> SAT c
$c*> :: forall a b. SAT a -> SAT b -> SAT b
*> :: forall a b. SAT a -> SAT b -> SAT b
$c<* :: forall a b. SAT a -> SAT b -> SAT a
<* :: forall a b. SAT a -> SAT b -> SAT a
Applicative, Applicative SAT
Applicative SAT =>
(forall a b. SAT a -> (a -> SAT b) -> SAT b)
-> (forall a b. SAT a -> SAT b -> SAT b)
-> (forall a. a -> SAT a)
-> Monad SAT
forall a. a -> SAT a
forall a b. SAT a -> SAT b -> SAT b
forall a b. SAT a -> (a -> SAT b) -> SAT b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. SAT a -> (a -> SAT b) -> SAT b
>>= :: forall a b. SAT a -> (a -> SAT b) -> SAT b
$c>> :: forall a b. SAT a -> SAT b -> SAT b
>> :: forall a b. SAT a -> SAT b -> SAT b
$creturn :: forall a. a -> SAT a
return :: forall a. a -> SAT a
Monad, Monad SAT
Monad SAT => (forall a. IO a -> SAT a) -> MonadIO SAT
forall a. IO a -> SAT a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> SAT a
liftIO :: forall a. IO a -> SAT a
MonadIO)

type Assignment = M.Map Int Bool

newtype Dec a = Dec (Reader Assignment a)
  deriving ((forall a b. (a -> b) -> Dec a -> Dec b)
-> (forall a b. a -> Dec b -> Dec a) -> Functor Dec
forall a b. a -> Dec b -> Dec a
forall a b. (a -> b) -> Dec a -> Dec b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Dec a -> Dec b
fmap :: forall a b. (a -> b) -> Dec a -> Dec b
$c<$ :: forall a b. a -> Dec b -> Dec a
<$ :: forall a b. a -> Dec b -> Dec a
Functor, Functor Dec
Functor Dec =>
(forall a. a -> Dec a)
-> (forall a b. Dec (a -> b) -> Dec a -> Dec b)
-> (forall a b c. (a -> b -> c) -> Dec a -> Dec b -> Dec c)
-> (forall a b. Dec a -> Dec b -> Dec b)
-> (forall a b. Dec a -> Dec b -> Dec a)
-> Applicative Dec
forall a. a -> Dec a
forall a b. Dec a -> Dec b -> Dec a
forall a b. Dec a -> Dec b -> Dec b
forall a b. Dec (a -> b) -> Dec a -> Dec b
forall a b c. (a -> b -> c) -> Dec a -> Dec b -> Dec c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Dec a
pure :: forall a. a -> Dec a
$c<*> :: forall a b. Dec (a -> b) -> Dec a -> Dec b
<*> :: forall a b. Dec (a -> b) -> Dec a -> Dec b
$cliftA2 :: forall a b c. (a -> b -> c) -> Dec a -> Dec b -> Dec c
liftA2 :: forall a b c. (a -> b -> c) -> Dec a -> Dec b -> Dec c
$c*> :: forall a b. Dec a -> Dec b -> Dec b
*> :: forall a b. Dec a -> Dec b -> Dec b
$c<* :: forall a b. Dec a -> Dec b -> Dec a
<* :: forall a b. Dec a -> Dec b -> Dec a
Applicative, Applicative Dec
Applicative Dec =>
(forall a b. Dec a -> (a -> Dec b) -> Dec b)
-> (forall a b. Dec a -> Dec b -> Dec b)
-> (forall a. a -> Dec a)
-> Monad Dec
forall a. a -> Dec a
forall a b. Dec a -> Dec b -> Dec b
forall a b. Dec a -> (a -> Dec b) -> Dec b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Dec a -> (a -> Dec b) -> Dec b
>>= :: forall a b. Dec a -> (a -> Dec b) -> Dec b
$c>> :: forall a b. Dec a -> Dec b -> Dec b
>> :: forall a b. Dec a -> Dec b -> Dec b
$creturn :: forall a. a -> Dec a
return :: forall a. a -> Dec a
Monad)

instance MonadSAT SAT where
  fresh :: SAT Literal
fresh = StateT S IO Literal -> SAT Literal
forall a. StateT S IO a -> SAT a
SAT (StateT S IO Literal -> SAT Literal)
-> StateT S IO Literal -> SAT Literal
forall a b. (a -> b) -> a -> b
$ do 
      Int
n <- Getting Int S Int -> StateT S IO Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int S Int
Lens' S Int
next_variable
      (Int -> Identity Int) -> S -> Identity S
Lens' S Int
next_variable ((Int -> Identity Int) -> S -> Identity S) -> Int -> StateT S IO ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int -> Int
forall a. Enum a => a -> a
succ Int
n
      Literal -> StateT S IO Literal
forall a. a -> StateT S IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT S IO Literal) -> Literal -> StateT S IO Literal
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> Literal
literal Bool
True (Int -> Literal) -> Int -> Literal
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> Int
fromEnum Int
n
  emit :: Clause -> SAT ()
emit Clause
cl = StateT S IO () -> SAT ()
forall a. StateT S IO a -> SAT a
SAT (StateT S IO () -> SAT ()) -> StateT S IO () -> SAT ()
forall a b. (a -> b) -> a -> b
$ do
      Handle
h <- Getting Handle S Handle -> StateT S IO Handle
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Handle S Handle
Lens' S Handle
solver_input
      let s :: ByteString
s = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Clause -> String
forall a. Show a => a -> String
show Clause
cl
      -- liftIO $ BS.putStrLn s
      IO () -> StateT S IO ()
forall a. IO a -> StateT S IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT S IO ()) -> IO () -> StateT S IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
h ByteString
s 

  note :: String -> SAT ()
note String
msg = StateT S IO () -> SAT ()
forall a. StateT S IO a -> SAT a
SAT (StateT S IO () -> SAT ()) -> StateT S IO () -> SAT ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT S IO ()
forall a. IO a -> StateT S IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT S IO ()) -> IO () -> StateT S IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
msg

  type Decoder SAT = Dec

instance Decode Dec Boolean Bool where
    decode :: Boolean -> Dec Bool
decode Boolean
b = case Boolean
b of
        Constant Bool
c -> Bool -> Dec Bool
forall a. a -> Dec a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
c
        Boolean  Literal
l -> do
            Bool
v <- Int -> Dec Bool
dv (Int -> Dec Bool) -> Int -> Dec Bool
forall a b. (a -> b) -> a -> b
$ Literal -> Int
variable Literal
l 
            Bool -> Dec Bool
forall a. a -> Dec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Dec Bool) -> Bool -> Dec Bool
forall a b. (a -> b) -> a -> b
$ if Literal -> Bool
positive Literal
l then Bool
v else Bool -> Bool
not Bool
v

dv :: Int -> Dec Bool
dv Int
v = Reader Assignment Bool -> Dec Bool
forall a. Reader Assignment a -> Dec a
Dec (Reader Assignment Bool -> Dec Bool)
-> Reader Assignment Bool -> Dec Bool
forall a b. (a -> b) -> a -> b
$ do 
  Assignment
assignment <- ReaderT Assignment Identity Assignment
forall r (m :: * -> *). MonadReader r m => m r
ask
  Bool -> Reader Assignment Bool
forall a. a -> ReaderT Assignment Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Reader Assignment Bool) -> Bool -> Reader Assignment Bool
forall a b. (a -> b) -> a -> b
$ case Int -> Assignment -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
v Assignment
assignment of
    Just Bool
v -> Bool
v
    Maybe Bool
Nothing -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ String
"unassigned", String
"variable", Int -> String
forall a. Show a => a -> String
show Int
v ]
      

solve :: String  -- ^ command, e.g., glucose
      -> [String] -- ^ options, e.g., -model
      -> SAT (Dec a) -- ^ action that builds the formula and returns the decoder
      -> IO (Maybe a)
solve :: forall a. String -> [String] -> SAT (Dec a) -> IO (Maybe a)
solve String
command [String]
opts (SAT StateT S IO (Dec a)
action) = IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO (Maybe a))
-> IO (Maybe a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
   ( do
     String -> IO ()
report String
"Satchmo.SAT.External: creating process"
     CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
proc String
command [String]
opts) 
       { std_in = CreatePipe 
       , std_out = CreatePipe
       , create_group = True 
       } )
   ( \ (Just Handle
sin, Just Handle
sout, Maybe Handle
_, ProcessHandle
ph) -> do
       String -> IO ()
report String
"Satchmo.SAT.External: bracket closing"
       ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
ph
   )
   (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
  -> IO (Maybe a))
 -> IO (Maybe a))
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO (Maybe a))
-> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \ (Just Handle
sin, Just Handle
sout, Maybe Handle
_, ProcessHandle
ph) -> do

       MVar (Reader Assignment a)
dec <- IO (MVar (Reader Assignment a))
forall a. IO (MVar a)
newEmptyMVar

       -- fork off a thread to start consuming the output
       String
output  <- Handle -> IO String
hGetContents Handle
sout -- lazy IO
       IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
C.evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ()
forall a. NFData a => a -> ()
rnf String
output) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ IO ()
waitOut -> 
          IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
report (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"S.S.External: waiter forked"

            let s0 :: S
s0 = S { _next_variable :: Int
_next_variable=Int
1, _solver_input :: Handle
_solver_input=Handle
sin}
            String -> IO ()
report (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"S.S.External: writing output"
            Dec Reader Assignment a
decoder <- StateT S IO (Dec a) -> S -> IO (Dec a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT S IO (Dec a)
action S
s0
            MVar (Reader Assignment a) -> Reader Assignment a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Reader Assignment a)
dec Reader Assignment a
decoder
            Handle -> IO ()
hClose Handle
sin

            IO ()
waitOut
            Handle -> IO ()
hClose Handle
sout
            String -> IO ()
report (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"S.S.External: waiter done"

       String -> IO ()
report String
"Satchmo.SAT.External: start waiting"
       ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
       Reader Assignment a
decoder <- MVar (Reader Assignment a) -> IO (Reader Assignment a)
forall a. MVar a -> IO a
takeMVar MVar (Reader Assignment a)
dec
       String -> IO ()
report String
"Satchmo.SAT.External: waiting done"

       let vlines :: [String]
vlines = do
             String
line <- String -> [String]
lines String
output
             Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"v" String
line
             String -> [String]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return String
line
       String -> IO ()
report (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show [String]
vlines
       let vs :: [Int]
vs = do
             String
line <- [String]
vlines
             String
w <- [String] -> [String]
forall a. HasCallStack => [a] -> [a]
tail ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
line
             Int -> [Int]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int
forall a. Read a => String -> a
read String
w :: Int)
       Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
         Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
vlines
         let m :: Assignment
m = [(Int, Bool)] -> Assignment
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Bool)] -> Assignment) -> [(Int, Bool)] -> Assignment
forall a b. (a -> b) -> a -> b
$ do 
               Int
v <- [Int]
vs ; Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 ; (Int, Bool) -> [(Int, Bool)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int
forall a. Num a => a -> a
abs Int
v, Int
vInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0)
         a -> Maybe a
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Reader Assignment a -> Assignment -> a
forall r a. Reader r a -> r -> a
runReader Reader Assignment a
decoder Assignment
m

-- * code from System.Process 
-- http://hackage.haskell.org/package/process-1.2.3.0/docs/src/System-Process.html#readProcess
-- but they are not exporting withForkWait, so I have to copy it

-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () ->  IO a) -> IO a
withForkWait :: forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait IO ()
async IO () -> IO a
body = do
  MVar (Either SomeException ())
waitVar <- IO (MVar (Either SomeException ()))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (Either SomeException ()))
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
async) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException ()) -> Either SomeException () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException ())
waitVar
    let wait :: IO ()
wait = MVar (Either SomeException ()) -> IO (Either SomeException ())
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException ())
waitVar IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    IO a -> IO a
forall a. IO a -> IO a
restore (IO () -> IO a
body IO ()
wait) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`C.onException` ThreadId -> IO ()
killThread ThreadId
tid

ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
  IOError { ioe_type :: IOException -> IOErrorType
ioe_type  = IOErrorType
ResourceVanished
          , ioe_errno :: IOException -> Maybe CInt
ioe_errno = Just CInt
ioe }
    | CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  IOException
_ -> IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e