dejafu/dejafu-tests/lib/Integration/SingleThreaded.hs

{-# LANGUAGE CPP #-}

module Integration.SingleThreaded where

import Control.Exception (ArithException(..), ArrayException(..))
import Test.DejaFu (Failure(..), gives, gives', isUncaughtException)

import Control.Monad (replicateM_)
import Control.Concurrent.Classy
import Control.Monad.IO.Class (liftIO)
import Test.DejaFu.Conc (subconcurrency)
import qualified Data.IORef as IORef

import Common

tests :: [TestTree]
tests =
  [ testGroup "MVar" mvarTests
  , testGroup "CRef" crefTests
  , testGroup "STM" stmTests
  , testGroup "Exceptions" exceptionTests
  , testGroup "Capabilities" capabilityTests
  , testGroup "Subconcurrency" subconcurrencyTests
  , testGroup "IO" ioTests
  ]

--------------------------------------------------------------------------------

mvarTests :: [TestTree]
mvarTests = toTestList
  [ djfu "Taking from an empty MVar blocks" (gives [Left Deadlock]) $ do
      var <- newEmptyMVarInt
      takeMVar var

  , djfu "Non-blockingly taking from an empty MVar gives nothing" (gives' [Nothing]) $ do
      var <- newEmptyMVarInt
      tryTakeMVar var

  , djfu "Putting into an empty MVar updates it" (gives' [True]) $ do
      var <- newEmptyMVarInt
      putMVar var 7
      (==7) <$> readMVar var

  , djfu "Non-blockingly putting into an empty MVar updates it" (gives' [True]) $ do
      var <- newEmptyMVarInt
      _   <- tryPutMVar var 7
      (==7) <$> readMVar var

  , djfu "Reading an empty MVar blocks" (gives [Left Deadlock]) $ do
      var <- newEmptyMVarInt
      readMVar var

  , djfu "Non-blockingly reading an empty MVar gives nothing" (gives' [Nothing]) $ do
      var <- newEmptyMVarInt
      tryReadMVar var

  , djfu "Putting into a full MVar blocks" (gives [Left Deadlock]) $ do
      var <- newMVarInt 7
      putMVar var 10

  , djfu "Non-blockingly putting into a full MVar fails" (gives' [False]) $ do
      var <- newMVarInt 7
      tryPutMVar var 10

  , djfu "Taking from a full MVar works" (gives' [True]) $ do
      var <- newMVarInt 7
      (==7) <$> takeMVar var

  , djfu "Non-blockingly taking from a full MVar works" (gives' [True]) $ do
      var <- newMVarInt 7
      (==Just 7) <$> tryTakeMVar var

  , djfu "Reading a full MVar works" (gives' [True]) $ do
      var <- newMVarInt 7
      (==7) <$> readMVar var

  , djfu "Non-blockingly reading a full MVar works" (gives' [True]) $ do
      var <- newMVarInt 7
      (==Just 7) <$> tryReadMVar var
  ]

--------------------------------------------------------------------------------

crefTests :: [TestTree]
crefTests = toTestList
  [ djfu "Reading a non-updated CRef gives its initial value" (gives' [True]) $ do
      ref <- newCRefInt 5
      (5==) <$> readCRef ref

  , djfu "Reading an updated CRef gives its new value" (gives' [True]) $ do
      ref <- newCRefInt 5
      writeCRef ref 6
      (6==) <$> readCRef ref

  , djfu "Updating a CRef by a function changes its value" (gives' [True]) $ do
      ref <- newCRefInt 5
      atomicModifyCRef ref (\i -> (i+1, ()))
      (6==) <$> readCRef ref

  , djfu "A ticket contains the value of the CRef at the time of its creation" (gives' [True]) $ do
      ref  <- newCRefInt 5
      tick <- readForCAS ref
      writeCRef ref 6
      (5==) <$> peekTicket tick

  , djfu "Compare-and-swap returns a ticket containing the new value" (gives' [True]) $ do
      ref  <- newCRefInt 5
      tick <- readForCAS ref
      (_, tick') <- casCRef ref tick 6
      (6==) <$> peekTicket tick'

  , djfu "Compare-and-swap on an unmodified CRef succeeds" (gives' [True]) $ do
      ref  <- newCRefInt 5
      tick <- readForCAS ref
      (suc, _) <- casCRef ref tick 6
      val <- readCRef ref
      return (suc && (6 == val))

  , djfu "Compare-and-swap on a modified CRef fails" (gives' [True]) $ do
      ref  <- newCRefInt 5
      tick <- readForCAS ref
      writeCRef ref 6
      (suc, _) <- casCRef ref tick 7
      val <- readCRef ref
      return (not suc && not (7 == val))
  ]

--------------------------------------------------------------------------------

stmTests :: [TestTree]
stmTests = toTestList
  [ djfu "When a TVar is updated, its new value is visible later in same transaction" (gives' [True]) $
      (6==) <$> atomically (do { v <- newTVarInt 5; writeTVar v 6; readTVar v })

  , djfu "When a TVar is updated, its new value is visible in a later transaction" (gives' [True]) $ do
      ctv <- atomically $ newTVarInt 5
      (5==) <$> atomically (readTVar ctv)

  , djfu "Aborting a transaction blocks the thread" (gives [Left STMDeadlock]) $
      (atomically retry :: MonadConc m => m ()) -- avoid an ambiguous type

  , djfu "Aborting a transaction can be caught and recovered from" (gives' [True]) $ do
      ctv <- atomically $ newTVarInt 5
      atomically $ orElse retry (writeTVar ctv 6)
      (6==) <$> atomically (readTVar ctv)

  , djfu "An exception thrown in a transaction can be caught" (gives' [True]) $ do
      ctv <- atomically $ newTVarInt 5
      atomically $ catchArithException
        (throwSTM Overflow)
        (\_ -> writeTVar ctv 6)
      (6==) <$> atomically (readTVar ctv)

  , djfu "Nested exception handlers in transactions work" (gives' [True]) $ do
      ctv <- atomically $ newTVarInt 5
      atomically $ catchArithException
        (catchArrayException
          (throwSTM Overflow)
          (\_ -> writeTVar ctv 0))
        (\_ -> writeTVar ctv 6)
      (6==) <$> atomically (readTVar ctv)

  , djfu "MonadSTM is a MonadFail" (alwaysFailsWith isUncaughtException) $
      (atomically $ fail "hello world" :: MonadConc m => m ())  -- avoid an ambiguous type
  ]

--------------------------------------------------------------------------------

exceptionTests :: [TestTree]
exceptionTests = toTestList
  [ djfu "An exception thrown can be caught" (gives' [True]) $
      catchArithException
        (throw Overflow)
        (\_ -> return True)

  , djfu "Nested exception handlers work" (gives' [True]) $
      catchArithException
        (catchArrayException
          (throw Overflow)
          (\_ -> return False))
        (\_ -> return True)

  , djfu "Uncaught exceptions kill the computation" (alwaysFailsWith isUncaughtException) $
      catchArithException
        (throw $ IndexOutOfBounds "")
        (\_ -> return False)

  , djfu "SomeException matches all exception types" (gives' [True]) $ do
      a <- catchSomeException
           (throw Overflow)
           (\_ -> return True)
      b <- catchSomeException
           (throw $ IndexOutOfBounds "")
           (\_ -> return True)
      return (a && b)

  , djfu "Exceptions thrown in a transaction can be caught outside it" (gives' [True]) $
      catchArithException
        (atomically $ throwSTM Overflow)
        (\_ -> return True)

  , djfu "Throwing an unhandled exception to the main thread kills it" (alwaysFailsWith isUncaughtException) $ do
      tid <- myThreadId
      throwTo tid Overflow

  , djfu "Throwing a handled exception to the main thread does not kill it" (gives' [True]) $ do
      tid <- myThreadId
      catchArithException (throwTo tid Overflow >> pure False) (\_ -> pure True)

  , djfu "MonadConc is a MonadFail" (alwaysFailsWith isUncaughtException) $
      (fail "hello world" :: MonadConc m => m ())  -- avoid an ambiguous type
  ]

--------------------------------------------------------------------------------

capabilityTests :: [TestTree]
capabilityTests = toTestList
  [ djfu "Reading the capabilities twice without update gives the same result" (gives' [True]) $ do
      c1 <- getNumCapabilities
      c2 <- getNumCapabilities
      return (c1 == c2)

  , djfu "Getting the updated capabilities gives the new value" (gives' [True]) $ do
      caps <- getNumCapabilities
      setNumCapabilities (caps + 1)
      (== caps + 1) <$> getNumCapabilities
  ]

--------------------------------------------------------------------------------

subconcurrencyTests :: [TestTree]
subconcurrencyTests = toTestList
  [ djfuS "Failures in subconcurrency can be observed" (gives' [True]) $ do
      x <- subconcurrency (newEmptyMVar >>= readMVar)
      pure (either (==Deadlock) (const False) x)

  , djfuS "Actions after a failing subconcurrency still happen" (gives' [True]) $ do
      var <- newMVarInt 0
      x <- subconcurrency (putMVar var 1)
      y <- readMVar var
      pure (either (==Deadlock) (const False) x && y == 0)

  , djfuS "Non-failing subconcurrency returns the final result" (gives' [True]) $ do
      var <- newMVarInt 3
      x <- subconcurrency (takeMVar var)
      pure (either (const False) (==3) x)
  ]

-------------------------------------------------------------------------------

ioTests :: [TestTree]
ioTests = toTestList
  [ djfu "Lifted IO is performed" (gives' [3]) $ do
      r <- liftIO (IORef.newIORef 0)
      replicateM_ 3 (liftIO (IORef.atomicModifyIORef r (\i -> (i+1, ()))))
      liftIO (IORef.readIORef r)
  ]