`_ <- mapM` --> `mapM_`
[ghc.git] / testsuite / tests / ghci.debugger / HappyTest.hs
1 {-# LANGUAGE CPP, MagicHash, BangPatterns #-}
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 | isTrue# (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 isTrue# (off_i >=# (0# :: Int#))
339 then isTrue# (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 narrow16Int# i
349 where
350 i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
351 high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
352 low = int2Word# (ord# (indexCharOffAddr# arr off'))
353 off' = off *# 2#
354
355
356
357
358
359 data HappyAddr = HappyA# Addr#
360
361
362
363
364 -----------------------------------------------------------------------------
365 -- HappyState data type (not arrays)
366
367 {-# LINE 170 "GenericTemplate.hs" #-}
368
369 -----------------------------------------------------------------------------
370 -- Shifting a token
371
372 happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
373 let i = (case x of { HappyErrorToken (I# (i)) -> i }) in
374 -- trace "shifting the error token" $
375 happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
376
377 happyShift new_state i tk st sts stk =
378 happyNewToken new_state (HappyCons (st) (sts)) ((HappyTerminal (tk))`HappyStk`stk)
379
380 -- happyReduce is specialised for the common cases.
381
382 happySpecReduce_0 i fn 0# tk st sts stk
383 = happyFail 0# tk st sts stk
384 happySpecReduce_0 nt fn j tk st@((action)) sts stk
385 = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
386
387 happySpecReduce_1 i fn 0# tk st sts stk
388 = happyFail 0# tk st sts stk
389 happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
390 = let r = fn v1 in
391 happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
392
393 happySpecReduce_2 i fn 0# tk st sts stk
394 = happyFail 0# tk st sts stk
395 happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
396 = let r = fn v1 v2 in
397 happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
398
399 happySpecReduce_3 i fn 0# tk st sts stk
400 = happyFail 0# tk st sts stk
401 happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
402 = let r = fn v1 v2 v3 in
403 happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
404
405 happyReduce k i fn 0# tk st sts stk
406 = happyFail 0# tk st sts stk
407 happyReduce k nt fn j tk st sts stk
408 = case happyDrop (k -# (1# :: Int#)) sts of
409 !sts1@((HappyCons (st1@(action)) (_))) ->
410 let r = fn stk in -- it doesn't hurt to always seq here...
411 happyDoSeq r (happyGoto nt j tk st1 sts1 r)
412
413 happyMonadReduce k nt fn 0# tk st sts stk
414 = happyFail 0# tk st sts stk
415 happyMonadReduce k nt fn j tk st sts stk =
416 happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
417 where !sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
418 drop_stk = happyDropStk k stk
419
420 happyMonad2Reduce k nt fn 0# tk st sts stk
421 = happyFail 0# tk st sts stk
422 happyMonad2Reduce k nt fn j tk st sts stk =
423 happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
424 where !sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
425 drop_stk = happyDropStk k stk
426
427 off = indexShortOffAddr happyGotoOffsets st1
428 off_i = (off +# nt)
429 new_state = indexShortOffAddr happyTable off_i
430
431
432
433
434 happyDrop 0# l = l
435 happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
436
437 happyDropStk 0# l = l
438 happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
439
440 -----------------------------------------------------------------------------
441 -- Moving to a new state after a reduction
442
443
444 happyGoto nt j tk st =
445 (happyTrace (", goto state " ++ show (I# (new_state)) ++ "\n")) $
446 happyDoAction j tk new_state
447 where off = indexShortOffAddr happyGotoOffsets st
448 off_i = (off +# nt)
449 new_state = indexShortOffAddr happyTable off_i
450
451
452
453
454 -----------------------------------------------------------------------------
455 -- Error recovery (0# is the error token)
456
457 -- parse error if we are in recovery and we fail again
458 happyFail 0# tk old_st _ stk =
459 -- trace "failing" $
460 happyError_ tk
461
462 {- We don't need state discarding for our restricted implementation of
463 "error". In fact, it can cause some bogus parses, so I've disabled it
464 for now --SDM
465
466 -- discard a state
467 happyFail 0# tk old_st (HappyCons ((action)) (sts))
468 (saved_tok `HappyStk` _ `HappyStk` stk) =
469 -- trace ("discarding state, depth " ++ show (length stk)) $
470 happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
471 -}
472
473 -- Enter error recovery: generate an error token,
474 -- save the old token and carry on.
475 happyFail i tk (action) sts stk =
476 -- trace "entering error recovery" $
477 happyDoAction 0# tk action sts ( (HappyErrorToken (I# (i))) `HappyStk` stk)
478
479 -- Internal happy errors:
480
481 notHappyAtAll = error "Internal Happy error\n"
482
483 -----------------------------------------------------------------------------
484 -- Hack to get the typechecker to accept our action functions
485
486
487 happyTcHack :: Int# -> a -> a
488 happyTcHack x y = y
489 {-# INLINE happyTcHack #-}
490
491
492 -----------------------------------------------------------------------------
493 -- Seq-ing. If the --strict flag is given, then Happy emits
494 -- happySeq = happyDoSeq
495 -- otherwise it emits
496 -- happySeq = happyDontSeq
497
498 happyDoSeq, happyDontSeq :: a -> b -> b
499 happyDoSeq a b = a `seq` b
500 happyDontSeq a b = b
501
502 -----------------------------------------------------------------------------
503 -- Don't inline any functions from the template. GHC has a nasty habit
504 -- of deciding to inline happyGoto everywhere, which increases the size of
505 -- the generated parser quite a bit.
506
507
508 {-# NOINLINE happyDoAction #-}
509 {-# NOINLINE happyTable #-}
510 {-# NOINLINE happyCheck #-}
511 {-# NOINLINE happyActOffsets #-}
512 {-# NOINLINE happyGotoOffsets #-}
513 {-# NOINLINE happyDefActions #-}
514
515 {-# NOINLINE happyShift #-}
516 {-# NOINLINE happySpecReduce_0 #-}
517 {-# NOINLINE happySpecReduce_1 #-}
518 {-# NOINLINE happySpecReduce_2 #-}
519 {-# NOINLINE happySpecReduce_3 #-}
520 {-# NOINLINE happyReduce #-}
521 {-# NOINLINE happyMonadReduce #-}
522 {-# NOINLINE happyGoto #-}
523 {-# NOINLINE happyFail #-}
524
525 -- end of Happy Template.