Skip to content

Commit 91333c3

Browse files
newhoggynewhoggy
authored
Support for property testing (#12)
* Move Effectful.Zoo.Hedgehog.Api.Tasty to Tasty module * New property function and PropertyT type * Replace property and unitTest functions with ToTestTree typeclass * New TestResult type * New MonadAssertion type class * Support for property testing with hedgehog.
1 parent a7733ac commit 91333c3

File tree

12 files changed

+380
-26
lines changed

12 files changed

+380
-26
lines changed

‎components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/HedgehogTest.hs

Lines changed: 12 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,16 @@
1+
{- HLINT ignore "Use camelCase" -}
2+
13
module Effectful.Zoo.Hedgehog.Test.HedgehogTest where
24

5+
import Control.Monad.Trans.Control
36
import Effectful
47
import Effectful.Zoo.Core
5-
import Effectful.Zoo.Log.Dynamic
6-
import Effectful.Zoo.Log.Api.Text
78
import Effectful.Zoo.Hedgehog
9+
import Effectful.Zoo.Hedgehog.Api.Tasty
10+
import Effectful.Zoo.Log.Api.Text
11+
import Effectful.Zoo.Log.Dynamic
812
import HaskellWorks.Prelude
13+
import Hedgehog qualified as H
914

1015
foo :: ()
1116
=> HasCallStack
@@ -20,3 +25,8 @@ test_simple =
2025
jot_ "This is a jot"
2126

2227
foo
28+
29+
property_simple :: PropertyTest
30+
property_simple =
31+
control \runInBase -> do
32+
runInBase H.success

‎components/hedgehog-test/Effectful/Zoo/Hedgehog/Test/PropertySpec.hs

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
{- HLINT ignore "Use camelCase" -}
2+
3+
module Effectful.Zoo.Hedgehog.Test.PropertySpec where
4+
5+
import Effectful.Zoo.Hedgehog.Effect.Run
6+
import HaskellWorks.Prelude
7+
import Hedgehog hiding (property, forAll)
8+
import Hedgehog qualified as H
9+
import Hedgehog.Gen qualified as G
10+
import Hedgehog.Range qualified as R
11+
12+
property_spec :: H.PropertyT IO ()
13+
property_spec = property do
14+
a <- forAll $ G.int (R.linear 0 100)
15+
True === True
16+
a === a
17+
H.success
18+
19+
test_spec :: H.TestT IO ()
20+
test_spec = unit do
21+
True === True
22+
True === True
23+
H.success

‎components/hedgehog-test/Main.hs

Lines changed: 7 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,18 @@
11
module Main where
22

3-
import Effectful.Zoo.Hedgehog (unitTest)
3+
import Effectful.Zoo.Hedgehog.Api.Tasty
44
import Effectful.Zoo.Hedgehog.Test.HedgehogTest (test_simple)
5+
import Effectful.Zoo.Hedgehog.Test.PropertySpec
56
import Test.Tasty (TestTree, defaultMain, testGroup)
67
import HaskellWorks.Prelude
78

89
tests :: TestTree
910
tests =
10-
testGroup "all" [
11-
unitTest "Simple test" test_simple
12-
]
11+
testGroup "all"
12+
[ toTestTree "Simple test" test_simple
13+
, toTestTree "Simple property spec" property_spec
14+
, toTestTree "Simple test spec" test_spec
15+
]
1316

1417
main :: IO ()
1518
main =

‎components/hedgehog/Effectful/Zoo/Hedgehog/Api/MonadAssertion.hs

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
module Effectful.Zoo.Hedgehog.Api.MonadAssertion
2+
( MonadAssertion(..),
3+
tryAssertion,
4+
tryExceptAssertion,
5+
) where
6+
7+
import Control.Monad.Catch (MonadCatch(..))
8+
import Control.Monad.Catch qualified as C
9+
import Control.Monad.Trans.Class
10+
import Control.Monad.Trans.Except qualified as E
11+
import Control.Monad.Trans.Resource qualified as IO
12+
import Control.Monad.Trans.Resource.Internal qualified as IO
13+
import Effectful.Zoo.Hedgehog.Data.TestResult
14+
import HaskellWorks.Prelude
15+
import Hedgehog.Internal.Property qualified as H
16+
17+
class Monad m => MonadAssertion m where
18+
throwAssertion :: H.Failure -> m a
19+
catchAssertion :: m a -> (H.Failure -> m a) -> m a
20+
21+
instance Monad m => MonadAssertion (H.TestT m) where
22+
throwAssertion f = H.liftTest $ H.mkTest (Left f, mempty)
23+
catchAssertion g h = H.TestT $ E.catchE (H.unTest g) (H.unTest . h)
24+
25+
instance MonadAssertion m => MonadAssertion (IO.ResourceT m) where
26+
throwAssertion = lift . throwAssertion
27+
catchAssertion r h = IO.ResourceT $ \i -> IO.unResourceT r i `catchAssertion` \e -> IO.unResourceT (h e) i
28+
29+
deriving newtype instance Monad m => MonadAssertion (H.PropertyT m)
30+
31+
tryAssertion :: ()
32+
=> MonadAssertion m
33+
=> m a
34+
-> m (Either H.Failure a)
35+
tryAssertion m =
36+
catchAssertion (Right <$> m) (pure . Left)
37+
38+
tryExceptAssertion :: ()
39+
=> MonadAssertion m
40+
=> MonadCatch m
41+
=> m a
42+
-> m (TestResult a)
43+
tryExceptAssertion m =
44+
tryAssertion (C.try m) >>= \case
45+
Right (Right a) -> pure $ TestResult a
46+
Right (Left e) -> pure $ TestError e
47+
Left f -> pure $ TestFailure f

‎components/hedgehog/Effectful/Zoo/Hedgehog/Api/Run.hs

Lines changed: 1 addition & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,5 @@
11
module Effectful.Zoo.Hedgehog.Api.Run
2-
( UnitTest,
3-
4-
hedgehog,
5-
unitTest,
2+
( hedgehog,
63
) where
74

85
import Control.Monad.Trans.Writer.Lazy qualified as MTL
@@ -15,14 +12,9 @@ import Effectful.Zoo.Hedgehog.Api.Journal
1512
import Effectful.Zoo.Hedgehog.Dynamic
1613
import Effectful.Zoo.Log.Dynamic
1714
import HaskellWorks.Prelude
18-
import Hedgehog (TestT)
1915
import Hedgehog qualified as H
2016
import Hedgehog.Internal.Property (Failure, Journal)
2117
import Hedgehog.Internal.Property qualified as H
22-
import Test.Tasty (TestName, TestTree)
23-
import Test.Tasty.Hedgehog (testProperty)
24-
25-
type UnitTest = TestT IO ()
2618

2719
hedgehog :: forall a. ()
2820
=> Eff
@@ -44,10 +36,3 @@ hedgehog f =
4436
& MTL.WriterT
4537
& ExceptT
4638
& H.TestT
47-
48-
unitTest :: ()
49-
=> TestName
50-
-> UnitTest
51-
-> TestTree
52-
unitTest desc =
53-
testProperty desc . H.withTests 1 . H.property . H.test

‎components/hedgehog/Effectful/Zoo/Hedgehog/Api/Tasty.hs

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
module Effectful.Zoo.Hedgehog.Api.Tasty
2+
( PropertyTest,
3+
UnitTest,
4+
5+
ToTestTree(..),
6+
) where
7+
8+
import HaskellWorks.Prelude
9+
import Hedgehog (PropertyT, TestT)
10+
import Hedgehog qualified as H
11+
import Test.Tasty (TestName, TestTree)
12+
import Test.Tasty.Hedgehog (testProperty)
13+
14+
type PropertyTest = PropertyT IO ()
15+
16+
type UnitTest = TestT IO ()
17+
18+
class ToTestTree a where
19+
toTestTree :: TestName -> a -> TestTree
20+
21+
instance ToTestTree (PropertyT IO ()) where
22+
toTestTree desc =
23+
testProperty desc . H.property
24+
25+
instance ToTestTree (TestT IO ()) where
26+
toTestTree desc =
27+
testProperty desc . H.withTests 1 . H.property . H.test

‎components/hedgehog/Effectful/Zoo/Hedgehog/Data/TestResult.hs

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
module Effectful.Zoo.Hedgehog.Data.TestResult
2+
( TestResult(..),
3+
) where
4+
5+
import HaskellWorks.Prelude
6+
import Hedgehog.Internal.Property qualified as H
7+
8+
data TestResult a
9+
= TestResult a
10+
| TestFailure H.Failure
11+
| TestError SomeException

‎components/hedgehog/Effectful/Zoo/Hedgehog/Dynamic.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ data Hedgehog :: Effect where
3636

3737
type instance DispatchOf Hedgehog = Dynamic
3838

39-
instance (r <: Hedgehog) => MonadTest (Eff r) where
39+
instance {-# OVERLAPS #-} (r <: Hedgehog) => MonadTest (Eff r) where
4040
liftTest t = send $ LiftTest t
4141

4242
runHedgehogIO :: forall a. ()

‎components/hedgehog/Effectful/Zoo/Hedgehog/Effect/Hedgehog.hs

Lines changed: 77 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
{- HLINT ignore "Eta reduce" -}
2+
3+
{-# OPTIONS_GHC -Wno-orphans #-}
4+
5+
module Effectful.Zoo.Hedgehog.Effect.Hedgehog
6+
( Hedgehog,
7+
HedgehogEnv(..),
8+
runHedgehogProperty,
9+
runHedgehogUnit,
10+
) where
11+
12+
import Control.Concurrent.STM qualified as IO
13+
import Control.Monad
14+
import Control.Monad.Catch (MonadThrow(..))
15+
import Effectful
16+
import Effectful.Concurrent
17+
import Effectful.Concurrent.STM
18+
import Effectful.Dispatch.Static
19+
import Effectful.Zoo.Core.Error.Static
20+
import Effectful.Zoo.Core
21+
import Effectful.Zoo.Hedgehog.Api.MonadAssertion
22+
import Effectful.Zoo.Hedgehog.Data.TestResult
23+
import HaskellWorks.Prelude
24+
import Hedgehog (MonadTest(..))
25+
import Hedgehog qualified as H
26+
import Hedgehog.Internal.Property qualified as H
27+
28+
-- | An effect for interacting with the filesystem.
29+
data Hedgehog :: Effect
30+
31+
type instance DispatchOf Hedgehog = Static WithSideEffects
32+
newtype instance StaticRep Hedgehog = Hedgehog HedgehogEnv
33+
34+
data HedgehogEnv
35+
= PropertyEnv (TMVar (H.PropertyT IO ()))
36+
| UnitTestEnv (TMVar (H.TestT IO ()))
37+
38+
instance {-# OVERLAPS #-}
39+
( r <: Concurrent
40+
, r <: Error H.Failure
41+
, r <: Hedgehog
42+
) => MonadTest (Eff r) where
43+
liftTest f = do
44+
Hedgehog env <- getStaticRep
45+
mvA <- newEmptyTMVarIO
46+
case env of
47+
PropertyEnv mvAction ->
48+
atomically $ putTMVar mvAction (tryExceptAssertion (liftTest f) >>= liftIO . IO.atomically . IO.putTMVar mvA)
49+
UnitTestEnv mvAction ->
50+
atomically $ putTMVar mvAction (tryExceptAssertion (liftTest f) >>= liftIO . IO.atomically . IO.putTMVar mvA)
51+
testResult <- atomically $ takeTMVar mvA
52+
getTestResult testResult
53+
54+
getTestResult :: ()
55+
=> r <: Error H.Failure
56+
=> TestResult a
57+
-> Eff r a
58+
getTestResult = \case
59+
TestResult a -> pure a
60+
TestFailure f -> throw f
61+
TestError e -> throwM e
62+
63+
runHedgehogProperty :: ()
64+
=> r <: IOE
65+
=> TMVar (H.PropertyT IO ())
66+
-> Eff (Hedgehog : r) a
67+
-> Eff r a
68+
runHedgehogProperty tvAction =
69+
evalStaticRep (Hedgehog (PropertyEnv tvAction))
70+
71+
runHedgehogUnit :: ()
72+
=> r <: IOE
73+
=> TMVar (H.TestT IO ())
74+
-> Eff (Hedgehog : r) a
75+
-> Eff r a
76+
runHedgehogUnit tvAction =
77+
evalStaticRep (Hedgehog (UnitTestEnv tvAction))

‎components/hedgehog/Effectful/Zoo/Hedgehog/Effect/HedgehogGen.hs

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
{- HLINT ignore "Eta reduce" -}
2+
3+
{-# OPTIONS_GHC -Wno-orphans #-}
4+
5+
module Effectful.Zoo.Hedgehog.Effect.HedgehogGen
6+
( HedgehogGen,
7+
HedgehogGenEnv(..),
8+
askHedgehogGenEnv,
9+
runHedgehogGenProperty,
10+
) where
11+
12+
import Effectful
13+
import Effectful.Concurrent.STM
14+
import Effectful.Dispatch.Static
15+
import Effectful.Zoo.Core
16+
import HaskellWorks.Prelude
17+
import Hedgehog qualified as H
18+
19+
-- | An effect for interacting with the filesystem.
20+
data HedgehogGen :: Effect
21+
22+
type instance DispatchOf HedgehogGen = Static WithSideEffects
23+
newtype instance StaticRep HedgehogGen = HedgehogGen HedgehogGenEnv
24+
25+
newtype HedgehogGenEnv
26+
= HedgehogGenEnv (TMVar (H.PropertyT IO ()))
27+
28+
askHedgehogGenEnv :: ()
29+
=> r <: HedgehogGen
30+
=> Eff r HedgehogGenEnv
31+
askHedgehogGenEnv = do
32+
HedgehogGen env <- getStaticRep
33+
pure env
34+
35+
runHedgehogGenProperty :: ()
36+
=> r <: IOE
37+
=> TMVar (H.PropertyT IO ())
38+
-> Eff (HedgehogGen : r) a
39+
-> Eff r a
40+
runHedgehogGenProperty tvAction =
41+
evalStaticRep (HedgehogGen (HedgehogGenEnv tvAction))

0 commit comments

Comments
 (0)