{-# LANGUAGE Strict #-}

-- | Utilities for exception safe message boxes.
--
-- This provides a wrapper around "UnliftIO.MessageBox.Class" instances
-- to catch 'SomeException' in all methods like 'deliver' and 'receive'.
module UnliftIO.MessageBox.CatchAll
  ( CatchAllFactory (..),
    CatchAllBox (..),
    CatchAllInput (..),
  )
where

import UnliftIO.MessageBox.Util.Future (Future (Future))
import UnliftIO.MessageBox.Class
  ( IsInput (..),
    IsMessageBox (..),
    IsMessageBoxFactory (..),
  )
import UnliftIO (SomeException, liftIO, try)
import UnliftIO.Concurrent (threadDelay)

-- | A wrapper around values that are instances
-- of 'IsMessageBoxFactory'. The factory wraps
-- the result of the delegated 'newMessageBox'
-- invocation into a 'CatchAllBox'.
newtype CatchAllFactory cfg = CatchAllFactory cfg
  deriving stock (CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
(CatchAllFactory cfg -> CatchAllFactory cfg -> Bool)
-> (CatchAllFactory cfg -> CatchAllFactory cfg -> Bool)
-> Eq (CatchAllFactory cfg)
forall cfg.
Eq cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
$c/= :: forall cfg.
Eq cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
== :: CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
$c== :: forall cfg.
Eq cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
Eq, Eq (CatchAllFactory cfg)
Eq (CatchAllFactory cfg)
-> (CatchAllFactory cfg -> CatchAllFactory cfg -> Ordering)
-> (CatchAllFactory cfg -> CatchAllFactory cfg -> Bool)
-> (CatchAllFactory cfg -> CatchAllFactory cfg -> Bool)
-> (CatchAllFactory cfg -> CatchAllFactory cfg -> Bool)
-> (CatchAllFactory cfg -> CatchAllFactory cfg -> Bool)
-> (CatchAllFactory cfg
    -> CatchAllFactory cfg -> CatchAllFactory cfg)
-> (CatchAllFactory cfg
    -> CatchAllFactory cfg -> CatchAllFactory cfg)
-> Ord (CatchAllFactory cfg)
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
CatchAllFactory cfg -> CatchAllFactory cfg -> Ordering
CatchAllFactory cfg -> CatchAllFactory cfg -> CatchAllFactory cfg
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall cfg. Ord cfg => Eq (CatchAllFactory cfg)
forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Ordering
forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> CatchAllFactory cfg
min :: CatchAllFactory cfg -> CatchAllFactory cfg -> CatchAllFactory cfg
$cmin :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> CatchAllFactory cfg
max :: CatchAllFactory cfg -> CatchAllFactory cfg -> CatchAllFactory cfg
$cmax :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> CatchAllFactory cfg
>= :: CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
$c>= :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
> :: CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
$c> :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
<= :: CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
$c<= :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
< :: CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
$c< :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Bool
compare :: CatchAllFactory cfg -> CatchAllFactory cfg -> Ordering
$ccompare :: forall cfg.
Ord cfg =>
CatchAllFactory cfg -> CatchAllFactory cfg -> Ordering
$cp1Ord :: forall cfg. Ord cfg => Eq (CatchAllFactory cfg)
Ord, Int -> CatchAllFactory cfg -> ShowS
[CatchAllFactory cfg] -> ShowS
CatchAllFactory cfg -> String
(Int -> CatchAllFactory cfg -> ShowS)
-> (CatchAllFactory cfg -> String)
-> ([CatchAllFactory cfg] -> ShowS)
-> Show (CatchAllFactory cfg)
forall cfg. Show cfg => Int -> CatchAllFactory cfg -> ShowS
forall cfg. Show cfg => [CatchAllFactory cfg] -> ShowS
forall cfg. Show cfg => CatchAllFactory cfg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatchAllFactory cfg] -> ShowS
$cshowList :: forall cfg. Show cfg => [CatchAllFactory cfg] -> ShowS
show :: CatchAllFactory cfg -> String
$cshow :: forall cfg. Show cfg => CatchAllFactory cfg -> String
showsPrec :: Int -> CatchAllFactory cfg -> ShowS
$cshowsPrec :: forall cfg. Show cfg => Int -> CatchAllFactory cfg -> ShowS
Show)

-- | A wrapper around values that are instances
-- of 'IsMessageBox'.
--
-- The 'Input' type will be wrapped using
-- 'CatchAllInput'.
newtype CatchAllBox box a = CatchAllBox (box a)

-- | A wrapper around values that are instances
-- of 'IsInput'.
newtype CatchAllInput i a = CatchAllInput (i a)

instance IsMessageBoxFactory cfg => IsMessageBoxFactory (CatchAllFactory cfg) where
  type MessageBox (CatchAllFactory cfg) = CatchAllBox (MessageBox cfg)
  {-# INLINE newMessageBox #-}
  newMessageBox :: CatchAllFactory cfg -> m (MessageBox (CatchAllFactory cfg) a)
newMessageBox (CatchAllFactory !cfg
cfg) = MessageBox cfg a -> CatchAllBox (MessageBox cfg) a
forall k (box :: k -> *) (a :: k). box a -> CatchAllBox box a
CatchAllBox (MessageBox cfg a -> CatchAllBox (MessageBox cfg) a)
-> m (MessageBox cfg a) -> m (CatchAllBox (MessageBox cfg) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> cfg -> m (MessageBox cfg a)
forall cfg (m :: * -> *) a.
(IsMessageBoxFactory cfg, MonadUnliftIO m) =>
cfg -> m (MessageBox cfg a)
newMessageBox cfg
cfg
  getConfiguredMessageLimit :: CatchAllFactory cfg -> Maybe Int
getConfiguredMessageLimit (CatchAllFactory !cfg
cfg) =
    cfg -> Maybe Int
forall cfg. IsMessageBoxFactory cfg => cfg -> Maybe Int
getConfiguredMessageLimit cfg
cfg

instance IsMessageBox box => IsMessageBox (CatchAllBox box) where
  type Input (CatchAllBox box) = CatchAllInput (Input box)
  {-# INLINE newInput #-}
  newInput :: CatchAllBox box a -> m (Input (CatchAllBox box) a)
newInput (CatchAllBox !box a
b) =
    Input box a -> CatchAllInput (Input box) a
forall k (i :: k -> *) (a :: k). i a -> CatchAllInput i a
CatchAllInput (Input box a -> CatchAllInput (Input box) a)
-> m (Input box a) -> m (CatchAllInput (Input box) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> box a -> m (Input box a)
forall (msgBox :: * -> *) (m :: * -> *) a.
(IsMessageBox msgBox, MonadUnliftIO m) =>
msgBox a -> m (Input msgBox a)
newInput box a
b
  {-# INLINE receive #-}
  receive :: CatchAllBox box a -> m (Maybe a)
receive (CatchAllBox !box a
box) =
    m (Maybe a) -> m (Either SomeException (Maybe a))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (box a -> m (Maybe a)
forall (msgBox :: * -> *) (m :: * -> *) a.
(IsMessageBox msgBox, MonadUnliftIO m) =>
msgBox a -> m (Maybe a)
receive box a
box)
      m (Either SomeException (Maybe a))
-> (Either SomeException (Maybe a) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e) m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Right Maybe a
r -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r
  {-# INLINE receiveAfter #-}
  -- | Call the wrapped 'receiveAfter' and catch all sync exceptions.
  -- 
  -- When an exception is caught return 'Nothing'.
  receiveAfter :: CatchAllBox box a -> Int -> m (Maybe a)
receiveAfter (CatchAllBox !box a
box) !Int
t =
    m (Maybe a) -> m (Either SomeException (Maybe a))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (box a -> Int -> m (Maybe a)
forall (msgBox :: * -> *) (m :: * -> *) a.
(IsMessageBox msgBox, MonadUnliftIO m) =>
msgBox a -> Int -> m (Maybe a)
receiveAfter box a
box Int
t)
      m (Either SomeException (Maybe a))
-> (Either SomeException (Maybe a) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e) m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Right Maybe a
r -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r
  {-# INLINE tryReceive #-}
  tryReceive :: CatchAllBox box a -> m (Future a)
tryReceive (CatchAllBox !box a
box) =
    m (Future a) -> m (Either SomeException (Future a))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (box a -> m (Future a)
forall (msgBox :: * -> *) (m :: * -> *) a.
(IsMessageBox msgBox, MonadUnliftIO m) =>
msgBox a -> m (Future a)
tryReceive box a
box)
      m (Either SomeException (Future a))
-> (Either SomeException (Future a) -> m (Future a))
-> m (Future a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e ->
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e)
            m () -> m (Future a) -> m (Future a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Future a -> m (Future a)
forall (m :: * -> *) a. Monad m => a -> m a
return
              ( IO (Maybe a) -> Future a
forall a. IO (Maybe a) -> Future a
Future
                  ( do
                      -- suspense...
                      Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
1000
                      -- ... anyway, the truth is: there is no spoon.
                      Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                  )
              )
        Right Future a
r -> Future a -> m (Future a)
forall (m :: * -> *) a. Monad m => a -> m a
return Future a
r

instance (IsInput i) => IsInput (CatchAllInput i) where
  {-# INLINE deliver #-}
  deliver :: CatchAllInput i a -> a -> m Bool
deliver (CatchAllInput !i a
i) !a
msg =
    m Bool -> m (Either SomeException Bool)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (i a -> a -> m Bool
forall (input :: * -> *) (m :: * -> *) a.
(IsInput input, MonadUnliftIO m) =>
input a -> a -> m Bool
deliver i a
i a
msg)
      m (Either SomeException Bool)
-> (Either SomeException Bool -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e) m () -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Right Bool
r -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
r