Remove Timeout carrier and implement it with liftWith.

This carrier is no longer necessary, because we can perform the needed
lifting and state manipulation with `liftWith`.

src/Semantic/Timeout.hs

@@ -1,66 +1,22 @@
-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, RankNTypes, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 module Semantic.Timeout
 ( timeout
-, Timeout
-, runTimeout
-, withTimeout
-, TimeoutC(..)
-, Duration(..)
 ) where
 
 import           Control.Algebra
-import           Control.Carrier.Reader
-import           Control.Monad.IO.Class
-import           Control.Monad.IO.Unlift
-import           Data.Duration
+import           Control.Effect.Lift
 import qualified System.Timeout as System
 
 -- | Run an action with a timeout. Returns 'Nothing' when no result is available
 -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats
 -- about not operating over FFI boundaries apply.
-timeout :: Has Timeout sig m => Duration -> m output -> m (Maybe output)
-timeout n = send . flip (Timeout n) pure
-
--- | 'Timeout' effects run other effects, aborting them if they exceed the
--- specified duration.
-data Timeout m k
-  = forall a . Timeout Duration (m a) (Maybe a -> m k)
-
-deriving instance Functor m => Functor (Timeout m)
-
-instance HFunctor Timeout where
-  hmap f (Timeout n task k) = Timeout n (f task) (f . k)
-
-instance Effect Timeout where
-  thread state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just)))
-
--- | Evaulate a 'Timeout' effect.
-runTimeout :: (forall x . m x -> IO x)
-           -> TimeoutC m a
-           -> m a
-runTimeout handler = runReader (Handler handler) . runTimeoutC
-
--- | A helper for 'runTimeout' that uses 'withRunInIO' to automatically
--- select a correct unlifting function.
-withTimeout :: MonadUnliftIO m
-            => TimeoutC m a
-            -> m a
-withTimeout r = withRunInIO (\f -> runHandler (Handler f) r)
-
-newtype Handler m = Handler (forall x . m x -> IO x)
-
-runHandler :: Handler m -> TimeoutC m a -> IO a
-runHandler h@(Handler handler) = handler . runReader h . runTimeoutC
-
-newtype TimeoutC m a = TimeoutC { runTimeoutC :: ReaderC (Handler m) m a }
-  deriving (Functor, Applicative, Monad, MonadFail, MonadIO)
-
-instance MonadUnliftIO m => MonadUnliftIO (TimeoutC m) where
-  askUnliftIO = TimeoutC . ReaderC $ \(Handler h) ->
-    withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (runTimeout h r))
-
-instance (Algebra sig m, MonadIO m) => Algebra (Timeout :+: sig) (TimeoutC m) where
-  alg (L (Timeout n task k)) = do
-    handler <- TimeoutC ask
-    liftIO (System.timeout (toMicroseconds n) (runHandler handler task)) >>= k
-  alg (R other) = TimeoutC (alg (R (handleCoercible other)))
+--
+-- Any state changes in the action are discarded iff the timeout fails.
+timeout :: Has (Lift IO) sig m => Int -> m a -> m (Maybe a)
+timeout n m = liftWith $ \ ctx hdl
+  -> maybe
+     -- Restore the old state if it timed out.
+     (Nothing <$ ctx)
+     -- Apply it if it succeeded.
+     (fmap Just) <$> System.timeout n (hdl (m <$ ctx))