~jojo/Carth

ref: 65fedc5ad30893bac36f128dac201ff7081f8e1b Carth/test/Arbitrary.hs -rw-r--r-- 5.5 KiB
65fedc5aJoJo Allow Box in pattern to dereference 1 year, 10 months ago
                                                                                
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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
{-# LANGUAGE LambdaCase, DataKinds, FlexibleInstances #-}

module Arbitrary () where

import Control.Applicative (liftA3, liftA2)
import Control.Monad
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
import Test.QuickCheck.Modifiers hiding (Small)

import SrcPos
import Parse
import Ast
import NonEmpty


instance Arbitrary Program where
    arbitrary = arbitraryProgram
    shrink = shrinkProgram
instance Arbitrary TypeDef where
    arbitrary = arbitraryTypeDef
    shrink = shrinkTypeDef
instance Arbitrary ConstructorDefs where
    arbitrary = arbitraryConstructorDefs
    shrink (ConstructorDefs cs) = map ConstructorDefs (shrink cs)
instance Arbitrary Expr' where
    arbitrary = arbitraryExpr'
    shrink = shrinkExpr'
instance Arbitrary a => Arbitrary (WithPos a) where
    arbitrary = fmap (WithPos dummyPos) arbitrary
    shrink x = fmap (WithPos (getPos x)) (shrink (unpos x))
instance Arbitrary Const where
    arbitrary = arbitraryConst
instance Arbitrary Pat where
    arbitrary = arbitraryPat
    shrink = shrinkPat
instance Arbitrary (Id Small) where
    arbitrary = fmap (Id . WithPos dummyPos) arbitrarySmall
    shrink = shrinkNothing
instance Arbitrary (Id Big) where
    arbitrary = fmap (Id . WithPos dummyPos) arbitraryBig
    shrink = shrinkNothing
instance Arbitrary Scheme where
    arbitrary = applyArbitrary2 Forall
instance Arbitrary Type where
    arbitrary = arbitraryType
instance Arbitrary TVar where
    arbitrary = fmap TVExplicit arbitrary
instance Arbitrary TPrim where
    arbitrary = elements [TUnit, TInt, TDouble, TChar, TStr, TBool]
instance Arbitrary a => Arbitrary (NonEmpty a) where
    arbitrary = arbitraryNonEmpty
    shrink (x :| xs) = [ x' :| xs' | (x', xs') <- shrink (x, xs) ]


arbitraryProgram :: Gen Program
arbitraryProgram = do
    defs <- vectorOf' (1, 4) arbitrary
    tdefs <- vectorOf' (0, 4) arbitrary
    pure (Program defs tdefs)

arbitraryTypeDef :: Gen TypeDef
arbitraryTypeDef =
    liftA3 TypeDef arbitrary (vectorOf' (0, 4) arbitrary) arbitrary

arbitraryConstructorDefs :: Gen ConstructorDefs
arbitraryConstructorDefs = fmap
    ConstructorDefs
    (choose (0, 5) >>= flip vectorOf arbitraryConstructorDef)

arbitraryConstructorDef :: Gen (Id Big, [Type])
arbitraryConstructorDef = liftA2 (,) arbitrary (vectorOf' (0, 4) arbitrary)

arbitraryExpr' :: Gen Expr'
arbitraryExpr' = frequency
    [ (7, fmap Lit arbitrary)
    , (10, fmap Var arbitrary)
    , (2, applyArbitrary2 App)
    , (1, applyArbitrary3 If)
    , (1, applyArbitrary2 Fun)
    , (1, applyArbitrary2 Let)
    , (1, applyArbitrary2 TypeAscr)
    , (1, applyArbitrary2 Match)
    , (1, fmap FunMatch arbitrary)
    , (5, fmap Ctor arbitrary)
    ]

arbitraryConst :: Gen Const
arbitraryConst = frequency
    [ (3, pure Unit)
    , (5, fmap Int arbitrary)
    , (5, fmap Double arbitrary)
    , (1, fmap (Str . getPrintableString) arbitrary)
    , (2, fmap Bool arbitrary)
    , (2, fmap Char arbitraryChar)
    ]

arbitraryChar :: Gen Char
arbitraryChar = oneof
    [ choose ('a', 'z')
    , choose ('A', 'Z')
    , choose ('0', '9')
    , elements ['+', '-', '?', '(', ']', '#']
    , elements ['\n', '\t', '\0', '\a']
    ]

arbitraryPat :: Gen Pat
arbitraryPat = frequency
    [ ( 2
      , liftM2 (PConstruction dummyPos) arbitrary (vectorOf' (0, 4) arbitrary)
      )
    , (4, fmap PVar arbitrary)
    ]

arbitraryType :: Gen Type
arbitraryType = frequency
    [ (1, fmap TVar arbitrary)
    , (4, fmap TPrim arbitrary)
    , (1, applyArbitrary2 TFun)
    ]

arbitraryNonEmpty :: Arbitrary a => Gen (NonEmpty a)
arbitraryNonEmpty = liftM2
    (\a as -> a :| as)
    arbitrary
    (choose (0, 4) >>= flip vectorOf arbitrary)

arbitraryBig :: Gen String
arbitraryBig = do
    c <- liftM2 (:) (choose ('A', 'Z')) arbitraryRestIdent
    if elem c reserveds then arbitraryBig else pure c

arbitrarySmall :: Gen String
arbitrarySmall = do
    let first = frequency [(26, choose ('a', 'z')), (4, elements ['_', '?'])]
    firsts <- frequency
        [ (10, fmap pure first)
        , ( 1
          , liftM2 (\a b -> a : [b]) (elements ['-', '+']) (choose ('a', 'z'))
          )
        ]
    rest <- arbitraryRestIdent
    let id = firsts ++ rest
    if elem id reserveds then arbitrarySmall else pure id

arbitraryRestIdent :: Gen String
arbitraryRestIdent = vectorOf' (0, 8) c
  where
    c = frequency
        [ (26, choose ('a', 'z'))
        , (26, choose ('A', 'Z'))
        , (4, elements ['_', '-', '+', '?'])
        ]

vectorOf' :: (Int, Int) -> Gen a -> Gen [a]
vectorOf' r ga = flip vectorOf ga =<< choose r

shrinkProgram :: Program -> [Program]
shrinkProgram (Program defs tdefs) =
    [ Program defs' tdefs' | (defs', tdefs') <- shrink (defs, tdefs) ]

shrinkTypeDef :: TypeDef -> [TypeDef]
shrinkTypeDef (TypeDef x tvs cs) = map (uncurry (TypeDef x)) (shrink (tvs, cs))

shrinkExpr' :: Expr' -> [Expr']
shrinkExpr' = \case
    App f x ->
        [Lit Unit, unpos f, unpos x]
            ++ [ App f' x' | (f', x') <- shrink (f, x) ]
    If p c a ->
        [Lit Unit, unpos p, unpos c, unpos a]
            ++ [ If p' c' a' | (p', c', a') <- shrink (p, c, a) ]
    Fun p b -> [Lit Unit, unpos b] ++ [ Fun p' b' | (p', b') <- shrink (p, b) ]
    Let bs x ->
        [Lit Unit, unpos x] ++ [ Let bs' x' | (bs', x') <- shrink (bs, x) ]
    Match e cs ->
        [Lit Unit, unpos e] ++ [ Match e' cs' | (e', cs') <- shrink (e, cs) ]
    FunMatch cs -> Lit Unit : map FunMatch (shrink cs)
    _ -> []

shrinkPat :: Pat -> [Pat]
shrinkPat = \case
    PConstruction pos c ps -> map (PConstruction pos c) (shrink ps)
    _ -> []