{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleContexts #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif

-------------------------------------------------------------------------------
-- |
-- Module      :  System.Timeout.Lifted
-- Copyright   :  (c) The University of Glasgow 2007
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Attach a timeout event to monadic computations
-- which are instances of 'MonadBaseControl'.
--
-------------------------------------------------------------------------------

module System.Timeout.Lifted ( timeout ) where

-- from base:
import Prelude                       ( (.) )
import           Data.Int            ( Int )
import           Data.Maybe          ( Maybe(Nothing, Just), maybe )
import           Control.Monad       ( (>>=), return, liftM )
import           System.IO           ( IO )
import qualified System.Timeout as T ( timeout )

-- from monad-control:
import Control.Monad.Trans.Control ( MonadBaseControl, restoreM, liftBaseWith )

#include "inlinable.h"

-- | Generalized version of 'T.timeout'.
--
-- Note that when the given computation times out any side effects of @m@ are
-- discarded. When the computation completes within the given time the
-- side-effects are restored on return.
timeout :: MonadBaseControl IO m => Int -> m a -> m (Maybe a)
timeout :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
Int -> m a -> m (Maybe a)
timeout Int
t m a
m = (RunInBase m IO -> IO (Maybe (StM m a))) -> m (Maybe (StM m a))
forall a. (RunInBase m IO -> IO a) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase m IO
runInIO -> Int -> IO (StM m a) -> IO (Maybe (StM m a))
forall a. Int -> IO a -> IO (Maybe a)
T.timeout Int
t (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
m)) m (Maybe (StM m a))
-> (Maybe (StM m a) -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                m (Maybe a)
-> (StM m a -> m (Maybe a)) -> Maybe (StM m a) -> m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a) -> m a -> m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just (m a -> m (Maybe a)) -> (StM m a -> m a) -> StM m a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StM m a -> m a
forall a. StM m a -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM)
{-# INLINABLE timeout #-}