~ubuntu-branches/ubuntu/raring/agda/raring-proposed

« back to all changes in this revision

Viewing changes to src/full/Agda/Utils/TestHelpers.hs

  • Committer: Bazaar Package Importer
  • Author(s): Iain Lane
  • Date: 2009-07-20 19:49:41 UTC
  • Revision ID: james.westby@ubuntu.com-20090720194941-hcjy91vrn16csh7d
Tags: upstream-2.2.4+dfsg
ImportĀ upstreamĀ versionĀ 2.2.4+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
-- | Some functions and generators suitable for writing QuickCheck
 
2
-- properties.
 
3
 
 
4
module Agda.Utils.TestHelpers
 
5
  ( -- * Algebraic properties
 
6
    associative
 
7
  , commutative
 
8
  , isZero
 
9
  , identity
 
10
  , leftDistributive
 
11
  , rightDistributive
 
12
    -- * Generators
 
13
  , natural
 
14
  , positive
 
15
  , maybeGen
 
16
  , maybeCoGen
 
17
  , listOfElements
 
18
    -- * Test driver.
 
19
  , runTests
 
20
  )
 
21
  where
 
22
 
 
23
import Agda.Utils.QuickCheck
 
24
import Data.List
 
25
import qualified System.IO.UTF8 as UTF8
 
26
 
 
27
------------------------------------------------------------------------
 
28
-- Algebraic properties
 
29
 
 
30
-- | Is the operator associative?
 
31
 
 
32
associative :: (Arbitrary a, Eq a, Show a)
 
33
            => (a -> a -> a)
 
34
            -> a -> a -> a -> Bool
 
35
associative (+) = \x y z ->
 
36
  x + (y + z) == (x + y) + z
 
37
 
 
38
-- | Is the operator commutative?
 
39
 
 
40
commutative :: (Arbitrary a, Eq a, Show a)
 
41
            => (a -> a -> a)
 
42
            -> a -> a -> Bool
 
43
commutative (+) = \x y ->
 
44
  x + y == y + x
 
45
 
 
46
-- | Is the element a zero for the operator?
 
47
 
 
48
isZero :: (Arbitrary a, Eq a, Show a)
 
49
     => a -> (a -> a -> a)
 
50
     -> a -> Bool
 
51
isZero zer (*) = \x ->
 
52
  (zer * x == zer)
 
53
  &&
 
54
  (x * zer == zer)
 
55
 
 
56
-- | Is the element a unit for the operator?
 
57
 
 
58
identity :: (Arbitrary a, Eq a, Show a)
 
59
         => a -> (a -> a -> a)
 
60
         -> a -> Bool
 
61
identity one (*) = \x ->
 
62
  (one * x == x)
 
63
  &&
 
64
  (x * one == x)
 
65
 
 
66
-- | Does the first operator distribute (from the left) over the
 
67
-- second one?
 
68
 
 
69
leftDistributive
 
70
  :: (Arbitrary a, Eq a, Show a)
 
71
  => (a -> a -> a) -> (a -> a -> a)
 
72
  -> a -> a -> a -> Bool
 
73
leftDistributive (*) (+) = \x y z ->
 
74
  x * (y + z) == (x * y) + (x * z)
 
75
 
 
76
-- | Does the first operator distribute (from the right) over the
 
77
-- second one?
 
78
 
 
79
rightDistributive
 
80
  :: (Arbitrary a, Eq a, Show a)
 
81
  => (a -> a -> a) -> (a -> a -> a)
 
82
  -> a -> a -> a -> Bool
 
83
rightDistributive (*) (+) = \x y z ->
 
84
  (x + y) * z == (x * z) + (y * z)
 
85
 
 
86
------------------------------------------------------------------------
 
87
-- Generators
 
88
 
 
89
-- | Generates natural numbers.
 
90
 
 
91
natural :: (Integral i) => Gen i
 
92
natural = fmap (fromInteger . abs) arbitrary
 
93
 
 
94
-- | Generates positive numbers.
 
95
 
 
96
positive :: (Integral i) => Gen i
 
97
positive = fmap ((+ 1) . abs . fromInteger) arbitrary
 
98
 
 
99
-- | Generates a list of elements picked from a given list.
 
100
listOfElements :: [a] -> Gen [a]
 
101
listOfElements [] = return []
 
102
listOfElements xs = listOf $ elements xs
 
103
 
 
104
-- | Generates values of 'Maybe' type, using the given generator to
 
105
-- generate the contents of the 'Just' constructor.
 
106
 
 
107
maybeGen :: Gen a -> Gen (Maybe a)
 
108
maybeGen gen = frequency [ (1, return Nothing)
 
109
                         , (9, fmap Just gen)
 
110
                         ]
 
111
 
 
112
-- | 'Coarbitrary' \"generator\" for 'Maybe'.
 
113
 
 
114
maybeCoGen :: (a -> Gen b -> Gen b) -> (Maybe a -> Gen b -> Gen b)
 
115
maybeCoGen f Nothing  = variant 0
 
116
maybeCoGen f (Just x) = variant 1 . f x
 
117
 
 
118
------------------------------------------------------------------------
 
119
-- Test driver
 
120
 
 
121
-- | Runs the tests, and returns 'True' if all tests were successful.
 
122
 
 
123
runTests :: String    -- ^ A label for the tests. Used for
 
124
                      --   informational purposes.
 
125
         -> [IO Bool]
 
126
         -> IO Bool
 
127
runTests name tests = do
 
128
  UTF8.putStrLn name
 
129
  fmap and $ sequence tests