diff options
author | Matth?us G. Chajdas <dev@anteru.net> | 2019-11-10 13:56:53 +0100 |
---|---|---|
committer | Matth?us G. Chajdas <dev@anteru.net> | 2019-11-10 13:56:53 +0100 |
commit | 1dd3124a9770e11b6684e5dd1e6bc15a0aa3bc67 (patch) | |
tree | 87a171383266dd1f64196589af081bc2f8e497c3 /tests/examplefiles/SmallCheck.hs | |
parent | f1c080e184dc1bbc36eaa7cd729ff3a499de568a (diff) | |
download | pygments-master.tar.gz |
Diffstat (limited to 'tests/examplefiles/SmallCheck.hs')
-rw-r--r-- | tests/examplefiles/SmallCheck.hs | 378 |
1 files changed, 0 insertions, 378 deletions
diff --git a/tests/examplefiles/SmallCheck.hs b/tests/examplefiles/SmallCheck.hs deleted file mode 100644 index 36c39efc..00000000 --- a/tests/examplefiles/SmallCheck.hs +++ /dev/null @@ -1,378 +0,0 @@ ---------------------------------------------------------------------- --- SmallCheck: another lightweight testing library. --- Colin Runciman, August 2006 --- Version 0.2 (November 2006) --- --- After QuickCheck, by Koen Claessen and John Hughes (2000-2004). ---------------------------------------------------------------------- - -module SmallCheck ( - smallCheck, depthCheck, - Property, Testable, - forAll, forAllElem, - exists, existsDeeperBy, thereExists, thereExistsElem, - (==>), - Series, Serial(..), - (\/), (><), two, three, four, - cons0, cons1, cons2, cons3, cons4, - alts0, alts1, alts2, alts3, alts4, - N(..), Nat, Natural, - depth, inc, dec - ) where - -import Data.List (intersperse) -import Control.Monad (when) -import System.IO (stdout, hFlush) - ------------------- <Series of depth-bounded values> ----------------- - --- Series arguments should be interpreted as a depth bound (>=0) --- Series results should have finite length - -type Series a = Int -> [a] - --- sum -infixr 7 \/ -(\/) :: Series a -> Series a -> Series a -s1 \/ s2 = \d -> s1 d ++ s2 d - --- product -infixr 8 >< -(><) :: Series a -> Series b -> Series (a,b) -s1 >< s2 = \d -> [(x,y) | x <- s1 d, y <- s2 d] - -------------------- <methods for type enumeration> ------------------ - --- enumerated data values should be finite and fully defined --- enumerated functional values should be total and strict - --- bounds: --- for data values, the depth of nested constructor applications --- for functional values, both the depth of nested case analysis --- and the depth of results - -class Serial a where - series :: Series a - coseries :: Serial b => Series (a->b) - -instance Serial () where - series _ = [()] - coseries d = [ \() -> b - | b <- series d ] - -instance Serial Int where - series d = [(-d)..d] - coseries d = [ \i -> if i > 0 then f (N (i - 1)) - else if i < 0 then g (N (abs i - 1)) - else z - | z <- alts0 d, f <- alts1 d, g <- alts1 d ] - -instance Serial Integer where - series d = [ toInteger (i :: Int) - | i <- series d ] - coseries d = [ f . (fromInteger :: Integer->Int) - | f <- series d ] - -newtype N a = N a - -instance Show a => Show (N a) where - show (N i) = show i - -instance (Integral a, Serial a) => Serial (N a) where - series d = map N [0..d'] - where - d' = fromInteger (toInteger d) - coseries d = [ \(N i) -> if i > 0 then f (N (i - 1)) - else z - | z <- alts0 d, f <- alts1 d ] - -type Nat = N Int -type Natural = N Integer - -instance Serial Float where - series d = [ encodeFloat sig exp - | (sig,exp) <- series d, - odd sig || sig==0 && exp==0 ] - coseries d = [ f . decodeFloat - | f <- series d ] - -instance Serial Double where - series d = [ frac (x :: Float) - | x <- series d ] - coseries d = [ f . (frac :: Double->Float) - | f <- series d ] - -frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b -frac = fromRational . toRational - -instance Serial Char where - series d = take (d+1) ['a'..'z'] - coseries d = [ \c -> f (N (fromEnum c - fromEnum 'a')) - | f <- series d ] - -instance (Serial a, Serial b) => - Serial (a,b) where - series = series >< series - coseries = map uncurry . coseries - -instance (Serial a, Serial b, Serial c) => - Serial (a,b,c) where - series = \d -> [(a,b,c) | (a,(b,c)) <- series d] - coseries = map uncurry3 . coseries - -instance (Serial a, Serial b, Serial c, Serial d) => - Serial (a,b,c,d) where - series = \d -> [(a,b,c,d) | (a,(b,(c,d))) <- series d] - coseries = map uncurry4 . coseries - -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 - -two :: Series a -> Series (a,a) -two s = s >< s - -three :: Series a -> Series (a,a,a) -three s = \d -> [(x,y,z) | (x,(y,z)) <- (s >< s >< s) d] - -four :: Series a -> Series (a,a,a,a) -four s = \d -> [(w,x,y,z) | (w,(x,(y,z))) <- (s >< s >< s >< s) d] - -cons0 :: - a -> Series a -cons0 c _ = [c] - -cons1 :: Serial a => - (a->b) -> Series b -cons1 c d = [c z | d > 0, z <- series (d-1)] - -cons2 :: (Serial a, Serial b) => - (a->b->c) -> Series c -cons2 c d = [c y z | d > 0, (y,z) <- series (d-1)] - -cons3 :: (Serial a, Serial b, Serial c) => - (a->b->c->d) -> Series d -cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)] - -cons4 :: (Serial a, Serial b, Serial c, Serial d) => - (a->b->c->d->e) -> Series e -cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)] - -alts0 :: Serial a => - Series a -alts0 d = series d - -alts1 :: (Serial a, Serial b) => - Series (a->b) -alts1 d = if d > 0 then series (dec d) - else [\_ -> x | x <- series d] - -alts2 :: (Serial a, Serial b, Serial c) => - Series (a->b->c) -alts2 d = if d > 0 then series (dec d) - else [\_ _ -> x | x <- series d] - -alts3 :: (Serial a, Serial b, Serial c, Serial d) => - Series (a->b->c->d) -alts3 d = if d > 0 then series (dec d) - else [\_ _ _ -> x | x <- series d] - -alts4 :: (Serial a, Serial b, Serial c, Serial d, Serial e) => - Series (a->b->c->d->e) -alts4 d = if d > 0 then series (dec d) - else [\_ _ _ _ -> x | x <- series d] - -instance Serial Bool where - series = cons0 True \/ cons0 False - coseries d = [ \x -> if x then b1 else b2 - | (b1,b2) <- series d ] - -instance Serial a => Serial (Maybe a) where - series = cons0 Nothing \/ cons1 Just - coseries d = [ \m -> case m of - Nothing -> z - Just x -> f x - | z <- alts0 d , - f <- alts1 d ] - -instance (Serial a, Serial b) => Serial (Either a b) where - series = cons1 Left \/ cons1 Right - coseries d = [ \e -> case e of - Left x -> f x - Right y -> g y - | f <- alts1 d , - g <- alts1 d ] - -instance Serial a => Serial [a] where - series = cons0 [] \/ cons2 (:) - coseries d = [ \xs -> case xs of - [] -> y - (x:xs') -> f x xs' - | y <- alts0 d , - f <- alts2 d ] - --- Warning: the coseries instance here may generate duplicates. -instance (Serial a, Serial b) => Serial (a->b) where - series = coseries - coseries d = [ \f -> g [f x | x <- series d] - | g <- series d ] - --- For customising the depth measure. Use with care! - -depth :: Int -> Int -> Int -depth d d' | d >= 0 = d'+1-d - | otherwise = error "SmallCheck.depth: argument < 0" - -dec :: Int -> Int -dec d | d > 0 = d-1 - | otherwise = error "SmallCheck.dec: argument <= 0" - -inc :: Int -> Int -inc d = d+1 - --- show the extension of a function (in part, bounded both by --- the number and depth of arguments) -instance (Serial a, Show a, Show b) => Show (a->b) where - show f = - if maxarheight == 1 - && sumarwidth + length ars * length "->;" < widthLimit then - "{"++( - concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars] - )++"}" - else - concat $ [a++"->\n"++indent r | (a,r) <- ars] - where - ars = take lengthLimit [ (show x, show (f x)) - | x <- series depthLimit ] - 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,Int) - ----------------- <properties and their evaluation> ------------------ - --- adapted from QuickCheck originals: here results come in lists, --- properties have depth arguments, stamps (for classifying random --- tests) are omitted, existentials are introduced - -newtype PR = Prop [Result] - -data Result = Result {ok :: Maybe Bool, arguments :: [String]} - -nothing :: Result -nothing = Result {ok = Nothing, arguments = []} - -result :: Result -> PR -result res = Prop [res] - -newtype Property = Property (Int -> PR) - -class Testable a where - property :: a -> Int -> PR - -instance Testable Bool where - property b _ = Prop [Result (Just b) []] - -instance Testable PR where - property prop _ = prop - -instance (Serial a, Show a, Testable b) => Testable (a->b) where - property f = f' where Property f' = forAll series f - -instance Testable Property where - property (Property f) d = f d - -evaluate :: Testable a => a -> Series Result -evaluate x d = rs where Prop rs = property x d - -forAll :: (Show a, Testable b) => Series a -> (a->b) -> Property -forAll xs f = Property $ \d -> Prop $ - [ r{arguments = show x : arguments r} - | x <- xs d, r <- evaluate (f x) d ] - -forAllElem :: (Show a, Testable b) => [a] -> (a->b) -> Property -forAllElem xs = forAll (const xs) - -thereExists :: Testable b => Series a -> (a->b) -> Property -thereExists xs f = Property $ \d -> Prop $ - [ Result - ( Just $ or [ all pass (evaluate (f x) d) - | x <- xs d ] ) - [] ] - where - pass (Result Nothing _) = True - pass (Result (Just b) _) = b - -thereExistsElem :: Testable b => [a] -> (a->b) -> Property -thereExistsElem xs = thereExists (const xs) - -exists :: (Serial a, Testable b) => - (a->b) -> Property -exists = thereExists series - -existsDeeperBy :: (Serial a, Testable b) => - (Int->Int) -> (a->b) -> Property -existsDeeperBy f = thereExists (series . f) - -infixr 0 ==> - -(==>) :: Testable a => Bool -> a -> Property -True ==> x = Property (property x) -False ==> x = Property (const (result nothing)) - ---------------------- <top-level test drivers> ---------------------- - --- similar in spirit to QuickCheck but with iterative deepening - --- test for values of depths 0..d stopping when a property --- fails or when it has been checked for all these values -smallCheck :: Testable a => Int -> a -> IO String -smallCheck d = iterCheck 0 (Just d) - -depthCheck :: Testable a => Int -> a -> IO String -depthCheck d = iterCheck d (Just d) - -iterCheck :: Testable a => Int -> Maybe Int -> a -> IO String -iterCheck dFrom mdTo t = iter dFrom - where - iter :: Int -> IO String - iter d = do - let Prop results = property t d - (ok,s) <- check (mdTo==Nothing) 0 0 True results - maybe (iter (d+1)) - (\dTo -> if ok && d < dTo - then iter (d+1) - else return s) - mdTo - -check :: Bool -> Int -> Int -> Bool -> [Result] -> IO (Bool, String) -check i n x ok rs | null rs = do - let s = " Completed "++show n++" test(s)" - y = if i then "." else " without failure." - z | x > 0 = " But "++show x++" did not meet ==> condition." - | otherwise = "" - return (ok, s ++ y ++ z) - -check i n x ok (Result Nothing _ : rs) = do - progressReport i n x - check i (n+1) (x+1) ok rs - -check i n x f (Result (Just True) _ : rs) = do - progressReport i n x - check i (n+1) x f rs - -check i n x f (Result (Just False) args : rs) = do - let s = " Failed test no. "++show (n+1)++". Test values follow." - s' = s ++ ": " ++ concat (intersperse ", " args) - if i then - check i (n+1) x False rs - else - return (False, s') - -progressReport :: Bool -> Int -> Int -> IO () -progressReport _ _ _ = return () |