RealTesting/Data.hs at master · koengit/RealTesting · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
{-# LANGUAGE FlexibleContexts, DefaultSignatures, TypeOperators #-}
module Data where

{-
Varying the data-part of test data by means of expressing them as numerical data.
-}

import Test.QuickCheck
import Data.List
import Optimize
import Badness
import VBool
import GHC.Generics
import Badness
import Data.Reflection

--------------------------------------------------------------------------------

class Data a where
  vals :: a -> [Double]
  fill :: a -> [Double] -> a

  default vals :: (Generic a, GData (Rep a)) => a -> [Double]
  vals = genericVals

  default fill :: (Generic a, GData (Rep a)) => a -> [Double] -> a
  fill = genericFill

instance Data ()
instance (Data a, Data b) => Data (a,b)
instance (Data a, Data b) => Data (Either a b)
instance Data a => Data [a]

instance Data Double where
  vals x       = [x]
  fill _ (v:_) = v

instance Data Int where
  vals n       = [fromIntegral n]
  fill _ (v:_) = round v

--------------------------------------------------------------------------------

genericVals :: (Generic a, GData (Rep a)) => a -> [Double]
genericVals = gvals . from

genericFill :: (Generic a, GData (Rep a)) => a -> [Double] -> a
genericFill x xs = to (gfill (from x) xs)

class GData f where
  gvals :: f a -> [Double]
  gfill :: f a -> [Double] -> f a

instance (GData f, GData g) => GData (f :*: g) where
  gvals (x :*: y)    = gvals x ++ gvals y
  gfill (x :*: y) vs = gfill x (take k vs) :*: gfill y (drop k vs)
   where
    k = length (gvals x)

instance (GData f, GData g) => GData (f :+: g) where
   gvals (L1 x)  = gvals x
   gvals (R1 y) = gvals y

   gfill (L1 x) = L1 . gfill x
   gfill (R1 y) = R1 . gfill y

instance GData f => GData (M1 i c f) where
  gvals (M1 x) = gvals x
  gfill (M1 x) = M1 . gfill x

instance Data a => GData (K1 i a) where
  gvals (K1 x) = vals x
  gfill (K1 x) = K1 . fill x

instance GData U1 where
  gvals _   = []
  gfill _ _ = U1

--------------------------------------------------------------------------------

data List a = List [a] Int [a] deriving ( Eq, Ord )

list :: Int -> [a] -> List a
list n xs = List (take (n `min` 30) xs) (0 `max` (n `min` 30)) xs

instance Show a => Show (List a) where
  show (List xs n ys) = show xs {- ++ "(" ++ tail (init (show (drop n ys))) ++ ")" -}

instance Arbitrary a => Arbitrary (List a) where
  arbitrary =
    do xs <- sequence [ arbitrary | i <- [1..30] ]
       n  <- choose (0,30)
       return (list n xs)

  shrink (List _ n xs) =
    [ list k xs | k <- [0..n-1] ] ++
    [ list n (take i xs ++ [x'] ++ drop (i+1) xs)
    | i <- [0..n-1]
    , x' <- shrink (xs!!i)
    ]

instance Data a => Data (List a) where
  vals (List _ n xs)    = vals n ++ vals xs
  fill (List _ n xs) vs = list (fill n (take 1 vs)) (fill xs (drop 1 vs))

--------------------------------------------------------------------------------

forData :: (Show a, Data a, Given Badness) => a -> (a -> VBool) -> (a, VBool)
forData x h = (fill x ws, ans)
 where
  (ws,ans) = goal   isFalse
           . giveUp 100
           . take   1000
           . minimize (repeat 15) (vals x)
           $ h . fill x

-- dummy implementation without NM for comparison
forData0 :: (Show a, Data a) => a -> (a -> VBool) -> Property
forData0 x h =
  whenFail (print x) $ isTrue (h x)

--------------------------------------------------------------------------------