git.iko.soy/effectful
on master help sign in
Added Timeout effect (#35)
23d789aMann mit Hut
effectful/effectful.cabal+2
compare with master
unifiedsplit
@@ -77,6 +77,7 @@ library
77 Effectful.Process
77 Effectful.Process
78 Effectful.Resource
78 Effectful.Resource
79 Effectful.Temporary
79 Effectful.Temporary
80+ Effectful.Timeout
80
81
81 reexported-modules: Effectful.Error
82 reexported-modules: Effectful.Error
82 , Effectful.Error.Dynamic
83 , Effectful.Error.Dynamic
@@ -117,6 +118,7 @@ test-suite test
117 EnvironmentTests
118 EnvironmentTests
118 ErrorTests
119 ErrorTests
119 StateTests
120 StateTests
121+ TimeoutTests
120 Utils
122 Utils
121 -- These are examples; We do not actually run them but list
123 -- These are examples; We do not actually run them but list
122 -- them here in order to check if they compile.
124 -- them here in order to check if they compile.
effectful/src/Effectful/Timeout.hsnew file+30
@@ -0,0 +1,30 @@
1+module Effectful.Timeout
2+ ( Timeout
3+ , runTimeout
4+ , timeout
5+ ) where
6+
7+import qualified System.Timeout as T
8+
9+import Effectful.Internal.Effect
10+import Effectful.Internal.Monad
11+
12+-- | An effect for timing out computations.
13+data Timeout :: Effect where
14+ Timeout :: Timeout m r
15+
16+-- | Run the 'Timeout' effect.
17+runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a
18+runTimeout = evalEffect (IdE Timeout)
19+
20+-- | Lifted 'T.timeout'.
21+timeout
22+ :: Timeout :> es
23+ => Int
24+ -- ^ The timeout in microseconds (1/10^6 seconds).
25+ -> Eff es a
26+ -- ^ The computation the timeout applies to.
27+ -> Eff es (Maybe a)
28+timeout n k = unsafeEff $ \es -> do
29+ seqUnliftEff es $ \unlift -> do
30+ T.timeout n $ unlift k
effectful/tests/Main.hs+2
@@ -7,6 +7,7 @@ import ConcurrencyTests
7import EnvironmentTests
7import EnvironmentTests
8import ErrorTests
8import ErrorTests
9import StateTests
9import StateTests
10+import TimeoutTests
10
11
11main :: IO ()
12main :: IO ()
12main = defaultMain $ testGroup "effectful"
13main = defaultMain $ testGroup "effectful"
@@ -15,4 +16,5 @@ main = defaultMain $ testGroup "effectful"
15 , environmentTests
16 , environmentTests
16 , errorTests
17 , errorTests
17 , stateTests
18 , stateTests
19+ , timeoutTests
18 ]
20 ]
effectful/tests/TimeoutTests.hsnew file+25
@@ -0,0 +1,25 @@
1+module TimeoutTests (timeoutTests) where
2+
3+import Control.Concurrent (threadDelay)
4+import Test.Tasty
5+import Test.Tasty.HUnit
6+
7+import Effectful
8+import Effectful.Timeout
9+import qualified Utils as U
10+
11+timeoutTests :: TestTree
12+timeoutTests = testGroup "Timeout"
13+ [ testCase "return before timeout" test_returnBeforeTimeout
14+ , testCase "timeout before return" test_timeoutBeforeReturn
15+ ]
16+
17+test_returnBeforeTimeout :: Assertion
18+test_returnBeforeTimeout = runEff $ do
19+ result <- runTimeout $ timeout 1000 $ return ()
20+ U.assertEqual "return value" (Just ()) result
21+
22+test_timeoutBeforeReturn :: Assertion
23+test_timeoutBeforeReturn = runEff $ do
24+ result <- runTimeout $ timeout 0 $ liftIO $ threadDelay 1000
25+ U.assertEqual "no return value" Nothing result