@@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
88import qualified Data.Set as Set
99import qualified Parse.Helpers (reserveds)
1010
11−import SourceSyntax.Literal
12−import SourceSyntax.Pattern
13−import SourceSyntax.Type hiding (listOf)
14−
15−instance Arbitrary Literal where
16− arbitrary = oneof [ IntNum <$> arbitrary
17− , FloatNum <$> (arbitrary `suchThat` noE)
18− , Chr <$> arbitrary
19− -- This is too permissive
20− , Str <$> arbitrary
21− -- Booleans aren't actually source syntax
22− -- , Boolean <$> arbitrary
23− ]
24− shrink l = case l of
25− IntNum n -> IntNum <$> shrink n
26− FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
27− Chr c -> Chr <$> shrink c
28− Str s -> Str <$> shrink s
29− Boolean b -> Boolean <$> shrink b
11+import qualified SourceSyntax.Literal as L
12+import qualified SourceSyntax.Pattern as P
13+import qualified SourceSyntax.Type as T
14+
15+instance Arbitrary L.Literal where
16+ arbitrary =
17+ oneof
18+ [ L.IntNum <$> arbitrary
19+ , L.FloatNum <$> (arbitrary `suchThat` noE)
20+ , L.Chr <$> arbitrary
21+ -- This is too permissive
22+ , L.Str <$> arbitrary
23+ -- Booleans aren't actually source syntax
24+ -- , Boolean <$> arbitrary
25+ ]
26+
27+ shrink lit =
28+ case lit of
29+ L.IntNum n -> L.IntNum <$> shrink n
30+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
31+ L.Chr c -> L.Chr <$> shrink c
32+ L.Str s -> L.Str <$> shrink s
33+ L.Boolean b -> L.Boolean <$> shrink b
3034
3135noE :: Double -> Bool
3236noE = notElem 'e' . show
3337
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
3443
35−instance Arbitrary Pattern where
44+instance Arbitrary P.Pattern where
3645 arbitrary = sized pat
37− where pat :: Int -> Gen Pattern
38− pat n = oneof [ pure PAnything
39− , PVar <$> lowVar
40− , PRecord <$> (listOf1 lowVar)
41− , PLiteral <$> arbitrary
42− , PAlias <$> lowVar <*> pat (n-1)
43− , PData <$> capVar <*> sizedPats
44− ]
45− where sizedPats = do
46− len <- choose (0,n)
47− let m = n `div` (len + 1)
48− vectorOf len $ pat m
49−
50− shrink pat = case pat of
51− PAnything -> []
52− PVar v -> PVar <$> shrinkWHead v
53− PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
54− PLiteral l -> PLiteral <$> shrink l
55− PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
56− PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
46+ where
47+ pat :: Int -> Gen P.Pattern
48+ pat n =
49+ oneof
50+ [ pure P.Anything
51+ , P.Var <$> lowVar
52+ , P.Record <$> (listOf1 lowVar)
53+ , P.Literal <$> arbitrary
54+ , P.Alias <$> lowVar <*> pat (n-1)
55+ , P.Data <$> capVar <*> genVector n pat
56+ ]
57+
58+ shrink pat =
59+ case pat of
60+ P.Anything -> []
61+ P.Var v -> P.Var <$> shrinkWHead v
62+ P.Literal l -> P.Literal <$> shrink l
63+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
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
5769
5870shrinkWHead :: Arbitrary a => [a] -> [[a]]
5971shrinkWHead [] = error "Should be nonempty"
6072shrinkWHead (x:xs) = (x:) <$> shrink xs
6173
62−instance Arbitrary Type where
74+instance Arbitrary T.Type where
6375 arbitrary = sized tipe
64− where tipe :: Int -> Gen Type
65− tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
66− , Var <$> lowVar
67− , Data <$> capVar <*> depthTipes
68− , Record <$> fields <*> pure Nothing
69− , Record <$> fields1 <*> (Just <$> lowVar)
70− ]
71− where depthTipe = choose (0,n) >>= tipe
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
85− Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
86− Var _ -> []
87− Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
88− Record fs t -> map snd fs ++ case t of
89− Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
90− Just _ ->
91− do
92− fields <- filter (not . null) $ shrinkList shrinkField fs
93− return $ Record fields t
94− where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
76+ where
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
85+ [ T.Lambda <$> depthTipe <*> depthTipe
86+ , T.Var <$> lowVar
87+ , T.Data <$> capVar <*> genVector n tipe
88+ , T.Record <$> fields <*> pure Nothing
89+ , T.Record <$> fields1 <*> (Just <$> lowVar)
90+ ]
91+
92+ shrink tipe =
93+ case tipe of
94+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
95+ T.Var _ -> []
96+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
97+ T.Record fs t -> map snd fs ++ record
98+ where
99+ record =
100+ case t of
101+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
102+ Just _ ->
103+ do fields <- filter (not . null) $ shrinkList shrinkField fs
104+ return $ T.Record fields t
105+
106+ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
95107
96108lowVar :: Gen String
97109lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
98− where lower = elements ['a'..'z']
110+ where
111+ lower = elements ['a'..'z']
99112
100113capVar :: Gen String
101114capVar = notReserved $ (:) <$> upper <*> listOf varLetter
102− where upper = elements ['A'..'Z']
115+ where
116+ upper = elements ['A'..'Z']
103117
104118varLetter :: Gen Char
105119varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
@@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds
109123
110124exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
111125exceptFor g xs = g `suchThat` notAnX
112− where notAnX = flip Set.notMember xset
113− xset = Set.fromList xs
126+ where
127+ notAnX = flip Set.notMember xset
128+ xset = Set.fromList xs