git.iko.soy/elk
on 63243ca help sign in
elk/tests/Tests/Property/Arbitrary.hs
75 lines 2.6 kB history raw
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2module Tests.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 SourceSyntax.Literal
12import SourceSyntax.Pattern
14instance Arbitrary Literal where
15 arbitrary = oneof [ IntNum <$> arbitrary
16 , FloatNum <$> (arbitrary `suchThat` noE)
17 , Chr <$> arbitrary
18 -- This is too permissive
19 , Str <$> arbitrary
20 -- Booleans aren't actually source syntax
21 -- , Boolean <$> arbitrary
22 ]
23 shrink l = case l of
24 IntNum n -> IntNum <$> shrink n
25 FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
26 Chr c -> Chr <$> shrink c
27 Str s -> Str <$> shrink s
28 Boolean b -> Boolean <$> shrink b
30noE :: Double -> Bool
31noE = notElem 'e' . show
34instance Arbitrary Pattern where
35 arbitrary = sized pat
36 where pat :: Int -> Gen Pattern
37 pat n = oneof [ pure PAnything
38 , PVar <$> lowVar
39 , PRecord <$> (listOf1 lowVar)
40 , PLiteral <$> arbitrary
41 , PAlias <$> lowVar <*> pat (n-1)
42 , PData <$> capVar <*> sizedPats
43 ]
44 where sizedPats = do
45 len <- choose (0,n)
46 let m = n `div` len in
47 vectorOf len $ pat m
49 shrink pat = case pat of
50 PAnything -> []
51 PVar v -> PVar <$> shrinkWHead v
52 PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
53 PLiteral l -> PLiteral <$> shrink l
54 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
55 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
56 where shrinkWHead (x:xs) = (x:) <$> shrink xs
58lowVar :: Gen String
59lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
60 where lower = elements ['a'..'z']
62capVar :: Gen String
63capVar = notReserved $ (:) <$> upper <*> listOf varLetter
64 where upper = elements ['A'..'Z']
66varLetter :: Gen Char
67varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
69notReserved :: Gen String -> Gen String
70notReserved = flip exceptFor Parse.Helpers.reserveds
72exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
73exceptFor g xs = g `suchThat` notAnX
74 where notAnX = flip Set.notMember xset
75 xset = Set.fromList xs