module Test.ClassLaws.Partial
( module Test.ClassLaws.Partial
, module Test.ChasingBottoms
) where
import Test.QuickCheck
import Test.ChasingBottoms hiding (Result, listOf)
import Data.List (intersperse)
import Control.Monad (liftM2, liftM3)
newtype Partial a = Partial {unPartial :: a}
instance TestablePartial prop => Testable (Partial prop) where
property (Partial x) = propertyPartial x
class TestablePartial prop where
propertyPartial :: prop -> Property
class ArbitraryPartial a where
arbitraryPartial :: Gen a
shrinkPartial :: a -> [a]
shrinkPartial _ = []
instance TestablePartial Bool where
propertyPartial = property
instance TestablePartial Property where
propertyPartial = property
instance ( ArbitraryPartial a
, Show (Partial a)
, TestablePartial prop
) => TestablePartial (a -> prop) where
propertyPartial f = forAllShrink arb shr prop
where
arb = fmap Partial arbitraryPartial
shr (Partial x) = map Partial (shrinkPartial x)
prop (Partial x) = propertyPartial (f x)
showPartial :: String -> (a -> String) -> a -> String
showPartial t _ p | isBottom p = "_|_" ++ t ++ "_"
showPartial _ f p = f p
instance Show (Partial ()) where
show (Partial u) = showPartial "()" show u
instance Show (Partial Bool) where
show (Partial b) = showPartial "Bool" show b
instance Show (Partial Char) where
show (Partial c) = showPartial "Char" show c
instance Show (Partial Int) where
show (Partial i) = showPartial "Int" show i
genPartial :: Int -> Int -> Gen a -> Gen a
genPartial ib ia ga = frequency [ (ib, return bottom), (ia, ga) ]
instance ArbitraryPartial Int where
arbitraryPartial = genPartial 1 20 $ arbitrary
instance ArbitraryPartial Char where
arbitraryPartial = genPartial 1 20 $ arbitrary
instance ArbitraryPartial Bool where
arbitraryPartial = genPartial 1 10 $ arbitrary
instance ArbitraryPartial () where
arbitraryPartial = genPartial 1 5 $ arbitrary
instance (Show (Partial a), Show (Partial b)) => Show (Partial (a,b)) where
show = showPartial "(,)" showPair
where showPair (Partial (a,b)) =
"(" ++ show (Partial a) ++ ","
++ show (Partial b) ++ ")"
instance (ArbitraryPartial a, ArbitraryPartial b) => ArbitraryPartial (a,b) where
arbitraryPartial = liftM2 (,) arbitraryPartial arbitraryPartial
instance (Show (Partial a), Show (Partial b), Show (Partial c)) => Show (Partial (a,b,c)) where
show = showPartial "(,)" showTriple
where showTriple (Partial (a,b,c)) =
"(" ++ show (Partial a) ++ ","
++ show (Partial b) ++ ","
++ show (Partial c) ++ ")"
instance (ArbitraryPartial a, ArbitraryPartial b, ArbitraryPartial c) => ArbitraryPartial (a,b,c) where
arbitraryPartial = liftM3 (,,) arbitraryPartial arbitraryPartial arbitraryPartial