Skip to content
Browse files

Paper.hs: wibbles.

  • Loading branch information...
1 parent 3b7da55 commit 8bf81b74e1c325a80e17007e772334340b204b8f @leepike committed Dec 29, 2012
Showing with 26 additions and 25 deletions.
  1. +26 −25 examples/Paper/Paper.hs
View
51 examples/Paper/Paper.hs
@@ -27,9 +27,14 @@ import System.Environment
-- single element to have a long list.
-- Container so that we don't have base types.
+
+-----------------------------------------------------------------
data A = A Int16
deriving (Read, Show, Typeable, Generic)
+data B = B [A] [A] [A] [A]
+ deriving (Read, Show, Typeable, Generic)
+
instance Serial Int16 where
series d = drawnFrom [(-d')..d']
where d' = fromIntegral d
@@ -41,19 +46,18 @@ instance Arbitrary A where
shrink (A i) = map A (shrink i)
instance Serial A where
- series = cons1 A
+ series = cons1 A
-data B = B [A] [A] [A] [A]
- deriving (Read, Show, Typeable, Generic)
instance SubTypes B
-- qc/shrink takes over 1m seconds
instance Arbitrary B where
- arbitrary = liftM4 B arbitrary arbitrary arbitrary arbitrary
- shrink (B a b c d) =
- if defShrink
- then [ B w x y z |
+ arbitrary = liftM4 B arbitrary arbitrary
+ arbitrary arbitrary
+ shrink (B a b c d) =
+ if defShrink
+ then [ B w x y z |
w <- tk a
, x <- tk b
, y <- tk c
@@ -62,18 +66,14 @@ instance Arbitrary B where
where tk x = take 10 (shrink x)
instance Serial B where
- series = cons4 B
-
-size :: B -> Int
-size (B a b c d) = length a + length b + length c + length d
+ series = cons4 B
add :: [A] -> Int16
add = sum . map (\(A i) -> i)
pre :: B -> Bool
-pre (B a b c d) = and $ map pre' [a, b, c, d]
- where pre' x = add x < 16
-
+pre (B a b c d) = all (\x -> add x < 16) [a, b, c, d]
+
post :: B -> Bool
post (B a b c d) = add a + add b + add c + add d < 64
@@ -86,7 +86,7 @@ prop_sc p = pre p S.==> post p
test :: IO (Maybe B) -> IO ()
test run = do
[arg] <- getArgs
- let rnds = (read arg) :: Int
+ let rnds = read arg :: Int
res <- replicateM rnds (test' run)
putStrLn ""
@@ -108,20 +108,20 @@ test run = do
type Res = Maybe (NominalDiffTime, Int)
test' :: IO (Maybe B) -> IO Res
-test' run = do
+test' run = do
start <- getCurrentTime
res <- run
stop <- getCurrentTime
let diff = diffUTCTime stop start
print diff
- case res of
+ case res of
Nothing -> return Nothing
Just r -> return $ Just (diff, size r)
-- -- XXX note we're parsing out QC results, so slower than QC.
--- testsc ::
--- testsc = do
+-- testsc ::
+-- testsc = do
-- start <- getCurrentTime
-- res <- runQC scStdArgs prop
--test $ >>= smartRun scStdArgs XXX prop)
@@ -131,20 +131,21 @@ test' run = do
runSC :: IO (Maybe B)
runSC = do
res <- runQC stdArgs prop_qc
- case res of
+ case res of
Nothing -> return Nothing
- Just r -> do smartRun scStdArgs r prop_qc >>= return . Just
-
+ Just r -> liftM Just $ smartRun scStdArgs r prop_qc
--------------------------------------------------------------------------------
+size :: B -> Int
+size (B a b c d) = length a + length b + length c + length d
+
defShrink :: Bool
defShrink = False
main :: IO ()
-main = do
- test $ runQC stdArgs prop_qc
--- test runSC
+main = test $ runQC stdArgs prop_qc
+-- test runSC
-- _ <- test' $ smallCheck 7 prop_sc >> return (Just $ B [] [] [] [])
-- return ()

0 comments on commit 8bf81b7

Please sign in to comment.
Something went wrong with that request. Please try again.