git.iko.soy/elk
on master help sign in
Add parse/print tests for Patterns.
24751a3Max New
tests/Tests/Property.hs+11−6
compare with master
unifiedsplit
@@ -5,18 +5,23 @@ import Test.Framework.Providers.QuickCheck2
5import Test.QuickCheck
5import Test.QuickCheck
6
6
7import SourceSyntax.Literal (Literal)
7import SourceSyntax.Literal (Literal)
8−import SourceSyntax.PrettyPrint (pretty)
8+import SourceSyntax.PrettyPrint (Pretty, pretty)
9−import Parse.Helpers (iParse)
9+import Parse.Helpers (IParser, iParse)
10import Parse.Literal (literal)
10import Parse.Literal (literal)
11+import Parse.Pattern (expr)
11import Tests.Property.Arbitrary
12import Tests.Property.Arbitrary
12
13
13propertyTests :: Test
14propertyTests :: Test
14propertyTests =
15propertyTests =
15 testGroup "Parse/Print Agreement Tests"
16 testGroup "Parse/Print Agreement Tests"
16 [
17 [
17− testProperty "Literal test" prop_literal_parse_print
18+ testProperty "Literal test" $ prop_parse_print literal
19+ , testProperty "Pattern test" $ prop_parse_print expr
18 ]
20 ]
19
21
20−prop_literal_parse_print :: Literal -> Bool
22+prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
21−prop_literal_parse_print l =
23+prop_parse_print p x =
22− either (const False) (== l) . iParse literal . show . pretty $ l
24+ either (const False) (== x) . parse_print p $ x
25+
26+parse_print :: (Pretty a) => IParser a -> a -> Either String a
27+parse_print p = either (Left . show) (Right) . iParse p . show . pretty
tests/Tests/Property/Arbitrary.hs+50−1
@@ -1,16 +1,21 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2module Tests.Property.Arbitrary where
2module Tests.Property.Arbitrary where
3
3
4−import Control.Applicative ((<$>))
4+import Control.Applicative ((<$>), (<*>), pure)
5import Test.QuickCheck.Arbitrary
5import Test.QuickCheck.Arbitrary
6import Test.QuickCheck.Gen
6import Test.QuickCheck.Gen
7
7
8+import qualified Data.Set as Set
9+import qualified Parse.Helpers (reserveds)
10+
8import SourceSyntax.Literal
11import SourceSyntax.Literal
12+import SourceSyntax.Pattern
9
13
10instance Arbitrary Literal where
14instance Arbitrary Literal where
11 arbitrary = oneof [ IntNum <$> arbitrary
15 arbitrary = oneof [ IntNum <$> arbitrary
12 , FloatNum <$> arbitrary
16 , FloatNum <$> arbitrary
13 , Chr <$> arbitrary
17 , Chr <$> arbitrary
18+ -- This is too permissive
14 , Str <$> arbitrary
19 , Str <$> arbitrary
15 -- Booleans aren't actually source syntax
20 -- Booleans aren't actually source syntax
16 -- , Boolean <$> arbitrary
21 -- , Boolean <$> arbitrary
@@ -21,3 +26,47 @@ instance Arbitrary Literal where
21 Chr c -> Chr <$> shrink c
26 Chr c -> Chr <$> shrink c
22 Str s -> Str <$> shrink s
27 Str s -> Str <$> shrink s
23 Boolean b -> Boolean <$> shrink b
28 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+