@@ -1,16 +1,21 @@
11{-# OPTIONS_GHC -fno-warn-orphans #-}
22module Tests.Property.Arbitrary where
33
4−import Control.Applicative ((<$>))
4+import Control.Applicative ((<$>), (<*>), pure)
55import Test.QuickCheck.Arbitrary
66import Test.QuickCheck.Gen
77
8+import qualified Data.Set as Set
9+import qualified Parse.Helpers (reserveds)
10+
811import SourceSyntax.Literal
12+import SourceSyntax.Pattern
913
1014instance Arbitrary Literal where
1115 arbitrary = oneof [ IntNum <$> arbitrary
1216 , FloatNum <$> arbitrary
1317 , Chr <$> arbitrary
18+ -- This is too permissive
1419 , Str <$> arbitrary
1520 -- Booleans aren't actually source syntax
1621 -- , Boolean <$> arbitrary
@@ -21,3 +26,47 @@ instance Arbitrary Literal where
2126 Chr c -> Chr <$> shrink c
2227 Str s -> Str <$> shrink s
2328 Boolean b -> Boolean <$> shrink b
29+
30+instance Arbitrary Pattern where
31+ arbitrary = sized pat
32+ where pat :: Int -> Gen Pattern
33+ pat n = oneof [ pure PAnything
34+ , PVar <$> lowVar
35+ , PRecord <$> (listOf1 lowVar)
36+ , PLiteral <$> arbitrary
37+ , PAlias <$> lowVar <*> pat (n-1)
38+ , PData <$> capVar <*> sizedPats
39+ ]
40+ where sizedPats = do
41+ len <- choose (0,n)
42+ let m = n `div` len in
43+ vectorOf len $ pat m
44+
45+ shrink pat = case pat of
46+ PAnything -> []
47+ PVar v -> PVar <$> shrinkWHead v
48+ PRecord fs -> PRecord <$> (filter (all $ not.null) . filter (not.null) $ shrink fs)
49+ PLiteral l -> PLiteral <$> shrink l
50+ PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
51+ PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
52+ where shrinkWHead (x:xs) = (x:) <$> shrink xs
53+
54+lowVar :: Gen String
55+lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
56+ where lower = elements ['a'..'z']
57+
58+capVar :: Gen String
59+capVar = notReserved $ (:) <$> upper <*> listOf varLetter
60+ where upper = elements ['A'..'Z']
61+
62+varLetter :: Gen Char
63+varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
64+
65+notReserved :: Gen String -> Gen String
66+notReserved = flip exceptFor Parse.Helpers.reserveds
67+
68+exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
69+exceptFor g xs = suchThat g notAnX
70+ where notAnX = flip Set.notMember xset
71+ xset = Set.fromList xs
72+