git.iko.soy/elk
on 267f708 help sign in
elk/tests/Test/Property/Arbitrary.hs
192 lines 5.0 kB history raw
1{-# OPTIONS_GHC -W -fno-warn-orphans #-}
2module Test.Property.Arbitrary where
4import Control.Applicative ((<$>), (<*>), pure)
5import Test.QuickCheck.Arbitrary
6import Test.QuickCheck.Gen
8import qualified Data.Set as Set
9import qualified Parse.Helpers (reserveds)
11import qualified AST.Literal as L
12import qualified AST.Pattern as P
13import qualified AST.Type as T
14import qualified AST.Variable as V
17instance Arbitrary V.Raw where
18 arbitrary =
19 V.Raw <$> capVar
21 shrink (V.Raw v) =
22 V.Raw <$> shrink v
25instance Arbitrary L.Literal where
26 arbitrary =
27 oneof
28 [ L.IntNum <$> arbitrary
29 , L.FloatNum <$> (arbitrary `suchThat` noE)
30 , L.Chr <$> arbitrary
31 -- This is too permissive
32 , L.Str <$> arbitrary
33 -- Booleans aren't actually source syntax
34 -- , Boolean <$> arbitrary
35 ]
37 shrink literal =
38 case literal of
39 L.IntNum int ->
40 L.IntNum <$> shrink int
42 L.FloatNum float ->
43 L.FloatNum <$> filter noE (shrink float)
45 L.Chr char ->
46 L.Chr <$> shrink char
48 L.Str string ->
49 L.Str <$> shrink string
51 L.Boolean bool ->
52 L.Boolean <$> shrink bool
55noE :: Double -> Bool
56noE =
57 notElem 'e' . show
60genVector :: Int -> (Int -> Gen a) -> Gen [a]
61genVector n generator =
62 do len <- choose (0,n)
63 let m = n `div` (len + 1)
64 vectorOf len $ generator m
66instance Arbitrary v => Arbitrary (P.Pattern v) where
67 arbitrary =
68 sized pattern
69 where
70 pattern :: (Arbitrary v) => Int -> Gen (P.Pattern v)
71 pattern n =
72 oneof
73 [ pure P.Anything
74 , P.Var <$> lowVar
75 , P.Record <$> (listOf1 lowVar)
76 , P.Literal <$> arbitrary
77 , P.Alias <$> lowVar <*> pattern (n-1)
78 , P.Data <$> arbitrary <*> genVector n pattern
79 ]
81 shrink pattern =
82 case pattern of
83 P.Anything ->
84 []
86 P.Var var ->
87 P.Var <$> consAndShrink var
89 P.Literal literal ->
90 P.Literal <$> shrink literal
92 P.Alias alias pattern ->
93 pattern : (P.Alias <$> consAndShrink alias <*> shrink pattern)
95 P.Data name patterns ->
96 patterns ++ (P.Data <$> shrink name <*> shrink patterns)
98 P.Record fields ->
99 P.Record <$> filter (all notNull) (filter notNull (shrink fields))
100 where
101 notNull = not . null
104consAndShrink :: Arbitrary a => [a] -> [[a]]
105consAndShrink values =
106 case values of
107 [] -> error "Should be nonempty"
108 x:xs -> (x:) <$> shrink xs
111instance Arbitrary v => Arbitrary (T.Type v) where
112 arbitrary =
113 sized tipe
114 where
115 tipe :: Arbitrary v => Int -> Gen (T.Type v)
116 tipe n =
117 let depthTipe = tipe =<< choose (0,n)
118 field = (,) <$> lowVar <*> depthTipe
119 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
120 fields1 = (:) <$> field <*> fields
121 depthTipes = (:) <$> depthTipe <*> genVector n tipe
122 in
123 oneof
124 [ T.Lambda <$> depthTipe <*> depthTipe
125 , T.Var <$> lowVar
126 , T.Type <$> arbitrary
127 , T.App <$> (T.Type <$> arbitrary) <*> depthTipes
128 , T.Record <$> fields <*> pure Nothing
129 , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)
130 ]
132 shrink tipe =
133 case tipe of
134 T.Lambda arg result ->
135 arg : result : (T.Lambda <$> shrink arg <*> shrink result)
137 T.Var _ ->
138 []
140 T.Aliased name tvars rootType ->
141 rootType : (T.Aliased name <$> shrinkList shrinkPair tvars <*> shrink rootType)
143 T.Type name ->
144 T.Type <$> shrink name
146 T.App func args ->
147 func : args ++ (T.App <$> shrink func <*> shrink args)
149 T.Record fields extension ->
150 map snd fields ++ record
151 where
152 record =
153 case extension of
154 Nothing ->
155 T.Record <$> shrinkList shrinkPair fields <*> pure Nothing
157 Just _ ->
158 do fields' <- filter (not . null) $ shrinkList shrinkPair fields
159 return $ T.Record fields' extension
160 where
161 shrinkPair (name, tipe) =
162 (,) <$> consAndShrink name <*> shrink tipe
165lowVar :: Gen String
166lowVar =
167 notReserved $
168 (:) <$> elements ['a'..'z'] <*> listOf varLetter
171capVar :: Gen String
172capVar =
173 notReserved $
174 (:) <$> elements ['A'..'Z'] <*> listOf varLetter
177varLetter :: Gen Char
178varLetter =
179 elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
182notReserved :: Gen String -> Gen String
183notReserved string =
184 string `exceptFor` Parse.Helpers.reserveds
187exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
188exceptFor generator list =
189 generator `suchThat` notInList
190 where
191 set = Set.fromList list
192 notInList x = Set.notMember x set