From f1424bf0c5243df87349e40d9344376d7ac4e524 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Fri, 3 Dec 2021 00:25:37 +0000 Subject: [PATCH] Drop dependency on tasty (#46) * Switch to ghc-8.10.7 resolver * Drop tasty * Drop hie.yaml * Update cabal file --- hie.yaml | 2 - selective.cabal | 4 +- stack.yaml | 7 +- test/Main.hs | 320 ++++++++++++++++++++++++++---------------------- test/Test.hs | 44 +++++++ 5 files changed, 226 insertions(+), 151 deletions(-) delete mode 100644 hie.yaml create mode 100644 test/Test.hs diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index c68add3..0000000 --- a/hie.yaml +++ /dev/null @@ -1,2 +0,0 @@ -cradle: - stack: diff --git a/selective.cabal b/selective.cabal index 3ef27a9..6ed4259 100644 --- a/selective.cabal +++ b/selective.cabal @@ -65,6 +65,7 @@ test-suite test Sketch, Teletype, Teletype.Rigid, + Test, Validation type: exitcode-stdio-1.0 main-is: Main.hs @@ -72,9 +73,6 @@ test-suite test containers >= 0.5.5.1 && < 0.7, QuickCheck >= 2.8 && < 2.15, selective, - tasty >= 0.11, - tasty-expected-failure >= 0.11, - tasty-quickcheck >= 0.8.4, transformers >= 0.4.2.0 && < 0.6 default-language: Haskell2010 ghc-options: -Wall diff --git a/stack.yaml b/stack.yaml index 9bbcc7d..809ab94 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1,6 @@ -resolver: lts-18.0 +resolver: ghc-8.10.7 + +extra-deps: + - QuickCheck-2.14.2@sha256:4ce29211223d5e6620ebceba34a3ca9ccf1c10c0cf387d48aea45599222ee5aa,7736 + - random-1.2.1@sha256:8bee24dc0c985a90ee78d94c61f8aed21c49633686f0f1c14c5078d818ee43a2,6598 + - splitmix-0.1.0.4@sha256:714a55fd28d3e2533bd5b49e74f604ef8e5d7b06f249c8816f6c54aed431dcf1,6483 diff --git a/test/Main.hs b/test/Main.hs index 087d454..da3cfe1 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -6,353 +6,383 @@ import Control.Selective import Data.Functor.Identity import Data.Maybe hiding (maybe) import Prelude hiding (maybe) -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.QuickCheck hiding (Success, Failure) import Build import Laws import Validation +import Test + import qualified Control.Selective.Free as F import qualified Control.Selective.Rigid.Free as FR import qualified Teletype as F import qualified Teletype.Rigid as FR main :: IO () -main = defaultMain $ testGroup "Tests" - [pingPong, build, over, under, validation, arrowMonad, maybe, identity, writer] +main = runTests $ testGroup "Tests" + [ pingPong + , build + , over + , under + , validation + , arrowMonad + , maybe + , identity + , writer ] -------------------------------------------------------------------------------- ------------------------ Ping-pong---------------------------------------------- -------------------------------------------------------------------------------- -pingPong :: TestTree +pingPong :: Tests pingPong = testGroup "pingPong" - [ testProperty "Free.getEffects pingPongS == [Read,Write \"pong\"]" $ + [ expectSuccess "Free.getEffects pingPongS == [Read,Write \"pong\"]" $ F.getEffects F.pingPongS == [F.Read (const ()),F.Write "pong" ()] - , testProperty "Free.getNecessaryEffects pingPongS == [Read]" $ + , expectSuccess "Free.getNecessaryEffects pingPongS == [Read]" $ F.getNecessaryEffects F.pingPongS == [F.Read (const ())] - , testProperty "Free.Rigid.getEffects pingPongS == [Read,Write \"pong\"]" $ + , expectSuccess "Free.Rigid.getEffects pingPongS == [Read,Write \"pong\"]" $ FR.getEffects FR.pingPongS == [FR.Read (const ()),FR.Write "pong" ()] ] -------------------------------------------------------------------------------- ------------------------ Build ------------------------------------------------- -------------------------------------------------------------------------------- -build :: TestTree -build = testGroup "Build" [cyclicDeps, taskBindDeps, runBuildDeps] +build :: Tests +build = testGroup "Build" + [ cyclicDeps + , taskBindDeps + , runBuildDeps ] -cyclicDeps :: TestTree +cyclicDeps :: Tests cyclicDeps = testGroup "cyclicDeps" - [ testProperty "dependenciesOver (fromJust $ cyclic \"B1\") == [\"C1\",\"B2\",\"A2\"]" $ + [ expectSuccess "dependenciesOver (fromJust $ cyclic \"B1\") == [\"C1\",\"B2\",\"A2\"]" $ dependenciesOver (fromJust $ cyclic "B1") == ["C1","B2","A2"] - , testProperty "dependenciesOver cyclic \"B2\") == [\"C1\",\"A1\",\"B1\"]" $ + , expectSuccess "dependenciesOver cyclic \"B2\") == [\"C1\",\"A1\",\"B1\"]" $ dependenciesOver (fromJust $ cyclic "B2") == ["C1","A1","B1"] - , testProperty "dependenciesUnder (fromJust $ cyclic \"B1\") == [\"C1\"]" $ + , expectSuccess "dependenciesUnder (fromJust $ cyclic \"B1\") == [\"C1\"]" $ dependenciesUnder (fromJust $ cyclic "B1") == ["C1"] - , testProperty "dependenciesUnder cyclic \"B2\") == [\"C1\"]" $ + , expectSuccess "dependenciesUnder cyclic \"B2\") == [\"C1\"]" $ dependenciesUnder (fromJust $ cyclic "B2") == ["C1"] ] -taskBindDeps :: TestTree +taskBindDeps :: Tests taskBindDeps = testGroup "taskBindDeps" - [ testProperty "dependenciesOver taskBind == [\"A1\",\"A2\",\"C5\",\"C6\",\"A2\",\"D5\",\"D6\"]" $ + [ expectSuccess "dependenciesOver taskBind == [\"A1\",\"A2\",\"C5\",\"C6\",\"A2\",\"D5\",\"D6\"]" $ dependenciesOver taskBind == ["A1","A2","C5","C6","A2","D5","D6"] - , testProperty "dependenciesUnder taskBind == [\"A1\"]" $ + , expectSuccess "dependenciesUnder taskBind == [\"A1\"]" $ dependenciesUnder taskBind == ["A1"] ] -runBuildDeps :: TestTree +runBuildDeps :: Tests runBuildDeps = testGroup "runBuildDeps" - [ testProperty "runBuild (fromJust $ cyclic \"B1\") == [Fetch \"C1\",Fetch \"B2\",Fetch \"A2\"]" $ + [ expectSuccess "runBuild (fromJust $ cyclic \"B1\") == [Fetch \"C1\",Fetch \"B2\",Fetch \"A2\"]" $ runBuild (fromJust $ cyclic "B1") == [Fetch "C1" (const ()),Fetch "B2" (const ()),Fetch "A2" (const ())] ] -------------------------------------------------------------------------------- ------------------------ Over -------------------------------------------------- -------------------------------------------------------------------------------- -over :: TestTree -over = testGroup "Over" [overLaws, overTheorems, overProperties] +over :: Tests +over = testGroup "Over" + [ overLaws + , overTheorems + , overProperties ] -overLaws :: TestTree +overLaws :: Tests overLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(Over String) x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(Over String) @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(Over String) @Int @Int x ] -overTheorems :: TestTree +overTheorems :: Tests overTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Over String) @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(Over String) @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(Over String) @Int @Int @Int x - , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Over String) @Int @Int x - , testProperty "(f <*> g) == (f `apS` g)" $ + , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Over String) @Int @Int x - , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Over String) @Int @Int x ] -overProperties :: TestTree +overProperties :: Tests overProperties = testGroup "Properties" - [ expectFail $ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectFailure "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(Over String) @Int @Int x - , testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(Over String) @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Under ------------------------------------------------- -------------------------------------------------------------------------------- -under :: TestTree -under = testGroup "Under" [underLaws, underTheorems, underProperties] +under :: Tests +under = testGroup "Under" + [ underLaws + , underTheorems + , underProperties ] -underLaws :: TestTree +underLaws :: Tests underLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(Under String) x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(Under String) @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(Under String) @Int @Int x ] -underTheorems :: TestTree +underTheorems :: Tests underTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Under String) @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(Under String) @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(Under String) @Int @Int @Int x - , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Under String) @Int @Int x -- 'Under' is a non-rigid selective functor - , expectFail $ testProperty "(f <*> g) == (f `apS` g)" $ + , expectFailure "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Under String) @Int @Int x - , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Under String) @Int @Int x ] -underProperties :: TestTree +underProperties :: Tests underProperties = testGroup "Properties" - [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(Under String) @Int @Int x - , expectFail $ testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectFailure "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(Under String) @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Validation -------------------------------------------- -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -validation :: TestTree +validation :: Tests validation = testGroup "Validation" - [validationLaws, validationTheorems, validationProperties, validationExample] + [ validationLaws + , validationTheorems + , validationProperties + , validationExample ] -validationLaws :: TestTree +validationLaws :: Tests validationLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(Validation String) @Int x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(Validation String) @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(Validation String) @Int @Int @Int x ] -validationTheorems :: TestTree +validationTheorems :: Tests validationTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(Validation String) @Int @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(Validation String) @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(Validation String) @Int @Int @Int x - , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(Validation String) @Int @Int x -- 'Validation' is a non-rigid selective functor - , expectFail $ testProperty "(f <*> g) == (f `apS` g)" $ + , expectFailure "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(Validation String) @Int @Int x -- 'Validation' is a non-rigid selective functor - , expectFail $ testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectFailure "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(Validation String) @Int @Int @Int x ] -validationProperties :: TestTree +validationProperties :: Tests validationProperties = testGroup "Properties" - [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(Validation String) @Int @Int x - , testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(Validation String) @Int @Int x ] -validationExample :: TestTree +validationExample :: Tests validationExample = testGroup "validationExample" - [ testProperty "shape (Success True) (Success 1) (Failure [\"width?\"]) (Failure [\"height?\"])" $ + [ expectSuccess "shape (Success True) (Success 1) (Failure [\"width?\"]) (Failure [\"height?\"])" $ shape (Success True) (Success 1) (Failure ["width?"]) (Failure ["height?"]) == Success (Circle 1) - , testProperty "shape (Success False) (Failure [\"radius?\"]) (Success 2) (Success 3)" $ + , expectSuccess "shape (Success False) (Failure [\"radius?\"]) (Success 2) (Success 3)" $ shape (Success False) (Failure ["radius?"]) (Success 2) (Success 3) == Success (Rectangle 2 3) - , testProperty "shape (Success False) (Failure [\"radius?\"]) (Success 2) (Failure [\"height?\"])" $ + , expectSuccess "shape (Success False) (Failure [\"radius?\"]) (Success 2) (Failure [\"height?\"])" $ shape (Success False) (Failure ["radius?"]) (Success 2) (Failure ["height?"]) == Failure ["height?"] - , testProperty "shape (Success False) (Success 1) (Failure [\"width?\"]) (Failure [\"height?\"])" $ + , expectSuccess "shape (Success False) (Success 1) (Failure [\"width?\"]) (Failure [\"height?\"])" $ shape (Success False) (Success 1) (Failure ["width?"]) (Failure ["height?"]) == Failure ["width?", "height?"] - , testProperty "shape (Failure [\"choice?\"]) (Failure [\"radius?\"]) (Success 2) (Failure [\"height?\"])" $ + , expectSuccess "shape (Failure [\"choice?\"]) (Failure [\"radius?\"]) (Success 2) (Failure [\"height?\"])" $ shape (Failure ["choice?"]) (Failure ["radius?"]) (Success 2) (Failure ["height?"]) == Failure ["choice?"] - , testProperty "twoShapes s1 s2" $ + , expectSuccess "twoShapes s1 s2" $ twoShapes (shape (Failure ["choice 1?"]) (Success 1) (Failure ["width 1?"]) (Success 3)) (shape (Success False) (Success 1) (Success 2) (Failure ["height 2?"])) == Failure ["choice 1?","height 2?"] ] -------------------------------------------------------------------------------- ------------------------ ArrowMonad -------------------------------------------- -------------------------------------------------------------------------------- -arrowMonad :: TestTree +arrowMonad :: Tests arrowMonad = testGroup "ArrowMonad (->)" - [arrowMonadLaws, arrowMonadTheorems, arrowMonadProperties] + [ arrowMonadLaws + , arrowMonadTheorems + , arrowMonadProperties ] -arrowMonadLaws :: TestTree +arrowMonadLaws :: Tests arrowMonadLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @(ArrowMonad (->)) @Int x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @(ArrowMonad (->)) @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @(ArrowMonad (->)) @Int @Int @Int x - , testProperty "select == selectM" $ + , expectSuccess "select == selectM" $ \x -> lawMonad @(ArrowMonad (->)) @Int @Int x - , testProperty "select == selectA" $ + , expectSuccess "select == selectA" $ \x -> selectALaw @(ArrowMonad (->)) @Int @Int x ] -arrowMonadTheorems :: TestTree +arrowMonadTheorems :: Tests arrowMonadTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @(ArrowMonad (->)) @Int @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @(ArrowMonad (->)) @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @(ArrowMonad (->)) @Int @Int @Int x - , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @(ArrowMonad (->)) @Int @Int x - , testProperty "(f <*> g) == (f `apS` g)" $ + , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @(ArrowMonad (->)) @Int @Int x - , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @(ArrowMonad (->)) @Int @Int @Int x ] -arrowMonadProperties :: TestTree +arrowMonadProperties :: Tests arrowMonadProperties = testGroup "Properties" - [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @(ArrowMonad (->)) @Int @Int x - , testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @(ArrowMonad (->)) @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Maybe ------------------------------------------------- -------------------------------------------------------------------------------- -maybe :: TestTree -maybe = testGroup "Maybe" [maybeLaws, maybeTheorems, maybeProperties] +maybe :: Tests +maybe = testGroup "Maybe" + [ maybeLaws + , maybeTheorems + , maybeProperties ] -maybeLaws :: TestTree +maybeLaws :: Tests maybeLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @Maybe @Int x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @Maybe @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @Maybe @Int @Int @Int x - , testProperty "select == selectM" $ + , expectSuccess "select == selectM" $ \x -> lawMonad @Maybe @Int @Int x ] -maybeTheorems :: TestTree +maybeTheorems :: Tests maybeTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @Maybe @Int @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @Maybe @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @Maybe @Int @Int @Int x - , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @Maybe @Int @Int x - , testProperty "(f <*> g) == (f `apS` g)" $ + , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @Maybe @Int @Int x - , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @Maybe @Int @Int @Int x ] -maybeProperties :: TestTree +maybeProperties :: Tests maybeProperties = testGroup "Properties" - [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @Maybe @Int @Int x - , testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @Maybe @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Identity ---------------------------------------------- -------------------------------------------------------------------------------- -identity :: TestTree -identity = testGroup "Identity" [identityLaws, identityTheorems, identityProperties] +identity :: Tests +identity = testGroup "Identity" + [ identityLaws + , identityTheorems + , identityProperties ] -identityLaws :: TestTree +identityLaws :: Tests identityLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @Identity @Int x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @Identity @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @Identity @Int @Int @Int x - , testProperty "select == selectM" $ + , expectSuccess "select == selectM" $ \x -> lawMonad @Identity @Int @Int x ] -identityTheorems :: TestTree +identityTheorems :: Tests identityTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @Identity @Int @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @Identity @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @Identity @Int @Int @Int x - , testProperty "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @Identity @Int @Int x - , testProperty "(f <*> g) == (f `apS` g)" $ + , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @Identity @Int @Int x - , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @Identity @Int @Int @Int x ] -identityProperties :: TestTree +identityProperties :: Tests identityProperties = testGroup "Properties" - [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @Identity @Int @Int x - , testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @Identity @Int @Int x ] -------------------------------------------------------------------------------- ------------------------ Writer ------------------------------------------------ -------------------------------------------------------------------------------- -writer :: TestTree -writer = testGroup "Writer" [writerLaws, writerTheorems, writerProperties] +writer :: Tests +writer = testGroup "Writer" + [ writerLaws + , writerTheorems + , writerProperties ] type MyWriter = Writer [Int] -writerLaws :: TestTree +writerLaws :: Tests writerLaws = testGroup "Laws" - [ testProperty "Identity: (x <*? pure id) == (either id id <$> x)" $ + [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $ \x -> lawIdentity @MyWriter @Int x - , testProperty "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ + , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $ \x -> lawDistributivity @MyWriter @Int @Int x - , testProperty "Associativity: take a look at tests/Laws.hs" $ + , expectSuccess "Associativity: take a look at tests/Laws.hs" $ \x -> lawAssociativity @MyWriter @Int @Int @Int x - , testProperty "select == selectM" $ + , expectSuccess "select == selectM" $ \x -> lawMonad @MyWriter @Int @Int x ] -writerTheorems :: TestTree +writerTheorems :: Tests writerTheorems = testGroup "Theorems" - [ testProperty "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ + [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $ \x -> theorem1 @MyWriter @Int @Int @Int x - , testProperty "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ + , expectSuccess "Apply a pure function to the Left case of the first argument: (select (first f <$> x) y) == (select x ((. f) <$> y))" $ \x -> theorem2 @MyWriter @Int @Int @Int x - , testProperty "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ + , expectSuccess "Apply a pure function to the second argument: (select x (f <$> y)) == (select (first (flip f) <$> x) ((&) <$> y))" $ \x -> theorem3 @MyWriter @Int @Int @Int x - , testProperty "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $ + , expectSuccess "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $ \x -> theorem4 @MyWriter @Int @Int x - , testProperty "(f <*> g) == (f `apS` g)" $ + , expectSuccess "(f <*> g) == (f `apS` g)" $ \x -> theorem5 @MyWriter @Int @Int x - , testProperty "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ + , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $ \x -> theorem6 @MyWriter @Int @Int @Int x ] -writerProperties :: TestTree +writerProperties :: Tests writerProperties = testGroup "Properties" - [ testProperty "pure-right: pure (Right x) <*? y = pure x" $ + [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $ \x -> propertyPureRight @MyWriter @Int @Int x - , testProperty "pure-left: pure (Left x) <*? y = ($x) <$> y" $ + , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @MyWriter @Int @Int x ] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 index 0000000..6895219 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,44 @@ +-- A little testing framework +module Test where + +import Data.List (intercalate) +import System.Exit (exitFailure) +import Test.QuickCheck hiding (Success, Failure, expectFailure) + + +data Expect = ExpectSuccess | ExpectFailure deriving Eq + +data Test = Test String Expect Property + +data Tests = Leaf Test | Node String [Tests] + +testGroup :: String -> [Tests] -> Tests +testGroup = Node + +expectSuccess :: Testable a => String -> a -> Tests +expectSuccess name p = Leaf $ Test name ExpectSuccess (property p) + +expectFailure :: Testable a => String -> a -> Tests +expectFailure name p = Leaf $ Test name ExpectFailure (property p) + +runTest :: [String] -> Test -> IO () +runTest labels (Test name expect property) = do + let label = intercalate "." (reverse (name : labels)) + result <- quickCheckWithResult (stdArgs { chatty = False }) property + case (expect, isSuccess result) of + (ExpectSuccess, True) -> putStrLn $ "OK: " ++ label + (ExpectFailure, False) -> putStrLn $ "OK (expected failure): " ++ label + (ExpectSuccess, False) -> do + putStrLn $ "\nTest failure:\n " ++ label ++ "\n" + putStrLn $ output result + exitFailure + (ExpectFailure, True) -> do + putStrLn $ "\nUnexpected test success:\n " ++ label ++ "\n" + putStrLn $ output result + exitFailure + +runTests :: Tests -> IO () +runTests = go [] + where + go labels (Leaf test) = runTest labels test + go labels (Node label tests) = mapM_ (go (label : labels)) tests