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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-|
Module: Instances.Utils.GenericArbitrary
Copyright: (C) 2014-2017 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Stability: Provisional
Portability: GHC
A generic default implemention of 'arbitrary'.
Ideally, this should be a part of @QuickCheck@ itself
(see https://github.com/nick8325/quickcheck/pull/40), but alas, it hasn't been
merged yet. Until then, we'll have to define it ourselves.
-}
module Instances.Utils.GenericArbitrary (genericArbitrary) where
import Generics.Deriving.Base
import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..))
import Prelude ()
import Prelude.Compat
import Test.QuickCheck (Arbitrary(..), Gen, choose)
-- | `Gen` for generic instances in which each constructor has equal probability
-- of being chosen.
genericArbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a
genericArbitrary = to <$> gArbitrary
class GArbitrary f where
gArbitrary :: Gen (f a)
instance GArbitrary V1 where
-- Following the `Encode' V1` example in GHC.Generics.
gArbitrary = undefined
instance GArbitrary U1 where
gArbitrary = return U1
instance (GArbitrary a, GArbitrary b) => GArbitrary (a :*: b) where
gArbitrary = (:*:) <$> gArbitrary <*> gArbitrary
instance ( SumSize a, SumSize b
, ChooseSum a, ChooseSum b ) => GArbitrary (a :+: b) where
gArbitrary = do
-- We cannot simply choose with equal probability between the left and
-- right part of the `a :+: b` (e.g. with `choose (False, True)`),
-- because GHC.Generics does not guarantee :+: to be balanced; even if it
-- did, it could only do so for sum types with 2^n alternatives.
-- If we did that and got a data structure of form `(a :+: (b :+: c))`,
-- then a would be chosen just as often as b and c together.
-- So we first have to compute the number of alternatives using `sumSize`,
-- and then uniformly sample a number in the corresponding range.
let size = unTagged2 (sumSize :: Tagged2 (a :+: b) Int)
x <- choose (1, size)
-- Optimisation:
-- We could just recursively call `gArbitrary` on the left orright branch
-- here, as in
-- if x <= sizeL
-- then L1 <$> gArbitrary
-- else R1 <$> gArbitrary
-- but this would unnecessarily sample again in the same sum type, and that
-- even though `x` completely determines which alternative to choose,
-- and sampling is slow because it needs IO and random numbers.
-- So instead we use `chooseSum x` to pick the x'th alternative from the
-- current sum type.
-- This made it around 50% faster for a sum type with 26 alternatives
-- on my computer.
chooseSum x
instance GArbitrary a => GArbitrary (M1 i c a) where
gArbitrary = M1 <$> gArbitrary
instance Arbitrary a => GArbitrary (K1 i a) where
gArbitrary = K1 <$> arbitrary
instance GArbitrary UChar where
gArbitrary = do
C# c <- arbitrary
return (UChar c)
instance GArbitrary UDouble where
gArbitrary = do
D# d <- arbitrary
return (UDouble d)
instance GArbitrary UFloat where
gArbitrary = do
F# f <- arbitrary
return (UFloat f)
instance GArbitrary UInt where
gArbitrary = do
I# i <- arbitrary
return (UInt i)
instance GArbitrary UWord where
gArbitrary = do
W# w <- arbitrary
return (UWord w)
newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
-- | Calculates the size of a sum type (numbers of alternatives).
--
-- Example: `data X = A | B | C` has `sumSize` 3.
class SumSize f where
sumSize :: Tagged2 f Int
-- Recursive case: Sum split `(:+:)`..
instance (SumSize a, SumSize b) => SumSize (a :+: b) where
sumSize = Tagged2 $ unTagged2 (sumSize :: Tagged2 a Int) +
unTagged2 (sumSize :: Tagged2 b Int)
{-# INLINE sumSize #-}
-- Constructor base case.
instance SumSize (C1 s a) where
sumSize = Tagged2 1
{-# INLINE sumSize #-}
-- | This class takes an integer `x` and returns a `gArbitrary` value
-- for the `x`'th alternative in a sum type.
class ChooseSum f where
chooseSum :: Int -> Gen (f a)
-- Recursive case: Check whether `x` lies in the left or the right side
-- of the (:+:) split.
instance (SumSize a, ChooseSum a, ChooseSum b) => ChooseSum (a :+: b) where
chooseSum x = do
let sizeL = unTagged2 (sumSize :: Tagged2 a Int)
if x <= sizeL
then L1 <$> chooseSum x
else R1 <$> chooseSum (x - sizeL)
-- Constructor base case.
instance (GArbitrary a) => ChooseSum (C1 s a) where
chooseSum 1 = gArbitrary
chooseSum _ = error "chooseSum: BUG"
|
