Don't skip validity checks for built-in classes (#17355)
[ghc.git] / testsuite / tests / typecheck / should_compile / tc095.hs
1 {-
2 Bug report from Jon Mountjoy:
3
4 While playing with Happy I managed to generate a Haskell program
5 which compiles fine under ghc but not under Hugs. I don't know which
6 one is the culprit....
7
8 In Hugs(January 1998), one gets
9
10 ERROR "hugs.hs" (line 32): Unresolved top-level overloading
11 *** Binding : happyReduce_1
12 *** Outstanding context : Functor b
13
14 where line 32 is the one marked -- ##
15
16 It compiles in ghc-3.00. Changing very small things, like the
17 line marked ---**** to
18 action_0 (6) = happyShift action_0 ---****
19
20 then makes ghc produce a similar message:
21
22 hugs.hs:37:
23 Cannot resolve the ambiguous context (Functor a1Ab)
24 `Functor a1Ab' arising from use of `reduction', at hugs.hs:37
25 -}
26
27 module ShouldSucceed where
28
29 data HappyAbsSyn t1 t2 t3
30 = HappyTerminal Token
31 | HappyErrorToken Int
32 | HappyAbsSyn1 t1
33 | HappyAbsSyn2 t2
34 | HappyAbsSyn3 t3
35
36 action_0 (6) = happyShift action_3 --- *****
37 action_0 (1) = happyGoto action_1
38 action_0 (2) = happyGoto action_2
39 action_0 _ = happyFail
40
41 action_1 (7) = happyAccept
42 action_1 _ = happyFail
43
44 action_2 _ = happyReduce_1
45
46 action_3 (5) = happyShift action_4
47 action_3 _ = happyFail
48
49 action_4 (4) = happyShift action_6
50 action_4 (3) = happyGoto action_5
51 action_4 _ = happyFail
52
53 action_5 _ = happyReduce_2
54
55 action_6 _ = happyReduce_3
56
57 happyReduce_1 = happySpecReduce_1 1 reduction where { -- ##
58 reduction
59 (HappyAbsSyn2 happy_var_1)
60 = HappyAbsSyn1
61 (\p -> let q = map (\(x,y) -> (x,y p)) happy_var_1 in (10.1))
62 ;
63 reduction _ = notHappyAtAll }
64
65 happyReduce_2 = happySpecReduce_3 2 reduction where {
66 reduction
67 (HappyAbsSyn3 happy_var_3)
68 _
69 (HappyTerminal (TokenVar happy_var_1))
70 = HappyAbsSyn2
71 ([(happy_var_1,happy_var_3)]);
72 reduction _ _ _ = notHappyAtAll }
73
74 happyReduce_3 = happySpecReduce_1 3 reduction where {
75 reduction
76 (HappyTerminal (TokenInt happy_var_1))
77 = HappyAbsSyn3
78 (\p -> happy_var_1);
79 reduction _ = notHappyAtAll }
80
81 happyNewToken action sts stk [] =
82 action 7 7 (error "reading EOF!") (HappyState action) sts stk []
83
84 happyNewToken action sts stk (tk:tks) =
85 let cont i = action i i tk (HappyState action) sts stk tks in
86 case tk of {
87 TokenInt happy_dollar_dollar -> cont 4;
88 TokenEq -> cont 5;
89 TokenVar happy_dollar_dollar -> cont 6;
90 }
91
92 happyThen = \m k -> k m
93 happyReturn = \a tks -> a
94 myparser = happyParse
95
96
97
98 happyError ::[Token] -> a
99 happyError _ = error "Parse error\n"
100
101 --Here are our tokens
102 data Token =
103 TokenInt Int
104 | TokenVar String
105 | TokenEq
106 deriving Show
107
108 main = print (myparser [] [])
109 -- $Id: tc095.hs,v 1.4 2005/05/24 11:33:11 simonpj Exp $
110
111 {-
112 The stack is in the following order throughout the parse:
113
114 i current token number
115 j another copy of this to avoid messing with the stack
116 tk current token semantic value
117 st current state
118 sts state stack
119 stk semantic stack
120 -}
121
122 -----------------------------------------------------------------------------
123
124 happyParse = happyNewToken action_0 [] []
125
126 -- All this HappyState stuff is simply because we can't have recursive
127 -- types in Haskell without an intervening data structure.
128
129 newtype HappyState b c = HappyState
130 (Int -> -- token number
131 Int -> -- token number (yes, again)
132 b -> -- token semantic value
133 HappyState b c -> -- current state
134 [HappyState b c] -> -- state stack
135 c)
136
137 -----------------------------------------------------------------------------
138 -- Accepting the parse
139
140 happyAccept j tk st sts [ HappyAbsSyn1 ans ] = happyReturn ans
141 happyAccept j tk st sts _ = notHappyAtAll
142
143 -----------------------------------------------------------------------------
144 -- Shifting a token
145
146 happyShift new_state (-1) tk st sts stk@(HappyErrorToken i : _) =
147 -- _trace "shifting the error token" $
148 new_state i i tk (HappyState new_state) (st:sts) stk
149
150 happyShift new_state i tk st sts stk =
151 happyNewToken new_state (st:sts) (HappyTerminal tk:stk)
152
153 -----------------------------------------------------------------------------
154 -- Reducing
155
156 -- happyReduce is specialised for the common cases.
157
158 -- don't allow reductions when we're in error recovery, because this can
159 -- lead to an infinite loop.
160
161 happySpecReduce_0 i fn (-1) tk _ sts stk
162 = case sts of
163 st@(HappyState action):sts -> action (-1) (-1) tk st sts stk
164 _ -> happyError
165 happySpecReduce_0 i fn j tk st@(HappyState action) sts stk
166 = action i j tk st (st:sts) (fn : stk)
167
168 happySpecReduce_1 i fn (-1) tk _ (st@(HappyState action):sts) stk
169 = action (-1) (-1) tk st sts stk
170 happySpecReduce_1 i fn j tk _ sts@(st@(HappyState action):_) (v1:stk')
171 = action i j tk st sts (fn v1 : stk')
172 happySpecReduce_1 _ _ _ _ _ _ _
173 = notHappyAtAll
174
175 happySpecReduce_2 i fn (-1) tk _ (st@(HappyState action):sts) stk
176 = action (-1) (-1) tk st sts stk
177 happySpecReduce_2 i fn j tk _ (_:sts@(st@(HappyState action):_)) (v1:v2:stk')
178 = action i j tk st sts (fn v1 v2 : stk')
179 happySpecReduce_2 _ _ _ _ _ _ _
180 = notHappyAtAll
181
182 happySpecReduce_3 i fn (-1) tk _ (st@(HappyState action):sts) stk
183 = action (-1) (-1) tk st sts stk
184 happySpecReduce_3 i fn j tk _ (_:_:sts@(st@(HappyState action):_))
185 (v1:v2:v3:stk')
186 = action i j tk st sts (fn v1 v2 v3 : stk')
187 happySpecReduce_3 _ _ _ _ _ _ _
188 = notHappyAtAll
189
190 happyReduce k i fn (-1) tk _ (st@(HappyState action):sts) stk
191 = action (-1) (-1) tk st sts stk
192 happyReduce k i fn j tk st sts stk = action i j tk st' sts' (fn stk)
193 where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts)
194
195 happyMonadReduce k i c fn (-1) tk _ sts stk
196 = case sts of
197 (st@(HappyState action):sts) -> action (-1) (-1) tk st sts stk
198 [] -> happyError
199 happyMonadReduce k i c fn j tk st sts stk =
200 happyThen (fn stk) (\r -> action i j tk st' sts' (c r : stk'))
201 where sts'@(st'@(HappyState action):_) = drop (k::Int) (st:sts)
202 stk' = drop (k::Int) stk
203
204 -----------------------------------------------------------------------------
205 -- Moving to a new state after a reduction
206
207 happyGoto action j tk st = action j j tk (HappyState action)
208
209 -----------------------------------------------------------------------------
210 -- Error recovery (-1 is the error token)
211
212 -- fail if we are in recovery and no more states to discard
213 {-# NOINLINE happyFail #-}
214 -- NOINLINE else GHC diverges with the contravariant data type bug
215 -- See test simplCore/should_compile/simpl012
216 happyFail (-1) tk st' [] stk = happyError
217
218 -- discard a state
219 happyFail (-1) tk st' (st@(HappyState action):sts) stk =
220 -- _trace "discarding state" $
221 action (-1) (-1) tk st sts stk
222
223 -- Enter error recovery: generate an error token,
224 -- save the old token and carry on.
225
226 -- we push the error token on the stack in anticipation of a shift,
227 -- and also because this is a convenient place to store the saved token.
228
229 happyFail i tk st@(HappyState action) sts stk =
230 -- _trace "entering error recovery" $
231 action (-1) (-1) tk st sts (HappyErrorToken i : stk)
232
233 -- Internal happy errors:
234
235 notHappyAtAll = error "Internal Happy error\n"
236
237 -- end of Happy Template.