selective 0.4.2 → 0.5
raw patch · 10 files changed
+378/−219 lines, 10 filesdep −mtldep −tastydep −tasty-expected-failuredep ~basedep ~transformers
Dependencies removed: mtl, tasty, tasty-expected-failure, tasty-quickcheck
Dependency ranges changed: base, transformers
Files
- CHANGES.md +9/−0
- examples/Processor.hs +33/−21
- examples/Query.hs +1/−1
- selective.cabal +9/−8
- src/Control/Selective.hs +35/−8
- src/Control/Selective/Rigid/Free.hs +3/−3
- test/Laws.hs +34/−38
- test/Main.hs +208/−138
- test/Sketch.hs +2/−2
- test/Test.hs +44/−0
CHANGES.md view
@@ -1,5 +1,14 @@ # Change log +## 0.5++* Allow `transformers-0.6`, see #47.+* Drop dependencies on `mtl` and `tasty`. See #45, #46.+* Derive the stock `Eq` and `Ord` instances for `Validation`, see #43.+* Add `selectT`, see #42.+* Add more general instances for `IdentityT` and `ReaderT`. This is technically+ a breaking change because `Selective` is not a superclass of `Monad`. See #38.+ ## 0.4.1 * Allow newer QuickCheck.
examples/Processor.hs view
@@ -1,30 +1,42 @@-{-# LANGUAGE ConstraintKinds, DeriveFunctor, GADTs, FlexibleContexts, LambdaCase #-}+{-# LANGUAGE ConstraintKinds, DeriveFunctor, GADTs, LambdaCase #-}+{-# LANGUAGE FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}+ module Processor where import Control.Selective import Control.Selective.Rigid.Free-import Data.Functor import Data.Bool+import Data.Functor import Data.Int (Int16)-import Data.Word (Word8) import Data.Map.Strict (Map)+import Data.Word (Word8)+import Foreign.Marshal.Utils (fromBool) import Prelude hiding (read, log) -import qualified Control.Monad.State as S-import qualified Data.Map.Strict as Map+import qualified Control.Monad.Trans.State as S+import qualified Data.Map.Strict as Map -- See Section 5.3 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf -- Note that we have changed the naming. --- | Hijack @mtl@'s 'MonadState' constraint to include Selective.-type MonadState s m = (Selective m, S.MonadState s m)+-- | A standard @MonadState@ class extended with the 'Selective' interface.+class (Selective m, Monad m) => MonadState s m | m -> s where+ get :: m s+ put :: s -> m ()+ state :: (s -> (a, s)) -> m a --- | Convert a 'Bool' to @0@ or @1@.-fromBool :: Num a => Bool -> a-fromBool True = 1-fromBool False = 0+instance Monad m => MonadState s (S.StateT s m) where+ get = S.get+ put = S.put+ state = S.state +gets :: MonadState s m => (s -> a) -> m a+gets f = f <$> get++modify :: MonadState s m => (s -> s) -> m ()+modify f = state (\s -> ((), f s))+ -------------------------------------------------------------------------------- -------- Types ----------------------------------------------------------------- --------------------------------------------------------------------------------@@ -94,16 +106,16 @@ show (Write k _ _) = "Write " ++ show k logEntry :: MonadState State m => LogEntry Key Value -> m ()-logEntry item = S.modify $ \s -> s { log = log s ++ [item] }+logEntry item = modify $ \s -> s { log = log s ++ [item] } -- | Interpret the base functor in a 'MonadState'. toState :: MonadState State m => RW a -> m a toState = \case (Read k t) -> do- v <- case k of Reg r -> S.gets ((Map.! r) . registers)- Cell addr -> S.gets ((Map.! addr) . memory)- Flag f -> S.gets ((Map.! f) . flags)- PC -> S.gets pc+ v <- case k of Reg r -> gets ((Map.! r) . registers)+ Cell addr -> gets ((Map.! addr) . memory)+ Flag f -> gets ((Map.! f) . flags)+ PC -> gets pc logEntry (ReadEntry k v) pure (t v) (Write k p t) -> do@@ -111,14 +123,14 @@ logEntry (WriteEntry k v) case k of Reg r -> let regs' s = Map.insert r v (registers s)- in S.state (\s -> (t v, s {registers = regs' s}))+ in state (\s -> (t v, s {registers = regs' s})) Cell addr -> let mem' s = Map.insert addr v (memory s)- in S.state (\s -> (t v, s {memory = mem' s}))+ in state (\s -> (t v, s {memory = mem' s})) Flag f -> let flags' s = Map.insert f v (flags s)- in S.state (\s -> (t v, s {flags = flags' s}))- PC -> S.state (\s -> (t v, s {pc = v}))+ in state (\s -> (t v, s {flags = flags' s}))+ PC -> state (\s -> (t v, s {pc = v})) --- | Interpret a program as a state trasformer.+-- | Interpret a program as a state transformer. runProgramState :: Program a -> State -> (a, State) runProgramState f = S.runState (runSelect toState f)
examples/Query.hs view
@@ -14,7 +14,7 @@ Select :: Query (Either a b) -> Query (a -> b) -> Query b instance Functor Query where- fmap f x = Apply (Pure f) x+ fmap f = Apply (Pure f) instance Applicative Query where pure = Pure
selective.cabal view
@@ -1,5 +1,5 @@ name: selective-version: 0.4.2+version: 0.5 synopsis: Selective applicative functors license: MIT license-file: LICENSE@@ -35,9 +35,9 @@ Control.Selective.Multi, Control.Selective.Rigid.Free, Control.Selective.Rigid.Freer- build-depends: base >= 4.7 && < 5,+ build-depends: base >= 4.9 && < 5, containers >= 0.5.5.1 && < 0.7,- transformers >= 0.4.2.0 && < 0.6+ transformers >= 0.4.2.0 && < 0.7 default-language: Haskell2010 other-extensions: DeriveFunctor, FlexibleInstances,@@ -52,6 +52,8 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ if impl(ghc >= 9.2)+ ghc-options: -Wno-operator-whitespace-ext-conflict test-suite test hs-source-dirs: test, examples@@ -63,18 +65,15 @@ Sketch, Teletype, Teletype.Rigid,+ Test, Validation type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >= 4.7 && < 5, containers >= 0.5.5.1 && < 0.7,- mtl >= 2.2.1 && < 2.3, 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+ transformers >= 0.4.2.0 && < 0.7 default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing@@ -82,3 +81,5 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ if impl(ghc >= 9.2)+ ghc-options: -Wno-operator-whitespace-ext-conflict
src/Control/Selective.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, LambdaCase, TupleSections, DeriveFunctor #-}+{-# LANGUAGE CPP, LambdaCase, TupleSections, DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -----------------------------------------------------------------------------@@ -17,7 +17,7 @@ ----------------------------------------------------------------------------- module Control.Selective ( -- * Type class- Selective (..), (<*?), branch, selectA, apS, selectM,+ Selective (..), (<*?), branch, selectA, selectT, apS, selectM, -- * Conditional combinators ifS, whenS, fromMaybeS, orElse, andAlso, untilRight, whileS, (<||>), (<&&>),@@ -197,6 +197,14 @@ selectA :: Applicative f => f (Either a b) -> f (a -> b) -> f b selectA x y = (\e f -> either f id e) <$> x <*> y +-- | If a functor is both 'Applicative' and 'Traversable', we can implement+-- 'select' in another interesting way: the effects associated with the second+-- argument can be skipped as long as the first argument contains only 'Right's.+selectT :: (Applicative f, Traversable f) => f (Either a b) -> f (a -> b) -> f b+selectT x y = case sequenceA x of+ Left a -> ($a) <$> y+ Right fb -> fb+ {-| Recover the application operator '<*>' from 'select'. /Rigid/ selective functors satisfy the law '<*>' @=@ 'apS' and furthermore, the resulting applicative functor satisfies all laws of 'Applicative':@@ -394,17 +402,19 @@ pure _ = Over mempty Over x <*> Over y = Over (mappend x y) +-- select = selectA instance Monoid m => Selective (Over m) where select (Over x) (Over y) = Over (mappend x y) -- | Static analysis of selective functors with under-approximation. newtype Under m a = Under { getUnder :: m }- deriving (Eq, Functor, Ord, Show)+ deriving (Eq, Functor, Ord, Show, Foldable, Traversable) instance Monoid m => Applicative (Under m) where pure _ = Under mempty Under x <*> Under y = Under (mappend x y) +-- select = selectT instance Monoid m => Selective (Under m) where select (Under m) _ = Under m @@ -419,7 +429,7 @@ -- | Selective instance for the standard applicative functor Validation. This is -- a good example of a non-trivial selective functor which is not a monad.-data Validation e a = Failure e | Success a deriving (Functor, Show)+data Validation e a = Failure e | Success a deriving (Eq, Functor, Ord, Show) instance Semigroup e => Applicative (Validation e) where pure = Success@@ -436,6 +446,27 @@ instance (Selective f, Selective g) => Selective (Product f g) where select (Pair fx gx) (Pair fy gy) = Pair (select fx fy) (select gx gy) +instance Selective f => Selective (IdentityT f) where+ select (IdentityT x) (IdentityT y) = IdentityT (select x y)++instance Selective f => Selective (ReaderT env f) where+ select (ReaderT x) (ReaderT y) = ReaderT $ \env -> select (x env) (y env)++distributeEither :: (Either a b, w) -> Either (a, w) (b, w)+distributeEither (Left a, w) = Left (a, w)+distributeEither (Right b, w) = Right (b, w)++distributeFunction :: Monoid w => (a -> b, w) -> (a, w) -> (b, w)+distributeFunction (f, wf) (x, wx) = (f x, mappend wx wf)++instance (Monoid w, Selective f) => Selective (WriterT w f) where+ select (WriterT x) (WriterT f) =+ WriterT $ select (distributeEither <$> x) (distributeFunction <$> f)++instance (Monoid w, Selective f) => Selective (S.WriterT w f) where+ select (S.WriterT x) (S.WriterT f) =+ S.WriterT $ select (distributeEither <$> x) (distributeFunction <$> f)+ -- TODO: Is this a useful instance? Note that composition of 'Alternative' -- requires @f@ to be 'Alternative', and @g@ to be 'Applicative', which is -- opposite to what we have here:@@ -480,15 +511,11 @@ instance Selective (ContT r m) where select = selectM instance Monad m => Selective (ExceptT e m) where select = selectM-instance Monad m => Selective (IdentityT m) where select = selectM instance Monad m => Selective (MaybeT m) where select = selectM-instance Monad m => Selective (ReaderT r m) where select = selectM instance (Monoid w, Monad m) => Selective (RWST r w s m) where select = selectM instance (Monoid w, Monad m) => Selective (S.RWST r w s m) where select = selectM instance Monad m => Selective (StateT s m) where select = selectM instance Monad m => Selective (S.StateT s m) where select = selectM-instance (Monoid w, Monad m) => Selective (WriterT w m) where select = selectM-instance (Monoid w, Monad m) => Selective (S.WriterT w m) where select = selectM ------------------------------------ Arrows ------------------------------------ -- See the following standard definitions in "Control.Arrow".
src/Control/Selective/Rigid/Free.hs view
@@ -69,9 +69,9 @@ -- Associativity law select x (Select y z) = Select (select (f <$> x) (g <$> y)) (h <$> z) where- f x = Right <$> x- g y = \a -> bimap (,a) ($a) y- h z = uncurry z+ f = fmap Right+ g y a = bimap (,a) ($a) y+ h = uncurry {- The following can be used in the above implementation as select = selectOpt.
test/Laws.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, TupleSections, TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Laws where -import Test.QuickCheck hiding (Failure, Success)-import Data.Bifunctor (bimap, first, second) import Control.Arrow hiding (first, second)+import Control.Monad.Trans.Writer import Control.Selective+import Data.Bifunctor (bimap, first, second) import Data.Function import Data.Functor.Identity+import Test.QuickCheck hiding (Failure, Success) import Text.Show.Functions() -- | TODO:@@ -27,72 +27,62 @@ -- | Associativity lawAssociativity :: (Selective f, Eq (f c)) =>- f (Either b c) -> f (Either a (b -> c)) -> f (a -> b -> c) -> Bool-lawAssociativity x y z = (x <*? (y <*? z)) == ((f <$> x) <*? (g <$> y) <*? (h <$> z))- where- f x = Right <$> x- g y = \a -> bimap (,a) ($a) y- h z = uncurry z+ f (Either b c) -> f (Either a (b -> c)) -> f (a -> b -> c) -> Bool+lawAssociativity x y z =+ (x <*? (y <*? z)) == ((f <$> x) <*? (g <$> y) <*? (h <$> z))+ where+ f = fmap Right+ g y a = bimap (,a) ($a) y+ h = uncurry {- | If 'f' is a 'Monad' |-} -lawMonad :: (Selective f, Monad f, Eq (f b)) =>- f (Either a b) -> f (a -> b) -> Bool+lawMonad :: (Selective f, Monad f, Eq (f b)) => f (Either a b) -> f (a -> b) -> Bool lawMonad x f = select x f == selectM x f -selectALaw :: (Selective f, Eq (f b)) =>- f (Either a b) -> f (a -> b) -> Bool+selectALaw :: (Selective f, Eq (f b)) => f (Either a b) -> f (a -> b) -> Bool selectALaw x f = select x f == selectA x f -------------------------------------------------------------------------------- ------------------------ Theorems ---------------------------------------------- ---------------------------------------------------------------------------------{-| Theorems about selective applicative functors,- as presented in the Fig.4 of the paper-|-}+{-| Theorems about selective applicative functors, see Fig. 4 of the paper |-} -- | Apply a pure function to the result:-theorem1 :: (Selective f, Eq (f c)) =>- (a -> c) -> f (Either b a) -> f (b -> a) -> Bool+theorem1 :: (Selective f, Eq (f c)) => (a -> c) -> f (Either b a) -> f (b -> a) -> Bool theorem1 f x y = (f <$> select x y) == select (second f <$> x) ((f .) <$> y) -- | Apply a pure function to the Left case of the first argument:-theorem2 :: (Selective f, Eq (f c)) =>- (a -> b) -> f (Either a c) -> f (b -> c) -> Bool+theorem2 :: (Selective f, Eq (f c)) => (a -> b) -> f (Either a c) -> f (b -> c) -> Bool theorem2 f x y = select (first f <$> x) y == select x ((. f) <$> y) -- | Apply a pure function to the second argument:-theorem3 :: (Selective f, Eq (f c)) =>- (a -> b -> c) -> f (Either b c) -> f a -> Bool+theorem3 :: (Selective f, Eq (f c)) => (a -> b -> c) -> f (Either b c) -> f a -> Bool theorem3 f x y = select x (f <$> y) == select (first (flip f) <$> x) ((&) <$> y) -- | Generalised identity: theorem4 :: (Selective f, Eq (f b)) => f (Either a b) -> (a -> b) -> Bool theorem4 x y = (x <*? pure y) == (either y id <$> x) -{-| For rigid selective functors (in particular, for monads):-|-}+{-| For rigid selective functors (in particular, for monads) |-} -- | Selective apply theorem5 :: (Selective f, Eq (f b)) => f (a -> b) -> f a -> Bool theorem5 f g = (f <*> g) == (f `apS` g) -- | Interchange-theorem6 :: (Selective f, Eq (f c)) =>- f a -> f (Either b c) -> f (b -> c) -> Bool+theorem6 :: (Selective f, Eq (f c)) => f a -> f (Either b c) -> f (b -> c) -> Bool theorem6 x y z = (x *> (y <*? z)) == ((x *> y) <*? z) -------------------------------------------------------------------------------- ------------------------ Properties ---------------------------------------------- -------------------------------------------------------------------------------- --- | pure-right--- pure (Right x) <*? y = pure x+-- | Pure-Right: pure (Right x) <*? y = pure x propertyPureRight :: (Selective f, Eq (f a)) => a -> f (b -> a) -> Bool propertyPureRight x y = (pure (Right x) <*? y) == pure x --- | pure-left--- pure (Left x) <*? y = ($x) <$> y+-- | Pure-Left: pure (Left x) <*? y = ($x) <$> y propertyPureLeft :: (Selective f, Eq (f b)) => a -> f (a -> b) -> Bool propertyPureLeft x y = (pure (Left x) <*? y) == (($x) <$> y) @@ -119,24 +109,22 @@ -------------------------------------------------------------------------------- ------------------------ Validation -------------------------------------------- ---------------------------------------------------------------------------------deriving instance (Eq e, Eq a) => Eq (Validation e a)- instance (Arbitrary e, Arbitrary a) => Arbitrary (Validation e a) where- arbitrary = oneof [Failure <$> arbitrary, Success <$> arbitrary]- shrink (Failure x) = [ Failure x' | x' <- shrink x ]- shrink (Success y) = [ Success y' | y' <- shrink y ]+ arbitrary = oneof [Failure <$> arbitrary, Success <$> arbitrary]+ shrink (Failure x) = [ Failure x' | x' <- shrink x ]+ shrink (Success y) = [ Success y' | y' <- shrink y ] -------------------------------------------------------------------------------- ------------------------ ArrowMonad -------------------------------------------- -------------------------------------------------------------------------------- instance Eq a => Eq (ArrowMonad (->) a) where- ArrowMonad f == ArrowMonad g = f () == g ()+ ArrowMonad f == ArrowMonad g = f () == g () instance Arbitrary a => Arbitrary (ArrowMonad (->) a) where- arbitrary = ArrowMonad . const <$> arbitrary+ arbitrary = ArrowMonad . const <$> arbitrary instance Show a => Show (ArrowMonad (->) a) where- show (ArrowMonad f) = show (f ())+ show (ArrowMonad f) = show (f ()) -------------------------------------------------------------------------------- ------------------------ Maybe ------------------------------------------------- --------------------------------------------------------------------------------@@ -150,3 +138,11 @@ propertyPureRightIdentity :: IO () propertyPureRightIdentity = quickCheck (propertyPureRight @Identity @Int @Int)+++--------------------------------------------------------------------------------+------------------------ Writer ------------------------------------------------+--------------------------------------------------------------------------------++instance (Arbitrary w, Arbitrary a) => Arbitrary (Writer w a) where+ arbitrary = curry writer <$> arbitrary <*> arbitrary
test/Main.hs view
@@ -1,318 +1,388 @@ {-# LANGUAGE TypeApplications #-} import Control.Arrow (ArrowMonad)+import Control.Monad.Trans.Writer hiding (writer) import Control.Selective import Data.Functor.Identity import Data.Maybe hiding (maybe) import Prelude hiding (maybe)-import Test.Tasty-import Test.Tasty.QuickCheck hiding (Success, Failure)-import Test.Tasty.ExpectedFailure 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]+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\"]" $- F.getEffects F.pingPongS == [F.Read (const ()),F.Write "pong" ()]- , testProperty "Free.getNecessaryEffects pingPongS == [Read]" $- F.getNecessaryEffects F.pingPongS == [F.Read (const ())]- , testProperty "Free.Rigid.getEffects pingPongS == [Read,Write \"pong\"]" $- FR.getEffects FR.pingPongS == [FR.Read (const ()),FR.Write "pong" ()] ]+ [ expectSuccess "Free.getEffects pingPongS == [Read,Write \"pong\"]" $+ F.getEffects F.pingPongS == [F.Read (const ()),F.Write "pong" ()]+ , expectSuccess "Free.getNecessaryEffects pingPongS == [Read]" $+ F.getNecessaryEffects F.pingPongS == [F.Read (const ())]+ , 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\"]" $- dependenciesOver (fromJust $ cyclic "B1") == ["C1","B2","A2"]- , testProperty "dependenciesOver cyclic \"B2\") == [\"C1\",\"A1\",\"B1\"]" $+ [ expectSuccess "dependenciesOver (fromJust $ cyclic \"B1\") == [\"C1\",\"B2\",\"A2\"]" $+ dependenciesOver (fromJust $ cyclic "B1") == ["C1","B2","A2"]+ , expectSuccess "dependenciesOver cyclic \"B2\") == [\"C1\",\"A1\",\"B1\"]" $ dependenciesOver (fromJust $ cyclic "B2") == ["C1","A1","B1"]- , testProperty "dependenciesUnder (fromJust $ cyclic \"B1\") == [\"C1\"]" $- dependenciesUnder (fromJust $ cyclic "B1") == ["C1"]- , testProperty "dependenciesUnder cyclic \"B2\") == [\"C1\"]" $+ , expectSuccess "dependenciesUnder (fromJust $ cyclic \"B1\") == [\"C1\"]" $+ dependenciesUnder (fromJust $ cyclic "B1") == ["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\"]" $- dependenciesOver taskBind == ["A1","A2","C5","C6","A2","D5","D6"]- , testProperty "dependenciesUnder taskBind == [\"A1\"]" $- dependenciesUnder taskBind == ["A1"] ]+ [ expectSuccess "dependenciesOver taskBind == [\"A1\",\"A2\",\"C5\",\"C6\",\"A2\",\"D5\",\"D6\"]" $+ dependenciesOver taskBind == ["A1","A2","C5","C6","A2","D5","D6"]+ , 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\"]" $- runBuild (fromJust $ cyclic "B1") == [Fetch "C1" (const ()),Fetch "B2" (const ()),Fetch "A2" (const ())] ]+ [ 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 :: Tests identity = testGroup "Identity"- [identityLaws, identityTheorems, identityProperties]+ [ 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 :: Tests+writer = testGroup "Writer"+ [ writerLaws+ , writerTheorems+ , writerProperties ]++type MyWriter = Writer [Int]++writerLaws :: Tests+writerLaws = testGroup "Laws"+ [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $+ \x -> lawIdentity @MyWriter @Int x+ , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $+ \x -> lawDistributivity @MyWriter @Int @Int x+ , expectSuccess "Associativity: take a look at tests/Laws.hs" $+ \x -> lawAssociativity @MyWriter @Int @Int @Int x+ , expectSuccess "select == selectM" $+ \x -> lawMonad @MyWriter @Int @Int x ]++writerTheorems :: Tests+writerTheorems = testGroup "Theorems"+ [ 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+ , 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+ , 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+ , expectSuccess "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $+ \x -> theorem4 @MyWriter @Int @Int x+ , expectSuccess "(f <*> g) == (f `apS` g)" $+ \x -> theorem5 @MyWriter @Int @Int x+ , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $+ \x -> theorem6 @MyWriter @Int @Int @Int x ]++writerProperties :: Tests+writerProperties = testGroup "Properties"+ [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $+ \x -> propertyPureRight @MyWriter @Int @Int x+ , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $+ \x -> propertyPureLeft @MyWriter @Int @Int x ]
test/Sketch.hs view
@@ -565,7 +565,7 @@ newtype Haxl a = Haxl { runHaxl :: IO (Result a) } deriving Functor instance Applicative Haxl where- pure = return+ pure = Haxl . return . Done Haxl iof <*> Haxl iox = Haxl $ do rf <- iof@@ -586,7 +586,7 @@ (Blocked bx x , Blocked bf f) -> Blocked (bx <> bf) (select x f) -- speculative -- execution instance Monad Haxl where- return = Haxl . return . Done+ return = pure Haxl iox >>= f = Haxl $ do rx <- iox
+ test/Test.hs view
@@ -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