smallcheck-1.2.1.1/0000755000000000000000000000000007346545000012151 5ustar0000000000000000smallcheck-1.2.1.1/CHANGELOG.md0000644000000000000000000000757507346545000014000 0ustar0000000000000000Changes ======= Version 1.2.1.1 ------------- * Annotate everything with `@since` pragmas. Version 1.2.1 ------------- * Add `Serial` and `CoSerial` instances for `Ordering`. Version 1.2.0 ------------- * Add `Serial` and `CoSerial` instances for `(,,,,)`, `(,,,,,)`, `Compose`, `Foreign.C.Types`, `Data.List.NonEmpty`, `Void`, `Complex`. * Add `Bounded`, `Functor`, `Foldable` and `Traversable` instances for `Positive` and `NonNegative` wrappers. * Add `NonZero` wrapper for non-zero integers. * Add `cons5`, `cons6`, `alts5`, `alts6`. Version 1.1.7 ------------- * Fix overlapping instances of `GSerial`. Version 1.1.6 ------------- * Mark modules as `Safe`, not just `Trustworthy`. Version 1.1.5 ------------- * Add `limit :: Monad m => Int -> Series m a -> Series m a` * Add `genericSeries` and `genericCoseries`, so that you can use the generic implementations more flexibly. Previously, the generic implementation was only available as the default method for `series`/`coseries` but not as standalone functions. Version 1.1.4 ------------- * Add instances for fixed-width Int and Word types (Int8, Word8 etc.) Version 1.1.3.1 --------------- * Fix compatibility with GHC 7.8 and older Version 1.1.3 ------------- * Add `Serial` and `CoSerial` instances for `Word` and `Natural` Version 1.1.2 ------------- * Export the `test` function * Add a `listSeries` function Version 1.1.1 ------------- Export some auxiliary functions from `T.S.Series`, and document how to express `consN` and `altsN` for `N > 4`. Version 1.1.0.1 --------------- Documentation fixes Version 1.1 ----------- * Add a `Serial` instance for `Ratio` * Add the `NonEmpty` wrapper for lists * Add `listM` (the monadic version of `list`) * Add optional explanation for test outcomes Version 1.0.4 ------------- Fix compatibility with GHC 7.4.1 Version 1.0.3 ------------- Fix a bug where no test cases were generated for some functional types (#19). Version 1.0.2 ------------- Fix a bug in the generic instance Version 1.0.1 ------------- Make SmallCheck build with GHC 7.4 Version 1.0 ----------- This is a major incompatible release of SmallCheck. Virtually every function has changed its name, type, semantics or module. So please carefully read the docs when upgrading. For some highlights, see [this blog post](http://ro-che.info/articles/2013-02-19-smallcheck.html). Version 0.6.2 ----------- * Derive Typeable Property instance * Add smallCheckPure Version 0.6.1 ----------- * Documentation improvements * Make the package build with GHC 7.4.1 Version 0.6 ----------- * Default Generic implementation of Serial instance (by Bas van Dijk) * The code is split into modules * Convert much of README into haddock documentation * Many small API changes * Remove impure Testable (IO a) instance Version 0.5 ----------- Make the package build with GHC 7.2. Some cosmetic changes. Version 0.4 ----------- The module SmallCheck is now Test.SmallCheck. Packaged with Cabal. Version 0.3 ----------- Existential quantifiers now have unique variants for which two witnesses are reported when uniqueness fails. The over-generating coseries method for functions of functional arguments has been replaced; now 'coseries' and the 'alts' family take a series argument. Test counters are now Integers, not Ints. Ord and Eq are now derived for the N types. Examples extended. Version 0.2 ----------- The 'smallCheck' driver now takes an argument d and runs test series at depths 0..d without interaction, stopping if any test fails. The interactive variant is still available as 'smallCheckI'. All Prelude numeric types now have Serial instances, including floating-point types. Serial types Nat and Natural are also defined. Examples extended. Version 0.1 ----------- The differences from 0.0 are two fixes (space-fault, output buffering), an 'unsafe' but sometimes useful Testable (IO a) instance and additional examples. smallcheck-1.2.1.1/CREDITS.md0000644000000000000000000000116407346545000013572 0ustar0000000000000000Credits ======= The original authors of SmallCheck are Colin Runciman, Matthew Naylor, and Fredrik Lindblad. Colin Runciman: > Thanks to Galois Connections, my hosts when I first wrote SmallCheck, > to users who have mailed me with feedback, to Ralf Hinze who suggested > the better method for functional coseries, to Neil Mitchell for > automating the derivation of Serial instances, to Matt Naylor for > the circuit-design examples and to Gwern Branwen for Cabal packaging. Contributors ------------ The following people have contributed to SmallCheck: * Bas van Dijk (default Generic implementation of Serial instance) smallcheck-1.2.1.1/LICENSE0000644000000000000000000000261607346545000013163 0ustar0000000000000000All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. smallcheck-1.2.1.1/README.md0000644000000000000000000000300407346545000013425 0ustar0000000000000000SmallCheck: a property-based testing library for Haskell ======================================================== **As of 2023, this library is largely obsolete: arbitrary test generators with shrinking such as [`falsify`](https://hackage.haskell.org/package/falsify) offer much better user experience.** SmallCheck is a testing library that allows to verify properties for all test cases up to some depth. The test cases are generated automatically by SmallCheck. Usefulness of such an approach to testing is based on the following observation: > If a program fails to meet its specification in some cases, it almost always > fails in some simple case. In many ways SmallCheck is very similar to QuickCheck. It uses the idea of type-based generators for test data, and the way testable properties are expressed is closely based on the QuickCheck approach. Like QuickCheck, SmallCheck tests whether properties hold for finite completely defined values at specific types, and reports counter-examples. The big difference is that instead of using a sample of randomly generated values, SmallCheck tests properties for all the finitely many values up to some depth, progressively increasing the depth used. For data values, depth means depth of construction. For functional values, it is a measure combining the depth to which arguments may be evaluated and the depth of possible results. The package is based on the [paper](http://www.cs.york.ac.uk/fp/smallcheck/smallcheck.pdf) by Colin Runciman, Matthew Naylor and Fredrik Lindblad. smallcheck-1.2.1.1/Setup.hs0000644000000000000000000000005607346545000013606 0ustar0000000000000000import Distribution.Simple main = defaultMain smallcheck-1.2.1.1/Test/0000755000000000000000000000000007346545000013070 5ustar0000000000000000smallcheck-1.2.1.1/Test/SmallCheck.hs0000644000000000000000000000722207346545000015435 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Test.SmallCheck -- Copyright : (c) Colin Runciman et al. -- License : BSD3 -- Maintainer: Roman Cheplyaka -- -- This module exports the main pieces of SmallCheck functionality. -- -- To generate test cases for your own types, refer to -- "Test.SmallCheck.Series". -- -- For pointers to other sources of information about SmallCheck, please refer -- to the README at -- -------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif module Test.SmallCheck ( -- * Constructing tests -- | The simplest kind of test is a function (possibly of many -- arguments) returning 'Data.Bool.Bool'. The function arguments are interpreted -- as being universally, existentially or uniquely quantified, depending -- on the quantification context. -- -- The default quantification context is universal ('forAll'). -- -- 'forAll', 'exists' and 'existsUnique' functions set the quantification -- context for function arguments. Depending on the quantification -- context, the test @\\x y -> p x y@ may be equivalent to: -- -- * \( \forall x, y\colon p\, x \, y \) ('forAll'), -- -- * \( \exists x, y\colon p\, x \, y \) ('exists'), -- -- * \( \exists! x, y\colon p\, x \, y \) ('existsUnique'). -- -- The quantification context affects all the variables immediately -- following the quantification operator, also extending past 'over', -- 'changeDepth' and 'changeDepth1' functions. -- -- However, it doesn't extend past other functions, like 'monadic', and -- doesn't affect the operands of '==>'. Such functions start a fresh -- default quantification context. -- ** Examples -- | -- * @\\x y -> p x y@ means -- \( \forall x, y\colon p\, x \, y \). -- -- * @'exists' $ \\x y -> p x y@ means -- \( \exists x, y\colon p\, x \, y \). -- -- * @'exists' $ \\x -> 'forAll' $ \\y -> p x y@ means -- \( \exists x\colon \forall y\colon p \, x \, y \). -- -- * @'existsUnique' $ \\x y -> p x y@ means -- \( \exists! x, y\colon p\, x \, y \). -- -- * @'existsUnique' $ \\x -> 'over' s $ \\y -> p x y@ means -- \( \exists! x, y \colon y \in s \wedge p \, x \, y \). -- -- * @'existsUnique' $ \\x -> 'monadic' $ \\y -> p x y@ means -- \( \exists! x \colon \forall y \colon [p \, x \, y] \). -- -- * @'existsUnique' $ \\x -> 'existsUnique' $ \\y -> p x y@ means -- \( \exists! x \colon \exists! y \colon p \, x \, y \). -- -- * @'exists' $ \\x -> (\\y -> p y) '==>' (\\z -> q z)@ means -- \( \exists x \colon (\forall y\colon p\, y) \implies (\forall z\colon q\, z) \). forAll, exists, existsUnique, over, monadic, (==>), changeDepth, changeDepth1, -- * Running tests -- | 'smallCheck' is a simple way to run a test. -- -- As an alternative, consider using a testing framework. -- -- The packages -- and -- -- provide integration with Tasty and HSpec, two popular testing -- frameworks. -- -- They allow to organize SmallCheck properties into a test suite (possibly -- together with HUnit or QuickCheck tests) and provide other useful -- features. -- -- For more ways to run the tests, see "Test.SmallCheck.Drivers". Depth, smallCheck, -- * Main types and classes Testable(..), Property, Reason ) where import Test.SmallCheck.Property import Test.SmallCheck.Drivers smallcheck-1.2.1.1/Test/SmallCheck/0000755000000000000000000000000007346545000015076 5ustar0000000000000000smallcheck-1.2.1.1/Test/SmallCheck/Drivers.hs0000644000000000000000000000566507346545000017064 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Test.SmallCheck.Drivers -- Copyright : (c) Colin Runciman et al. -- License : BSD3 -- Maintainer: Roman Cheplyaka -- -- You should only need this module if you wish to create your own way to -- run SmallCheck tests -------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif module Test.SmallCheck.Drivers ( smallCheck, smallCheckM, smallCheckWithHook, test, ppFailure, PropertyFailure(..), PropertySuccess(..), Argument, Reason, TestQuality(..) ) where import Control.Monad (when, return) import Data.Function (($), (.), const) import Data.IORef (readIORef, writeIORef, IORef, newIORef) -- NB: explicit import list to avoid name clash with modifyIORef' import Data.Maybe (Maybe(Nothing, Just)) import Data.Ord ((>)) import Prelude (Integer, (+), seq) import System.IO (IO, putStrLn) import Test.SmallCheck.Property import Test.SmallCheck.Property.Result import Text.Printf (printf) -- | A simple driver that runs the test in the 'IO' monad and prints the -- results. -- -- @since 1.0 smallCheck :: Testable IO a => Depth -> a -> IO () smallCheck d a = do ((good, bad), mbEx) <- runTestWithStats d a let testsRun = good + bad case mbEx of Nothing -> do printf "Completed %d tests without failure.\n" testsRun when (bad > 0) $ printf "But %d did not meet ==> condition.\n" bad Just x -> do printf "Failed test no. %d.\n" testsRun putStrLn $ ppFailure x runTestWithStats :: Testable IO a => Depth -> a -> IO ((Integer, Integer), Maybe PropertyFailure) runTestWithStats d prop = do good <- newIORef 0 bad <- newIORef 0 let hook GoodTest = modifyIORef' good (+1) hook BadTest = modifyIORef' bad (+1) r <- smallCheckWithHook d hook prop goodN <- readIORef good badN <- readIORef bad return ((goodN, badN), r) -- NB: modifyIORef' is in base starting at least from GHC 7.6.1. -- -- So get rid of this once 7.6.1 becomes widely adopted. modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do x <- readIORef ref let x' = f x x' `seq` writeIORef ref x' -- | Use this if: -- -- * You need to run a test in a monad different from 'IO' -- -- * You need to analyse the results rather than just print them -- -- @since 1.0 smallCheckM :: Testable m a => Depth -> a -> m (Maybe PropertyFailure) smallCheckM d = smallCheckWithHook d (const $ return ()) -- | Like `smallCheckM`, but allows to specify a monadic hook that gets -- executed after each test is run. -- -- Useful for applications that want to report progress information to the -- user. -- -- @since 1.0 smallCheckWithHook :: Testable m a => Depth -> (TestQuality -> m ()) -> a -> m (Maybe PropertyFailure) smallCheckWithHook d hook a = runProperty d hook $ test a smallcheck-1.2.1.1/Test/SmallCheck/Property.hs0000644000000000000000000002735607346545000017273 0ustar0000000000000000-- vim:fdm=marker:foldtext=foldtext() -------------------------------------------------------------------- -- | -- Module : Test.SmallCheck.Property -- Copyright : (c) Colin Runciman et al. -- License : BSD3 -- Maintainer: Roman Cheplyaka -- -- Properties and tools to construct them. -------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- Are we using new, polykinded and derivable Typeable yet? #define NEWTYPEABLE MIN_VERSION_base(4,7,0) #if NEWTYPEABLE {-# LANGUAGE Safe #-} #else -- Trustworthy is needed because of the hand-written Typeable instance #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif #endif module Test.SmallCheck.Property ( -- * Constructors forAll, exists, existsUnique, over, (==>), monadic, changeDepth, changeDepth1, -- * Property's entrails Property, PropertySuccess(..), PropertyFailure(..), runProperty, TestQuality(..), Argument, Reason, Depth, Testable(..), ) where import Control.Applicative (pure, (<$>), (<$)) import Control.Arrow (first) import Control.Monad (Monad, liftM, mzero, return, (=<<), (>>=)) import Control.Monad.Logic (MonadLogic, runLogicT, ifte, once, msplit, lnot) import Control.Monad.Reader (Reader, runReader, lift, ask, local, reader) import Data.Bool (Bool, otherwise) import Data.Either (Either, either) import Data.Eq (Eq) import Data.Function (($), flip, (.), const, id) import Data.Functor (fmap) import Data.Int (Int) import Data.Maybe (Maybe (Nothing, Just)) import Data.Ord (Ord, (<=)) import Data.Typeable (Typeable) import Prelude (Enum, (-)) import Test.SmallCheck.Property.Result import Test.SmallCheck.Series import Test.SmallCheck.SeriesMonad import Text.Show (Show, show) #if MIN_VERSION_base(4,17,0) import Data.Type.Equality (type (~)) #endif #if !NEWTYPEABLE import Data.Typeable (Typeable1, mkTyConApp, typeOf) import Prelude (undefined) #if MIN_VERSION_base(4,4,0) import Data.Typeable (mkTyCon3) #else import Data.Typeable (mkTyCon) #endif #endif ------------------------------ -- Property-related types ------------------------------ --{{{ -- | The type of properties over the monad @m@. -- -- @since 1.0 newtype Property m = Property { unProperty :: Reader (Env m) (PropertySeries m) } #if NEWTYPEABLE deriving Typeable #endif data PropertySeries m = PropertySeries { searchExamples :: Series m PropertySuccess , searchCounterExamples :: Series m PropertyFailure , searchClosest :: Series m (Property m, [Argument]) } data Env m = Env { quantification :: Quantification , testHook :: TestQuality -> m () } data Quantification = Forall | Exists | ExistsUnique -- | @since 1.0 data TestQuality = GoodTest | BadTest deriving (Eq, Ord, Enum, Show) #if !NEWTYPEABLE -- Typeable here is not polykinded yet, and also GHC doesn't know how to -- derive this. instance Typeable1 m => Typeable (Property m) where typeOf _ = mkTyConApp #if MIN_VERSION_base(4,4,0) (mkTyCon3 "smallcheck" "Test.SmallCheck.Property" "Property") #else (mkTyCon "smallcheck Test.SmallCheck.Property Property") #endif [typeOf (undefined :: m ())] #endif -- }}} ------------------------------------ -- Property runners and constructors ------------------------------------ --{{{ unProp :: Env t -> Property t -> PropertySeries t unProp q (Property p) = runReader p q runProperty :: Monad m => Depth -> (TestQuality -> m ()) -> Property m -> m (Maybe PropertyFailure) runProperty depth hook prop = (\l -> runLogicT l (\x _ -> return $ Just x) (return Nothing)) $ runSeries depth $ searchCounterExamples $ flip runReader (Env Forall hook) $ unProperty prop atomicProperty :: Series m PropertySuccess -> Series m PropertyFailure -> PropertySeries m atomicProperty s f = let prop = PropertySeries s f (pure (Property $ pure prop, [])) in prop makeAtomic :: Property m -> Property m makeAtomic (Property prop) = Property $ flip fmap prop $ \ps -> atomicProperty (searchExamples ps) (searchCounterExamples ps) -- | @'over' s $ \\x -> p x@ makes @x@ range over the 'Series' @s@ (by -- default, all variables range over the 'series' for their types). -- -- Note that, unlike the quantification operators, this affects only the -- variable following the operator and not subsequent variables. -- -- 'over' does not affect the quantification context. -- -- @since 1.0 over :: (Show a, Testable m b) => Series m a -> (a -> b) -> Property m over = testFunction -- | Execute a monadic test. -- -- @since 1.0 monadic :: Testable m a => m a -> Property m monadic a = Property $ reader $ \env -> let pair = unProp env . freshContext <$> lift a in atomicProperty (searchExamples =<< pair) (searchCounterExamples =<< pair) -- }}} ------------------------------- -- Testable class and instances ------------------------------- -- {{{ -- | Class of tests that can be run in a monad. For pure tests, it is -- recommended to keep their types polymorphic in @m@ rather than -- specialising it to 'Data.Functor.Identity'. -- -- @since 1.0 class Monad m => Testable m a where -- | @since 1.0 test :: a -> Property m instance Monad m => Testable m Bool where test b = Property $ reader $ \env -> let success = do lift $ testHook env GoodTest if b then return $ PropertyTrue Nothing else mzero failure = PropertyFalse Nothing <$ lnot success in atomicProperty success failure -- | Works like the 'Data.Bool.Bool' instance, but includes an explanation of the result. -- -- 'Data.Either.Left' and 'Data.Either.Right' correspond to test failure and success -- respectively. -- -- @since 1.1 instance Monad m => Testable m (Either Reason Reason) where test r = Property $ reader $ \env -> let success = do lift $ testHook env GoodTest either (const mzero) (pure . PropertyTrue . Just) r failure = do lift $ testHook env GoodTest either (pure . PropertyFalse . Just) (const mzero) r in atomicProperty success failure instance (Serial m a, Show a, Testable m b) => Testable m (a->b) where test = testFunction series instance (Monad m, m ~ n) => Testable n (Property m) where test = id testFunction :: (Show a, Testable m b) => Series m a -> (a -> b) -> Property m testFunction s f = Property $ reader $ \env -> let closest = do x <- s (p, args) <- searchClosest $ unProp env $ test $ f x return (p, show x : args) in case quantification env of Forall -> PropertySeries success failure closest -- {{{ where failure = do x <- s failure <- searchCounterExamples $ unProp env $ test $ f x let arg = show x return $ case failure of CounterExample args etc -> CounterExample (arg:args) etc _ -> CounterExample [arg] failure success = PropertyTrue Nothing <$ lnot failure -- }}} Exists -> PropertySeries success failure closest -- {{{ where success = do x <- s s <- searchExamples $ unProp env $ test $ f x let arg = show x return $ case s of Exist args etc -> Exist (arg:args) etc _ -> Exist [arg] s failure = NotExist <$ lnot success -- }}} ExistsUnique -> PropertySeries success failure closest -- {{{ where search = atMost 2 $ do (prop, args) <- closest ex <- once $ searchExamples $ unProp env $ test prop return (args, ex) success = search >>= \examples -> case examples of [(x,s)] -> return $ ExistUnique x s _ -> mzero failure = search >>= \examples -> case examples of [] -> return NotExist (x1,s1):(x2,s2):_ -> return $ AtLeastTwo x1 s1 x2 s2 _ -> mzero -- }}} atMost :: MonadLogic m => Int -> m a -> m [a] atMost n m | n <= 0 = return [] | otherwise = do m' <- msplit m case m' of Nothing -> return [] Just (x,rest) -> (x:) `liftM` atMost (n-1) rest -- }}} ------------------------------ -- Test constructors ------------------------------ -- {{{ quantify :: Quantification -> Property m -> Property m quantify q (Property a) = makeAtomic $ Property $ local (\env -> env { quantification = q }) a freshContext :: Testable m a => a -> Property m freshContext = forAll -- | Set the universal quantification context. -- -- @since 1.0 forAll :: Testable m a => a -> Property m forAll = quantify Forall . test -- | Set the existential quantification context. -- -- @since 1.0 exists :: Testable m a => a -> Property m exists = quantify Exists . test -- | Set the uniqueness quantification context. -- -- Bear in mind that \( \exists! x, y\colon p\, x \, y \) -- is not the same as \( \exists! x \colon \exists! y \colon p \, x \, y \). -- -- For example, \( \exists! x \colon \exists! y \colon |x| = |y| \) -- is true (it holds only when \(x=y=0\)), -- but \( \exists! x, y \colon |x| = |y| \) is false -- (there are many such pairs). -- -- As is customary in mathematics, -- @'existsUnique' $ \\x y -> p x y@ is equivalent to -- @'existsUnique' $ \\(x, y) -> p x y@ and not to -- @'existsUnique' $ \\x -> 'existsUnique' $ \\y -> p x y@ -- (the latter, of course, may be explicitly written when desired). -- -- That is, all the variables affected by the same uniqueness context are -- quantified simultaneously as a tuple. -- -- @since 1.0 existsUnique :: Testable m a => a -> Property m existsUnique = quantify ExistsUnique . test -- | The '==>' operator can be used to express a restricting condition -- under which a property should hold. It corresponds to implication in the -- classical logic. -- -- Note that '==>' resets the quantification context for its operands to -- the default (universal). -- -- @since 1.0 infixr 0 ==> (==>) :: (Testable m c, Testable m a) => c -> a -> Property m cond ==> prop = Property $ do env <- ask let counterExample = once $ searchCounterExamples $ unProp env' $ freshContext cond -- NB: we do not invoke the test hook in the antecedent where env' = env { testHook = const $ return () } consequent = unProp env $ freshContext prop badTestHook = lift $ testHook env BadTest success = ifte counterExample -- then (\ex -> do badTestHook return $ Vacuously ex ) -- else (searchExamples consequent) failure = ifte counterExample -- then (const $ do lift $ testHook env BadTest mzero ) -- else (searchCounterExamples consequent) return $ atomicProperty success failure -- | Run property with a modified depth. Affects all quantified variables -- in the property. -- -- @since 1.0 changeDepth :: Testable m a => (Depth -> Depth) -> a -> Property m changeDepth modifyDepth a = Property (changeDepthPS <$> unProperty (test a)) where changeDepthPS (PropertySeries ss sf sc) = PropertySeries (localDepth modifyDepth ss) (localDepth modifyDepth sf) (first (changeDepth modifyDepth) <$> localDepth modifyDepth sc) -- | Quantify the function's argument over its 'series', but adjust the -- depth. This doesn't affect any subsequent variables. -- -- @since 1.0 changeDepth1 :: (Show a, Serial m a, Testable m b) => (Depth -> Depth) -> (a -> b) -> Property m changeDepth1 modifyDepth = over $ localDepth modifyDepth series -- }}} smallcheck-1.2.1.1/Test/SmallCheck/Property/0000755000000000000000000000000007346545000016722 5ustar0000000000000000smallcheck-1.2.1.1/Test/SmallCheck/Property/Result.hs0000644000000000000000000000535507346545000020544 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif module Test.SmallCheck.Property.Result ( PropertySuccess(..) , PropertyFailure(..) , ppFailure , Reason , Argument ) where import Data.Bool (Bool (False, True)) import Data.Eq (Eq) import Data.Function (($), (.)) import Data.Int (Int) import Data.List (map) import Data.Maybe (Maybe (Nothing, Just)) import Prelude (String) import Text.PrettyPrint (Doc, empty, hsep, nest, render, text, (<+>), ($+$), ($$)) import Text.Show (Show) -- | @since 1.0 type Argument = String -- | An explanation for the test outcome. -- -- @since 1.1 type Reason = String -- | @since 1.0 data PropertySuccess = Exist [Argument] PropertySuccess | ExistUnique [Argument] PropertySuccess | PropertyTrue (Maybe Reason) -- ^ @since 1.1 | Vacuously PropertyFailure deriving (Eq, Show) -- | @since 1.0 data PropertyFailure = NotExist | AtLeastTwo [Argument] PropertySuccess [Argument] PropertySuccess | CounterExample [Argument] PropertyFailure | PropertyFalse (Maybe Reason) -- ^ @since 1.1 deriving (Eq, Show) class Pretty a where pretty :: a -> Doc instance Pretty PropertyFailure where pretty NotExist = text "argument does not exist" pretty (AtLeastTwo args1 s1 args2 s2) = text "there are at least two" <+> plural args1 empty (text "sets of") <+> text "arguments satisfying the property:" $$ formatExample args1 s1 $$ formatExample args2 s2 where formatExample args s = nest ind $ text "for" <+> prettyArgs args pretty s pretty (CounterExample args f) = text "there" <+> text (plural args "exists" "exist") <+> prettyArgs args <+> text "such that" pretty f pretty (PropertyFalse Nothing) = text "condition is false" pretty (PropertyFalse (Just s)) = text s instance Pretty PropertySuccess where pretty (PropertyTrue Nothing) = text "condition is true" pretty (PropertyTrue (Just s)) = text s pretty (Exist args s) = existsMsg False args s pretty (ExistUnique args s) = existsMsg True args s pretty (Vacuously s) = text "property is vacuously true because" pretty s ind :: Int ind = 2 infixl 5 () :: Doc -> Doc -> Doc a b = a $+$ nest ind b prettyArgs :: [Argument] -> Doc prettyArgs = hsep . map text existsMsg :: Pretty a => Bool -> [Argument] -> a -> Doc existsMsg unique args s = text "there" <+> text (plural args "exists" "exist") <+> (if unique then text "unique" else empty) <+> prettyArgs args <+> text "such that" pretty s plural :: [a] -> b -> b -> b plural lst sing pl = case lst of _:_:_ -> pl _ -> sing -- | @since 1.0 ppFailure :: PropertyFailure -> String ppFailure = render . pretty smallcheck-1.2.1.1/Test/SmallCheck/Series.hs0000644000000000000000000011764607346545000016703 0ustar0000000000000000-- vim:fdm=marker:foldtext=foldtext() -------------------------------------------------------------------- -- | -- Module : Test.SmallCheck.Series -- Copyright : (c) Colin Runciman et al. -- License : BSD3 -- Maintainer: Roman Cheplyaka -- -- You need this module if you want to generate test values of your own -- types. -- -- You'll typically need the following extensions: -- -- >{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -- -- SmallCheck itself defines data generators for all the data types used -- by the "Prelude". -- -- In order to generate values and functions of your own types, you need -- to make them instances of 'Serial' (for values) and 'CoSerial' (for -- functions). There are two main ways to do so: using Generics or writing -- the instances by hand. -------------------------------------------------------------------- {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DefaultSignatures #-} #endif {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} #if MIN_VERSION_base(4,8,0) {-# LANGUAGE Safe #-} #else {-# LANGUAGE OverlappingInstances #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif #endif #define HASCBOOL MIN_VERSION_base(4,10,0) module Test.SmallCheck.Series ( -- {{{ -- * Generic instances -- | The easiest way to create the necessary instances is to use GHC -- generics (available starting with GHC 7.2.1). -- -- Here's a complete example: -- -- >{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -- >{-# LANGUAGE DeriveGeneric #-} -- > -- >import Test.SmallCheck.Series -- >import GHC.Generics -- > -- >data Tree a = Null | Fork (Tree a) a (Tree a) -- > deriving Generic -- > -- >instance Serial m a => Serial m (Tree a) -- -- Here we enable the @DeriveGeneric@ extension which allows to derive 'Generic' -- instance for our data type. Then we declare that @Tree@ @a@ is an instance of -- 'Serial', but do not provide any definitions. This causes GHC to use the -- default definitions that use the 'Generic' instance. -- -- One minor limitation of generic instances is that there's currently no -- way to distinguish newtypes and datatypes. Thus, newtype constructors -- will also count as one level of depth. -- * Data Generators -- | Writing 'Serial' instances for application-specific types is -- straightforward. You need to define a 'series' generator, typically using -- @consN@ family of generic combinators where N is constructor arity. -- -- For example: -- -- >data Tree a = Null | Fork (Tree a) a (Tree a) -- > -- >instance Serial m a => Serial m (Tree a) where -- > series = cons0 Null \/ cons3 Fork -- -- For newtypes use 'newtypeCons' instead of 'cons1'. -- The difference is that 'cons1' is counts as one level of depth, while -- 'newtypeCons' doesn't affect the depth. -- -- >newtype Light a = Light a -- > -- >instance Serial m a => Serial m (Light a) where -- > series = newtypeCons Light -- -- For data types with more than 6 fields define @consN@ as -- -- >consN f = decDepth $ -- > f <$> series -- > <~> series -- > <~> series -- > <~> ... {- series repeated N times in total -} -- ** What does @consN@ do, exactly? -- | @consN@ has type -- @(Serial t₁, ..., Serial tₙ) => (t₁ -> ... -> tₙ -> t) -> Series t@. -- -- @consN@ @f@ is a series which, for a given depth \(d > 0\), produces values of the -- form -- -- >f x₁ ... xₙ -- -- where @xₖ@ ranges over all values of type @tₖ@ of depth up to \(d-1\) -- (as defined by the 'series' functions for @tₖ@). -- -- @consN@ functions also ensure that xₖ are enumerated in the -- breadth-first order. Thus, combinations of smaller depth come first -- (assuming the same is true for @tₖ@). -- -- If \(d \le 0\), no values are produced. cons0, cons1, cons2, cons3, cons4, cons5, cons6, newtypeCons, -- * Function Generators -- | To generate functions of an application-specific argument type, -- make the type an instance of 'CoSerial'. -- -- Again there is a standard pattern, this time using the @altsN@ -- combinators where again N is constructor arity. Here are @Tree@ and -- @Light@ instances: -- -- -- >instance CoSerial m a => CoSerial m (Tree a) where -- > coseries rs = -- > alts0 rs >>- \z -> -- > alts3 rs >>- \f -> -- > return $ \t -> -- > case t of -- > Null -> z -- > Fork t1 x t2 -> f t1 x t2 -- -- >instance CoSerial m a => CoSerial m (Light a) where -- > coseries rs = -- > newtypeAlts rs >>- \f -> -- > return $ \l -> -- > case l of -- > Light x -> f x -- -- For data types with more than 6 fields define @altsN@ as -- -- >altsN rs = do -- > rs <- fixDepth rs -- > decDepthChecked -- > (constM $ constM $ ... $ constM rs) -- > (coseries $ coseries $ ... $ coseries rs) -- > {- constM and coseries are repeated N times each -} -- ** What does altsN do, exactly? -- | @altsN@ has type -- @(Serial t₁, ..., Serial tₙ) => Series t -> Series (t₁ -> ... -> tₙ -> t)@. -- -- @altsN@ @s@ is a series which, for a given depth \( d \), produces functions of -- type -- -- >t₁ -> ... -> tₙ -> t -- -- If \( d \le 0 \), these are constant functions, one for each value produced -- by @s@. -- -- If \( d > 0 \), these functions inspect each of their arguments up to the depth -- \( d-1 \) (as defined by the 'coseries' functions for the corresponding -- types) and return values produced by @s@. The depth to which the -- values are enumerated does not depend on the depth of inspection. alts0, alts1, alts2, alts3, alts4, alts5, alts6, newtypeAlts, -- * Basic definitions Depth, Series, Serial(..), CoSerial(..), #if __GLASGOW_HASKELL__ >= 702 -- * Generic implementations genericSeries, genericCoseries, #endif -- * Convenient wrappers Positive(..), NonNegative(..), NonZero(..), NonEmpty(..), -- * Other useful definitions (\/), (><), (<~>), (>>-), localDepth, decDepth, getDepth, generate, limit, listSeries, list, listM, fixDepth, decDepthChecked, constM -- }}} ) where import Control.Applicative (empty, pure, (<$>), (<|>)) import Control.Monad (Monad, liftM, guard, mzero, mplus, msum, return, (>>), (>>=)) import Control.Monad.Identity (Identity(Identity), runIdentity) import Control.Monad.Logic (MonadLogic, (>>-), interleave, msplit, observeAllT) import Control.Monad.Reader (ask, local) import Data.Bool (Bool (True, False), (&&), (||)) import Data.Char (Char) import Data.Complex (Complex((:+))) import Data.Either (Either (Left, Right), either) import Data.Eq (Eq, (==), (/=)) import Data.Foldable (Foldable) import Data.Function (($), (.), const) import Data.Functor (Functor, fmap) import Data.Functor.Compose (Compose(Compose), getCompose) import Data.Int (Int, Int8, Int16, Int32, Int64) import Data.List (intercalate, take, map, length, (++), maximum, sum, unlines, lines, concat) import qualified Data.List.NonEmpty as NE import Data.Maybe (Maybe (Just, Nothing), maybe) import Data.Ord (Ord, Ordering (LT, EQ, GT), max, (<), (>), (>=), compare, (<=)) import Data.Ratio (Ratio, numerator, denominator, (%)) import Data.Traversable (Traversable) import Data.Tuple (uncurry) import Data.Void (Void, absurd) import Data.Word (Word, Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Prelude (Integer, Real, toRational, Enum, toEnum, fromEnum, Num, (+), (*), Integral, quotRem, toInteger, negate, abs, signum, fromInteger, Bounded, minBound, maxBound, Float, Double, (-), odd, encodeFloat, decodeFloat, realToFrac, seq, subtract) import Test.SmallCheck.SeriesMonad import Text.Show (Show, showsPrec, show) #if MIN_VERSION_base(4,5,0) import Foreign.C.Types (CFloat(CFloat), CDouble(CDouble), CChar(CChar), CSChar(CSChar), CUChar(CUChar), CShort(CShort), CUShort(CUShort), CInt(CInt), CUInt(CUInt), CLong(CLong), CULong(CULong), CPtrdiff(CPtrdiff), CSize(CSize), CWchar(CWchar), CSigAtomic(CSigAtomic), CLLong(CLLong), CULLong(CULLong), CIntPtr(CIntPtr), CUIntPtr(CUIntPtr), CIntMax(CIntMax), CUIntMax(CUIntMax), CClock(CClock), CTime(CTime), CUSeconds(CUSeconds), CSUSeconds(CSUSeconds)) #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic, (:+:)(L1, R1), (:*:)((:*:)), C1, K1(K1), unK1, M1(M1), unM1, U1(U1), V1, Rep, to, from) #else import Prelude (RealFloat) #endif #if HASCBOOL import Foreign.C.Types (CBool(CBool)) #endif ------------------------------ -- Main types and classes ------------------------------ --{{{ -- | @since 1.0 class Monad m => Serial m a where series :: Series m a #if __GLASGOW_HASKELL__ >= 704 default series :: (Generic a, GSerial m (Rep a)) => Series m a series = genericSeries #endif #if __GLASGOW_HASKELL__ >= 702 -- | @since 1.1.5 genericSeries :: (Monad m, Generic a, GSerial m (Rep a)) => Series m a genericSeries = to <$> gSeries #endif -- | @since 1.0 class Monad m => CoSerial m a where -- | A proper 'coseries' implementation should pass the depth unchanged to -- its first argument. Doing otherwise will make enumeration of curried -- functions non-uniform in their arguments. coseries :: Series m b -> Series m (a->b) #if __GLASGOW_HASKELL__ >= 704 default coseries :: (Generic a, GCoSerial m (Rep a)) => Series m b -> Series m (a->b) coseries = genericCoseries #endif #if __GLASGOW_HASKELL__ >= 702 -- | @since 1.1.5 genericCoseries :: (Monad m, Generic a, GCoSerial m (Rep a)) => Series m b -> Series m (a->b) genericCoseries rs = (. from) <$> gCoseries rs #endif -- }}} ------------------------------ -- Helper functions ------------------------------ -- {{{ -- | A simple series specified by a function from depth to the list of -- values up to that depth. -- -- @since 1.0 generate :: (Depth -> [a]) -> Series m a generate f = do d <- getDepth msum $ map return $ f d -- | Limit a 'Series' to its first @n@ elements. -- -- @since 1.1.5 limit :: forall m a . Monad m => Int -> Series m a -> Series m a limit n0 (Series s) = Series $ go n0 s where go 0 _ = empty go n mb1 = do cons :: Maybe (b, ml b) <- msplit mb1 case cons of Nothing -> empty Just (b, mb2) -> return b <|> go (n-1) mb2 suchThat :: Series m a -> (a -> Bool) -> Series m a suchThat s p = s >>= \x -> if p x then pure x else empty -- | Given a depth, return the list of values generated by a 'Serial' instance. -- -- For example, list all integers up to depth 1: -- -- * @listSeries 1 :: [Int] -- returns [0,1,-1]@ -- -- @since 1.1.2 listSeries :: Serial Identity a => Depth -> [a] listSeries d = list d series -- | Return the list of values generated by a 'Series'. Useful for -- debugging 'Serial' instances. -- -- Examples: -- -- * @'list' 3 'series' :: ['Int'] -- returns [0,1,-1,2,-2,3,-3]@ -- -- * @'list' 3 ('series' :: 'Series' 'Data.Functor.Identity' 'Int') -- returns [0,1,-1,2,-2,3,-3]@ -- -- * @'list' 2 'series' :: [['Bool']] -- returns [[],['True'],['False']]@ -- -- The first two are equivalent. The second has a more explicit type binding. -- -- @since 1.0 list :: Depth -> Series Identity a -> [a] list d s = runIdentity $ observeAllT $ runSeries d s -- | Monadic version of 'list'. -- -- @since 1.1 listM d s = observeAllT $ runSeries d s -- | Sum (union) of series. -- -- @since 1.0 infixr 7 \/ (\/) :: Monad m => Series m a -> Series m a -> Series m a (\/) = interleave -- | Product of series -- -- @since 1.0 infixr 8 >< (><) :: Monad m => Series m a -> Series m b -> Series m (a,b) a >< b = (,) <$> a <~> b -- | Fair version of 'Control.Applicative.ap' and 'Control.Applicative.<*>'. -- -- @since 1.0 infixl 4 <~> (<~>) :: Monad m => Series m (a -> b) -> Series m a -> Series m b a <~> b = a >>- (<$> b) uncurry3 :: (a->b->c->d) -> ((a,b,c)->d) uncurry3 f (x,y,z) = f x y z uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e) uncurry4 f (w,x,y,z) = f w x y z uncurry5 :: (a->b->c->d->e->f) -> ((a,b,c,d,e)->f) uncurry5 f (v,w,x,y,z) = f v w x y z uncurry6 :: (a->b->c->d->e->f->g) -> ((a,b,c,d,e,f)->g) uncurry6 f (u,v,w,x,y,z) = f u v w x y z -- | Query the current depth. -- -- @since 1.0 getDepth :: Series m Depth getDepth = Series ask -- | Run a series with a modified depth. -- -- @since 1.0 localDepth :: (Depth -> Depth) -> Series m a -> Series m a localDepth f (Series a) = Series $ local f a -- | Run a 'Series' with the depth decreased by 1. -- -- If the current depth is less or equal to 0, the result is 'empty'. -- -- @since 1.0 decDepth :: Series m a -> Series m a decDepth a = do checkDepth localDepth (subtract 1) a checkDepth :: Series m () checkDepth = do d <- getDepth guard $ d > 0 -- | @'constM' = 'liftM' 'const'@ -- -- @since 1.1.1 constM :: Monad m => m b -> m (a -> b) constM = liftM const -- | Fix the depth of a series at the current level. The resulting series -- will no longer depend on the \"ambient\" depth. -- -- @since 1.1.1 fixDepth :: Series m a -> Series m (Series m a) fixDepth s = getDepth >>= \d -> return $ localDepth (const d) s -- | If the current depth is 0, evaluate the first argument. Otherwise, -- evaluate the second argument with decremented depth. -- -- @since 1.1.1 decDepthChecked :: Series m a -> Series m a -> Series m a decDepthChecked b r = do d <- getDepth if d <= 0 then b else decDepth r unwind :: MonadLogic m => m a -> m [a] unwind a = msplit a >>= maybe (return []) (\(x,a') -> (x:) `liftM` unwind a') -- }}} ------------------------------ -- cons* and alts* functions ------------------------------ -- {{{ -- | @since 1.0 cons0 :: a -> Series m a cons0 x = decDepth $ pure x -- | @since 1.0 cons1 :: Serial m a => (a->b) -> Series m b cons1 f = decDepth $ f <$> series -- | Same as 'cons1', but preserves the depth. -- -- @since 1.0 newtypeCons :: Serial m a => (a->b) -> Series m b newtypeCons f = f <$> series -- | @since 1.0 cons2 :: (Serial m a, Serial m b) => (a->b->c) -> Series m c cons2 f = decDepth $ f <$> series <~> series -- | @since 1.0 cons3 :: (Serial m a, Serial m b, Serial m c) => (a->b->c->d) -> Series m d cons3 f = decDepth $ f <$> series <~> series <~> series -- | @since 1.0 cons4 :: (Serial m a, Serial m b, Serial m c, Serial m d) => (a->b->c->d->e) -> Series m e cons4 f = decDepth $ f <$> series <~> series <~> series <~> series -- | @since 1.2.0 cons5 :: (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e) => (a->b->c->d->e->f) -> Series m f cons5 f = decDepth $ f <$> series <~> series <~> series <~> series <~> series -- | @since 1.2.0 cons6 :: (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e, Serial m f) => (a->b->c->d->e->f->g) -> Series m g cons6 f = decDepth $ f <$> series <~> series <~> series <~> series <~> series <~> series -- | @since 1.0 alts0 :: Series m a -> Series m a alts0 s = s -- | @since 1.0 alts1 :: CoSerial m a => Series m b -> Series m (a->b) alts1 rs = do rs <- fixDepth rs decDepthChecked (constM rs) (coseries rs) -- | @since 1.0 alts2 :: (CoSerial m a, CoSerial m b) => Series m c -> Series m (a->b->c) alts2 rs = do rs <- fixDepth rs decDepthChecked (constM $ constM rs) (coseries $ coseries rs) -- | @since 1.0 alts3 :: (CoSerial m a, CoSerial m b, CoSerial m c) => Series m d -> Series m (a->b->c->d) alts3 rs = do rs <- fixDepth rs decDepthChecked (constM $ constM $ constM rs) (coseries $ coseries $ coseries rs) -- | @since 1.0 alts4 :: (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d) => Series m e -> Series m (a->b->c->d->e) alts4 rs = do rs <- fixDepth rs decDepthChecked (constM $ constM $ constM $ constM rs) (coseries $ coseries $ coseries $ coseries rs) -- | @since 1.2.0 alts5 :: (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e) => Series m f -> Series m (a->b->c->d->e->f) alts5 rs = do rs <- fixDepth rs decDepthChecked (constM $ constM $ constM $ constM $ constM rs) (coseries $ coseries $ coseries $ coseries $ coseries rs) -- | @since 1.2.0 alts6 :: (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e, CoSerial m f) => Series m g -> Series m (a->b->c->d->e->f->g) alts6 rs = do rs <- fixDepth rs decDepthChecked (constM $ constM $ constM $ constM $ constM $ constM rs) (coseries $ coseries $ coseries $ coseries $ coseries $ coseries rs) -- | Same as 'alts1', but preserves the depth. -- -- @since 1.0 newtypeAlts :: CoSerial m a => Series m b -> Series m (a->b) newtypeAlts = coseries -- }}} ------------------------------ -- Generic instances ------------------------------ -- {{{ class GSerial m f where gSeries :: Series m (f a) class GCoSerial m f where gCoseries :: Series m b -> Series m (f a -> b) #if __GLASGOW_HASKELL__ >= 702 instance {-# OVERLAPPABLE #-} GSerial m f => GSerial m (M1 i c f) where gSeries = M1 <$> gSeries {-# INLINE gSeries #-} instance GCoSerial m f => GCoSerial m (M1 i c f) where gCoseries rs = (. unM1) <$> gCoseries rs {-# INLINE gCoseries #-} instance Serial m c => GSerial m (K1 i c) where gSeries = K1 <$> series {-# INLINE gSeries #-} instance CoSerial m c => GCoSerial m (K1 i c) where gCoseries rs = (. unK1) <$> coseries rs {-# INLINE gCoseries #-} instance GSerial m U1 where gSeries = pure U1 {-# INLINE gSeries #-} instance GCoSerial m U1 where gCoseries rs = constM rs {-# INLINE gCoseries #-} instance GSerial m V1 where gSeries = mzero {-# INLINE gSeries #-} instance GCoSerial m V1 where gCoseries = const $ return (\a -> a `seq` let x = x in x) {-# INLINE gCoseries #-} instance (Monad m, GSerial m a, GSerial m b) => GSerial m (a :*: b) where gSeries = (:*:) <$> gSeries <~> gSeries {-# INLINE gSeries #-} instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :*: b) where gCoseries rs = uncur <$> gCoseries (gCoseries rs) where uncur f (x :*: y) = f x y {-# INLINE gCoseries #-} instance (Monad m, GSerial m a, GSerial m b) => GSerial m (a :+: b) where gSeries = (L1 <$> gSeries) `interleave` (R1 <$> gSeries) {-# INLINE gSeries #-} instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :+: b) where gCoseries rs = gCoseries rs >>- \f -> gCoseries rs >>- \g -> return $ \e -> case e of L1 x -> f x R1 y -> g y {-# INLINE gCoseries #-} instance {-# OVERLAPPING #-} GSerial m f => GSerial m (C1 c f) where gSeries = M1 <$> decDepth gSeries {-# INLINE gSeries #-} #endif -- }}} ------------------------------ -- Instances for basic types ------------------------------ -- {{{ instance Monad m => Serial m () where series = return () instance Monad m => CoSerial m () where coseries rs = constM rs instance Monad m => Serial m Integer where series = unM <$> series instance Monad m => CoSerial m Integer where coseries = fmap (. M) . coseries -- | @since 1.1.3 instance Monad m => Serial m Natural where series = unN <$> series -- | @since 1.1.3 instance Monad m => CoSerial m Natural where coseries = fmap (. N) . coseries instance Monad m => Serial m Int where series = unM <$> series instance Monad m => CoSerial m Int where coseries = fmap (. M) . coseries -- | @since 1.1.3 instance Monad m => Serial m Word where series = unN <$> series -- | @since 1.1.3 instance Monad m => CoSerial m Word where coseries = fmap (. N) . coseries -- | @since 1.1.4 instance Monad m => Serial m Int8 where series = unM <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Int8 where coseries = fmap (. M) . coseries -- | @since 1.1.4 instance Monad m => Serial m Word8 where series = unN <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Word8 where coseries = fmap (. N) . coseries -- | @since 1.1.4 instance Monad m => Serial m Int16 where series = unM <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Int16 where coseries = fmap (. M) . coseries -- | @since 1.1.4 instance Monad m => Serial m Word16 where series = unN <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Word16 where coseries = fmap (. N) . coseries -- | @since 1.1.4 instance Monad m => Serial m Int32 where series = unM <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Int32 where coseries = fmap (. M) . coseries -- | @since 1.1.4 instance Monad m => Serial m Word32 where series = unN <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Word32 where coseries = fmap (. N) . coseries -- | @since 1.1.4 instance Monad m => Serial m Int64 where series = unM <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Int64 where coseries = fmap (. M) . coseries -- | @since 1.1.4 instance Monad m => Serial m Word64 where series = unN <$> series -- | @since 1.1.4 instance Monad m => CoSerial m Word64 where coseries = fmap (. N) . coseries -- | 'N' is a wrapper for 'Integral' types that causes only non-negative values -- to be generated. Generated functions of type @N a -> b@ do not distinguish -- different negative values of @a@. newtype N a = N { unN :: a } deriving (Eq, Ord, Show) instance Real a => Real (N a) where toRational (N x) = toRational x instance Enum a => Enum (N a) where toEnum x = N (toEnum x) fromEnum (N x) = fromEnum x instance Num a => Num (N a) where N x + N y = N (x + y) N x * N y = N (x * y) negate (N x) = N (negate x) abs (N x) = N (abs x) signum (N x) = N (signum x) fromInteger x = N (fromInteger x) instance Integral a => Integral (N a) where quotRem (N x) (N y) = (N q, N r) where (q, r) = x `quotRem` y toInteger (N x) = toInteger x instance (Num a, Enum a, Serial m a) => Serial m (N a) where series = generate $ \d -> take (d+1) [0..] instance (Integral a, Monad m) => CoSerial m (N a) where coseries rs = -- This is a recursive function, because @alts1 rs@ typically calls -- back to 'coseries' (but with lower depth). -- -- The recursion stops when depth == 0. Then alts1 produces a constant -- function, and doesn't call back to 'coseries'. alts0 rs >>- \z -> alts1 rs >>- \f -> return $ \(N i) -> if i > 0 then f (N $ i-1) else z -- | 'M' is a helper type to generate values of a signed type of increasing magnitude. newtype M a = M { unM :: a } deriving (Eq, Ord, Show) instance Real a => Real (M a) where toRational (M x) = toRational x instance Enum a => Enum (M a) where toEnum x = M (toEnum x) fromEnum (M x) = fromEnum x instance Num a => Num (M a) where M x + M y = M (x + y) M x * M y = M (x * y) negate (M x) = M (negate x) abs (M x) = M (abs x) signum (M x) = M (signum x) fromInteger x = M (fromInteger x) instance Integral a => Integral (M a) where quotRem (M x) (M y) = (M q, M r) where (q, r) = x `quotRem` y toInteger (M x) = toInteger x instance (Num a, Enum a, Monad m) => Serial m (M a) where series = others `interleave` positives where positives = generate $ \d -> take d [1..] others = generate $ \d -> take (d+1) [0,-1..] instance (Ord a, Num a, Monad m) => CoSerial m (M a) where coseries rs = alts0 rs >>- \z -> alts1 rs >>- \f -> alts1 rs >>- \g -> pure $ \ i -> case compare i 0 of GT -> f (M (i - 1)) LT -> g (M (abs i - 1)) EQ -> z instance Monad m => Serial m Float where series = series >>- \(sig, exp) -> guard (odd sig || sig==0 && exp==0) >> return (encodeFloat sig exp) instance Monad m => CoSerial m Float where coseries rs = coseries rs >>- \f -> return $ f . decodeFloat instance Monad m => Serial m Double where series = (realToFrac :: Float -> Double) <$> series instance Monad m => CoSerial m Double where coseries rs = (. (realToFrac :: Double -> Float)) <$> coseries rs -- | @since 1.1 instance (Integral i, Serial m i) => Serial m (Ratio i) where series = pairToRatio <$> series where pairToRatio (n, Positive d) = n % d -- | @since 1.1 instance (Integral i, CoSerial m i) => CoSerial m (Ratio i) where coseries rs = (. ratioToPair) <$> coseries rs where ratioToPair r = (numerator r, denominator r) instance Monad m => Serial m Char where series = generate $ \d -> take (d+1) ['a'..'z'] instance Monad m => CoSerial m Char where coseries rs = coseries rs >>- \f -> return $ \c -> f (N (fromEnum c - fromEnum 'a')) instance (Serial m a, Serial m b) => Serial m (a,b) where series = cons2 (,) instance (CoSerial m a, CoSerial m b) => CoSerial m (a,b) where coseries rs = uncurry <$> alts2 rs instance (Serial m a, Serial m b, Serial m c) => Serial m (a,b,c) where series = cons3 (,,) instance (CoSerial m a, CoSerial m b, CoSerial m c) => CoSerial m (a,b,c) where coseries rs = uncurry3 <$> alts3 rs instance (Serial m a, Serial m b, Serial m c, Serial m d) => Serial m (a,b,c,d) where series = cons4 (,,,) instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d) => CoSerial m (a,b,c,d) where coseries rs = uncurry4 <$> alts4 rs -- | @since 1.2.0 instance (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e) => Serial m (a,b,c,d,e) where series = cons5 (,,,,) -- | @since 1.2.0 instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e) => CoSerial m (a,b,c,d,e) where coseries rs = uncurry5 <$> alts5 rs -- | @since 1.2.0 instance (Serial m a, Serial m b, Serial m c, Serial m d, Serial m e, Serial m f) => Serial m (a,b,c,d,e,f) where series = cons6 (,,,,,) -- | @since 1.2.0 instance (CoSerial m a, CoSerial m b, CoSerial m c, CoSerial m d, CoSerial m e, CoSerial m f) => CoSerial m (a,b,c,d,e,f) where coseries rs = uncurry6 <$> alts6 rs instance Monad m => Serial m Bool where series = cons0 True \/ cons0 False instance Monad m => CoSerial m Bool where coseries rs = rs >>- \r1 -> rs >>- \r2 -> return $ \x -> if x then r1 else r2 -- | @since 1.2.1 instance Monad m => Serial m Ordering where series = cons0 LT \/ cons0 EQ \/ cons0 GT -- | @since 1.2.1 instance Monad m => CoSerial m Ordering where coseries rs = rs >>- \r1 -> rs >>- \r2 -> rs >>- \r3 -> pure $ \x -> case x of LT -> r1 EQ -> r2 GT -> r3 instance (Serial m a) => Serial m (Maybe a) where series = cons0 Nothing \/ cons1 Just instance (CoSerial m a) => CoSerial m (Maybe a) where coseries rs = maybe <$> alts0 rs <~> alts1 rs instance (Serial m a, Serial m b) => Serial m (Either a b) where series = cons1 Left \/ cons1 Right instance (CoSerial m a, CoSerial m b) => CoSerial m (Either a b) where coseries rs = either <$> alts1 rs <~> alts1 rs instance Serial m a => Serial m [a] where series = cons0 [] \/ cons2 (:) instance CoSerial m a => CoSerial m [a] where coseries rs = alts0 rs >>- \y -> alts2 rs >>- \f -> return $ \xs -> case xs of [] -> y; x:xs' -> f x xs' -- | @since 1.2.0 instance Serial m a => Serial m (NE.NonEmpty a) where series = cons2 (NE.:|) -- | @since 1.2.0 instance CoSerial m a => CoSerial m (NE.NonEmpty a) where coseries rs = alts2 rs >>- \f -> return $ \(x NE.:| xs') -> f x xs' #if MIN_VERSION_base(4,4,0) -- | @since 1.2.0 instance Serial m a => Serial m (Complex a) where #else -- | @since 1.2.0 instance (RealFloat a, Serial m a) => Serial m (Complex a) where #endif series = cons2 (:+) #if MIN_VERSION_base(4,4,0) -- | @since 1.2.0 instance CoSerial m a => CoSerial m (Complex a) where #else -- | @since 1.2.0 instance (RealFloat a, CoSerial m a) => CoSerial m (Complex a) where #endif coseries rs = alts2 rs >>- \f -> return $ \(x :+ xs') -> f x xs' -- | @since 1.2.0 instance Monad m => Serial m Void where series = mzero -- | @since 1.2.0 instance Monad m => CoSerial m Void where coseries = const $ return absurd instance (CoSerial m a, Serial m b) => Serial m (a->b) where series = coseries series -- Thanks to Ralf Hinze for the definition of coseries -- using the nest auxiliary. instance (Serial m a, CoSerial m a, Serial m b, CoSerial m b) => CoSerial m (a->b) where coseries r = do args <- unwind series g <- nest r args return $ \f -> g $ map f args where nest :: forall a b m c . (Serial m b, CoSerial m b) => Series m c -> [a] -> Series m ([b] -> c) nest rs args = do case args of [] -> const `liftM` rs _:rest -> do let sf = coseries $ nest rs rest f <- sf return $ \(b:bs) -> f b bs -- show the extension of a function (in part, bounded both by -- the number and depth of arguments) instance (Serial Identity a, Show a, Show b) => Show (a -> b) where show f = if maxarheight == 1 && sumarwidth + length ars * length "->;" < widthLimit then "{"++ intercalate ";" [a++"->"++r | (a,r) <- ars] ++"}" else concat $ [a++"->\n"++indent r | (a,r) <- ars] where ars = take lengthLimit [ (show x, show (f x)) | x <- list depthLimit series ] maxarheight = maximum [ max (height a) (height r) | (a,r) <- ars ] sumarwidth = sum [ length a + length r | (a,r) <- ars] indent = unlines . map (" "++) . lines height = length . lines (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Depth) -- | @since 1.2.0 instance (Monad m, Serial m (f (g a))) => Serial m (Compose f g a) where series = Compose <$> series -- | @since 1.2.0 instance (Monad m, CoSerial m (f (g a))) => CoSerial m (Compose f g a) where coseries = fmap (. getCompose) . coseries -- }}} ------------------------------ -- Convenient wrappers ------------------------------ -- {{{ -------------------------------------------------------------------------- -- | 'Positive' @x@ guarantees that \( x > 0 \). -- -- @since 1.0 newtype Positive a = Positive { getPositive :: a } deriving ( Eq , Ord , Functor -- ^ @since 1.2.0 , Foldable -- ^ @since 1.2.0 , Traversable -- ^ @since 1.2.0 ) instance Real a => Real (Positive a) where toRational (Positive x) = toRational x -- | @since 1.2.0 instance (Num a, Bounded a) => Bounded (Positive a) where minBound = Positive 1 maxBound = Positive (maxBound :: a) instance Enum a => Enum (Positive a) where toEnum x = Positive (toEnum x) fromEnum (Positive x) = fromEnum x instance Num a => Num (Positive a) where Positive x + Positive y = Positive (x + y) Positive x * Positive y = Positive (x * y) negate (Positive x) = Positive (negate x) abs (Positive x) = Positive (abs x) signum (Positive x) = Positive (signum x) fromInteger x = Positive (fromInteger x) instance Integral a => Integral (Positive a) where quotRem (Positive x) (Positive y) = (Positive q, Positive r) where (q, r) = x `quotRem` y toInteger (Positive x) = toInteger x instance (Num a, Ord a, Serial m a) => Serial m (Positive a) where series = Positive <$> series `suchThat` (> 0) instance Show a => Show (Positive a) where showsPrec n (Positive x) = showsPrec n x -- | 'NonNegative' @x@ guarantees that \( x \ge 0 \). -- -- @since 1.0 newtype NonNegative a = NonNegative { getNonNegative :: a } deriving ( Eq , Ord , Functor -- ^ @since 1.2.0 , Foldable -- ^ @since 1.2.0 , Traversable -- ^ @since 1.2.0 ) instance Real a => Real (NonNegative a) where toRational (NonNegative x) = toRational x -- | @since 1.2.0 instance (Num a, Bounded a) => Bounded (NonNegative a) where minBound = NonNegative 0 maxBound = NonNegative (maxBound :: a) instance Enum a => Enum (NonNegative a) where toEnum x = NonNegative (toEnum x) fromEnum (NonNegative x) = fromEnum x instance Num a => Num (NonNegative a) where NonNegative x + NonNegative y = NonNegative (x + y) NonNegative x * NonNegative y = NonNegative (x * y) negate (NonNegative x) = NonNegative (negate x) abs (NonNegative x) = NonNegative (abs x) signum (NonNegative x) = NonNegative (signum x) fromInteger x = NonNegative (fromInteger x) instance Integral a => Integral (NonNegative a) where quotRem (NonNegative x) (NonNegative y) = (NonNegative q, NonNegative r) where (q, r) = x `quotRem` y toInteger (NonNegative x) = toInteger x instance (Num a, Ord a, Serial m a) => Serial m (NonNegative a) where series = NonNegative <$> series `suchThat` (>= 0) instance Show a => Show (NonNegative a) where showsPrec n (NonNegative x) = showsPrec n x -- | 'NonZero' @x@ guarantees that \( x \ne 0 \). -- -- @since 1.2.0 newtype NonZero a = NonZero { getNonZero :: a } deriving (Eq, Ord, Functor, Foldable, Traversable) instance Real a => Real (NonZero a) where toRational (NonZero x) = toRational x instance (Eq a, Num a, Bounded a) => Bounded (NonZero a) where minBound = let x = minBound in NonZero (if x == 0 then 1 else x) maxBound = let x = maxBound in NonZero (if x == 0 then -1 else x) instance Enum a => Enum (NonZero a) where toEnum x = NonZero (toEnum x) fromEnum (NonZero x) = fromEnum x instance Num a => Num (NonZero a) where NonZero x + NonZero y = NonZero (x + y) NonZero x * NonZero y = NonZero (x * y) negate (NonZero x) = NonZero (negate x) abs (NonZero x) = NonZero (abs x) signum (NonZero x) = NonZero (signum x) fromInteger x = NonZero (fromInteger x) instance Integral a => Integral (NonZero a) where quotRem (NonZero x) (NonZero y) = (NonZero q, NonZero r) where (q, r) = x `quotRem` y toInteger (NonZero x) = toInteger x instance (Num a, Ord a, Serial m a) => Serial m (NonZero a) where series = NonZero <$> series `suchThat` (/= 0) instance Show a => Show (NonZero a) where showsPrec n (NonZero x) = showsPrec n x -- | 'NonEmpty' @xs@ guarantees that @xs@ is not null. -- -- @since 1.1 newtype NonEmpty a = NonEmpty { getNonEmpty :: [a] } instance (Serial m a) => Serial m (NonEmpty a) where series = NonEmpty <$> cons2 (:) instance Show a => Show (NonEmpty a) where showsPrec n (NonEmpty x) = showsPrec n x -- }}} ------------------------------ -- Foreign.C.Types ------------------------------ -- {{{ #if MIN_VERSION_base(4,5,0) -- | @since 1.2.0 instance Monad m => Serial m CFloat where series = newtypeCons CFloat -- | @since 1.2.0 instance Monad m => CoSerial m CFloat where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CFloat x -> f x -- | @since 1.2.0 instance Monad m => Serial m CDouble where series = newtypeCons CDouble -- | @since 1.2.0 instance Monad m => CoSerial m CDouble where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CDouble x -> f x #if HASCBOOL -- | @since 1.2.0 instance Monad m => Serial m CBool where series = newtypeCons CBool -- | @since 1.2.0 instance Monad m => CoSerial m CBool where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CBool x -> f x #endif -- | @since 1.2.0 instance Monad m => Serial m CChar where series = newtypeCons CChar -- | @since 1.2.0 instance Monad m => CoSerial m CChar where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CChar x -> f x -- | @since 1.2.0 instance Monad m => Serial m CSChar where series = newtypeCons CSChar -- | @since 1.2.0 instance Monad m => CoSerial m CSChar where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSChar x -> f x -- | @since 1.2.0 instance Monad m => Serial m CUChar where series = newtypeCons CUChar -- | @since 1.2.0 instance Monad m => CoSerial m CUChar where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUChar x -> f x -- | @since 1.2.0 instance Monad m => Serial m CShort where series = newtypeCons CShort -- | @since 1.2.0 instance Monad m => CoSerial m CShort where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CShort x -> f x -- | @since 1.2.0 instance Monad m => Serial m CUShort where series = newtypeCons CUShort -- | @since 1.2.0 instance Monad m => CoSerial m CUShort where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUShort x -> f x -- | @since 1.2.0 instance Monad m => Serial m CInt where series = newtypeCons CInt -- | @since 1.2.0 instance Monad m => CoSerial m CInt where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CInt x -> f x -- | @since 1.2.0 instance Monad m => Serial m CUInt where series = newtypeCons CUInt -- | @since 1.2.0 instance Monad m => CoSerial m CUInt where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUInt x -> f x -- | @since 1.2.0 instance Monad m => Serial m CLong where series = newtypeCons CLong -- | @since 1.2.0 instance Monad m => CoSerial m CLong where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CLong x -> f x -- | @since 1.2.0 instance Monad m => Serial m CULong where series = newtypeCons CULong -- | @since 1.2.0 instance Monad m => CoSerial m CULong where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CULong x -> f x -- | @since 1.2.0 instance Monad m => Serial m CPtrdiff where series = newtypeCons CPtrdiff -- | @since 1.2.0 instance Monad m => CoSerial m CPtrdiff where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CPtrdiff x -> f x -- | @since 1.2.0 instance Monad m => Serial m CSize where series = newtypeCons CSize -- | @since 1.2.0 instance Monad m => CoSerial m CSize where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSize x -> f x -- | @since 1.2.0 instance Monad m => Serial m CWchar where series = newtypeCons CWchar -- | @since 1.2.0 instance Monad m => CoSerial m CWchar where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CWchar x -> f x -- | @since 1.2.0 instance Monad m => Serial m CSigAtomic where series = newtypeCons CSigAtomic -- | @since 1.2.0 instance Monad m => CoSerial m CSigAtomic where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSigAtomic x -> f x -- | @since 1.2.0 instance Monad m => Serial m CLLong where series = newtypeCons CLLong -- | @since 1.2.0 instance Monad m => CoSerial m CLLong where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CLLong x -> f x -- | @since 1.2.0 instance Monad m => Serial m CULLong where series = newtypeCons CULLong -- | @since 1.2.0 instance Monad m => CoSerial m CULLong where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CULLong x -> f x -- | @since 1.2.0 instance Monad m => Serial m CIntPtr where series = newtypeCons CIntPtr -- | @since 1.2.0 instance Monad m => CoSerial m CIntPtr where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CIntPtr x -> f x -- | @since 1.2.0 instance Monad m => Serial m CUIntPtr where series = newtypeCons CUIntPtr -- | @since 1.2.0 instance Monad m => CoSerial m CUIntPtr where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUIntPtr x -> f x -- | @since 1.2.0 instance Monad m => Serial m CIntMax where series = newtypeCons CIntMax -- | @since 1.2.0 instance Monad m => CoSerial m CIntMax where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CIntMax x -> f x -- | @since 1.2.0 instance Monad m => Serial m CUIntMax where series = newtypeCons CUIntMax -- | @since 1.2.0 instance Monad m => CoSerial m CUIntMax where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUIntMax x -> f x -- | @since 1.2.0 instance Monad m => Serial m CClock where series = newtypeCons CClock -- | @since 1.2.0 instance Monad m => CoSerial m CClock where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CClock x -> f x -- | @since 1.2.0 instance Monad m => Serial m CTime where series = newtypeCons CTime -- | @since 1.2.0 instance Monad m => CoSerial m CTime where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CTime x -> f x -- | @since 1.2.0 instance Monad m => Serial m CUSeconds where series = newtypeCons CUSeconds -- | @since 1.2.0 instance Monad m => CoSerial m CUSeconds where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CUSeconds x -> f x -- | @since 1.2.0 instance Monad m => Serial m CSUSeconds where series = newtypeCons CSUSeconds -- | @since 1.2.0 instance Monad m => CoSerial m CSUSeconds where coseries rs = newtypeAlts rs >>- \f -> return $ \l -> case l of CSUSeconds x -> f x #endif -- }}} smallcheck-1.2.1.1/Test/SmallCheck/SeriesMonad.hs0000644000000000000000000000471007346545000017645 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Safe #-} #endif module Test.SmallCheck.SeriesMonad where import Control.Applicative (Applicative, Alternative, (<$>), pure, (<*>), empty, (<|>)) import Control.Arrow (second) import Control.Monad (Monad, (>>=), return, MonadPlus, mzero, mplus) import Control.Monad.Logic (MonadLogic, LogicT, msplit) import Control.Monad.Reader (MonadTrans, ReaderT, runReaderT, lift) import Data.Function ((.), ($)) import Data.Functor (Functor, fmap) import Data.Int (Int) -- | Maximum depth of generated test values. -- -- For data values, it is the depth of nested constructor applications. -- -- For functional values, it is both the depth of nested case analysis -- and the depth of results. -- -- @since 0.6 type Depth = Int -- | 'Series' is a `MonadLogic` action that enumerates values of a certain -- type, up to some depth. -- -- The depth bound is tracked in the 'Series' monad and can be extracted using -- 'Test.SmallCheck.Series.getDepth' and changed using 'Test.SmallCheck.Series.localDepth'. -- -- To manipulate series at the lowest level you can use its 'Monad', -- 'MonadPlus' and 'MonadLogic' instances. This module provides some -- higher-level combinators which simplify creating series. -- -- A proper 'Series' should be monotonic with respect to the depth — i.e. -- 'Test.SmallCheck.Series.localDepth' @(+1)@ @s@ should emit all the values that @s@ emits (and -- possibly some more). -- -- It is also desirable that values of smaller depth come before the values -- of greater depth. -- -- @since 1.0 newtype Series m a = Series (ReaderT Depth (LogicT m) a) instance Functor (Series m) where fmap f (Series x) = Series (fmap f x) instance Monad (Series m) where Series x >>= f = Series (x >>= unSeries . f) where unSeries (Series y) = y return = pure instance Applicative (Series m) where pure = Series . pure Series x <*> Series y = Series (x <*> y) instance MonadPlus (Series m) where mzero = empty mplus = (<|>) instance Alternative (Series m) where empty = Series empty Series x <|> Series y = Series (x <|> y) -- This instance is written manually. Using the GND for it is not safe. instance Monad m => MonadLogic (Series m) where msplit (Series a) = Series (fmap (second Series) <$> msplit a) instance MonadTrans Series where lift a = Series $ lift . lift $ a runSeries :: Depth -> Series m a -> LogicT m a runSeries d (Series a) = runReaderT a d smallcheck-1.2.1.1/smallcheck.cabal0000644000000000000000000000350607346545000015247 0ustar0000000000000000name: smallcheck version: 1.2.1.1 license: BSD3 license-file: LICENSE maintainer: Andrew Lelechenko author: Colin Runciman, Roman Cheplyaka cabal-version: >=1.10 tested-with: ghc ==9.6.1 ghc ==9.4.5 ghc ==9.2.7 ghc ==9.0.2 ghc ==8.10.7 ghc ==8.8.4 ghc ==8.6.5 ghc ==8.4.4 ghc ==8.2.2 ghc ==8.0.2 ghc ==7.10.3 ghc ==7.8.4 ghc ==7.6.3 ghc ==7.4.2 ghc ==7.2.2 ghc ==7.0.4 homepage: https://github.com/Bodigrim/smallcheck bug-reports: https://github.com/Bodigrim/smallcheck/issues synopsis: A property-based testing library description: As of 2023, this library is largely obsolete: arbitrary test generators with shrinking such as [falsify](https://hackage.haskell.org/package/falsify) offer much better user experience. . SmallCheck is a testing library that allows to verify properties for all test cases up to some depth. The test cases are generated automatically by SmallCheck. category: Testing build-type: Simple extra-source-files: README.md CREDITS.md CHANGELOG.md source-repository head type: git location: git://github.com/Bodigrim/smallcheck.git library default-language: Haskell2010 exposed-modules: Test.SmallCheck Test.SmallCheck.Drivers Test.SmallCheck.Series other-modules: Test.SmallCheck.Property Test.SmallCheck.SeriesMonad Test.SmallCheck.Property.Result build-depends: base >=4.3 && <5, mtl <2.4, logict >=0.5 && <0.9, pretty <1.2 if impl(ghc <8.0) build-depends: semigroups <0.21, transformers <0.7 if impl(ghc <7.10) build-depends: nats <1.2, void <0.8 if impl(ghc <7.6) build-depends: ghc-prim >=0.2 && <1 if impl(ghc >= 8.0) ghc-options: -Wcompat