git.iko.soy/elk
on master help sign in
Style changes and making things compatible with new Pattern constructor names
5a80766Evan Czaplicki
tests/Tests/Property.hs+17−16
compare with master
unifiedsplit
@@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
10import Text.PrettyPrint as P
10import Text.PrettyPrint as P
11
11
12import SourceSyntax.Literal as Lit
12import SourceSyntax.Literal as Lit
13−import SourceSyntax.Pattern as Pat
13+import qualified SourceSyntax.Pattern as P
14import SourceSyntax.PrettyPrint (Pretty, pretty)
14import SourceSyntax.PrettyPrint (Pretty, pretty)
15import Parse.Helpers (IParser, iParse)
15import Parse.Helpers (IParser, iParse)
16import Parse.Literal (literal)
16import Parse.Literal (literal)
@@ -31,24 +31,25 @@ propertyTests =
31 where
31 where
32 -- This test was autogenerated from the Pattern test and should be
32 -- This test was autogenerated from the Pattern test and should be
33 -- left in all its ugly glory.
33 -- left in all its ugly glory.
34− longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
34+ longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
35− , Pat.PRecord [
35+ , P.Record
36− "q7yclkcm7k_ikstrczv_"
36+ [ "q7yclkcm7k_ikstrczv_"
37− , "wQRv6gKsvvkjw4b5F"
37+ , "wQRv6gKsvvkjw4b5F"
38− ,"c9'eFfhk9FTvsMnwF_D"
38+ ,"c9'eFfhk9FTvsMnwF_D"
39− ,"yqxhEkHvRFwZ"
39+ ,"yqxhEkHvRFwZ"
40− ,"o"
40+ ,"o"
41− ,"nbUlCn3y3NnkVoxhW"
41+ ,"nbUlCn3y3NnkVoxhW"
42− ,"iJ0MNy3KZ_lrs"
42+ ,"iJ0MNy3KZ_lrs"
43− ,"ug"
43+ ,"ug"
44− ,"sHHsX"
44+ ,"sHHsX"
45− ,"mRKs9d"
45+ ,"mRKs9d"
46− ,"o2KiCX5'ZRzHJfRi8" ]
46+ ,"o2KiCX5'ZRzHJfRi8" ]
47− , Pat.PVar "su'BrrbPUK6I33Eq" ]
47+ , P.Var "su'BrrbPUK6I33Eq"
48+ ]
48
49
49prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
50prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
50prop_parse_print p x =
51prop_parse_print p x =
51 either (const False) (== x) . parse_print p $ x
52 either (const False) (== x) . parse_print p $ x
52
53
53parse_print :: (Pretty a) => IParser a -> a -> Either String a
54parse_print :: (Pretty a) => IParser a -> a -> Either String a
54−parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
55+parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
tests/Tests/Property/Arbitrary.hs+91−76
@@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
8import qualified Data.Set as Set
8import qualified Data.Set as Set
9import qualified Parse.Helpers (reserveds)
9import qualified Parse.Helpers (reserveds)
10
10
11−import SourceSyntax.Literal
11+import qualified SourceSyntax.Literal as L
12−import SourceSyntax.Pattern
12+import qualified SourceSyntax.Pattern as P
13−import SourceSyntax.Type hiding (listOf)
13+import qualified SourceSyntax.Type as T
14−
14+
15−instance Arbitrary Literal where
15+instance Arbitrary L.Literal where
16+ arbitrary =
17+ oneof
16− arbitrary = oneof [ IntNum <$> arbitrary
18+ [ L.IntNum <$> arbitrary
17− , FloatNum <$> (arbitrary `suchThat` noE)
19+ , L.FloatNum <$> (arbitrary `suchThat` noE)
18− , Chr <$> arbitrary
20+ , L.Chr <$> arbitrary
19− -- This is too permissive
21+ -- This is too permissive
20− , Str <$> arbitrary
22+ , L.Str <$> arbitrary
21− -- Booleans aren't actually source syntax
23+ -- Booleans aren't actually source syntax
22− -- , Boolean <$> arbitrary
24+ -- , Boolean <$> arbitrary
23− ]
25+ ]
26+
24− shrink l = case l of
27+ shrink lit =
28+ case lit of
25− IntNum n -> IntNum <$> shrink n
29+ L.IntNum n -> L.IntNum <$> shrink n
26− FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
30+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
27− Chr c -> Chr <$> shrink c
31+ L.Chr c -> L.Chr <$> shrink c
28− Str s -> Str <$> shrink s
32+ L.Str s -> L.Str <$> shrink s
29− Boolean b -> Boolean <$> shrink b
33+ L.Boolean b -> L.Boolean <$> shrink b
30
34
31noE :: Double -> Bool
35noE :: Double -> Bool
32noE = notElem 'e' . show
36noE = notElem 'e' . show
33
37
38+genVector :: Int -> (Int -> Gen a) -> Gen [a]
39+genVector n generator = do
40+ len <- choose (0,n)
41+ let m = n `div` (len + 1)
42+ vectorOf len $ generator m
34
43
35−instance Arbitrary Pattern where
44+instance Arbitrary P.Pattern where
36 arbitrary = sized pat
45 arbitrary = sized pat
46+ where
37− where pat :: Int -> Gen Pattern
47+ pat :: Int -> Gen P.Pattern
38− pat n = oneof [ pure PAnything
48+ pat n =
49+ oneof
50+ [ pure P.Anything
39− , PVar <$> lowVar
51+ , P.Var <$> lowVar
40− , PRecord <$> (listOf1 lowVar)
52+ , P.Record <$> (listOf1 lowVar)
41− , PLiteral <$> arbitrary
53+ , P.Literal <$> arbitrary
42− , PAlias <$> lowVar <*> pat (n-1)
54+ , P.Alias <$> lowVar <*> pat (n-1)
43− , PData <$> capVar <*> sizedPats
55+ , P.Data <$> capVar <*> genVector n pat
44− ]
56+ ]
45− where sizedPats = do
57+
46− len <- choose (0,n)
47− let m = n `div` (len + 1)
48− vectorOf len $ pat m
49−
50− shrink pat = case pat of
58+ shrink pat =
51− PAnything -> []
59+ case pat of
60+ P.Anything -> []
52− PVar v -> PVar <$> shrinkWHead v
61+ P.Var v -> P.Var <$> shrinkWHead v
53− PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
62+ P.Literal l -> P.Literal <$> shrink l
54− PLiteral l -> PLiteral <$> shrink l
55− PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
63+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
56− PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
64+ P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)
65+ P.Record fs ->
66+ P.Record <$> filter (all notNull) (filter notNull (shrink fs))
67+ where
68+ notNull = not . null
57
69
58shrinkWHead :: Arbitrary a => [a] -> [[a]]
70shrinkWHead :: Arbitrary a => [a] -> [[a]]
59shrinkWHead [] = error "Should be nonempty"
71shrinkWHead [] = error "Should be nonempty"
60shrinkWHead (x:xs) = (x:) <$> shrink xs
72shrinkWHead (x:xs) = (x:) <$> shrink xs
61
73
62−instance Arbitrary Type where
74+instance Arbitrary T.Type where
63 arbitrary = sized tipe
75 arbitrary = sized tipe
76+ where
64− where tipe :: Int -> Gen Type
77+ tipe :: Int -> Gen T.Type
78+ tipe n =
79+ let depthTipe = tipe =<< choose (0,n)
80+ field = (,) <$> lowVar <*> depthTipe
81+ fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
82+ fields1 = (:) <$> field <*> fields
83+ in
84+ oneof
65− tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
85+ [ T.Lambda <$> depthTipe <*> depthTipe
66− , Var <$> lowVar
86+ , T.Var <$> lowVar
67− , Data <$> capVar <*> depthTipes
87+ , T.Data <$> capVar <*> genVector n tipe
68− , Record <$> fields <*> pure Nothing
88+ , T.Record <$> fields <*> pure Nothing
69− , Record <$> fields1 <*> (Just <$> lowVar)
89+ , T.Record <$> fields1 <*> (Just <$> lowVar)
70− ]
90+ ]
71− where depthTipe = choose (0,n) >>= tipe
91+
72− depthTipes = do
73− len <- choose (0,n)
74− let m = n `div` (len + 1)
75− vectorOf len $ tipe m
76−
77− field = (,) <$> lowVar <*> depthTipe
78− fields = do
79− len <- choose (0,n)
80− let m = n `div` (len + 1)
81− vectorOf len $ (,) <$> lowVar <*> tipe m
82− fields1 = (:) <$> field <*> fields
83−
84− shrink tipe = case tipe of
92+ shrink tipe =
93+ case tipe of
85− Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
94+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
86− Var _ -> []
95+ T.Var _ -> []
87− Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
96+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
88− Record fs t -> map snd fs ++ case t of
97+ T.Record fs t -> map snd fs ++ record
98+ where
99+ record =
100+ case t of
89− Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
101+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
90− Just _ ->
102+ Just _ ->
91− do
92− fields <- filter (not . null) $ shrinkList shrinkField fs
103+ do fields <- filter (not . null) $ shrinkList shrinkField fs
93− return $ Record fields t
104+ return $ T.Record fields t
105+
94− where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
106+ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
95
107
96lowVar :: Gen String
108lowVar :: Gen String
97lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
109lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
110+ where
98− where lower = elements ['a'..'z']
111+ lower = elements ['a'..'z']
99
112
100capVar :: Gen String
113capVar :: Gen String
101capVar = notReserved $ (:) <$> upper <*> listOf varLetter
114capVar = notReserved $ (:) <$> upper <*> listOf varLetter
115+ where
102− where upper = elements ['A'..'Z']
116+ upper = elements ['A'..'Z']
103
117
104varLetter :: Gen Char
118varLetter :: Gen Char
105varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
119varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
@@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds
109
123
110exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
124exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
111exceptFor g xs = g `suchThat` notAnX
125exceptFor g xs = g `suchThat` notAnX
126+ where
112− where notAnX = flip Set.notMember xset
127+ notAnX = flip Set.notMember xset
113− xset = Set.fromList xs
128+ xset = Set.fromList xs