IOClockTests.hs (3782B)
1 {-# LANGUAGE ScopedTypeVariables #-} 2 module IOClockTests (ioClockTests) where 3 4 import qualified IO.Clock as C 5 import qualified IO.Driver as V 6 import qualified IO.Protocol as P 7 import Runtime (T(..), ofNumber, ofString, ofList) 8 import Control.Concurrent 9 import Control.Exception 10 import Control.Monad 11 import Data.IORef 12 import System.Timeout (timeout) 13 import Test.Tasty 14 import Test.Tasty.HUnit 15 16 request g op payload = Fork (ofNumber 10) (Fork (ofString g) (Fork (ofNumber 1) (Fork (ofString op) payload))) 17 ok value = Fork (Stem Leaf) (Fork value Leaf) 18 completed action value = V.runDetailed action >>= \result -> case result of 19 V.Completed actual -> actual @?= value 20 _ -> assertFailure "expected completion" 21 22 ioClockTests = localOption (mkTimeout 10000000) $ testGroup "IO clocks/scheduler" 23 [ testCase "monotonic result is canonical unsigned Word64, not a wall epoch" $ do 24 before <- C.monotonicNanoseconds 25 V.runDetailed (request "clock" "monotonic" Leaf) >>= \outcome -> case outcome of 26 V.Completed (Fork (Stem Leaf) (Fork value Leaf)) -> case V.canonicalNat 64 value of 27 Just value -> do 28 after <- C.monotonicNanoseconds 29 assertBool "sample order" (before <= value && value <= after) 30 _ -> assertFailure "noncanonical clock value" 31 _ -> assertFailure "clock failed" 32 , testCase "zero sleep and yield return ordinary unit Results" $ do 33 completed (request "clock" "sleep" Leaf) (ok Leaf) 34 completed (request "scheduler" "yield" Leaf) (ok Leaf) 35 , testCase "relative sleep does not acknowledge before the requested duration" $ do 36 before <- C.monotonicNanoseconds 37 completed (request "clock" "sleep" (ofNumber 20)) (ok Leaf) 38 after <- C.monotonicNanoseconds 39 assertBool "early sleep completion" (after-before >= 20000000) 40 , testCase "wait chunks preserve milliseconds and never overflow host microseconds" $ do 41 calls <- newIORef [] 42 C.sleepWith (\n -> modifyIORef' calls (++[n])) 2501 43 readIORef calls >>= (@?= [1000000,1000000,501000]) 44 writeIORef calls [] 45 C.sleepWith (\n -> modifyIORef' calls (++[n])) 0 46 readIORef calls >>= (@?= []) 47 result <- try (C.sleepWith (\n -> writeIORef calls [n] >> ioError (userError "stop")) 9223372036854775807) :: IO (Either IOException ()) 48 case result of Left _ -> pure (); _ -> assertFailure "waiter failure ignored" 49 readIORef calls >>= (@?= [1000000]) 50 , testCase "maximum relative wait is interruptible rather than an overflowing short wait" $ do 51 entered <- newEmptyMVar 52 done <- newEmptyMVar 53 tid <- forkIO $ (try (putMVar entered () >> C.sleepMilliseconds 9223372036854775807) :: IO (Either SomeException ())) >>= putMVar done 54 takeMVar entered 55 threadDelay 20000 56 tryReadMVar done >>= \result -> case result of Nothing -> pure (); _ -> assertFailure "wait completed early" 57 killThread tid 58 timeout 2000000 (takeMVar done) >>= \result -> case result of 59 Just (Left _) -> pure () 60 _ -> assertFailure "wait ignored interruption" 61 , testCase "invalid clock/scheduler arguments fail ordinarily without truncation" $ 62 forM_ [("clock","sleep",ofNumber 9223372036854775808), ("clock","sleep",Fork Leaf Leaf), 63 ("clock","sleep",Stem Leaf), ("clock","monotonic",ofNumber 1), ("scheduler","yield",ofNumber 1)] $ \(g,op,args) -> 64 completed (request g op args) (Fork Leaf (Fork (ofList (map ofString ["invalid-argument",g++"/"++op,"","none"])) Leaf)) 65 , testCase "clock inspection is inert even with an undefined duration" $ 66 P.inspectAction (request "clock" "sleep" (error "duration demanded")) @?= 67 Right (ofList [ofString "facility",ofString "clock",ofNumber 1,ofString "sleep",ofString "available"]) 68 ]