github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-01 11:46:14 +03:00
Code Issues Projects Releases Wiki Activity

Port Timeout effect to FE1.

Browse Source
This commit is contained in:
Patrick Thomson 2019-11-08 21:40:42 -05:00
parent d53a7bafdd
commit 9a419428af
1 changed files with 7 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Semantic/Timeout.hs
View File

@ -8,8 +8,8 @@ module Semantic.Timeout
, Duration(..)
) where
import Control.Effect.Carrier
import Control.Effect.Reader
import Control.Algebra
import Control.Carrier.Reader
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Data.Duration
@ -18,7 +18,7 @@ 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 :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output)
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
@ -32,7 +32,7 @@ instance HFunctor Timeout where
hmap f (Timeout n task k) = Timeout n (f task) (f . k)
instance Effect Timeout where
handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just)))
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)
@ -59,8 +59,8 @@ instance MonadUnliftIO m => MonadUnliftIO (TimeoutC m) where
askUnliftIO = TimeoutC . ReaderC $ \(Handler h) ->
withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (runTimeout h r))
instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where
eff (L (Timeout n task k)) = do
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
eff (R other) = TimeoutC (eff (R (handleCoercible other)))
alg (R other) = TimeoutC (alg (R (handleCoercible other)))