5fdbe7f66dc49fb4669c66bda8350cf5de9a10e4
[ghc.git] / testsuite / tests / ghci.debugger / HappyTest.hs
1 {-# LANGUAGE CPP, MagicHash #-}
2 import Data.Char
3 import Data.Array
4 import GHC.Exts
5 import System.IO
6 import System.IO.Unsafe
7 import Debug.Trace
8
9 import Control.Applicative (Applicative(..))
10 import Control.Monad (liftM, ap)
11
12 -- parser produced by Happy Version 1.16
13
14 data HappyAbsSyn
15 = HappyTerminal Token
16 | HappyErrorToken Int
17 | HappyAbsSyn4 (Exp)
18 | HappyAbsSyn5 (Exp1)
19 | HappyAbsSyn6 (Term)
20 | HappyAbsSyn7 (Factor)
21
22 happyActOffsets :: HappyAddr
23 happyActOffsets = HappyA# "\x01\x00\x25\x00\x1e\x00\x1b\x00\x1d\x00\x18\x00\x00\x00\x00\x00\x00\x00\x01\x00\xf8\xff\x03\x00\x03\x00\x03\x00\x03\x00\x20\x00\x01\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x01\x00\x00\x00\x00\x00"#
24
25 happyGotoOffsets :: HappyAddr
26 happyGotoOffsets = HappyA# "\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x07\x00\xfe\xff\x1c\x00\x06\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00"#
27
28 happyDefActions :: HappyAddr
29 happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xff\xfa\xff\xf7\xff\xf6\xff\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xfc\xff\xf8\xff\xf9\xff\xf4\xff\x00\x00\x00\x00\xfe\xff"#
30
31 happyCheck :: HappyAddr
32 happyCheck = HappyA# "\xff\xff\x03\x00\x01\x00\x0b\x00\x03\x00\x04\x00\x03\x00\x04\x00\x02\x00\x03\x00\x03\x00\x0a\x00\x02\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x00\x00\x01\x00\x02\x00\x03\x00\x02\x00\x03\x00\x08\x00\x09\x00\x04\x00\x06\x00\x07\x00\x05\x00\x01\x00\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
33
34 happyTable :: HappyAddr
35 happyTable = HappyA# "\x00\x00\x13\x00\x03\x00\x16\x00\x08\x00\x09\x00\x08\x00\x09\x00\x11\x00\x06\x00\x14\x00\x0a\x00\x18\x00\x0a\x00\x18\x00\x04\x00\x05\x00\x06\x00\x16\x00\x04\x00\x05\x00\x06\x00\x0a\x00\x04\x00\x05\x00\x06\x00\x03\x00\x04\x00\x05\x00\x06\x00\x12\x00\x06\x00\x0c\x00\x0d\x00\x10\x00\x0e\x00\x0f\x00\x11\x00\x03\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
36
37 happyReduceArr = array (1, 11) [
38 (1 , happyReduce_1),
39 (2 , happyReduce_2),
40 (3 , happyReduce_3),
41 (4 , happyReduce_4),
42 (5 , happyReduce_5),
43 (6 , happyReduce_6),
44 (7 , happyReduce_7),
45 (8 , happyReduce_8),
46 (9 , happyReduce_9),
47 (10 , happyReduce_10),
48 (11 , happyReduce_11)
49 ]
50
51 happy_n_terms = 13 :: Int
52 happy_n_nonterms = 4 :: Int
53
54 happyReduce_1 = happyReduce 6# 0# happyReduction_1
55 happyReduction_1 ((HappyAbsSyn4 happy_var_6) `HappyStk`
56 _ `HappyStk`
57 (HappyAbsSyn4 happy_var_4) `HappyStk`
58 _ `HappyStk`
59 (HappyTerminal (TokenVar happy_var_2)) `HappyStk`
60 _ `HappyStk`
61 happyRest)
62 = HappyAbsSyn4
63 (Let happy_var_2 happy_var_4 happy_var_6
64 ) `HappyStk` happyRest
65
66 happyReduce_2 = happySpecReduce_1 0# happyReduction_2
67 happyReduction_2 (HappyAbsSyn5 happy_var_1)
68 = HappyAbsSyn4
69 (Exp1 happy_var_1
70 )
71 happyReduction_2 _ = notHappyAtAll
72
73 happyReduce_3 = happySpecReduce_3 1# happyReduction_3
74 happyReduction_3 (HappyAbsSyn6 happy_var_3)
75 _
76 (HappyAbsSyn5 happy_var_1)
77 = HappyAbsSyn5
78 (Plus happy_var_1 happy_var_3
79 )
80 happyReduction_3 _ _ _ = notHappyAtAll
81
82 happyReduce_4 = happySpecReduce_3 1# happyReduction_4
83 happyReduction_4 (HappyAbsSyn6 happy_var_3)
84 _
85 (HappyAbsSyn5 happy_var_1)
86 = HappyAbsSyn5
87 (Minus happy_var_1 happy_var_3
88 )
89 happyReduction_4 _ _ _ = notHappyAtAll
90
91 happyReduce_5 = happySpecReduce_1 1# happyReduction_5
92 happyReduction_5 (HappyAbsSyn6 happy_var_1)
93 = HappyAbsSyn5
94 (Term happy_var_1
95 )
96 happyReduction_5 _ = notHappyAtAll
97
98 happyReduce_6 = happySpecReduce_3 2# happyReduction_6
99 happyReduction_6 (HappyAbsSyn7 happy_var_3)
100 _
101 (HappyAbsSyn6 happy_var_1)
102 = HappyAbsSyn6
103 (Times happy_var_1 happy_var_3
104 )
105 happyReduction_6 _ _ _ = notHappyAtAll
106
107 happyReduce_7 = happySpecReduce_3 2# happyReduction_7
108 happyReduction_7 (HappyAbsSyn7 happy_var_3)
109 _
110 (HappyAbsSyn6 happy_var_1)
111 = HappyAbsSyn6
112 (Div happy_var_1 happy_var_3
113 )
114 happyReduction_7 _ _ _ = notHappyAtAll
115
116 happyReduce_8 = happySpecReduce_1 2# happyReduction_8
117 happyReduction_8 (HappyAbsSyn7 happy_var_1)
118 = HappyAbsSyn6
119 (Factor happy_var_1
120 )
121 happyReduction_8 _ = notHappyAtAll
122
123 happyReduce_9 = happySpecReduce_1 3# happyReduction_9
124 happyReduction_9 (HappyTerminal (TokenInt happy_var_1))
125 = HappyAbsSyn7
126 (Int happy_var_1
127 )
128 happyReduction_9 _ = notHappyAtAll
129
130 happyReduce_10 = happySpecReduce_1 3# happyReduction_10
131 happyReduction_10 (HappyTerminal (TokenVar happy_var_1))
132 = HappyAbsSyn7
133 (Var happy_var_1
134 )
135 happyReduction_10 _ = notHappyAtAll
136
137 happyReduce_11 = happySpecReduce_3 3# happyReduction_11
138 happyReduction_11 _
139 (HappyAbsSyn4 happy_var_2)
140 _
141 = HappyAbsSyn7
142 (Brack happy_var_2
143 )
144 happyReduction_11 _ _ _ = notHappyAtAll
145
146 happyNewToken action sts stk [] =
147 happyDoAction 12# notHappyAtAll action sts stk []
148
149 happyNewToken action sts stk (tk:tks) =
150 let cont i = happyDoAction i tk action sts stk tks in
151 case tk of {
152 TokenLet -> cont 1#;
153 TokenIn -> cont 2#;
154 TokenInt happy_dollar_dollar -> cont 3#;
155 TokenVar happy_dollar_dollar -> cont 4#;
156 TokenEq -> cont 5#;
157 TokenPlus -> cont 6#;
158 TokenMinus -> cont 7#;
159 TokenTimes -> cont 8#;
160 TokenDiv -> cont 9#;
161 TokenOB -> cont 10#;
162 TokenCB -> cont 11#;
163 _ -> happyError' (tk:tks)
164 }
165
166 happyError_ tk tks = happyError' (tk:tks)
167
168 newtype HappyIdentity a = HappyIdentity a
169 happyIdentity = HappyIdentity
170 happyRunIdentity (HappyIdentity a) = a
171
172 instance Functor HappyIdentity where
173 fmap = liftM
174
175 instance Applicative HappyIdentity where
176 pure = return
177 (<*>) = ap
178
179 instance Monad HappyIdentity where
180 return = HappyIdentity
181 (HappyIdentity p) >>= q = q p
182
183 happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
184 happyThen = (>>=)
185 happyReturn :: () => a -> HappyIdentity a
186 happyReturn = (return)
187 happyThen1 m k tks = (>>=) m (\a -> k a tks)
188 happyReturn1 :: () => a -> b -> HappyIdentity a
189 happyReturn1 = \a tks -> (return) a
190 happyError' :: () => [Token] -> HappyIdentity a
191 happyError' = HappyIdentity . happyError
192
193 calc tks = happyRunIdentity happySomeParser where
194 happySomeParser = happyThen (happyParse 0# tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
195
196 happySeq = happyDontSeq
197
198
199 happyError tks = error "Parse error"
200
201
202
203 data Exp = Let String Exp Exp | Exp1 Exp1
204 data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term
205 data Term = Times Term Factor | Div Term Factor | Factor Factor
206 data Factor = Int Int | Var String | Brack Exp
207
208
209
210 data Token
211 = TokenLet
212 | TokenIn
213 | TokenInt Int
214 | TokenVar String
215 | TokenEq
216 | TokenPlus
217 | TokenMinus
218 | TokenTimes
219 | TokenDiv
220 | TokenOB
221 | TokenCB
222
223
224
225 lexer :: String -> [Token]
226 lexer [] = []
227 lexer (c:cs)
228 | isSpace c = lexer cs
229 | isAlpha c = lexVar (c:cs)
230 | isDigit c = lexNum (c:cs)
231 lexer ('=':cs) = TokenEq : lexer cs
232 lexer ('+':cs) = TokenPlus : lexer cs
233 lexer ('-':cs) = TokenMinus : lexer cs
234 lexer ('*':cs) = TokenTimes : lexer cs
235 lexer ('/':cs) = TokenDiv : lexer cs
236 lexer ('(':cs) = TokenOB : lexer cs
237 lexer (')':cs) = TokenCB : lexer cs
238
239 lexNum cs = TokenInt (read num) : lexer rest
240 where (num,rest) = span isDigit cs
241
242 lexVar cs =
243 case span isAlpha cs of
244 ("let",rest) -> TokenLet : lexer rest
245 ("in",rest) -> TokenIn : lexer rest
246 (var,rest) -> TokenVar var : lexer rest
247
248
249
250
251 runCalc :: String -> Exp
252 runCalc = calc . lexer
253
254
255
256 main = case runCalc "1 + 2 + 3" of {
257 (Exp1 (Plus (Plus (Term (Factor (Int 1))) (Factor (Int 2))) (Factor (Int 3)))) ->
258 case runCalc "1 * 2 + 3" of {
259 (Exp1 (Plus (Term (Times (Factor (Int 1)) (Int 2))) (Factor (Int 3)))) ->
260 case runCalc "1 + 2 * 3" of {
261 (Exp1 (Plus (Term (Factor (Int 1))) (Times (Factor (Int 2)) (Int 3)))) ->
262 case runCalc "let x = 2 in x * (x - 2)" of {
263 (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n";
264 _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit }
265 quit = print "Test failed\n"
266 {-# LINE 1 "GenericTemplate.hs" #-}
267 {-# LINE 1 "<built-in>" #-}
268 {-# LINE 1 "<command line>" #-}
269 {-# LINE 1 "GenericTemplate.hs" #-}
270 -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
271
272 {-# LINE 28 "GenericTemplate.hs" #-}
273
274
275 data Happy_IntList = HappyCons Int# Happy_IntList
276
277
278
279
280
281 {-# LINE 49 "GenericTemplate.hs" #-}
282
283 {-# LINE 59 "GenericTemplate.hs" #-}
284
285
286
287 happyTrace string expr = unsafePerformIO $ do
288 hPutStr stderr string
289 return expr
290
291
292
293
294 infixr 9 `HappyStk`
295 data HappyStk a = HappyStk a (HappyStk a)
296
297 -----------------------------------------------------------------------------
298 -- starting the parse
299
300 happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
301
302 -----------------------------------------------------------------------------
303 -- Accepting the parse
304
305 -- If the current token is 0#, it means we've just accepted a partial
306 -- parse (a %partial parser). We must ignore the saved token on the top of
307 -- the stack in this case.
308 happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =
309 happyReturn1 ans
310 happyAccept j tk st sts (HappyStk ans _) =
311 (happyTcHack j (happyTcHack st)) (happyReturn1 ans)
312
313 -----------------------------------------------------------------------------
314 -- Arrays only: do the next action
315
316
317
318 happyDoAction i tk st
319 = (happyTrace ("state: " ++ show (I# (st)) ++ ",\ttoken: " ++ show (I# (i)) ++ ",\taction: ")) $
320
321
322 case action of
323 0# -> (happyTrace ("fail.\n")) $
324 happyFail i tk st
325 -1# -> (happyTrace ("accept.\n")) $
326 happyAccept i tk st
327 n | (n <# (0# :: Int#)) -> (happyTrace ("reduce (rule " ++ show rule ++ ")")) $
328
329 (happyReduceArr ! rule) i tk st
330 where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
331 n -> (happyTrace ("shift, enter state " ++ show (I# (new_state)) ++ "\n")) $
332
333
334 happyShift new_state i tk st
335 where new_state = (n -# (1# :: Int#))
336 where off = indexShortOffAddr happyActOffsets st
337 off_i = (off +# i)
338 check = if (off_i >=# (0# :: Int#))
339 then (indexShortOffAddr happyCheck off_i ==# i)
340 else False
341 action | check = indexShortOffAddr happyTable off_i
342 | otherwise = indexShortOffAddr happyDefActions st
343
344 {-# LINE 127 "GenericTemplate.hs" #-}
345
346
347 indexShortOffAddr (HappyA# arr) off =
348 #if __GLASGOW_HASKELL__ > 500
349 narrow16Int# i
350 #elif __GLASGOW_HASKELL__ == 500
351 intToInt16# i
352 #else
353 (i `iShiftL#` 16#) `iShiftRA#` 16#
354 #endif
355 where
356 #if __GLASGOW_HASKELL__ >= 503
357 i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
358 #else
359 i = word2Int# ((high `shiftL#` 8#) `or#` low)
360 #endif
361 high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
362 low = int2Word# (ord# (indexCharOffAddr# arr off'))
363 off' = off *# 2#
364
365
366
367
368
369 data HappyAddr = HappyA# Addr#
370
371
372
373
374 -----------------------------------------------------------------------------
375 -- HappyState data type (not arrays)
376
377 {-# LINE 170 "GenericTemplate.hs" #-}
378
379 -----------------------------------------------------------------------------
380 -- Shifting a token
381
382 happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
383 let i = (case x of { HappyErrorToken (I# (i)) -> i }) in
384 -- trace "shifting the error token" $
385 happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
386
387 happyShift new_state i tk st sts stk =
388 happyNewToken new_state (HappyCons (st) (sts)) ((HappyTerminal (tk))`HappyStk`stk)
389
390 -- happyReduce is specialised for the common cases.
391
392 happySpecReduce_0 i fn 0# tk st sts stk
393 = happyFail 0# tk st sts stk
394 happySpecReduce_0 nt fn j tk st@((action)) sts stk
395 = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
396
397 happySpecReduce_1 i fn 0# tk st sts stk
398 = happyFail 0# tk st sts stk
399 happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
400 = let r = fn v1 in
401 happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
402
403 happySpecReduce_2 i fn 0# tk st sts stk
404 = happyFail 0# tk st sts stk
405 happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
406 = let r = fn v1 v2 in
407 happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
408
409 happySpecReduce_3 i fn 0# tk st sts stk
410 = happyFail 0# tk st sts stk
411 happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
412 = let r = fn v1 v2 v3 in
413 happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
414
415 happyReduce k i fn 0# tk st sts stk
416 = happyFail 0# tk st sts stk
417 happyReduce k nt fn j tk st sts stk
418 = case happyDrop (k -# (1# :: Int#)) sts of
419 sts1@((HappyCons (st1@(action)) (_))) ->
420 let r = fn stk in -- it doesn't hurt to always seq here...
421 happyDoSeq r (happyGoto nt j tk st1 sts1 r)
422
423 happyMonadReduce k nt fn 0# tk st sts stk
424 = happyFail 0# tk st sts stk
425 happyMonadReduce k nt fn j tk st sts stk =
426 happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
427 where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
428 drop_stk = happyDropStk k stk
429
430 happyMonad2Reduce k nt fn 0# tk st sts stk
431 = happyFail 0# tk st sts stk
432 happyMonad2Reduce k nt fn j tk st sts stk =
433 happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
434 where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
435 drop_stk = happyDropStk k stk
436
437 off = indexShortOffAddr happyGotoOffsets st1
438 off_i = (off +# nt)
439 new_state = indexShortOffAddr happyTable off_i
440
441
442
443
444 happyDrop 0# l = l
445 happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
446
447 happyDropStk 0# l = l
448 happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
449
450 -----------------------------------------------------------------------------
451 -- Moving to a new state after a reduction
452
453
454 happyGoto nt j tk st =
455 (happyTrace (", goto state " ++ show (I# (new_state)) ++ "\n")) $
456 happyDoAction j tk new_state
457 where off = indexShortOffAddr happyGotoOffsets st
458 off_i = (off +# nt)
459 new_state = indexShortOffAddr happyTable off_i
460
461
462
463
464 -----------------------------------------------------------------------------
465 -- Error recovery (0# is the error token)
466
467 -- parse error if we are in recovery and we fail again
468 happyFail 0# tk old_st _ stk =
469 -- trace "failing" $
470 happyError_ tk
471
472 {- We don't need state discarding for our restricted implementation of
473 "error". In fact, it can cause some bogus parses, so I've disabled it
474 for now --SDM
475
476 -- discard a state
477 happyFail 0# tk old_st (HappyCons ((action)) (sts))
478 (saved_tok `HappyStk` _ `HappyStk` stk) =
479 -- trace ("discarding state, depth " ++ show (length stk)) $
480 happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
481 -}
482
483 -- Enter error recovery: generate an error token,
484 -- save the old token and carry on.
485 happyFail i tk (action) sts stk =
486 -- trace "entering error recovery" $
487 happyDoAction 0# tk action sts ( (HappyErrorToken (I# (i))) `HappyStk` stk)
488
489 -- Internal happy errors:
490
491 notHappyAtAll = error "Internal Happy error\n"
492
493 -----------------------------------------------------------------------------
494 -- Hack to get the typechecker to accept our action functions
495
496
497 happyTcHack :: Int# -> a -> a
498 happyTcHack x y = y
499 {-# INLINE happyTcHack #-}
500
501
502 -----------------------------------------------------------------------------
503 -- Seq-ing. If the --strict flag is given, then Happy emits
504 -- happySeq = happyDoSeq
505 -- otherwise it emits
506 -- happySeq = happyDontSeq
507
508 happyDoSeq, happyDontSeq :: a -> b -> b
509 happyDoSeq a b = a `seq` b
510 happyDontSeq a b = b
511
512 -----------------------------------------------------------------------------
513 -- Don't inline any functions from the template. GHC has a nasty habit
514 -- of deciding to inline happyGoto everywhere, which increases the size of
515 -- the generated parser quite a bit.
516
517
518 {-# NOINLINE happyDoAction #-}
519 {-# NOINLINE happyTable #-}
520 {-# NOINLINE happyCheck #-}
521 {-# NOINLINE happyActOffsets #-}
522 {-# NOINLINE happyGotoOffsets #-}
523 {-# NOINLINE happyDefActions #-}
524
525 {-# NOINLINE happyShift #-}
526 {-# NOINLINE happySpecReduce_0 #-}
527 {-# NOINLINE happySpecReduce_1 #-}
528 {-# NOINLINE happySpecReduce_2 #-}
529 {-# NOINLINE happySpecReduce_3 #-}
530 {-# NOINLINE happyReduce #-}
531 {-# NOINLINE happyMonadReduce #-}
532 {-# NOINLINE happyGoto #-}
533 {-# NOINLINE happyFail #-}
534
535 -- end of Happy Template.