1{-# LINE 1 "templates/GenericTemplate.hs" #-}
2-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45data Happy_IntList = HappyCons Int Happy_IntList
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79happyTrace string expr = Happy_System_IO_Unsafe.unsafePerformIO $ do
80    Happy_System_IO.hPutStr Happy_System_IO.stderr string
81    return expr
82
83
84
85
86infixr 9 `HappyStk`
87data HappyStk a = HappyStk a (HappyStk a)
88
89-----------------------------------------------------------------------------
90-- starting the parse
91
92happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
93
94-----------------------------------------------------------------------------
95-- Accepting the parse
96
97-- If the current token is ERROR_TOK, it means we've just accepted a partial
98-- parse (a %partial parser).  We must ignore the saved token on the top of
99-- the stack in this case.
100happyAccept (0) tk st sts (_ `HappyStk` ans `HappyStk` _) =
101        happyReturn1 ans
102happyAccept j tk st sts (HappyStk ans _) =
103         (happyReturn1 ans)
104
105-----------------------------------------------------------------------------
106-- Arrays only: do the next action
107
108
109
110happyDoAction i tk st
111        = (happyTrace ("state: " ++ show (st) ++
112                      ",\ttoken: " ++ show (i) ++
113                      ",\taction: ")) $
114          case action of
115                (0)           -> (happyTrace ("fail.\n")) $
116                                     happyFail (happyExpListPerState ((st) :: Int)) i tk st
117                (-1)          -> (happyTrace ("accept.\n")) $
118                                     happyAccept i tk st
119                n | (n < ((0) :: Int)) -> (happyTrace ("reduce (rule " ++ show rule
120                                                               ++ ")")) $
121                                                   (happyReduceArr Happy_Data_Array.! rule) i tk st
122                                                   where rule = ((negate ((n + ((1) :: Int)))))
123                n                 -> (happyTrace ("shift, enter state "
124                                                 ++ show (new_state)
125                                                 ++ "\n")) $
126                                     happyShift new_state i tk st
127                                     where new_state = (n - ((1) :: Int))
128   where off    = happyAdjustOffset (indexShortOffAddr happyActOffsets st)
129         off_i  = (off + i)
130         check  = if (off_i >= ((0) :: Int))
131                  then (indexShortOffAddr happyCheck off_i == i)
132                  else False
133         action
134          | check     = indexShortOffAddr happyTable off_i
135          | otherwise = indexShortOffAddr happyDefActions st
136
137
138
139
140
141
142
143
144
145
146
147
148indexShortOffAddr arr off = arr Happy_Data_Array.! off
149
150
151{-# INLINE happyLt #-}
152happyLt x y = (x < y)
153
154
155
156
157
158
159readArrayBit arr bit =
160    Bits.testBit (indexShortOffAddr arr (bit `div` 16)) (bit `mod` 16)
161
162
163
164
165
166
167-----------------------------------------------------------------------------
168-- HappyState data type (not arrays)
169
170
171
172
173
174
175
176
177
178
179
180
181
182-----------------------------------------------------------------------------
183-- Shifting a token
184
185happyShift new_state (0) tk st sts stk@(x `HappyStk` _) =
186     let i = (case x of { HappyErrorToken (i) -> i }) in
187--     trace "shifting the error token" $
188     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
189
190happyShift new_state i tk st sts stk =
191     happyNewToken new_state (HappyCons (st) (sts)) ((HappyTerminal (tk))`HappyStk`stk)
192
193-- happyReduce is specialised for the common cases.
194
195happySpecReduce_0 i fn (0) tk st sts stk
196     = happyFail [] (0) tk st sts stk
197happySpecReduce_0 nt fn j tk st@((action)) sts stk
198     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
199
200happySpecReduce_1 i fn (0) tk st sts stk
201     = happyFail [] (0) tk st sts stk
202happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
203     = let r = fn v1 in
204       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
205
206happySpecReduce_2 i fn (0) tk st sts stk
207     = happyFail [] (0) tk st sts stk
208happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
209     = let r = fn v1 v2 in
210       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
211
212happySpecReduce_3 i fn (0) tk st sts stk
213     = happyFail [] (0) tk st sts stk
214happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
215     = let r = fn v1 v2 v3 in
216       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
217
218happyReduce k i fn (0) tk st sts stk
219     = happyFail [] (0) tk st sts stk
220happyReduce k nt fn j tk st sts stk
221     = case happyDrop (k - ((1) :: Int)) sts of
222         sts1@((HappyCons (st1@(action)) (_))) ->
223                let r = fn stk in  -- it doesn't hurt to always seq here...
224                happyDoSeq r (happyGoto nt j tk st1 sts1 r)
225
226happyMonadReduce k nt fn (0) tk st sts stk
227     = happyFail [] (0) tk st sts stk
228happyMonadReduce k nt fn j tk st sts stk =
229      case happyDrop k (HappyCons (st) (sts)) of
230        sts1@((HappyCons (st1@(action)) (_))) ->
231          let drop_stk = happyDropStk k stk in
232          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
233
234happyMonad2Reduce k nt fn (0) tk st sts stk
235     = happyFail [] (0) tk st sts stk
236happyMonad2Reduce k nt fn j tk st sts stk =
237      case happyDrop k (HappyCons (st) (sts)) of
238        sts1@((HappyCons (st1@(action)) (_))) ->
239         let drop_stk = happyDropStk k stk
240
241             off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1)
242             off_i = (off + nt)
243             new_state = indexShortOffAddr happyTable off_i
244
245
246
247
248          in
249          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
250
251happyDrop (0) l = l
252happyDrop n (HappyCons (_) (t)) = happyDrop (n - ((1) :: Int)) t
253
254happyDropStk (0) l = l
255happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs
256
257-----------------------------------------------------------------------------
258-- Moving to a new state after a reduction
259
260
261happyGoto nt j tk st =
262   (happyTrace (", goto state " ++ show (new_state) ++ "\n")) $
263   happyDoAction j tk new_state
264   where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st)
265         off_i = (off + nt)
266         new_state = indexShortOffAddr happyTable off_i
267
268
269
270
271-----------------------------------------------------------------------------
272-- Error recovery (ERROR_TOK is the error token)
273
274-- parse error if we are in recovery and we fail again
275happyFail explist (0) tk old_st _ stk@(x `HappyStk` _) =
276     let i = (case x of { HappyErrorToken (i) -> i }) in
277--      trace "failing" $
278        happyError_ explist i tk
279
280{-  We don't need state discarding for our restricted implementation of
281    "error".  In fact, it can cause some bogus parses, so I've disabled it
282    for now --SDM
283
284-- discard a state
285happyFail  ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts)
286                                                (saved_tok `HappyStk` _ `HappyStk` stk) =
287--      trace ("discarding state, depth " ++ show (length stk))  $
288        DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk))
289-}
290
291-- Enter error recovery: generate an error token,
292--                       save the old token and carry on.
293happyFail explist i tk (action) sts stk =
294--      trace "entering error recovery" $
295        happyDoAction (0) tk action sts ((HappyErrorToken (i)) `HappyStk` stk)
296
297-- Internal happy errors:
298
299notHappyAtAll :: a
300notHappyAtAll = error "Internal Happy error\n"
301
302-----------------------------------------------------------------------------
303-- Hack to get the typechecker to accept our action functions
304
305
306
307
308
309
310
311-----------------------------------------------------------------------------
312-- Seq-ing.  If the --strict flag is given, then Happy emits
313--      happySeq = happyDoSeq
314-- otherwise it emits
315--      happySeq = happyDontSeq
316
317happyDoSeq, happyDontSeq :: a -> b -> b
318happyDoSeq   a b = a `seq` b
319happyDontSeq a b = b
320
321-----------------------------------------------------------------------------
322-- Don't inline any functions from the template.  GHC has a nasty habit
323-- of deciding to inline happyGoto everywhere, which increases the size of
324-- the generated parser quite a bit.
325
326
327{-# NOINLINE happyDoAction #-}
328{-# NOINLINE happyTable #-}
329{-# NOINLINE happyCheck #-}
330{-# NOINLINE happyActOffsets #-}
331{-# NOINLINE happyGotoOffsets #-}
332{-# NOINLINE happyDefActions #-}
333
334{-# NOINLINE happyShift #-}
335{-# NOINLINE happySpecReduce_0 #-}
336{-# NOINLINE happySpecReduce_1 #-}
337{-# NOINLINE happySpecReduce_2 #-}
338{-# NOINLINE happySpecReduce_3 #-}
339{-# NOINLINE happyReduce #-}
340{-# NOINLINE happyMonadReduce #-}
341{-# NOINLINE happyGoto #-}
342{-# NOINLINE happyFail #-}
343
344-- end of Happy Template.
345