Replace LeanCheck tests with Hedgehog tests

.hlint.yaml

@@ -27,6 +27,7 @@
 
 # I don't think these help.
 - ignore: {name: Avoid lambda, within: Integration.Refinement}
+- ignore: {name: Reduce duplication, within: Unit.Properties}
 - ignore: {name: Reduce duplication, within: Integration.Litmus}
 - ignore: {name: Reduce duplication, within: Integration.MultiThreaded}
 - ignore: {name: Reduce duplication, within: Integration.SingleThreaded}

dejafu-tests/dejafu-tests.cabal

@@ -40,7 +40,6 @@ library
                      , Examples.SearchParty
                      , Examples.SearchParty.Impredicative
 
-                     , Test.Tasty.LeanCheck
                      , Common
                      , QSemN
 
@@ -52,7 +51,6 @@ library
                      , dejafu
                      , exceptions
                      , hedgehog
-                     , leancheck
                      , mtl
                      , mwc-random
                      , QuickCheck

dejafu-tests/lib/Test/Tasty/LeanCheck.hs

@@ -1,38 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Test.Tasty.LeanCheck where
-
-import           Data.Proxy           (Proxy(..))
-import qualified Test.LeanCheck       as LeanCheck
-import           Test.Tasty.Options
-import           Test.Tasty.Providers
-import           Text.Printf          (printf)
-import           Text.Read            (readMaybe)
-
--- | Create a 'Test' for a LeanCheck 'LeanCheck.Testable' property.
-testProperty :: LeanCheck.Testable p => TestName -> p -> TestTree
-testProperty name = singleTest name . LeanCheckTest
-
--- | The number of tests for LeanCheck to try.
-newtype LeanCheckTests = LeanCheckTests Int
-  deriving (Num, Ord, Eq, Real, Enum, Integral)
-
--- | A LeanCheck test.
-data LeanCheckTest where
-  LeanCheckTest :: LeanCheck.Testable p => p -> LeanCheckTest
-
-instance IsOption LeanCheckTests where
-  defaultValue = 2500
-  parseValue = fmap LeanCheckTests . readMaybe
-  optionName = pure "leancheck-tests"
-  optionHelp = pure "Tests to use for leancheck tests"
-
-instance IsTest LeanCheckTest where
-  testOptions = pure [Option (Proxy :: Proxy LeanCheckTests)]
-
-  run opts (LeanCheckTest prop) _ = pure $
-    let LeanCheckTests tests = lookupOption opts
-    in case LeanCheck.counterExample tests prop of
-      Just ce -> testFailed (printf "*** Failed! Counter example:\n%s" (unlines ce))
-      Nothing -> testPassed (printf "+++ OK, passed %d tests." tests)

dejafu-tests/lib/Unit.hs

@@ -1,17 +1,91 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Unit where
 
-import           Test.Tasty.Options (OptionDescription)
+import           Data.Proxy          (Proxy(..))
+import           Test.Tasty          (askOption, localOption)
+import           Test.Tasty.Hedgehog (HedgehogDiscardLimit(..),
+                                      HedgehogShrinkLimit(..),
+                                      HedgehogShrinkRetries(..),
+                                      HedgehogTestLimit)
+import           Test.Tasty.Options  (IsOption(..), OptionDescription(..))
+import           Text.Read           (readMaybe)
 
-import qualified Unit.Properties    as P
+import qualified Unit.Properties     as P
 
 import           Common
 
 -- | Run all the unit tests.
 tests :: [TestTree]
-tests =
+tests = map applyHedgehogOptions
   [ testGroup "Properties" P.tests
   ]
 
 -- | Tasty options
 options :: [OptionDescription]
-options = []
+options =
+  [ Option (Proxy :: Proxy UnitHedgehogTestLimit)
+  , Option (Proxy :: Proxy UnitHedgehogDiscardLimit)
+  , Option (Proxy :: Proxy UnitHedgehogShrinkLimit)
+  , Option (Proxy :: Proxy UnitHedgehogShrinkRetries)
+  ]
+
+
+-------------------------------------------------------------------------------
+-- Hedgehog options
+
+-- | The number of successful test cases required before Hedgehog will pass a test
+newtype UnitHedgehogTestLimit = UnitHedgehogTestLimit Int
+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+instance IsOption UnitHedgehogTestLimit where
+  defaultValue = 1500
+  parseValue = fmap UnitHedgehogTestLimit . readMaybe
+  optionName = pure "unit-hedgehog-tests"
+  optionHelp = pure "hedgehog-tests for the unit tests"
+
+-- | The number of discarded cases allowed before Hedgehog will fail a test
+newtype UnitHedgehogDiscardLimit = UnitHedgehogDiscardLimit Int
+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+instance IsOption UnitHedgehogDiscardLimit where
+  defaultValue = 1000
+  parseValue = fmap UnitHedgehogDiscardLimit . readMaybe
+  optionName = pure "unit-hedgehog-discards"
+  optionHelp = pure "hedgehog-discards for the unit tests"
+
+-- | The number of shrinks allowed before Hedgehog will fail a test
+newtype UnitHedgehogShrinkLimit = UnitHedgehogShrinkLimit Int
+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+instance IsOption UnitHedgehogShrinkLimit where
+  defaultValue =
+    let HedgehogShrinkLimit d = defaultValue
+    in fromIntegral d
+  parseValue = fmap UnitHedgehogShrinkLimit . readMaybe
+  optionName = pure "unit-hedgehog-shrinks"
+  optionHelp = pure "hedgehog-shrinks for the unit tests"
+
+-- | The number of times to re-run a test during shrinking
+newtype UnitHedgehogShrinkRetries = UnitHedgehogShrinkRetries Int
+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+instance IsOption UnitHedgehogShrinkRetries where
+  defaultValue =
+    let HedgehogShrinkRetries d = defaultValue
+    in fromIntegral d
+  parseValue = fmap UnitHedgehogShrinkRetries . readMaybe
+  optionName = pure "unit-hedgehog-retries"
+  optionHelp = pure "hedgehog-retries for the unit tests"
+
+-- | Apply the Hedgehog options.
+applyHedgehogOptions :: TestTree -> TestTree
+applyHedgehogOptions tt0 =
+  askOption $ \(UnitHedgehogTestLimit tl) ->
+  askOption $ \(UnitHedgehogDiscardLimit dl) ->
+  askOption $ \(UnitHedgehogShrinkLimit sl) ->
+  askOption $ \(UnitHedgehogShrinkRetries sr) ->
+  localOption (fromIntegral tl :: HedgehogTestLimit) $
+  localOption (fromIntegral dl :: HedgehogDiscardLimit) $
+  localOption (fromIntegral sl :: HedgehogShrinkLimit) $
+  localOption (fromIntegral sr :: HedgehogShrinkRetries) tt0

dejafu-tests/lib/Unit/Properties.hs

@@ -1,29 +1,22 @@
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Unit.Properties where
 
 import qualified Control.Exception                as E
 import           Control.Monad                    (zipWithM)
 import qualified Control.Monad.ST                 as ST
 import qualified Data.Foldable                    as F
-import           Data.Map                         (Map)
 import qualified Data.Map                         as M
-import           Data.Maybe                       (fromJust, isJust)
-import           Data.Proxy                       (Proxy(..))
 import qualified Data.Sequence                    as S
-import           Data.Set                         (Set)
 import qualified Data.Set                         as Set
 import qualified Data.STRef                       as ST
+import qualified Hedgehog                         as H
+import qualified Hedgehog.Gen                     as HGen
 import qualified Test.DejaFu.Conc.Internal.Common as D
 import qualified Test.DejaFu.Conc.Internal.Memory as Mem
 import qualified Test.DejaFu.Internal             as D
 import qualified Test.DejaFu.SCT.Internal.DPOR    as SCT
-import           Test.DejaFu.Types                (Lookahead, ThreadAction)
 import qualified Test.DejaFu.Types                as D
-import           Test.LeanCheck                   (Listable(..), cons0, cons1,
+import qualified Test.Tasty.Hedgehog              as H
-                                                   cons2, cons3, mapT, (==>),
-                                                   (><), (\/))
-import           Test.Tasty.LeanCheck             (testProperty)
 
 import           Common
 
@@ -39,111 +32,177 @@ tests =
 
 classLawProps :: [TestTree]
 classLawProps = toTestList
-    [ testGroup "Id"      (eqord (Proxy :: Proxy D.Id))
+    [ testGroup "Id"      (eqord genId)
-    , testGroup "Failure" (eqord (Proxy :: Proxy D.Failure))
+    , testGroup "Failure" (eqord genFailure)
     ]
   where
-    eqord :: forall a. (Eq a, Ord a, Listable a, Show a) => Proxy a -> [TestTree]
+    eqord gen =
-    eqord _ =
+      [ H.testProperty "Reflexivity (==)" . H.property $ do
-      [ testProperty "Reflexivity (==)"     $ \(x :: a)     -> x == x
+          x <- H.forAll gen
-      , testProperty "Symmetry (==)"        $ \(x :: a) y   -> (x == y) == (y == x)
+          x H.=== x
-      , testProperty "Transitivity (==)"    $ \(x :: a) y z -> x == y && y == z ==> x == z
+
-      , testProperty "Reflexivity (<=)"     $ \(x :: a)     -> x <= x
+      , H.testProperty "Symmetry (==)" . H.property $ do
-      , testProperty "Antisymmetry (<=)"    $ \(x :: a) y   -> x <= y && y <= x ==> x == y
+          x <- H.forAll gen
-      , testProperty "Transitivity (<=)"    $ \(x :: a) y z -> x <= y && y <= z ==> x <= z
+          y <- H.forAll gen
-      , testProperty "Eq / Ord Consistency" $ \(x :: a) y   -> x == y ==> x <= y
+          (x == y) H.=== (y == x)
+
+      , H.testProperty "Transitivity (==)" . H.property $ do
+          x <- H.forAll gen
+          y <- H.forAll (HGen.filter (==x) gen)
+          z <- H.forAll (HGen.filter (==y) gen)
+          x H.=== z
+
+      , H.testProperty "Reflexivity (<=)" . H.property $ do
+          x <- H.forAll gen
+          H.assert (x <= x)
+
+      , H.testProperty "Antisymmetry (<=)" . H.property $ do
+          x <- H.forAll gen
+          y <- H.forAll (HGen.filter (\y -> x <= y && y <= x) gen)
+          x H.=== y
+
+      , H.testProperty "Transitivity (<=)" . H.property $ do
+          x <- H.forAll gen
+          y <- H.forAll (HGen.filter (x<=) gen)
+          z <- H.forAll (HGen.filter (y<=) gen)
+          H.assert (x <= z)
+
+      , H.testProperty "Eq / Ord Consistency" . H.property $ do
+          x <- H.forAll gen
+          y <- H.forAll (HGen.filter (==x) gen)
+          H.assert (x <= y)
+          H.assert (y <= x)
       ]
 
 -------------------------------------------------------------------------------
 
 commonProps :: [TestTree]
 commonProps = toTestList
-  [ testProperty "simplifyAction a == simplifyLookahead (rewind a)" $
+  [ H.testProperty "simplifyAction a == simplifyLookahead (rewind a)" . H.property $ do
-    \act -> canRewind act ==>
+      act <- H.forAll genThreadAction
-    D.simplifyAction act == D.simplifyLookahead (rewind' act)
+      case D.rewind act of
+        Just lh -> D.simplifyAction act H.=== D.simplifyLookahead lh
+        Nothing -> H.discard
 
-  , testProperty "isBarrier a ==> synchronises a r" $
+  , H.testProperty "isBarrier a ==> synchronises a r" . H.property $ do
-    \a r -> D.isBarrier a ==> D.synchronises a r
+      a <- H.forAll (HGen.filter D.isBarrier genActionType)
+      r <- H.forAll genCRefId
+      H.assert (D.synchronises a r)
 
-  , testProperty "isCommit a r ==> synchronises a r" $
+  , H.testProperty "isCommit a r ==> synchronises a r" . H.property $ do
-    \a r -> D.isCommit a r ==> D.synchronises a r
+      a <- H.forAll genPartiallySynchronisedActionType
+      case D.crefOf a of
+        Just r -> H.assert (D.synchronises a r)
+        _ -> H.discard
   ]
 
 -------------------------------------------------------------------------------
 
 memoryProps :: [TestTree]
 memoryProps = toTestList
-    [ testProperty "bufferWrite emptyBuffer k c a /= emptyBuffer" $
+    [ H.testProperty "bufferWrite emptyBuffer k c a /= emptyBuffer" . H.property $ do
-      \k a -> crefProp $ \cref -> do
+        k <- H.forAll genWBKey
-        wb <- Mem.bufferWrite Mem.emptyBuffer k cref a
+        a <- H.forAll genInt
-        not <$> wb `eqWB` Mem.emptyBuffer
+        res <- crefProp $ \cref -> do
+          wb <- Mem.bufferWrite Mem.emptyBuffer k cref a
+          wb `eqWB` Mem.emptyBuffer
+        H.assert (not res)
 
-    , testProperty "commitWrite emptyBuffer k == emptyBuffer" $
+    , H.testProperty "commitWrite emptyBuffer k == emptyBuffer" . H.property $ do
-      \k -> ST.runST $ do
+        k <- H.forAll genWBKey
-        wb <- Mem.commitWrite Mem.emptyBuffer k
+        H.assert $ ST.runST $ do
-        wb `eqWB` Mem.emptyBuffer
+          wb <- Mem.commitWrite Mem.emptyBuffer k
+          wb `eqWB` Mem.emptyBuffer
 
-    , testProperty "commitWrite (bufferWrite emptyBuffer k a) k == emptyBuffer" $
+    , H.testProperty "commitWrite (bufferWrite emptyBuffer k a) k == emptyBuffer" . H.property $ do
-      \k a -> crefProp $ \cref -> do
+        k <- H.forAll genWBKey
-        wb1 <- Mem.bufferWrite Mem.emptyBuffer k cref a
+        a <- H.forAll genInt
-        wb2 <- Mem.commitWrite wb1 k
+        res <- crefProp $ \cref -> do
-        wb2 `eqWB` Mem.emptyBuffer
+          wb1 <- Mem.bufferWrite Mem.emptyBuffer k cref a
+          wb2 <- Mem.commitWrite wb1 k
+          wb2 `eqWB` Mem.emptyBuffer
+        H.assert res
 
-    , testProperty "Single buffered write/read from same thread" $
+    , H.testProperty "Single buffered write/read from same thread" . H.property $ do
-      \k@(tid, _) a -> crefProp $ \cref -> do
+        k@(tid, _) <- H.forAll genWBKey
-        _ <- Mem.bufferWrite Mem.emptyBuffer k cref a
+        a <- H.forAll genInt
-        (a ==) <$> Mem.readCRef cref tid
+        res <- crefProp $ \cref -> do
+          _ <- Mem.bufferWrite Mem.emptyBuffer k cref a
+          Mem.readCRef cref tid
+        a H.=== res
 
-    , testProperty "Overriding buffered write/read from same thread" $
+    , H.testProperty "Overriding buffered write/read from same thread" . H.property $ do
-      \k@(tid, _) a1 a2 -> crefProp $ \cref -> do
+        k@(tid, _) <- H.forAll genWBKey
-        _ <- Mem.bufferWrite Mem.emptyBuffer k cref a1
+        a1 <- H.forAll genInt
-        _ <- Mem.bufferWrite Mem.emptyBuffer k cref a2
+        a2 <- H.forAll genInt
-        (a2 ==) <$> Mem.readCRef cref tid
+        res <- crefProp $ \cref -> do
+          _ <- Mem.bufferWrite Mem.emptyBuffer k cref a1
+          _ <- Mem.bufferWrite Mem.emptyBuffer k cref a2
+          Mem.readCRef cref tid
+        a2 H.=== res
 
-    , testProperty "Buffered write/read from different thread" $
+    , H.testProperty "Buffered write/read from different thread" . H.property $ do
-      \k1@(tid1, _) k2@(tid2, _) a1 a2 -> crefProp $ \cref -> do
+        k1@(tid, _) <- H.forAll genWBKey
-        _ <- Mem.bufferWrite Mem.emptyBuffer k1 cref a1
+        k2 <- H.forAll (HGen.filter ((/=tid) . fst) genWBKey)
-        _ <- Mem.bufferWrite Mem.emptyBuffer k2 cref a2
+        a1 <- H.forAll genInt
-        a' <- Mem.readCRef cref tid1
+        a2 <- H.forAll genInt
-        pure (tid1 /= tid2 ==> a' == a1)
+        res <- crefProp $ \cref -> do
+          _ <- Mem.bufferWrite Mem.emptyBuffer k1 cref a1
+          _ <- Mem.bufferWrite Mem.emptyBuffer k2 cref a2
+          Mem.readCRef cref tid
+        a1 H.=== res
     ]
   where
-    crefProp :: (forall s. D.CRef (ST.STRef s) Int -> ST.ST s Bool) -> D.CRefId -> Bool
+    crefProp
-    crefProp prop crid = ST.runST $ makeCRef crid >>= prop
+      :: (Monad m, Show a)
+      => (forall s. D.CRef (ST.STRef s) Int -> ST.ST s a)
+      -> H.PropertyT m a
+    crefProp p = do
+      crefId <- H.forAll genCRefId
+      pure $ ST.runST $ do
+        cref <- makeCRef crefId
+        p cref
 
 -------------------------------------------------------------------------------
 
 sctProps :: [TestTree]
 sctProps = toTestList
-  [ testProperty "canInterrupt ==> canInterruptL" $
+  [ H.testProperty "canInterrupt ==> canInterruptL" . H.property $ do
-    \ds tid act ->
+      ds <- H.forAll genDepState
-      canRewind act && SCT.canInterrupt ds tid act ==>
+      tid <- H.forAll genThreadId
-      SCT.canInterruptL ds tid (rewind' act)
+      act <- H.forAll (HGen.filter (SCT.canInterrupt ds tid) genThreadAction)
+      case D.rewind act of
+        Just lh -> H.assert (SCT.canInterruptL ds tid lh)
+        Nothing -> H.discard
 
-  , testProperty "dependent ==> dependent'" $
+  , H.testProperty "dependent ==> dependent'" . H.property $ do
-    \ds tid1 tid2 ta1 ta2 ->
+      ds <- H.forAll genDepState
-      canRewind ta2 && SCT.dependent ds tid1 ta1 tid2 ta2 ==>
+      tid1 <- H.forAll genThreadId
-      SCT.dependent' ds tid1 ta1 tid2 (rewind' ta2)
+      tid2 <- H.forAll genThreadId
+      ta1 <- H.forAll genThreadAction
+      ta2 <- H.forAll (HGen.filter (SCT.dependent ds tid1 ta1 tid2) genThreadAction)
+      case D.rewind ta2 of
+        Just lh -> H.assert (SCT.dependent' ds tid1 ta1 tid2 lh)
+        Nothing -> H.discard
 
-  , testProperty "dependent x y == dependent y x" $
+  , H.testProperty "dependent x y == dependent y x" . H.property $ do
-    \ds tid1 tid2 ta1 ta2 ->
+      ds <- H.forAll genDepState
-      SCT.dependent ds tid1 ta1 tid2 ta2 ==
+      tid1 <- H.forAll genThreadId
-      SCT.dependent ds tid2 ta2 tid1 ta1
+      tid2 <- H.forAll genThreadId
+      ta1 <- H.forAll genThreadAction
+      ta2 <- H.forAll genThreadAction
+      SCT.dependent ds tid1 ta1 tid2 ta2 H.=== SCT.dependent ds tid2 ta2 tid1 ta1
 
-  , testProperty "dependentActions x y == dependentActions y x" $
+  , H.testProperty "dependentActions x y == dependentActions y x" . H.property $ do
-    \ds a1 a2 ->
+      ds <- H.forAll genDepState
-      SCT.dependentActions ds a1 a2 == SCT.dependentActions ds a2 a1
+      a1 <- H.forAll genActionType
+      a2 <- H.forAll genActionType
+      SCT.dependentActions ds a1 a2 H.=== SCT.dependentActions ds a2 a1
   ]
 
 -------------------------------------------------------------------------------
 -- Utils
 
-canRewind :: ThreadAction -> Bool
-canRewind = isJust . D.rewind
-
-rewind' :: ThreadAction -> Lookahead
-rewind' = fromJust . D.rewind
-
 makeCRef :: D.CRefId -> ST.ST t (D.CRef (ST.STRef t) Int)
 makeCRef crid = D.CRef crid <$> ST.newSTRef (M.empty, 0, 42)
 
@@ -177,115 +236,168 @@ eqWB (Mem.WriteBuffer wb1) (Mem.WriteBuffer wb2) = andM (pure (ks1 == ks2) :
       q <- p
       if q then andM ps else pure False
 
+(==>) :: Monad m => Bool -> H.PropertyT m a -> H.PropertyT m a
+False ==> _ = H.discard
+True  ==> p = p
+infixr 0 ==>
+
 -------------------------------------------------------------------------------
--- Typeclass instances
+-- Generators
 
-instance Listable D.ThreadId where
+genThreadId :: H.Gen D.ThreadId
-  tiers = mapT D.ThreadId tiers
+genThreadId = D.ThreadId <$> genId
 
-instance Listable D.CRefId where
+genCRefId :: H.Gen D.CRefId
-  tiers = mapT D.CRefId tiers
+genCRefId = D.CRefId <$> genId
 
-instance Listable D.MVarId where
+genMVarId :: H.Gen D.MVarId
-  tiers = mapT D.MVarId tiers
+genMVarId = D.MVarId <$> genId
 
-instance Listable D.TVarId where
+genTVarId :: H.Gen D.TVarId
-  tiers = mapT D.TVarId tiers
+genTVarId = D.TVarId <$> genId
 
-instance Listable D.Id where
+genId :: H.Gen D.Id
-  tiers = mapT (D.Id Nothing) tiers
+genId = D.Id <$> HGen.maybe genString <*> genSmallInt
 
-instance Listable D.ThreadAction where
+genFailure :: H.Gen D.Failure
-  tiers =
+genFailure = HGen.element $
-       cons1 D.Fork
+  [ D.InternalError
-    \/ cons0 D.MyThreadId
+  , D.Abort
-    \/ cons1 D.GetNumCapabilities
+  , D.Deadlock
-    \/ cons1 D.SetNumCapabilities
+  , D.STMDeadlock
-    \/ cons0 D.Yield
+  , D.IllegalSubconcurrency
-    \/ cons1 D.ThreadDelay
+  ] ++ map D.UncaughtException -- have a few different exception types
-    \/ cons1 D.NewMVar
+  [ E.toException E.Overflow
-    \/ cons2 D.PutMVar
+  , E.toException E.ThreadKilled
-    \/ cons1 D.BlockedPutMVar
+  , E.toException E.NonTermination
-    \/ cons3 D.TryPutMVar
+  ]
-    \/ cons1 D.ReadMVar
-    \/ cons2 D.TryReadMVar
-    \/ cons1 D.BlockedReadMVar
-    \/ cons2 D.TakeMVar
-    \/ cons1 D.BlockedTakeMVar
-    \/ cons3 D.TryTakeMVar
-    \/ cons1 D.NewCRef
-    \/ cons1 D.ReadCRef
-    \/ cons1 D.ReadCRefCas
-    \/ cons1 D.ModCRef
-    \/ cons1 D.ModCRefCas
-    \/ cons1 D.WriteCRef
-    \/ cons2 D.CasCRef
-    \/ cons2 D.CommitCRef
-    \/ cons2 D.STM
-    \/ cons1 D.BlockedSTM
-    \/ cons0 D.Catching
-    \/ cons0 D.PopCatching
-    \/ cons0 D.Throw
-    \/ cons1 D.ThrowTo
-    \/ cons1 D.BlockedThrowTo
-    \/ cons0 D.Killed
-    \/ cons2 D.SetMasking
-    \/ cons2 D.ResetMasking
-    \/ cons0 D.LiftIO
-    \/ cons0 D.Return
-    \/ cons0 D.Stop
-    \/ cons0 D.Subconcurrency
-    \/ cons0 D.StopSubconcurrency
 
-instance Listable D.TAction where
+genWBKey :: H.Gen (D.ThreadId, Maybe D.CRefId)
-  tiers =
+genWBKey = (,) <$> genThreadId <*> HGen.maybe genCRefId
-       cons1 D.TNew
-    \/ cons1 D.TRead
-    \/ cons1 D.TWrite
-    \/ cons0 D.TRetry
-    \/ cons2 D.TOrElse
-    \/ cons0 D.TThrow
-    \/ cons2 D.TCatch
-    \/ cons0 D.TStop
 
-instance Listable E.MaskingState where
+genThreadAction :: H.Gen D.ThreadAction
-  list =
+genThreadAction = HGen.choice
-    [ E.Unmasked
+  [ D.Fork <$> genThreadId
-    , E.MaskedInterruptible
+  , pure D.MyThreadId
-    , E.MaskedUninterruptible
+  , D.GetNumCapabilities <$> genSmallInt
-    ]
+  , D.SetNumCapabilities <$> genSmallInt
+  , pure D.Yield
+  , D.ThreadDelay <$> genSmallInt
+  , D.NewMVar <$> genMVarId
+  , D.PutMVar <$> genMVarId <*> genSmallList genThreadId
+  , D.BlockedPutMVar <$> genMVarId
+  , D.TryPutMVar <$> genMVarId <*> HGen.bool <*> genSmallList genThreadId
+  , D.ReadMVar <$> genMVarId
+  , D.TryReadMVar <$> genMVarId <*> HGen.bool
+  , D.BlockedReadMVar <$> genMVarId
+  , D.TakeMVar <$> genMVarId <*> genSmallList genThreadId
+  , D.BlockedTakeMVar <$> genMVarId
+  , D.TryTakeMVar <$> genMVarId <*> HGen.bool <*> genSmallList genThreadId
+  , D.NewCRef <$> genCRefId
+  , D.ReadCRef <$> genCRefId
+  , D.ReadCRefCas <$> genCRefId
+  , D.ModCRef <$> genCRefId
+  , D.ModCRefCas <$> genCRefId
+  , D.WriteCRef <$> genCRefId
+  , D.CasCRef <$> genCRefId <*> HGen.bool
+  , D.CommitCRef <$> genThreadId <*> genCRefId
+  , D.STM <$> genSmallList genTAction <*> genSmallList genThreadId
+  , D.BlockedSTM <$> genSmallList genTAction
+  , pure D.Catching
+  , pure D.PopCatching
+  , pure D.Throw
+  , D.ThrowTo <$> genThreadId
+  , D.BlockedThrowTo <$> genThreadId
+  , pure D.Killed
+  , D.SetMasking <$> HGen.bool <*> genMaskingState
+  , D.ResetMasking <$> HGen.bool <*> genMaskingState
+  , pure D.LiftIO
+  , pure D.Return
+  , pure D.Stop
+  , pure D.Subconcurrency
+  , pure D.StopSubconcurrency
+  ]
 
-instance Listable D.ActionType where
+genTAction :: H.Gen D.TAction
-  tiers =
+genTAction = HGen.choice
-       cons1 D.UnsynchronisedRead
+  [ D.TNew <$> genTVarId
-    \/ cons1 D.UnsynchronisedWrite
+  , D.TRead <$> genTVarId
-    \/ cons0 D.UnsynchronisedOther
+  , D.TWrite <$> genTVarId
-    \/ cons1 D.PartiallySynchronisedCommit
+  , pure D.TRetry
-    \/ cons1 D.PartiallySynchronisedWrite
+  , HGen.small $ D.TOrElse <$> genSmallList genTAction <*> HGen.maybe (genSmallList genTAction)
-    \/ cons1 D.PartiallySynchronisedModify
+  , pure D.TThrow
-    \/ cons1 D.SynchronisedModify
+  , HGen.small $ D.TCatch <$> genSmallList genTAction <*> HGen.maybe (genSmallList genTAction)
-    \/ cons1 D.SynchronisedRead
+  , pure D.TStop
-    \/ cons1 D.SynchronisedWrite
+  ]
-    \/ cons0 D.SynchronisedOther
 
-instance Listable SCT.DepState where
+genMaskingState :: H.Gen E.MaskingState
-  tiers = mapT (\(a,(b,c)) -> SCT.DepState a b c) (tiers >< tiers >< tiers)
+genMaskingState = HGen.element
+  [ E.Unmasked
+  , E.MaskedInterruptible
+  , E.MaskedUninterruptible
+  ]
 
-instance (Ord k, Listable k, Listable v) => Listable (Map k v) where
+genActionType :: H.Gen D.ActionType
-  tiers = mapT M.fromList tiers
+genActionType = HGen.choice
+  [ genUnsynchronisedActionType
+  , genPartiallySynchronisedActionType
+  , genSynchronisedActionType
+  ]
 
-instance (Ord v, Listable v) => Listable (Set v) where
+genUnsynchronisedActionType :: H.Gen D.ActionType
-  tiers = mapT Set.fromList tiers
+genUnsynchronisedActionType = HGen.choice
+  [ D.UnsynchronisedRead <$> genCRefId
+  , D.UnsynchronisedWrite <$> genCRefId
+  , pure D.UnsynchronisedOther
+  ]
 
-instance Listable D.Failure where
+genPartiallySynchronisedActionType :: H.Gen D.ActionType
-  list =
+genPartiallySynchronisedActionType = HGen.choice
-    [ D.InternalError
+  [ D.PartiallySynchronisedCommit <$> genCRefId
-    , D.Abort
+  , D.PartiallySynchronisedWrite <$> genCRefId
-    , D.Deadlock
+  , D.PartiallySynchronisedModify <$> genCRefId
-    , D.STMDeadlock
+  ]
-    , D.IllegalSubconcurrency
+
-    ] ++ map D.UncaughtException -- have a few different exception types
+genSynchronisedActionType :: H.Gen D.ActionType
-    [ E.toException E.Overflow
+genSynchronisedActionType = HGen.choice
-    , E.toException E.ThreadKilled
+  [ D.SynchronisedModify <$> genCRefId
-    , E.toException E.NonTermination
+  , D.SynchronisedRead <$> genMVarId
-    ]
+  , D.SynchronisedWrite <$> genMVarId
+  , pure D.SynchronisedOther
+  ]
+
+genDepState :: H.Gen SCT.DepState
+genDepState = SCT.DepState
+  <$> genMap genCRefId HGen.bool
+  <*> genSet genMVarId
+  <*> genMap genThreadId genMaskingState
+
+-------------------------------------------------------------------------------
+-- Utility generators
+
+genSmallInt :: H.Gen Int
+genSmallInt = genIntFromTo 0 10
+
+genInt :: H.Gen Int
+genInt = genIntFromTo 0 100
+
+genIntFromTo :: Int -> Int -> H.Gen Int
+genIntFromTo from = HGen.int . HRange.linear from
+
+genMap :: Ord k => H.Gen k -> H.Gen v -> H.Gen (M.Map k v)
+genMap genKey genVal = M.fromList <$> genList ((,) <$> genKey <*> genVal)
+
+genSet :: Ord a => H.Gen a -> H.Gen (Set.Set a)
+genSet gen = Set.fromList <$> genList gen
+
+genString :: H.Gen String
+genString = genSmallList HGen.enumBounded
+
+genList :: H.Gen a -> H.Gen [a]
+genList = genListUpTo 100
+
+genSmallList :: H.Gen a -> H.Gen [a]
+genSmallList = genListUpTo 10
+
+genListUpTo :: Int -> H.Gen a -> H.Gen [a]
+genListUpTo = HGen.list . HRange.linear 0