@@ -0,0 +1,75 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+module Tests.Property.Arbitrary where
3+
4+import Control.Applicative ((<$>), (<*>), pure)
5+import Test.QuickCheck.Arbitrary
6+import Test.QuickCheck.Gen
7+
8+import qualified Data.Set as Set
9+import qualified Parse.Helpers (reserveds)
10+
11+import SourceSyntax.Literal
12+import SourceSyntax.Pattern
13+
14+instance 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
29+
30+noE :: Double -> Bool
31+noE = notElem 'e' . show
32+
33+
34+instance 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
48+
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
57+
58+lowVar :: Gen String
59+lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
60+ where lower = elements ['a'..'z']
61+
62+capVar :: Gen String
63+capVar = notReserved $ (:) <$> upper <*> listOf varLetter
64+ where upper = elements ['A'..'Z']
65+
66+varLetter :: Gen Char
67+varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
68+
69+notReserved :: Gen String -> Gen String
70+notReserved = flip exceptFor Parse.Helpers.reserveds
71+
72+exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
73+exceptFor g xs = g `suchThat` notAnX
74+ where notAnX = flip Set.notMember xset
75+ xset = Set.fromList xs