-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ #if !defined(__GLASGOW_HASKELL__) # error This code isn't being built with GHC. #endif -- Get WORDS_BIGENDIAN (if defined) #include "MachDeps.h" -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) #define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) #define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) #define PLUS(n,m) (n Happy_GHC_Exts.+# m) #define MINUS(n,m) (n Happy_GHC_Exts.-# m) #define TIMES(n,m) (n Happy_GHC_Exts.*# m) #define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) type Happy_Int = Happy_GHC_Exts.Int# data Happy_IntList = HappyCons Happy_Int Happy_IntList #define ERROR_TOK 0# #define CATCH_TOK 1# #if defined(HAPPY_COERCE) # define GET_ERROR_TOKEN(x) (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# i) -> i }) # define MK_ERROR_TOKEN(i) (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# i)) # define MK_TOKEN(x) (happyInTok (x)) #else # define GET_ERROR_TOKEN(x) (case x of { HappyErrorToken (Happy_GHC_Exts.I# i) -> i }) # define MK_ERROR_TOKEN(i) (HappyErrorToken (Happy_GHC_Exts.I# i)) # define MK_TOKEN(x) (HappyTerminal (x)) #endif #if defined(HAPPY_DEBUG) # define DEBUG_TRACE(s) (happyTrace (s)) $ happyTrace string expr = Happy_System_IO_Unsafe.unsafePerformIO $ do Happy_System_IO.hPutStr Happy_System_IO.stderr string return expr #else # define DEBUG_TRACE(s) {- nothing -} #endif infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) ----------------------------------------------------------------------------- -- starting the parse happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll ----------------------------------------------------------------------------- -- Accepting the parse -- If the current token is ERROR_TOK, it means we've just accepted a partial -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept ERROR_TOK tk st sts (_ `HappyStk` ans `HappyStk` _) = happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j (happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action happyDoAction i tk st = DEBUG_TRACE("state: " ++ show (Happy_GHC_Exts.I# st) ++ ",\ttoken: " ++ show (Happy_GHC_Exts.I# i) ++ ",\taction: ") case happyDecodeAction (happyNextAction i st) of HappyFail -> DEBUG_TRACE("failing.\n") happyFail i tk st HappyAccept -> DEBUG_TRACE("accept.\n") happyAccept i tk st HappyReduce rule -> DEBUG_TRACE("reduce (rule " ++ show (Happy_GHC_Exts.I# rule) ++ ")") (happyReduceArr Happy_Data_Array.! (Happy_GHC_Exts.I# rule)) i tk st HappyShift new_state -> DEBUG_TRACE("shift, enter state " ++ show (Happy_GHC_Exts.I# new_state) ++ "\n") happyShift new_state i tk st {-# INLINE happyNextAction #-} happyNextAction i st = case happyIndexActionTable i st of Just (Happy_GHC_Exts.I# act) -> act Nothing -> happyIndexOffAddr happyDefActions st {-# INLINE happyIndexActionTable #-} happyIndexActionTable i st | GTE(i, 0#), GTE(off, 0#), EQ(happyIndexOffAddr happyCheck off, i) -- i >= 0: Guard against INVALID_TOK (do the default action, which ultimately errors) -- off >= 0: Otherwise it's a default action -- equality check: Ensure that the entry in the compressed array is owned by st = Prelude.Just (Happy_GHC_Exts.I# (happyIndexOffAddr happyTable off)) | otherwise = Prelude.Nothing where off = PLUS(happyIndexOffAddr happyActOffsets st, i) data HappyAction = HappyFail | HappyAccept | HappyReduce Happy_Int -- rule number | HappyShift Happy_Int -- new state deriving Show {-# INLINE happyDecodeAction #-} happyDecodeAction :: Happy_Int -> HappyAction happyDecodeAction 0# = HappyFail happyDecodeAction -1# = HappyAccept happyDecodeAction action | LT(action, 0#) = HappyReduce NEGATE(PLUS(action, 1#)) | otherwise = HappyShift MINUS(action, 1#) {-# INLINE happyIndexGotoTable #-} happyIndexGotoTable nt st = happyIndexOffAddr happyTable off where off = PLUS(happyIndexOffAddr happyGotoOffsets st, nt) {-# INLINE happyIndexOffAddr #-} happyIndexOffAddr :: HappyAddr -> Happy_Int -> Happy_Int happyIndexOffAddr (HappyA# arr) off = #if __GLASGOW_HASKELL__ >= 901 Happy_GHC_Exts.int32ToInt# -- qualified import because it doesn't exist on older GHC's #endif #ifdef WORDS_BIGENDIAN -- The CI of `alex` tests this code path (Happy_GHC_Exts.word32ToInt32# (Happy_GHC_Exts.wordToWord32# (Happy_GHC_Exts.byteSwap32# (Happy_GHC_Exts.word32ToWord# (Happy_GHC_Exts.int32ToWord32# #endif (Happy_GHC_Exts.indexInt32OffAddr# arr off) #ifdef WORDS_BIGENDIAN ))))) #endif happyIndexRuleArr :: Happy_Int -> (# Happy_Int, Happy_Int #) happyIndexRuleArr r = (# nt, len #) where !(Happy_GHC_Exts.I# n_starts) = happy_n_starts offs = TIMES(MINUS(r,n_starts),2#) nt = happyIndexOffAddr happyRuleArr offs len = happyIndexOffAddr happyRuleArr PLUS(offs,1#) data HappyAddr = HappyA# Happy_GHC_Exts.Addr# ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state ERROR_TOK tk st sts stk@(x `HappyStk` _) = -- See "Error Fixup" below let i = GET_ERROR_TOKEN(x) in DEBUG_TRACE("shifting the error token") happyDoAction i tk new_state (HappyCons st sts) stk happyShift new_state i tk st sts stk = happyNewToken new_state (HappyCons st sts) (MK_TOKEN(tk) `HappyStk` stk) -- happyReduce is specialised for the common cases. happySpecReduce_0 nt fn j tk st sts stk = happySeq fn (happyGoto nt j tk st (HappyCons st sts) (fn `HappyStk` stk)) happySpecReduce_1 nt fn j tk old_st sts@(HappyCons st _) (v1 `HappyStk` stk') = let r = fn v1 in happyTcHack old_st (happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))) happySpecReduce_2 nt fn j tk old_st (HappyCons _ sts@(HappyCons st _)) (v1 `HappyStk` v2 `HappyStk` stk') = let r = fn v1 v2 in happyTcHack old_st (happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))) happySpecReduce_3 nt fn j tk old_st (HappyCons _ (HappyCons _ sts@(HappyCons st _))) (v1 `HappyStk` v2 `HappyStk` v3 `HappyStk` stk') = let r = fn v1 v2 v3 in happyTcHack old_st (happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))) happyReduce k nt fn j tk st sts stk = case happyDrop MINUS(k,(1# :: Happy_Int)) sts of sts1@(HappyCons st1 _) -> let r = fn stk in -- it doesn't hurt to always seq here... st `happyTcHack` happyDoSeq r (happyGoto nt j tk st1 sts1 r) happyMonadReduce k nt fn j tk st sts stk = case happyDrop k (HappyCons st sts) of sts1@(HappyCons st1 _) -> let drop_stk = happyDropStk k stk in j `happyTcHack` happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) happyMonad2Reduce k nt fn j tk st sts stk = case happyDrop k (HappyCons st sts) of sts1@(HappyCons st1 _) -> let drop_stk = happyDropStk k stk off = happyIndexOffAddr happyGotoOffsets st1 off_i = PLUS(off, nt) new_state = happyIndexOffAddr happyTable off_i in j `happyTcHack` happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) happyDrop 0# l = l happyDrop n (HappyCons _ t) = happyDrop MINUS(n,(1# :: Happy_Int)) t happyDropStk 0# l = l happyDropStk n (x `HappyStk` xs) = happyDropStk MINUS(n,(1#::Happy_Int)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction happyGoto nt j tk st = DEBUG_TRACE(", goto state " ++ show (Happy_GHC_Exts.I# new_state) ++ "\n") happyDoAction j tk new_state where new_state = happyIndexGotoTable nt st {- Note [Error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~ When there is no applicable action for the current lookahead token `tk`, happy enters error recovery mode. Depending on whether the grammar file declares the two action form `%error { abort } { report }` for Resumptive Error Handling, it works in one (not resumptive) or two phases (resumptive): 1. Fixup mode: Try to see if there is an action for the error token ERROR_TOK. If there is, do *not* emit an error and pretend instead that an `error` token was inserted. When there is no ERROR_TOK action, report an error. In non-resumptive error handling, calling the single error handler (e.g. `happyError`) will throw an exception and abort the parser. However, in resumptive error handling we enter *error resumption mode*. 2. Error resumption mode: After reporting the error (with `report`), happy will attempt to find a good state stack to resume parsing in. For each candidate stack, it discards input until one of the candidates resumes (i.e. shifts the current input). If no candidate resumes before the end of input, resumption failed and calls the `abort` function, to much the same effect as in non-resumptive error handling. Candidate stacks are declared by the grammar author using the special `catch` terminal and called "catch frames". This mechanism is described in detail in Note [happyResume]. The `catch` resumption mechanism (2) is what usually is associated with `error` in `bison` or `menhir`. Since `error` is used for the Fixup mechanism (1) above, we call the corresponding token `catch`. Furthermore, in constrast to `bison`, our implementation of `catch` non-deterministically considers multiple catch frames on the stack for resumption (See Note [Multiple catch frames]). Note [happyResume] ~~~~~~~~~~~~~~~~~~ `happyResume` implements the resumption mechanism from Note [Error recovery]. It is best understood by example. Consider Exp :: { String } Exp : '1' { "1" } | catch { "catch" } | Exp '+' Exp %shift { $1 ++ " + " ++ $3 } -- %shift: associate 1 + 1 + 1 to the right | '(' Exp ')' { "(" ++ $2 ++ ")" } The idea of the use of `catch` here is that upon encountering a parse error during expression parsing, we can gracefully degrade using the `catch` rule, still producing a partial syntax tree and keep on parsing to find further syntax errors. Let's trace the parser state for input 11+1, which will error out after shifting 1. After shifting, we have the following item stack (growing downwards and omitting transitive closure items): State 0: %start_parseExp -> . Exp State 5: Exp -> '1' . (Stack as a list of state numbers: [5,0].) As Note [Error recovery] describes, we will first try Fixup mode. That fails because no production can shift the `error` token. Next we try Error resumption mode. This works as follows: 1. Pop off the item stack until we find an item that can shift the `catch` token. (Implemented in `pop_items`.) * State 5 cannot shift catch. Pop. * State 0 can shift catch, which would transition into State 4: Exp -> catch . So record the *stack* `[4,0]` after doing the shift transition. We call this a *catch frame*, where the top is a *catch state*, corresponding to an item in which we just shifted a `catch` token. There can be multiple such catch stacks, see Note [Multiple catch frames]. 2. Discard tokens from the input until the lookahead can be shifted in one of the catch stacks. (Implemented in `discard_input_until_exp` and `some_catch_state_shifts`.) * We cannot shift the current lookahead '1' in state 4, so we discard * We *can* shift the next lookahead '+' in state 4, but only after reducing, which pops State 4 and goes to State 3: State 3: %start_parseExp -> Exp . Exp -> Exp . '+' Exp Here we can shift '+'. As you can see, to implement this machinery we need to simulate the operation of the LALR automaton, especially reduction (`happySimulateReduce`). Note [Multiple catch frames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For fewer spurious error messages, it can be beneficial to trace multiple catch items. Consider Exp : '1' | catch | Exp '+' Exp %shift | '(' Exp ')' Let's trace the parser state for input (;+1, which will error out after shifting (. After shifting, we have the following item stack (growing downwards): State 0: %start_parseExp -> . Exp State 6: Exp -> '(' . Exp ')' Upon error, we want to find items in the stack which can shift a catch token. Note that both State 0 and State 6 can shift a catch token, transitioning into State 4: Exp -> catch . Hence we record the catch frames `[4,6,0]` and `[4,0]` for possible resumption. Which catch frame do we pick for resumption? Note that resuming catch frame `[4,0]` will parse as "catch+1", whereas resuming the innermost frame `[4,6,0]` corresponds to parsing "(catch+1". The latter would keep discarding input until the closing ')' is found. So we will discard + and 1, leading to a spurious syntax error at the end of input, aborting the parse and never producing a partial syntax tree. Bad! It is far preferable to resume with catch frame `[4,0]`, where we can resume successfully on input +, so that is what we do. In general, we pick the catch frame for resumption that discards the least amount of input for a successful shift, preferring the topmost such catch frame. -} -- happyFail :: Happy_Int -> _ -> Happy_Int -> _ -- This function triggers Note [Error recovery]. -- If the current token is ERROR_TOK, phase (1) has failed and we might try -- phase (2). happyFail ERROR_TOK = happyFixupFailed happyFail i = happyTryFixup i -- Enter Error Fixup (see Note [Error recovery]): -- generate an error token, save the old token and carry on. -- When a `happyShift` accepts the error token, we will pop off the error token -- to resume parsing with the current lookahead `i`. happyTryFixup i tk action sts stk = DEBUG_TRACE("entering `error` fixup.\n") happyDoAction ERROR_TOK tk action sts (MK_ERROR_TOKEN(i) `HappyStk` stk) -- NB: `happyShift` will simply pop the error token and carry on with -- `tk`. Hence we don't change `tk` in the call here -- See Note [Error recovery], phase (2). -- Enter resumption mode after reporting the error by calling `happyResume`. happyFixupFailed tk st sts (x `HappyStk` stk) = let i = GET_ERROR_TOKEN(x) in DEBUG_TRACE("`error` fixup failed.\n") let resume = happyResume i tk st sts stk expected = happyExpectedTokens st sts in happyReport i tk expected resume -- happyResume :: Happy_Int -> _ -> Happy_Int -> _ -- See Note [happyResume] happyResume i tk st sts stk = pop_items [] st sts stk where !(Happy_GHC_Exts.I# n_starts) = happy_n_starts -- this is to test whether we have a start token !(Happy_GHC_Exts.I# eof_i) = happy_n_terms - 1 -- this is the token number of the EOF token happy_list_to_list :: Happy_IntList -> [Int] happy_list_to_list (HappyCons st sts) | LT(st, n_starts) = [(Happy_GHC_Exts.I# st)] | otherwise = (Happy_GHC_Exts.I# st) : happy_list_to_list sts -- See (1) of Note [happyResume] pop_items catch_frames st sts stk | LT(st, n_starts) = DEBUG_TRACE("reached start state " ++ show (Happy_GHC_Exts.I# st) ++ ", ") if null catch_frames_new then DEBUG_TRACE("no resumption.\n") happyAbort else DEBUG_TRACE("now discard input, trying to anchor in states (reverse " ++ show (map (happy_list_to_list . fst) catch_frames_new) ++ ").\n") discard_input_until_exp i tk (reverse catch_frames_new) | (HappyCons st1 sts1) <- sts, _ `HappyStk` stk1 <- stk = pop_items catch_frames_new st1 sts1 stk1 where !catch_frames_new | HappyShift new_state <- happyDecodeAction (happyNextAction CATCH_TOK st) , DEBUG_TRACE("can shift catch token in state " ++ show (Happy_GHC_Exts.I# st) ++ ", into state " ++ show (Happy_GHC_Exts.I# new_state) ++ "\n") null (filter (\(HappyCons _ (HappyCons h _),_) -> EQ(st,h)) catch_frames) = (HappyCons new_state (HappyCons st sts), MK_ERROR_TOKEN(i) `HappyStk` stk):catch_frames -- MK_ERROR_TOKEN(i) is just some dummy that should not be accessed by user code | otherwise = DEBUG_TRACE("already shifted or can't shift catch in " ++ show (Happy_GHC_Exts.I# st) ++ "\n") catch_frames -- See (2) of Note [happyResume] discard_input_until_exp i tk catch_frames | Just (HappyCons st (HappyCons catch_st sts), catch_frame) <- some_catch_state_shifts i catch_frames = DEBUG_TRACE("found expected token in state " ++ show (Happy_GHC_Exts.I# st) ++ " after shifting from " ++ show (Happy_GHC_Exts.I# catch_st) ++ ": " ++ show (Happy_GHC_Exts.I# i) ++ "\n") happyDoAction i tk st (HappyCons catch_st sts) catch_frame | EQ(i,eof_i) -- is i EOF? = DEBUG_TRACE("reached EOF, cannot resume. abort parse :(\n") happyAbort | otherwise = DEBUG_TRACE("discard token " ++ show (Happy_GHC_Exts.I# i) ++ "\n") happyLex (\eof_tk -> discard_input_until_exp eof_i eof_tk catch_frames) -- eof (\i tk -> discard_input_until_exp i tk catch_frames) -- not eof some_catch_state_shifts _ [] = DEBUG_TRACE("no catch state could shift.\n") Nothing some_catch_state_shifts i catch_frames@(((HappyCons st sts),_):_) = try_head i st sts catch_frames where try_head i st sts catch_frames = -- PRECONDITION: head catch_frames = (HappyCons st sts) DEBUG_TRACE("trying token " ++ show (Happy_GHC_Exts.I# i) ++ " in state " ++ show (Happy_GHC_Exts.I# st) ++ ": ") case happyDecodeAction (happyNextAction i st) of HappyFail -> DEBUG_TRACE("fail.\n") some_catch_state_shifts i (tail catch_frames) HappyAccept -> DEBUG_TRACE("accept.\n") Just (head catch_frames) HappyShift _ -> DEBUG_TRACE("shift.\n") Just (head catch_frames) HappyReduce r -> case happySimulateReduce r st sts of (HappyCons st1 sts1) -> try_head i st1 sts1 catch_frames happySimulateReduce r st sts = DEBUG_TRACE("simulate reduction of rule " ++ show (Happy_GHC_Exts.I# r) ++ ", ") let (# nt, len #) = happyIndexRuleArr r in DEBUG_TRACE("nt " ++ show (Happy_GHC_Exts.I# nt) ++ ", len: " ++ show (Happy_GHC_Exts.I# len) ++ ", new_st ") let !(sts1@(HappyCons st1 _)) = happyDrop len (HappyCons st sts) new_st = happyIndexGotoTable nt st1 in DEBUG_TRACE(show (Happy_GHC_Exts.I# new_st) ++ ".\n") (HappyCons new_st sts1) happyTokenToString :: Prelude.Int -> Prelude.String happyTokenToString i = happyTokenStrings Prelude.!! (i Prelude.- 2) -- 2: errorTok, catchTok happyExpectedTokens :: Happy_Int -> Happy_IntList -> [Prelude.String] -- Upon a parse error, we want to suggest tokens that are expected in that -- situation. This function computes such tokens. -- It works by examining the top of the state stack. -- For every token number that does a shift transition, record that token number. -- For every token number that does a reduce transition, simulate that reduction -- on the state state stack and repeat. -- The recorded token numbers are then formatted with 'happyTokenToString' and -- returned. happyExpectedTokens st sts = DEBUG_TRACE("constructing expected tokens.\n") map happyTokenToString $ search_shifts st sts [] where search_shifts st sts shifts = foldr (add_action st sts) shifts (distinct_actions st) add_action st sts (Happy_GHC_Exts.I# i, Happy_GHC_Exts.I# act) shifts = DEBUG_TRACE("found action in state " ++ show (Happy_GHC_Exts.I# st) ++ ", input " ++ show (Happy_GHC_Exts.I# i) ++ ", " ++ show (happyDecodeAction act) ++ "\n") case happyDecodeAction act of HappyFail -> shifts HappyAccept -> shifts -- This would always be %eof or error... Not helpful HappyShift _ -> Happy_Data_List.insert (Happy_GHC_Exts.I# i) shifts HappyReduce r -> case happySimulateReduce r st sts of (HappyCons st1 sts1) -> search_shifts st1 sts1 shifts distinct_actions st -- The (token number, action) pairs of all actions in the given state = ((-1), (Happy_GHC_Exts.I# (happyIndexOffAddr happyDefActions st))) : [ (i, act) | i <- [begin_i..happy_n_terms], act <- get_act row_off i ] where row_off = happyIndexOffAddr happyActOffsets st begin_i = 2 -- +2: errorTok,catchTok get_act off (Happy_GHC_Exts.I# i) -- happyIndexActionTable with cached row offset | let off_i = PLUS(off,i) , GTE(off_i,0#) , EQ(happyIndexOffAddr happyCheck off_i,i) = [(Happy_GHC_Exts.I# (happyIndexOffAddr happyTable off_i))] | otherwise = [] -- Internal happy errors: notHappyAtAll :: a notHappyAtAll = Prelude.error "Internal Happy parser panic. This is not supposed to happen! Please open a bug report at https://github.com/haskell/happy/issues.\n" ----------------------------------------------------------------------------- -- Hack to get the typechecker to accept our action functions happyTcHack :: Happy_Int -> a -> a happyTcHack x y = y {-# INLINE happyTcHack #-} ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits -- happySeq = happyDoSeq -- otherwise it emits -- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq a b = a `Prelude.seq` b happyDontSeq a b = b ----------------------------------------------------------------------------- -- Don't inline any functions from the template. GHC has a nasty habit -- of deciding to inline happyGoto everywhere, which increases the size of -- the generated parser quite a bit. {-# NOINLINE happyDoAction #-} {-# NOINLINE happyTable #-} {-# NOINLINE happyCheck #-} {-# NOINLINE happyActOffsets #-} {-# NOINLINE happyGotoOffsets #-} {-# NOINLINE happyDefActions #-} {-# NOINLINE happyShift #-} {-# NOINLINE happySpecReduce_0 #-} {-# NOINLINE happySpecReduce_1 #-} {-# NOINLINE happySpecReduce_2 #-} {-# NOINLINE happySpecReduce_3 #-} {-# NOINLINE happyReduce #-} {-# NOINLINE happyMonadReduce #-} {-# NOINLINE happyGoto #-} {-# NOINLINE happyFail #-} -- end of Happy Template.