never executed always true always false

    1 {-# LANGUAGE Strict #-}
    2 
    3 -- | Utilities for exception safe message boxes.
    4 --
    5 -- This provides a wrapper around "UnliftIO.MessageBox.Class" instances
    6 -- to catch 'SomeException' in all methods like 'deliver' and 'receive'.
    7 module UnliftIO.MessageBox.CatchAll
    8   ( CatchAllArg (..),
    9     CatchAllBox (..),
   10     CatchAllInput (..),
   11   )
   12 where
   13 
   14 import UnliftIO.MessageBox.Util.Future (Future (Future))
   15 import UnliftIO.MessageBox.Class
   16   ( IsInput (..),
   17     IsMessageBox (..),
   18     IsMessageBoxArg (..),
   19   )
   20 import UnliftIO (SomeException, liftIO, try)
   21 import UnliftIO.Concurrent (threadDelay)
   22 
   23 -- | A wrapper around values that are instances
   24 -- of 'IsMessageBoxArg'. The factory wraps
   25 -- the result of the delegated 'newMessageBox'
   26 -- invocation into a 'CatchAllBox'.
   27 newtype CatchAllArg cfg = CatchAllArg cfg
   28   deriving stock (Eq, Ord, Show)
   29 
   30 -- | A wrapper around values that are instances
   31 -- of 'IsMessageBox'.
   32 --
   33 -- The 'Input' type will be wrapped using
   34 -- 'CatchAllInput'.
   35 newtype CatchAllBox box a = CatchAllBox (box a)
   36 
   37 -- | A wrapper around values that are instances
   38 -- of 'IsInput'.
   39 newtype CatchAllInput i a = CatchAllInput (i a)
   40 
   41 instance IsMessageBoxArg cfg => IsMessageBoxArg (CatchAllArg cfg) where
   42   type MessageBox (CatchAllArg cfg) = CatchAllBox (MessageBox cfg)
   43   {-# INLINE newMessageBox #-}
   44   newMessageBox (CatchAllArg !cfg) = CatchAllBox <$> newMessageBox cfg
   45   getConfiguredMessageLimit (CatchAllArg !cfg) =
   46     getConfiguredMessageLimit cfg
   47 
   48 instance IsMessageBox box => IsMessageBox (CatchAllBox box) where
   49   type Input (CatchAllBox box) = CatchAllInput (Input box)
   50   {-# INLINE newInput #-}
   51   newInput (CatchAllBox !b) =
   52     CatchAllInput <$> newInput b
   53   {-# INLINE receive #-}
   54   receive (CatchAllBox !box) =
   55     try @_ @SomeException
   56       (receive box)
   57       >>= \case
   58         Left _e -> liftIO (print _e) >> return Nothing
   59         Right r -> return r
   60   {-# INLINE receiveAfter #-}
   61   -- | Call the wrapped 'receiveAfter' and catch all sync exceptions.
   62   -- 
   63   -- When an exception is caught return 'Nothing'.
   64   receiveAfter (CatchAllBox !box) !t =
   65     try @_ @SomeException
   66       (receiveAfter box t)
   67       >>= \case
   68         Left _e -> liftIO (print _e) >> pure Nothing
   69         Right r -> return r
   70   {-# INLINE tryReceive #-}
   71   tryReceive (CatchAllBox !box) =
   72     try @_ @SomeException
   73       (tryReceive box)
   74       >>= \case
   75         Left _e ->
   76           liftIO (print _e)
   77             >> return
   78               ( Future
   79                   ( do
   80                       -- suspense...
   81                       threadDelay 1000
   82                       -- ... anyway, the truth is: there is no spoon.
   83                       return Nothing
   84                   )
   85               )
   86         Right r -> return r
   87 
   88 instance (IsInput i) => IsInput (CatchAllInput i) where
   89   {-# INLINE deliver #-}
   90   deliver (CatchAllInput !i) !msg =
   91     try @_ @SomeException
   92       (deliver i msg)
   93       >>= \case
   94         Left _e -> liftIO (print _e) >> return False
   95         Right r -> return r