selective 0.5 → 0.6
raw patch · 17 files changed
+246/−72 lines, 17 filesdep ~transformers
Dependency ranges changed: transformers
Files
- CHANGES.md +10/−0
- LICENSE +1/−1
- README.md +1/−1
- examples/Parser.hs +3/−3
- examples/Query.hs +2/−2
- examples/Teletype.hs +2/−1
- examples/Teletype/Rigid.hs +2/−1
- selective.cabal +6/−5
- src/Control/Selective.hs +54/−42
- src/Control/Selective/Free.hs +1/−1
- src/Control/Selective/Multi.hs +1/−1
- src/Control/Selective/Rigid/Free.hs +2/−2
- src/Control/Selective/Rigid/Freer.hs +2/−2
- src/Control/Selective/Trans/Except.hs +95/−0
- test/Laws.hs +7/−0
- test/Main.hs +49/−1
- test/Test.hs +8/−9
CHANGES.md view
@@ -1,5 +1,15 @@ # Change log +## 0.6++* Start supporting GHC 9.4. See #66.+* Add `ComposeTraversable`. See #65.+* Make the `Applicative` instance of `ComposeEither` more interesting by relying+ on the `Selective f` constraint. See #64.+* Make the `Lift` instance lazier. See #63.+* Stop supporting GHC <= 8.6. See #62.+* Add `Control.Selective.Trans.Except` transformer. See #39.+ ## 0.5 * Allow `transformers-0.6`, see #47.
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2018-2021 Andrey Mokhov+Copyright (c) 2018-2023 Andrey Mokhov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
README.md view
@@ -1,6 +1,6 @@ # Selective applicative functors -[](https://hackage.haskell.org/package/selective) [](https://github.com/snowleopard/selective/actions)+[](https://hackage.haskell.org/package/selective) [](https://github.com/snowleopard/selective/actions) This is a library for *selective applicative functors*, or just *selective functors* for short, an abstraction between applicative functors and monads, introduced in
examples/Parser.hs view
@@ -40,17 +40,17 @@ (c:cs) -> [(c,cs)] sat :: (Char -> Bool) -> Parser Char-sat p = do { c <- item; if p c then return c else zero }+sat p = do { c <- item; if p c then pure c else zero } char :: Char -> Parser Char char c = sat (==c) string :: String -> Parser String-string [] = return ""+string [] = pure "" string (c:cs) = do _ <- char c _ <- string cs- return (c:cs)+ pure (c:cs) bin :: Parser Int bin = undefined
examples/Query.hs view
@@ -51,11 +51,11 @@ getPure (Apply f x) = do pf <- getPure f px <- getPure x- return (pf px)+ pure (pf px) getPure (Select x y) = do px <- getPure x py <- getPure y- return (either py id px)+ pure (either py id px) getEffects :: Query a -> ([Prompt], [FilePath]) getEffects (Terminal p) = ([p], [] )
examples/Teletype.hs view
@@ -3,6 +3,7 @@ import Prelude hiding (getLine, putStrLn) import qualified Prelude as IO+import qualified Control.Monad as IO import Control.Selective import Control.Selective.Free @@ -69,7 +70,7 @@ -- | Monadic ping-pong, which has the desired behaviour, but cannot be -- statically analysed. pingPongM :: IO ()-pingPongM = IO.getLine >>= \s -> if s == "ping" then IO.putStrLn "pong" else pure ()+pingPongM = IO.getLine >>= \s -> IO.when (s == "ping") (IO.putStrLn "pong") -- | Applicative ping-pong, which always executes both effect, but can be -- statically analysed.
examples/Teletype/Rigid.hs view
@@ -3,6 +3,7 @@ import Prelude hiding (getLine, putStrLn) import qualified Prelude as IO+import qualified Control.Monad as IO import Control.Selective import Control.Selective.Rigid.Free @@ -62,7 +63,7 @@ -- | Monadic ping-pong, which has the desired behaviour, but cannot be -- statically analysed. pingPongM :: IO ()-pingPongM = IO.getLine >>= \s -> if s == "ping" then IO.putStrLn "pong" else pure ()+pingPongM = IO.getLine >>= \s -> IO.when (s == "ping") (IO.putStrLn "pong") -- | Applicative ping-pong, which always executes both effect, but can be -- statically analysed.
selective.cabal view
@@ -1,17 +1,17 @@ name: selective-version: 0.5+version: 0.6 synopsis: Selective applicative functors license: MIT license-file: LICENSE author: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard maintainer: Andrey Mokhov <andrey.mokhov@gmail.com>, github: @snowleopard-copyright: Andrey Mokhov, 2018-2021+copyright: Andrey Mokhov, 2018-2023 homepage: https://github.com/snowleopard/selective bug-reports: https://github.com/snowleopard/selective/issues category: Control build-type: Simple cabal-version: 1.18-tested-with: GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4, GHC==8.2, GHC==8.0+tested-with: GHC==9.4.4, GHC==9.2.6, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5 description: Selective applicative functors: declare your effects statically, select which to execute dynamically. .@@ -34,7 +34,8 @@ Control.Selective.Free, Control.Selective.Multi, Control.Selective.Rigid.Free,- Control.Selective.Rigid.Freer+ Control.Selective.Rigid.Freer,+ Control.Selective.Trans.Except build-depends: base >= 4.9 && < 5, containers >= 0.5.5.1 && < 0.7, transformers >= 0.4.2.0 && < 0.7@@ -55,7 +56,7 @@ if impl(ghc >= 9.2) ghc-options: -Wno-operator-whitespace-ext-conflict -test-suite test+test-suite main hs-source-dirs: test, examples other-modules: Build, Laws,
src/Control/Selective.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP, LambdaCase, TupleSections, DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DerivingVia #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Selective--- Copyright : (c) Andrey Mokhov 2018-2019+-- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental@@ -27,7 +27,7 @@ SelectA (..), SelectM (..), Over (..), Under (..), Validation (..), -- * Miscellaneous- swapEither, ComposeEither (..)+ swapEither, ComposeEither (..), ComposeTraversable (..) ) where import Control.Applicative@@ -35,7 +35,6 @@ import Control.Arrow import Control.Monad.ST import Control.Monad.Trans.Cont-import Control.Monad.Trans.Except import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader@@ -197,10 +196,10 @@ 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+-- | For traversable functors, 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' values.+selectT :: 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@@ -275,7 +274,7 @@ matchM :: Monad m => Cases a -> m a -> (a -> m b) -> m (Either a b) matchM (Cases _ p) mx f = do x <- mx- if p x then Right <$> f x else return (Left x)+ if p x then Right <$> f x else pure (Left x) -- TODO: Add a type-safe version based on @KnownNat@. -- | A restricted version of monadic bind. Fails with an error if the 'Bounded'@@ -302,8 +301,15 @@ -- | Return the first @Right@ value. If both are @Left@'s, accumulate errors. orElse :: (Selective f, Semigroup e) => f (Either e a) -> f (Either e a) -> f (Either e a)-orElse x y = branch x (flip appendLeft <$> y) (pure Right)+orElse x y = select (prepare <$> x) (combine <$> y)+ where+ prepare :: Either e a -> Either e (Either e a)+ prepare = fmap Right + combine :: Semigroup e => Either e a -> e -> Either e a+ combine (Left ey) ex = Left (ex <> ey)+ combine (Right a) _ = Right a+ -- | Accumulate the @Right@ values, or return the first @Left@. andAlso :: (Selective f, Semigroup a) => f (Either e a) -> f (Either e a) -> f (Either e a) andAlso x y = swapEither <$> orElse (swapEither <$> x) (swapEither <$> y)@@ -312,11 +318,6 @@ swapEither :: Either a b -> Either b a swapEither = either Right Left --- | Append two semigroup values or return the @Right@ one.-appendLeft :: Semigroup a => a -> Either a b -> Either a b-appendLeft a1 (Left a2) = Left (a1 <> a2)-appendLeft _ (Right b) = Right b- -- | Keep checking an effectful condition while it holds. whileS :: Selective f => f Bool -> f () whileS act = whenS act (whileS act)@@ -348,11 +349,7 @@ allS p = foldr ((<&&>) . p) (pure True) -- | Generalised folding with the short-circuiting behaviour.-foldS :: (Selective f, Foldable t, Monoid a-#if !MIN_VERSION_base(4,11,0)- , Semigroup a-#endif- ) => t (f (Either e a)) -> f (Either e a)+foldS :: (Selective f, Foldable t, Monoid a) => t (f (Either e a)) -> f (Either e a) foldS = foldr andAlso (pure (Right mempty)) -- Instances@@ -374,8 +371,8 @@ -- Note: Validation e a ~ Lift (Under e) a instance Selective f => Selective (Lift f) where+ select (Pure (Right x)) _ = Pure x -- Lazy in the second argument select x (Pure y) = either y id <$> x- select (Pure (Right x)) _ = Pure x select (Pure (Left x)) (Other y) = Other $ ($x) <$> y select (Other x ) (Other y) = Other $ x <*? y @@ -397,10 +394,7 @@ -- | Static analysis of selective functors with over-approximation. newtype Over m a = Over { getOver :: m } deriving (Eq, Functor, Ord, Show)--instance Monoid m => Applicative (Over m) where- pure _ = Over mempty- Over x <*> Over y = Over (mappend x y)+ deriving Applicative via (Const m) -- select = selectA instance Monoid m => Selective (Over m) where@@ -409,10 +403,7 @@ -- | Static analysis of selective functors with under-approximation. newtype Under m a = Under { getUnder :: m } 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)+ deriving Applicative via (Const m) -- select = selectT instance Monoid m => Selective (Under m) where@@ -510,7 +501,6 @@ instance Selective STM where select = selectM instance Selective (ContT r m) where select = selectM-instance Monad m => Selective (ExceptT e m) where select = selectM instance Monad m => Selective (MaybeT 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@@ -529,20 +519,42 @@ toArrow :: Arrow a => ArrowMonad a (i -> o) -> a i o toArrow (ArrowMonad f) = arr ((),) >>> first f >>> arr (uncurry ($)) ----------------------------------- Alternative ------------------------------------ | Composition of a functor @f@ with the 'Either' monad.+------------------------------ ComposeTraversable ------------------------------+-- | Composition of a selective functor @f@ and an applicative traversable+-- functor @g@.+newtype ComposeTraversable f g a = ComposeTraversable (f (g a))+ deriving (Functor, Applicative) via Compose f g++instance (Selective f, Applicative g, Traversable g) => Selective (ComposeTraversable f g) where+ select (ComposeTraversable x) (ComposeTraversable f) = ComposeTraversable $+ select (prepare <$> x) (combine <$> f)+ where+ prepare :: Traversable g => g (Either a b) -> Either a (g b)+ prepare = sequenceA++ combine :: Traversable g => g (a -> b) -> a -> g b+ combine = sequenceA++--------------------------------- ComposeEither --------------------------------+-- | Composition of a selective functor @f@ with the 'Either' monad. newtype ComposeEither f e a = ComposeEither (f (Either e a))- deriving Functor+ deriving Functor via Compose f (Either e)+ deriving Selective via ComposeTraversable f (Either e) -instance Applicative f => Applicative (ComposeEither f e) where- pure a = ComposeEither (pure $ Right a)- ComposeEither x <*> ComposeEither y = ComposeEither ((<*>) <$> x <*> y)+instance Selective f => Applicative (ComposeEither f e) where+ pure = ComposeEither . pure . Right -instance (Selective f, Monoid e-#if !MIN_VERSION_base(4,11,0)- , Semigroup e-#endif- ) => Alternative (ComposeEither f e) where+ ComposeEither f <*> ComposeEither a = ComposeEither $+ select (prepare <$> f) (combine <$> a)+ where+ prepare :: Either e (a -> b) -> Either (a -> b) (Either e b)+ prepare = either (Right . Left) Left++ combine :: Either e a -> (a -> b) -> Either e b+ combine = flip fmap++---------------------------------- Alternative ---------------------------------+instance (Selective f, Monoid e) => Alternative (ComposeEither f e) where empty = ComposeEither (pure $ Left mempty) ComposeEither x <|> ComposeEither y = ComposeEither (x `orElse` y) @@ -559,7 +571,7 @@ 1) A generic 'failIfLeft' if not possible, although many actual instances should be able to implement it. -2) More importantly, this requires duplication of work: if we failed becauase we+2) More importantly, this requires duplication of work: if we failed because we happened to parse a 'Left' value in the first parser, then we need to rerun it, obtain a 'Left' once again, and then execute the second parser. Again, a specific instance may be able to cache the result and reuse it without
src/Control/Selective/Free.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Free--- Copyright : (c) Andrey Mokhov 2018-2019+-- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental
src/Control/Selective/Multi.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Multi--- Copyright : (c) Andrey Mokhov 2018-2020+-- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental
src/Control/Selective/Rigid/Free.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Rigid.Free--- Copyright : (c) Andrey Mokhov 2018-2019+-- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental@@ -30,7 +30,7 @@ getPure, getEffects, getNecessaryEffect, runSelect, foldSelect ) where -import Control.Monad.Trans.Except+import Control.Selective.Trans.Except import Control.Selective import Data.Bifunctor import Data.Functor
src/Control/Selective/Rigid/Freer.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Selective.Rigid.Freer--- Copyright : (c) Andrey Mokhov 2018-2019+-- Copyright : (c) Andrey Mokhov 2018-2023 -- License : MIT (see the file LICENSE) -- Maintainer : andrey.mokhov@gmail.com -- Stability : experimental@@ -26,7 +26,7 @@ getPure, getEffects, getNecessaryEffect, runSelect, foldSelect ) where -import Control.Monad.Trans.Except+import Control.Selective.Trans.Except import Control.Selective import Data.Bifunctor import Data.Function
+ src/Control/Selective/Trans/Except.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveTraversable, DerivingVia #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Selective.Trans.Except+-- Copyright : (c) Andrey Mokhov 2018-2023+-- License : MIT (see the file LICENSE)+-- Maintainer : andrey.mokhov@gmail.com+-- Stability : experimental+--+-- This is a library for /selective applicative functors/, or just+-- /selective functors/ for short, an abstraction between applicative functors+-- and monads, introduced in this paper:+-- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf.+--+-- This module defines a newtype around 'ExceptT' from @transformers@ with less+-- restrictive 'Applicative', 'Selective', and 'Alternative' implementations.+-- It supplies an @instance 'Selective' f => 'Selective' ('ExceptT' e f)@, which+-- makes 'ExceptT' a bona-fide 'Selective' transformer.+--+-- The API follows the API from the @transformers@ package, so it can be used as+-- a drop-in replacement. The documentation can be found in the+-- [@transformers@](https://hackage.haskell.org/package/transformers/docs/Control-Monad-Trans-Except.html) package.+-----------------------------------------------------------------------------+module Control.Selective.Trans.Except where++import Control.Applicative (Alternative)+import Control.Monad (MonadPlus)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Zip (MonadZip)+import Data.Functor.Classes+import Data.Functor.Contravariant (Contravariant)+import Data.Functor.Identity+#if MIN_VERSION_base(4,13,0)+-- MonadFail is imported already+#else+import Control.Monad.Fail+#endif++import qualified Control.Monad.Trans.Except as T+import Control.Monad.Trans.Class++import Control.Selective+import Control.Monad.Signatures++-- | A newtype wrapper around 'T.ExceptT' from @transformers@ that provides less+-- restrictive 'Applicative', 'Selective' and 'Alternative' instances.+newtype ExceptT e f a = ExceptT { unwrap :: T.ExceptT e f a }+ deriving+ ( Functor, Foldable, Traversable, Monad, Contravariant, Eq, Ord, Read, Show+ , MonadTrans, MonadFix, MonadFail, MonadZip, MonadIO, MonadPlus, Eq1, Ord1+ , Read1, Show1 )+ deriving (Applicative, Selective, Alternative) via (ComposeEither f e)++-- | Inject an 'T.ExceptT' value into the newtype wrapper.+wrap :: T.ExceptT e m a -> ExceptT e m a+wrap = ExceptT++type Except e = ExceptT e Identity++except :: Monad m => Either e a -> ExceptT e m a+except = ExceptT . T.except++runExcept :: Except e a -> Either e a+runExcept = T.runExcept . unwrap++mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b+mapExcept f = ExceptT . T.mapExcept f . unwrap++withExcept :: (e -> e') -> Except e a -> Except e' a+withExcept f = ExceptT . T.withExcept f . unwrap++runExceptT :: ExceptT e m a -> m (Either e a)+runExceptT = T.runExceptT . unwrap++mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b+mapExceptT f = ExceptT . T.mapExceptT f . unwrap++withExceptT :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a+withExceptT f = ExceptT . T.withExceptT f . unwrap++throwE :: Monad m => e -> ExceptT e m a+throwE = ExceptT . T.throwE++catchE :: Monad m => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a+catchE action continuation = ExceptT $ T.catchE (unwrap action) (unwrap . continuation)++liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b+liftCallCC callCC caller = ExceptT $ T.liftCallCC callCC (unwrap . caller . (ExceptT .))++liftListen :: Monad m => Listen w m (Either e a) -> Listen w (ExceptT e m) a+liftListen listen (ExceptT action) = ExceptT $ T.liftListen listen action++liftPass :: Monad m => Pass w m (Either e a) -> Pass w (ExceptT e m) a+liftPass pass (ExceptT action) = ExceptT $ T.liftPass pass action
test/Laws.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE FlexibleInstances, TupleSections, TypeApplications #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Laws where import Control.Arrow hiding (first, second)+import qualified Control.Monad.Trans.Except as Transformers import Control.Monad.Trans.Writer import Control.Selective+import Control.Selective.Trans.Except import Data.Bifunctor (bimap, first, second) import Data.Function import Data.Functor.Identity@@ -146,3 +150,6 @@ instance (Arbitrary w, Arbitrary a) => Arbitrary (Writer w a) where arbitrary = curry writer <$> arbitrary <*> arbitrary++deriving instance (Arbitrary e, Arbitrary a) => Arbitrary (Transformers.Except e a)+deriving instance (Arbitrary e, Arbitrary a) => Arbitrary (Except e a)
test/Main.hs view
@@ -2,6 +2,7 @@ import Control.Arrow (ArrowMonad) import Control.Monad.Trans.Writer hiding (writer)+import Control.Selective.Trans.Except hiding (except) import Control.Selective import Data.Functor.Identity import Data.Maybe hiding (maybe)@@ -28,7 +29,9 @@ , arrowMonad , maybe , identity- , writer ]+ , writer+ , except+ ] -------------------------------------------------------------------------------- ------------------------ Ping-pong----------------------------------------------@@ -386,3 +389,48 @@ \x -> propertyPureRight @MyWriter @Int @Int x , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $ \x -> propertyPureLeft @MyWriter @Int @Int x ]++--------------------------------------------------------------------------------+------------------------ Except ------------------------------------------------+--------------------------------------------------------------------------------++except :: Tests+except = testGroup "Except"+ [ exceptLaws+ , exceptTheorems+ , exceptProperties ]++type MyExcept = Except [Int]++exceptLaws :: Tests+exceptLaws = testGroup "Laws"+ [ expectSuccess "Identity: (x <*? pure id) == (either id id <$> x)" $+ \x -> lawIdentity @MyExcept @Int x+ , expectSuccess "Distributivity: (pure x <*? (y *> z)) == ((pure x <*? y) *> (pure x <*? z))" $+ \x -> lawDistributivity @MyExcept @Int @Int x+ , expectSuccess "Associativity: take a look at tests/Laws.hs" $+ \x -> lawAssociativity @MyExcept @Int @Int @Int x+ , expectSuccess "select == selectM" $+ \x -> lawMonad @MyExcept @Int @Int x ]++exceptTheorems :: Tests+exceptTheorems = testGroup "Theorems"+ [ expectSuccess "Apply a pure function to the result: (f <$> select x y) == (select (second f <$> x) ((f .) <$> y))" $+ \x -> theorem1 @MyExcept @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 @MyExcept @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 @MyExcept @Int @Int @Int x+ , expectSuccess "Generalised Identity: (x <*? pure y) == (either y id <$> x)" $+ \x -> theorem4 @MyExcept @Int @Int x+ , expectSuccess "(f <*> g) == (f `apS` g)" $+ \x -> theorem5 @MyExcept @Int @Int x+ , expectSuccess "Interchange: (x *> (y <*? z)) == ((x *> y) <*? z)" $+ \x -> theorem6 @MyExcept @Int @Int @Int x ]++exceptProperties :: Tests+exceptProperties = testGroup "Properties"+ [ expectSuccess "pure-right: pure (Right x) <*? y = pure x" $+ \x -> propertyPureRight @MyExcept @Int @Int x+ , expectSuccess "pure-left: pure (Left x) <*? y = ($x) <$> y" $+ \x -> propertyPureLeft @MyExcept @Int @Int x ]
test/Test.hs view
@@ -5,7 +5,6 @@ import System.Exit (exitFailure) import Test.QuickCheck hiding (Success, Failure, expectFailure) - data Expect = ExpectSuccess | ExpectFailure deriving Eq data Test = Test String Expect Property@@ -23,17 +22,17 @@ runTest :: [String] -> Test -> IO () runTest labels (Test name expect property) = do- let label = intercalate "." (reverse (name : labels))+ let label = "[" ++ intercalate "." (reverse labels) ++ "] " ++ name result <- quickCheckWithResult (stdArgs { chatty = False }) property case (expect, isSuccess result) of- (ExpectSuccess, True) -> putStrLn $ "OK: " ++ label- (ExpectFailure, False) -> putStrLn $ "OK (expected failure): " ++ label+ (ExpectSuccess, True) ->+ putStrLn $ "[OK] " ++ label+ (ExpectFailure, False) ->+ putStrLn $ "[OK, expected failure] " ++ label+ (ExpectFailure, True) ->+ putStrLn $ "[Warning, unexpected success] " ++ 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 $ "\n[Failure] " ++ label ++ "\n" putStrLn $ output result exitFailure