barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-26 23:13:48 +03:00
Code Issues Projects Releases Wiki Activity

Replace QuickCheck tests with Hedgehog ones

Browse Source
This commit is contained in:
Michael Walker 2018-02-15 11:34:24 +00:00
parent 5cdbc7acad
commit 2fd9e9aae7
6 changed files with 270 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
dejafu-tests/dejafu-tests.cabal
View File

@ -53,12 +53,11 @@ library
, hedgehog
, mtl
, mwc-random
, QuickCheck
, random
, tasty
, tasty-expected-failure
, tasty-dejafu
, tasty-hedgehog
, tasty-quickcheck
, vector
if impl(ghc < 8.0.1)
build-depends: transformers
@ -72,7 +71,6 @@ executable dejafu-tests
build-depends: base
, dejafu-tests
, tasty
, tasty-quickcheck
hs-source-dirs: exe
default-language: Haskell2010
ghc-options: -Wall -threaded -rtsopts

17
dejafu-tests/exe/Main.hs
View File

@ -1,18 +1,17 @@
module Main where
import qualified Test.Tasty as T
import qualified Test.Tasty.Options as T
import qualified Test.Tasty.QuickCheck as T
import qualified Test.Tasty as T
import qualified Test.Tasty.Options as T
import qualified Examples as E
import qualified Integration as I
import qualified Unit as U
import qualified Examples as E
import qualified Integration as I
import qualified Unit as U
main :: IO ()
main =
let ingredients = T.includingOptions options : T.defaultIngredients
runner = T.defaultMainWithIngredients ingredients
in runner (T.adjustOption reduceQCTests tests)
in runner tests
tests :: T.TestTree
tests = T.testGroup "Tests"
@ -23,7 +22,3 @@ tests = T.testGroup "Tests"
options :: [T.OptionDescription]
options = U.options ++ I.options ++ E.options
-- | Reduce the default number of quickcheck runs.
reduceQCTests :: T.QuickCheckTests -> T.QuickCheckTests
reduceQCTests (T.QuickCheckTests n) = T.QuickCheckTests (min 25 n)

53
dejafu-tests/lib/Common.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE GADTs #-}
module Common (module Common, module Test.Tasty.DejaFu, T.TestTree) where
module Common (module Common, module Test.Tasty.DejaFu, T.TestTree, T.expectFail) where
import Control.Exception (ArithException, ArrayException,
SomeException, displayException)
@ -9,6 +9,8 @@ import qualified Control.Monad.Catch as C
import Control.Monad.Conc.Class
import Control.Monad.IO.Class (liftIO)
import Control.Monad.STM.Class
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Hedgehog as H
import qualified Hedgehog.Gen as HGen
import qualified Hedgehog.Range as HRange
@ -23,6 +25,7 @@ import Test.DejaFu.Types
import Test.DejaFu.Utils
import qualified Test.Tasty as T
import Test.Tasty.DejaFu hiding (testProperty)
import qualified Test.Tasty.ExpectedFailure as T
import qualified Test.Tasty.Hedgehog as H
-------------------------------------------------------------------------------
@ -90,8 +93,8 @@ alwaysFailsWith p = alwaysTrue (either p (const False))
prop_dep_fun :: (Eq a, Show a) => ConcIO a -> H.Property
prop_dep_fun conc = H.property $ do
mem <- H.forAll HGen.enumBounded
seed <- H.forAll $ HGen.int (HRange.linear 0 100)
fs <- H.forAll $ HGen.list (HRange.linear 0 100) HGen.bool
seed <- H.forAll genInt
fs <- H.forAll $ genList HGen.bool
(efa1, tids1, efa2, tids2) <- liftIO $ runNorm seed (shuffle fs) mem
H.footnote (" to: " ++ show tids2)
@ -139,6 +142,50 @@ catchArrayException = C.catch
catchSomeException :: C.MonadCatch m => m a -> (SomeException -> m a) -> m a
catchSomeException = C.catch
-------------------------------------------------------------------------------
-- 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 (Map.Map k v)
genMap genKey genVal = HGen.map (HRange.linear 0 100) ((,) <$> genKey <*> genVal)
genSmallMap :: Ord k => H.Gen k -> H.Gen v -> H.Gen (Map.Map k v)
genSmallMap genKey genVal = HGen.map (HRange.linear 0 10) ((,) <$> genKey <*> genVal)
genSet :: Ord a => H.Gen a -> H.Gen (Set.Set a)
genSet = HGen.set (HRange.linear 0 100)
genSmallSet :: Ord a => H.Gen a -> H.Gen (Set.Set a)
genSmallSet = HGen.set (HRange.linear 0 10)
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
type Function k v = (v, Map.Map k v)
genFunction :: Ord k => H.Gen k -> H.Gen v -> H.Gen (Function k v)
genFunction genKey genVal = (,) <$> genVal <*> genSmallMap genKey genVal
applyFunction :: Ord k => (v, Map.Map k v) -> k -> v
applyFunction (def, assocs) k = Map.findWithDefault def k assocs
-------------------------------------------------------------------------------
-- Utilities

82
dejafu-tests/lib/Examples.hs
View File

@ -1,6 +1,15 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Examples 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 Examples.AutoUpdate as A
import qualified Examples.ClassLaws as C
@ -13,7 +22,7 @@ import Common
-- | Run all the example tests.
tests :: [TestTree]
tests =
tests = map applyHedgehogOptions
[ testGroup "AutoUpdate" A.tests
, testGroup "ClassLaws" C.tests
, testGroup "Logger" L.tests
@ -24,4 +33,71 @@ tests =
-- | Tasty options
options :: [OptionDescription]
options = []
options =
[ Option (Proxy :: Proxy ExampleHedgehogTestLimit)
, Option (Proxy :: Proxy ExampleHedgehogDiscardLimit)
, Option (Proxy :: Proxy ExampleHedgehogShrinkLimit)
, Option (Proxy :: Proxy ExampleHedgehogShrinkRetries)
]
-------------------------------------------------------------------------------
-- Hedgehog options
-- | The number of successful test cases required before Hedgehog will pass a test
newtype ExampleHedgehogTestLimit = ExampleHedgehogTestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
instance IsOption ExampleHedgehogTestLimit where
defaultValue = 25
parseValue = fmap ExampleHedgehogTestLimit . readMaybe
optionName = pure "example-hedgehog-tests"
optionHelp = pure "hedgehog-tests for the example tests"
-- | The number of discarded cases allowed before Hedgehog will fail a test
newtype ExampleHedgehogDiscardLimit = ExampleHedgehogDiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
instance IsOption ExampleHedgehogDiscardLimit where
defaultValue =
let HedgehogDiscardLimit d = defaultValue
in fromIntegral d
parseValue = fmap ExampleHedgehogDiscardLimit . readMaybe
optionName = pure "example-hedgehog-discards"
optionHelp = pure "hedgehog-discards for the example tests"
-- | The number of shrinks allowed before Hedgehog will fail a test
newtype ExampleHedgehogShrinkLimit = ExampleHedgehogShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
instance IsOption ExampleHedgehogShrinkLimit where
defaultValue =
let HedgehogShrinkLimit d = defaultValue
in fromIntegral d
parseValue = fmap ExampleHedgehogShrinkLimit . readMaybe
optionName = pure "example-hedgehog-shrinks"
optionHelp = pure "hedgehog-shrinks for the example tests"
-- | The number of times to re-run a test during shrinking
newtype ExampleHedgehogShrinkRetries = ExampleHedgehogShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
instance IsOption ExampleHedgehogShrinkRetries where
defaultValue =
let HedgehogShrinkRetries d = defaultValue
in fromIntegral d
parseValue = fmap ExampleHedgehogShrinkRetries . readMaybe
optionName = pure "example-hedgehog-retries"
optionHelp = pure "hedgehog-retries for the example tests"
-- | Apply the Hedgehog options.
applyHedgehogOptions :: TestTree -> TestTree
applyHedgehogOptions tt0 =
askOption $ \(ExampleHedgehogTestLimit tl) ->
askOption $ \(ExampleHedgehogDiscardLimit dl) ->
askOption $ \(ExampleHedgehogShrinkLimit sl) ->
askOption $ \(ExampleHedgehogShrinkRetries sr) ->
localOption (fromIntegral tl :: HedgehogTestLimit) $
localOption (fromIntegral dl :: HedgehogDiscardLimit) $
localOption (fromIntegral sl :: HedgehogShrinkLimit) $
localOption (fromIntegral sr :: HedgehogShrinkRetries) tt0

259
dejafu-tests/lib/Examples/ClassLaws.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
-- | Typeclass laws for @Concurrently@ from the async package.
@ -10,20 +9,24 @@ import Control.Exception (SomeException)
import Control.Monad (ap, forever, liftM, (>=>))
import Control.Monad.Catch (onException)
import Control.Monad.Conc.Class
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Maybe (isJust)
import Data.Set (fromList)
import qualified Hedgehog as H
import Test.DejaFu (defaultBounds, defaultMemType)
import Test.DejaFu.Conc (ConcIO)
import Test.DejaFu.SCT (sctBound)
import Test.QuickCheck (Arbitrary(..), Property, monomorphic)
import qualified Test.QuickCheck as QC
import Test.QuickCheck.Function (Fun, apply)
import Test.QuickCheck.Monadic (assert, monadicIO, run)
import Test.Tasty.QuickCheck (testProperty)
import qualified Test.Tasty.Hedgehog as H
import Common
-- Tests at bottom of file due to Template Haskell silliness.
tests :: [TestTree]
tests =
[ testGroup "Functor" functorProps
, testGroup "Applicative" applicativeProps
, testGroup "Monad" monadProps
, testGroup "Alternative" alternativeProps
]
--------------------------------------------------------------------------------
@ -44,13 +47,18 @@ type C = Concurrently ConcIO
instance MonadConc m => Functor (Concurrently m) where
fmap f (Concurrently a) = Concurrently $ f <$> a
-- fmap id a = a
prop_functor_id :: Ord a => C a -> Property
prop_functor_id ca = ca `eq` fmap id ca
functorProps :: [TestTree]
functorProps = toTestList
[ H.testProperty "fmap id a = a" . H.property $ do
(cval -> ca) <- H.forAll genA
H.assert =<< ca `eq` fmap id ca
-- fmap f . fmap g = fmap (f . g)
prop_functor_comp :: Ord c => C a -> Fun a b -> Fun b c -> Property
prop_functor_comp ca (apply -> f) (apply -> g) = (g . f <$> ca) `eq` (g <$> (f <$> ca))
, H.testProperty "fmap f . fmap g = fmap (f . g)" . H.property $ do
(cval -> ca) <- H.forAll genA
(fun -> f) <- H.forAll genFun
(fun -> g) <- H.forAll genFun
H.assert =<< (g . f <$> ca) `eq` (g <$> (f <$> ca))
]
--------------------------------------------------------------------------------
-- Applicative
@ -60,28 +68,37 @@ instance MonadConc m => Applicative (Concurrently m) where
Concurrently fs <*> Concurrently as = Concurrently $ (\(f, a) -> f a) <$> concurrently fs as
-- pure id <*> a = a
prop_applicative_id :: Ord a => C a -> Property
prop_applicative_id ca = ca `eq` (pure id <*> ca)
applicativeProps :: [TestTree]
applicativeProps =
[ H.testProperty "pure id <*> a = a" . H.property $ do
(cval -> ca) <- H.forAll genA
H.assert =<< ca `eq` (pure id <*> ca)
-- pure f <*> pure x = pure (f x)
prop_applicative_homo :: Ord b => a -> Fun a b -> Property
prop_applicative_homo a (apply -> f) = pure (f a) `eq` (pure f <*> pure a)
, H.testProperty "pure f <*> pure x = pure (f x)" . H.property $ do
(fun -> f) <- H.forAll genFun
a <- H.forAll genA
H.assert =<< pure (f a) `eq` (pure f <*> pure a)
-- u <*> pure y = pure ($ y) <*> u
prop_applicative_inter :: Ord b => C (Fun a b) -> a -> Property
prop_applicative_inter u y = (u' <*> pure y) `eq` (pure ($ y) <*> u') where
u' = apply <$> u
, H.testProperty "u <*> pure y = pure ($ y) <*> u" . H.property $ do
(cfun -> u) <- H.forAll genFun
y <- H.forAll genA
H.assert =<< (u <*> pure y) `eq` (pure ($ y) <*> u)
-- u <*> (v <*> w) = pure (.) <*> u <*> v <*> w
prop_applicative_comp :: Ord c => C (Fun b c) -> C (Fun a b) -> C a -> Property
prop_applicative_comp u v w = (u' <*> (v' <*> w)) `eq` (pure (.) <*> u' <*> v' <*> w) where
u' = apply <$> u
v' = apply <$> v
, testGroup "u <*> (v <*> w) = pure (.) <*> u <*> v <*> w"
[ H.testProperty "Without races" . H.property $ do
(cfun -> u) <- H.forAll genFun
(cfun -> v) <- H.forAll genFun
(cval -> w) <- H.forAll genA
H.assert =<< (u <*> (v <*> w)) `eq` (pure (.) <*> u <*> v <*> w)
-- f <$> x = pure f <*> x
prop_applicative_fmap :: Ord b => Fun a b -> C a -> Property
prop_applicative_fmap (apply -> f) a = (f <$> a) `eq` (pure f <*> a)
-- todo: H.testProperty "With races" ...
]
, H.testProperty "f <$> x = pure f <*> x" . H.property $ do
(fun -> f) <- H.forAll genFun
(cval -> a) <- H.forAll genA
H.assert =<< (f <$> a) `eq` (pure f <*> a)
]
--------------------------------------------------------------------------------
-- Monad
@ -91,39 +108,52 @@ instance MonadConc m => Monad (Concurrently m) where
Concurrently a >>= f = Concurrently $ a >>= runConcurrently . f
-- return >=> f = f
prop_monad_left_id :: Ord b => Fun a (C b) -> a -> Property
prop_monad_left_id (apply -> f) = f `eqf` (return >=> f)
monadProps :: [TestTree]
monadProps =
[ H.testProperty "return >=> f = f" . H.property $ do
(func -> f) <- H.forAll genFun
a <- H.forAll genA
H.assert =<< f a `eq` (return >=> f) a
-- f >=> return = f
prop_monad_right_id :: Ord b => Fun a (C b) -> a -> Property
prop_monad_right_id (apply -> f) = f `eqf` (f >=> return)
, H.testProperty "f >=> return = f" . H.property $ do
(func -> f) <- H.forAll genFun
a <- H.forAll genA
H.assert =<< f a `eq` (f >=> return) a
-- (f >=> g) >=> h = f >=> (g >=> h)
prop_monad_assoc :: Ord d => Fun a (C b) -> Fun b (C c) -> Fun c (C d) -> a -> Property
prop_monad_assoc (apply -> f) (apply -> g) (apply -> h) = ((f >=> g) >=> h) `eqf` (f >=> (g >=> h))
, H.testProperty "(f >=> g) >=> h = f >=> (g >=> h)" . H.property $ do
(func -> f) <- H.forAll genFun
(func -> g) <- H.forAll genFun
(func -> h) <- H.forAll genFun
a <- H.forAll genA
H.assert =<< ((f >=> g) >=> h) a `eq` (f >=> (g >=> h)) a
-- f <$> a = f `liftM` a
prop_monad_fmap :: Ord b => Fun a b -> C a -> Property
prop_monad_fmap (apply -> f) a = (f <$> a) `eq` (f `liftM` a)
, H.testProperty "f <$> a = f `liftM` a" . H.property $ do
(fun -> f) <- H.forAll genFun
(cval -> a) <- H.forAll genA
H.assert =<< (f <$> a) `eq` (f `liftM` a)
-- return = pure
prop_monad_pure :: Ord a => a -> Property
prop_monad_pure = pure `eqf` return
, H.testProperty "return = pure" . H.property $ do
a <- H.forAll genA
H.assert =<< pure a `eq` return a
-- (<*>) = ap
prop_monad_ap :: Ord b => Fun a b -> a -> Property
prop_monad_ap (apply -> f) a = (pure f <*> pure a) `eq` (return f `ap` return a)
, testGroup "(<*>) = ap"
[ H.testProperty "Without races" . H.property $ do
(fun -> f) <- H.forAll genFun
a <- H.forAll genA
H.assert =<< (pure f <*> pure a) `eq` (return f `ap` return a)
-- (<*>) = ap, side-effect-testing version
prop_monad_ap' :: forall a b. Ord b => Fun a b -> Fun a b -> a -> Property
prop_monad_ap' (apply -> f) (apply -> g) a = go (<*>) `eq'` go ap where
go :: (C (a -> b) -> C a -> C b) -> ConcIO b
go combine = do
var <- newEmptyMVar
let cf = do { res <- tryTakeMVar var; pure $ if isJust res then f else g }
let ca = do { putMVar var (); pure a }
runConcurrently $ Concurrently cf `combine` Concurrently ca
, expectFail . H.testProperty "With races" . H.property $ do
(fun -> f1) <- H.forAll genFun
(fun -> f2) <- H.forAll genFun
a <- H.forAll genA
let go combine = do
var <- newEmptyMVar
let cf = do { res <- tryTakeMVar var; pure $ if isJust res then f1 else f2 }
let ca = do { putMVar var (); pure a }
runConcurrently $ Concurrently cf `combine` Concurrently ca
H.assert =<< go (<*>) `eq'` go ap
]
]
--------------------------------------------------------------------------------
-- Alternative
@ -134,43 +164,39 @@ instance MonadConc m => Alternative (Concurrently m) where
Concurrently as <|> Concurrently bs =
Concurrently $ either id id <$> race as bs
-- x <|> (y <|> z) = (x <|> y) <|> z
prop_alternative_assoc :: Ord a => C a -> C a -> C a -> Property
prop_alternative_assoc x y z = (x <|> (y <|> z)) `eq` ((x <|> y) <|> z)
alternativeProps :: [TestTree]
alternativeProps =
[ testGroup "x <|> (y <|> z) = (x <|> y) <|> z"
[ H.testProperty "Without races" . H.property $ do
(cval -> x) <- H.forAll genA
(cval -> y) <- H.forAll genA
(cval -> z) <- H.forAll genA
H.assert =<< (x <|> (y <|> z)) `eq` ((x <|> y) <|> z)
-- x = x <|> empty
prop_alternative_right_id :: Ord a => C a -> Property
prop_alternative_right_id x = x `eq` (x <|> empty)
-- todo: H.testProperty "With races" ...
]
-- x = empty <|> x
prop_alternative_left_id :: Ord a => C a -> Property
prop_alternative_left_id x = x `eq` (empty <|> x)
, H.testProperty "x = x <|> empty" . H.property $ do
(cval -> x) <- H.forAll genA
H.assert =<< x `eq` (x <|> empty)
, H.testProperty "x = empty <|> x" . H.property $ do
(cval -> x) <- H.forAll genA
H.assert =<< x `eq` (empty <|> x)
]
--------------------------------------------------------------------------------
-- Stuff for testing
instance Show (Concurrently m a) where
show _ = "<concurrently>"
instance (Arbitrary a, Applicative m) => Arbitrary (Concurrently m a) where
arbitrary = Concurrently . pure <$> arbitrary
instance Monoid Integer where
mempty = 0
mappend = (+)
eq :: Ord a => C a -> C a -> Property
eq :: (MonadIO m, Ord a) => C a -> C a -> m Bool
eq left right = runConcurrently left `eq'` runConcurrently right
eq' :: forall a. Ord a => ConcIO a -> ConcIO a -> Property
eq' left right = monadicIO $ do
leftTraces <- run $ sctBound defaultMemType defaultBounds left
rightTraces <- run $ sctBound defaultMemType defaultBounds right
eq' :: (MonadIO m, Ord a) => ConcIO a -> ConcIO a -> m Bool
eq' left right = liftIO $ do
leftTraces <- sctBound defaultMemType defaultBounds left
rightTraces <- sctBound defaultMemType defaultBounds right
let toSet = fromList . map fst
assert (toSet leftTraces == toSet rightTraces)
eqf :: Ord b => (a -> C b) -> (a -> C b) -> a -> Property
eqf left right a = left a `eq` right a
pure (toSet leftTraces == toSet rightTraces)
--------------------------------------------------------------------------------
-- Stuff copied from async
@ -214,47 +240,24 @@ race left right = concurrently' left right collect where
Left ex -> throw ex
Right r -> pure r
--------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Hedgehog generators
return []
genA :: H.Gen Int
genA = genSmallInt
-- QuickChecking the Applicative composition and Alternative
-- associativity laws is really slow to run every time, sadly. I have
-- done all I can think of for now to cut down the number of
-- executions tried, they give rise to something on the order of 10000
-- or so executions (100 sets of random inputs, 2 computations per
-- test, 40 to 50 schedules for each computation)
--
-- I expect a large portion of it is due to the exception handling,
-- which is admittedly rather heavy-handed right now. There's got to
-- be some better way than just having all exceptions be dependent
-- with everything ever, except Stop.
genFun :: H.Gen (Function Int Int)
genFun = genFunction genA genA
tests :: [TestTree]
tests =
[ testGroup "Functor Laws"
[ testProperty "identity" $(monomorphic 'prop_functor_id)
, testProperty "composition" $(monomorphic 'prop_functor_comp)
]
, testGroup "Applicative Laws"
[ testProperty "identity" $(monomorphic 'prop_applicative_id)
, testProperty "homomorphism" $(monomorphic 'prop_applicative_homo)
, testProperty "interchange" $(monomorphic 'prop_applicative_inter)
, testProperty "composition" $(monomorphic 'prop_applicative_comp)
, testProperty "fmap" $(monomorphic 'prop_applicative_fmap)
]
, testGroup "Monad Laws"
[ testProperty "left identity" $(monomorphic 'prop_monad_left_id)
, testProperty "right identity" $(monomorphic 'prop_monad_right_id)
, testProperty "associativity" $(monomorphic 'prop_monad_assoc)
, testProperty "fmap" $(monomorphic 'prop_monad_fmap)
, testProperty "pure" $(monomorphic 'prop_monad_pure)
, testProperty "ap" $(monomorphic 'prop_monad_ap)
, testProperty "ap (side effects)" $ QC.expectFailure $(monomorphic 'prop_monad_ap')
]
, testGroup "Alternative Laws"
[ testProperty "left identity" $(monomorphic 'prop_alternative_left_id)
, testProperty "right identity" $(monomorphic 'prop_alternative_right_id)
--, testProperty "associativity" $(monomorphic 'prop_alternative_assoc)
]
]
-- for viewpatterns
fun :: Ord a => Function a b -> a -> b
fun = applyFunction
cfun :: Ord a => Function a b -> C (a -> b)
cfun = pure . applyFunction
func :: Ord a => Function a b -> a -> C b
func = fmap pure . applyFunction
cval :: a -> C a
cval = pure

37
dejafu-tests/lib/Unit/Properties.hs
View File

@ -7,7 +7,6 @@ import qualified Control.Monad.ST as ST
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Sequence as S
import qualified Data.Set as Set
import qualified Data.STRef as ST
import qualified Hedgehog as H
import qualified Hedgehog.Gen as HGen
@ -368,36 +367,6 @@ genSynchronisedActionType = HGen.choice
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
<$> genSmallMap genCRefId HGen.bool
<*> genSmallSet genMVarId
<*> genSmallMap genThreadId genMaskingState