@@ -13,71 +13,104 @@ import qualified AST.Pattern as P
1313import qualified AST.Type as T
1414import qualified AST.Variable as V
1515
16+
1617instance Arbitrary V.Raw where
17− arbitrary = V.Raw <$> capVar
18− shrink (V.Raw v) = V.Raw <$> shrink v
18+ arbitrary =
19+ V.Raw <$> capVar
20+
21+ shrink (V.Raw v) =
22+ V.Raw <$> shrink v
23+
1924
2025instance Arbitrary L.Literal where
2126 arbitrary =
2227 oneof
23− [ L.IntNum <$> arbitrary
24− , L.FloatNum <$> (arbitrary `suchThat` noE)
25− , L.Chr <$> arbitrary
26− -- This is too permissive
27− , L.Str <$> arbitrary
28− -- Booleans aren't actually source syntax
29− -- , Boolean <$> arbitrary
30− ]
31−
32− shrink lit =
33− case lit of
34− L.IntNum n -> L.IntNum <$> shrink n
35− L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
36− L.Chr c -> L.Chr <$> shrink c
37− L.Str s -> L.Str <$> shrink s
38− L.Boolean b -> L.Boolean <$> shrink b
28+ [ L.IntNum <$> arbitrary
29+ , L.FloatNum <$> (arbitrary `suchThat` noE)
30+ , L.Chr <$> arbitrary
31+ -- This is too permissive
32+ , L.Str <$> arbitrary
33+ -- Booleans aren't actually source syntax
34+ -- , Boolean <$> arbitrary
35+ ]
36+
37+ shrink literal =
38+ case literal of
39+ L.IntNum int ->
40+ L.IntNum <$> shrink int
41+
42+ L.FloatNum float ->
43+ L.FloatNum <$> filter noE (shrink float)
44+
45+ L.Chr char ->
46+ L.Chr <$> shrink char
47+
48+ L.Str string ->
49+ L.Str <$> shrink string
50+
51+ L.Boolean bool ->
52+ L.Boolean <$> shrink bool
53+
3954
4055noE :: Double -> Bool
41−noE = notElem 'e' . show
56+noE =
57+ notElem 'e' . show
58+
4259
4360genVector :: Int -> (Int -> Gen a) -> Gen [a]
44−genVector n generator = do
45− len <- choose (0,n)
46− let m = n `div` (len + 1)
47− vectorOf len $ generator m
61+genVector n generator =
62+ do len <- choose (0,n)
63+ let m = n `div` (len + 1)
64+ vectorOf len $ generator m
4865
4966instance Arbitrary v => Arbitrary (P.Pattern v) where
50− arbitrary = sized pat
67+ arbitrary =
68+ sized pattern
5169 where
52− pat :: (Arbitrary v) => Int -> Gen (P.Pattern v)
53− pat n =
70+ pattern :: (Arbitrary v) => Int -> Gen (P.Pattern v)
71+ pattern n =
5472 oneof
5573 [ pure P.Anything
5674 , P.Var <$> lowVar
5775 , P.Record <$> (listOf1 lowVar)
5876 , P.Literal <$> arbitrary
59− , P.Alias <$> lowVar <*> pat (n-1)
60− , P.Data <$> arbitrary <*> genVector n pat
77+ , P.Alias <$> lowVar <*> pattern (n-1)
78+ , P.Data <$> arbitrary <*> genVector n pattern
6179 ]
6280
63− shrink pat =
64− case pat of
65− P.Anything -> []
66− P.Var v -> P.Var <$> shrinkWHead v
67− P.Literal l -> P.Literal <$> shrink l
68− P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
69− P.Data s ps -> ps ++ (P.Data <$> shrink s <*> shrink ps)
70− P.Record fs ->
71− P.Record <$> filter (all notNull) (filter notNull (shrink fs))
72− where
73− notNull = not . null
74−
75−shrinkWHead :: Arbitrary a => [a] -> [[a]]
76−shrinkWHead [] = error "Should be nonempty"
77−shrinkWHead (x:xs) = (x:) <$> shrink xs
81+ shrink pattern =
82+ case pattern of
83+ P.Anything ->
84+ []
85+
86+ P.Var var ->
87+ P.Var <$> consAndShrink var
88+
89+ P.Literal literal ->
90+ P.Literal <$> shrink literal
91+
92+ P.Alias alias pattern ->
93+ pattern : (P.Alias <$> consAndShrink alias <*> shrink pattern)
94+
95+ P.Data name patterns ->
96+ patterns ++ (P.Data <$> shrink name <*> shrink patterns)
97+
98+ P.Record fields ->
99+ P.Record <$> filter (all notNull) (filter notNull (shrink fields))
100+ where
101+ notNull = not . null
102+
103+
104+consAndShrink :: Arbitrary a => [a] -> [[a]]
105+consAndShrink values =
106+ case values of
107+ [] -> error "Should be nonempty"
108+ x:xs -> (x:) <$> shrink xs
109+
78110
79111instance Arbitrary v => Arbitrary (T.Type v) where
80− arbitrary = sized tipe
112+ arbitrary =
113+ sized tipe
81114 where
82115 tipe :: Arbitrary v => Int -> Gen (T.Type v)
83116 tipe n =
@@ -88,50 +121,72 @@ instance Arbitrary v => Arbitrary (T.Type v) where
88121 depthTipes = (:) <$> depthTipe <*> genVector n tipe
89122 in
90123 oneof
91− [ T.Lambda <$> depthTipe <*> depthTipe
92− , T.Var <$> lowVar
93− , T.Type <$> arbitrary
94− , T.App <$> (T.Type <$> arbitrary) <*> depthTipes
95− , T.Record <$> fields <*> pure Nothing
96− , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)
97− ]
124+ [ T.Lambda <$> depthTipe <*> depthTipe
125+ , T.Var <$> lowVar
126+ , T.Type <$> arbitrary
127+ , T.App <$> (T.Type <$> arbitrary) <*> depthTipes
128+ , T.Record <$> fields <*> pure Nothing
129+ , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)
130+ ]
98131
99132 shrink tipe =
100133 case tipe of
101− T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
102− T.Var _ -> []
103− T.Aliased v t -> t : (T.Aliased v <$> shrink t)
104− T.Type v -> T.Type <$> shrink v
105− T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts)
106− T.Record fs t -> map snd fs ++ record
107− where
108− record =
109− case t of
110− Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
111− Just _ ->
112− do fields <- filter (not . null) $ shrinkList shrinkField fs
113− return $ T.Record fields t
114−
115− shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
134+ T.Lambda arg result ->
135+ arg : result : (T.Lambda <$> shrink arg <*> shrink result)
136+
137+ T.Var _ ->
138+ []
139+
140+ T.Aliased v t ->
141+ t : (T.Aliased v <$> shrink t)
142+
143+ T.Type name ->
144+ T.Type <$> shrink name
145+
146+ T.App func args ->
147+ func : args ++ (T.App <$> shrink func <*> shrink args)
148+
149+ T.Record fields extension ->
150+ map snd fields ++ record
151+ where
152+ record =
153+ case extension of
154+ Nothing ->
155+ T.Record <$> shrinkList shrinkField fields <*> pure Nothing
156+
157+ Just _ ->
158+ do fields' <- filter (not . null) $ shrinkList shrinkField fields
159+ return $ T.Record fields' extension
160+
161+ shrinkField (name, tipe) =
162+ (,) <$> consAndShrink name <*> shrink tipe
163+
116164
117165lowVar :: Gen String
118−lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
119− where
120− lower = elements ['a'..'z']
166+lowVar =
167+ notReserved $
168+ (:) <$> elements ['a'..'z'] <*> listOf varLetter
169+
121170
122171capVar :: Gen String
123−capVar = notReserved $ (:) <$> upper <*> listOf varLetter
124− where
125− upper = elements ['A'..'Z']
172+capVar =
173+ notReserved $
174+ (:) <$> elements ['A'..'Z'] <*> listOf varLetter
175+
126176
127177varLetter :: Gen Char
128−varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
178+varLetter =
179+ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
180+
129181
130182notReserved :: Gen String -> Gen String
131−notReserved = flip exceptFor Parse.Helpers.reserveds
183+notReserved string =
184+ string `exceptFor` Parse.Helpers.reserveds
185+
132186
133187exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
134−exceptFor g xs = g `suchThat` notAnX
188+exceptFor generator list =
189+ generator `suchThat` notInList
135190 where
136− notAnX = flip Set.notMember xset
137− xset = Set.fromList xs
191+ set = Set.fromList list
192+ notInList x = Set.notMember x set