Introduce catchTok and modify several definitions

packages/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs

@@ -94,7 +94,7 @@ the driver and data strs (large template).
 > -> CommonOptions -- Happy.CodeGen.Common.Options
 > -> (String -- data
 > ,String) -- parser
->
+
 > produceGLRParser (base, lib) basename tables start header trailer (debug,options) g common_options
 > = ( content base $ ""
 > , lib_content lib
@@ -103,7 +103,7 @@ the driver and data strs (large template).
 > (imps, lang_exts) = case ghcExts_opt of
 > UseGhcExts is os -> (is, os)
 > _ -> ("", [])
->
+
 > defines = concat
 > [ [ "HAPPY_DEBUG" | debug ]
 > , [ "HAPPY_GHC" | UseGhcExts _ _ <- return ghcExts_opt ]
@@ -251,7 +251,7 @@ Formats the tables as code.
 > -> GhcExts -- Use unboxed values?
 > -> Grammar -- Happy Grammar
 > -> ShowS
->
+
 > mkTbls (action,goto) sem_info exts g
 > = let gsMap = mkGSymMap g
 > semfn_map = mk_semfn_map sem_info
@@ -303,10 +303,12 @@ It also shares identical reduction values as CAFs
 > errorLine = name ++ " _ _ = Error"
 > mkState (i,arr)
 > = filter (/="") $ map (mkLine i) (assocs arr)
->
+
 > mkLine state (symInt,action)
 > | symInt == errorTok -- skip error productions
 > = "" -- NB see ProduceCode's handling of these
+> | symInt == catchTok -- skip error productions
+> = "" -- NB see ProduceCode's handling of these
 > | otherwise
 > = case action of
 > LR'Fail -> ""
@@ -356,10 +358,10 @@ Do the same with the Happy goto table.
 > name = "goto"
 > errorLine = "goto _ _ = " ++ show_st exts (negate 1)
 > mkLines = map mkState (assocs goTbl)
->
+
 > mkState (i,arr)
 > = unlines $ filter (/="") $ map (mkLine i) (assocs arr)
->
+
 > mkLine state (ntInt,goto)
 > = case goto of
 > NoGoto -> ""

packages/backend-lalr/data/HappyTemplate.hs

@@ -23,6 +23,7 @@ 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 })
@@ -71,7 +72,7 @@ happyDoAction i tk st =
  ",\taction: ")
  case happyDecodeAction (happyNextAction i st) of
  HappyFail -> DEBUG_TRACE("failing.\n")
- happyFail (happyExpListPerState (Happy_GHC_Exts.I# st)) i tk st
+ 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) ++ ")")
@@ -132,6 +133,13 @@ happyIndexOffAddr (HappyA# arr) off =
  (Happy_GHC_Exts.indexInt32OffAddr# arr off)
 #endif
 
+indexRuleArr arr r = (Happy_GHC_Exts.I# nt, Happy_GHC_Exts.I# len)
+ where
+ (Happy_GHC_Exts.I# n_starts) = happy_n_starts
+ offs = TIMES(MINUS(r,n_starts),2#)
+ nt = happyIndexOffAddr arr offs
+ len = happyIndexOffAddr arr PLUS(offs,1#)
+
 {-# INLINE happyLt #-}
 happyLt x y = LT(x,y)
 
@@ -146,67 +154,56 @@ data HappyAddr = HappyA# Happy_GHC_Exts.Addr#
 
 happyShift new_state ERROR_TOK tk st sts stk@(x `HappyStk` _) =
  let i = GET_ERROR_TOKEN(x) in
--- trace "shifting the error token" $
+ DEBUG_TRACE("shifting the error token")
  happyDoAction i tk new_state (HappyCons st sts) stk
+-- TODO: When `i` would enter error recovery again, we should instead
+-- discard input until the lookahead is acceptable. Perhaps this is
+-- simplest to implement in CodeGen for productions using `error`;
+-- there we know the context and can implement local shift+discard actions.
+-- still need to remember parser-defined error site, though.
 
 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 i fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
 happySpecReduce_0 nt fn j tk st sts stk
- = happyGoto nt j tk st (HappyCons st sts) (fn `HappyStk` stk)
+ = happySeq fn (happyGoto nt j tk st (HappyCons st sts) (fn `HappyStk` stk))
 
-happySpecReduce_1 i fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
-happySpecReduce_1 nt fn j tk _ sts@(HappyCons st _) (v1 `HappyStk` stk')
+happySpecReduce_1 nt fn j tk old_st sts@(HappyCons st _) (v1 `HappyStk` stk')
  = let r = fn v1 in
- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+  happyTcHack old_st (happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')))
 
-happySpecReduce_2 i fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
-happySpecReduce_2 nt fn j tk _
+happySpecReduce_2 nt fn j tk old_st
  (HappyCons _ sts@(HappyCons st _))
  (v1 `HappyStk` v2 `HappyStk` stk')
  = let r = fn v1 v2 in
- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+  happyTcHack old_st (happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')))
 
-happySpecReduce_3 i fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
-happySpecReduce_3 nt fn j tk _
+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
- happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
+  happyTcHack old_st (happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')))
 
-happyReduce k i fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
 happyReduce k nt fn j tk st sts stk
- = case happyDrop MINUS(k,(1# :: Happy_Int)) sts of
+ = case happyDrop k (HappyCons st sts) of
  sts1@(HappyCons st1 _) ->
  let r = fn stk in -- it doesn't hurt to always seq here...
  happyDoSeq r (happyGoto nt j tk st1 sts1 r)
 
-happyMonadReduce k nt fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
 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
  happyThen1 (fn stk tk)
  (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
 
-happyMonad2Reduce k nt fn ERROR_TOK tk st sts stk
- = happyFail [] ERROR_TOK tk st sts stk
 happyMonad2Reduce k nt fn j tk st sts stk =
- case happyDrop k (HappyCons st sts) of
+ j `happyTcHack` case happyDrop k (HappyCons st sts) of
  sts1@(HappyCons st1 _) ->
  let drop_stk = happyDropStk k stk
- off = happyAdjustOffset (happyIndexOffAddr happyGotoOffsets st1)
- off_i = PLUS(off, nt)
- new_state = happyIndexOffAddr happyTable off_i
+ new_state = happyIndexGotoTable nt st1
  in
  happyThen1 (fn stk tk)
  (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))
@@ -226,30 +223,144 @@ happyGoto nt j tk st =
  where new_state = happyIndexGotoTable nt st
 
 -----------------------------------------------------------------------------
--- Error recovery (ERROR_TOK is the error token)
-
--- parse error if we are in recovery and we fail again
-happyFail explist ERROR_TOK tk old_st _ stk@(x `HappyStk` _) =
- let i = GET_ERROR_TOKEN(x) in
--- trace "failing" $
- happyError_ explist i tk
-
-{- We don't need state discarding for our restricted implementation of
- "error". In fact, it can cause some bogus parses, so I've disabled it
- for now --SDM
-
--- discard a state
-happyFail ERROR_TOK tk old_st (HappyCons action sts)
- (saved_tok `HappyStk` _ `HappyStk` stk) =
--- trace ("discarding state, depth " ++ show (length stk)) $
- happyDoAction ERROR_TOK tk action sts (saved_tok`HappyStk`stk)
--}
-
--- Enter error recovery: generate an error token,
--- save the old token and carry on.
-happyFail explist i tk action sts stk =
--- trace "entering error recovery" $
- happyDoAction ERROR_TOK tk action sts (MK_ERROR_TOKEN(i) `HappyStk` stk)
+-- Error recovery
+--
+-- When there is no applicable action for the current lookahead token `tk`,
+-- happy enters error recovery mode. It works in 2 phases:
+--
+-- 1. Fixup: Try to see if there is an action for the error token (`errorTok`,
+-- which is ERROR_TOK). If there is, do *not* emit an error and pretend
+-- instead that an `errorTok` was inserted.
+-- When there is no `errorTok` action, call the error handler
+-- (e.g., `happyError`) with the resumption continuation `happyResume`.
+-- 2. Error resumption mode: If the error handler wants to resume parsing in
+-- order to report multiple parse errors, it will call the resumption
+-- continuation (of result type `P (Maybe a)`).
+-- In the absence of the %resumptive declaration, this resumption will
+-- always (do a bit of work, and) `return Nothing`.
+-- In the presence of the %resumptive declaration, the grammar author
+-- can use the special `catch` terminal to declare where parsing should
+-- resume after an error.
+-- E.g., if `stmt : expr ';' | catch ';'` then the resumption will
+--
+-- (a) Pop off the state stack until it finds an item
+-- `stmt -> . catch ';'`.
+-- Then, it will push a `catchTok` onto the stack, perform a shift and
+-- end up in item `stmt -> catch . ';'`.
+-- (b) Discard tokens from the lexer until it finds ';'.
+-- (In general, it will discard until the lookahead has a non-default
+-- action in the matches a token that applies
+-- in the situation `P -> α catch . β`, where β might empty.)
+--
+-- 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`.
+
+-- Enter error Fixup: generate an error token,
+-- save the old token and carry on.
+-- When a `happyShift` accepts, 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
+
+-- parse error if we are in fixup and fail again
+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 = map happyTokenToString (happyExpectedTokens st sts) in
+ if happyAlreadyInResumption st sts
+ then resume
+ else happyReport i tk expected resume
+
+happyAlreadyInResumption st sts
+ | (Happy_GHC_Exts.I# n_starts) <- happy_n_starts, LT(st, n_starts)
+ = False -- end of the stack
+ | (Happy_GHC_Exts.I# st) `elem` happyCatchStates
+ = True
+ | HappyCons st1 sts1 <- sts
+ = happyAlreadyInResumption st1 sts1
+
+happyFail ERROR_TOK = happyFixupFailed
+happyFail i = happyTryFixup i
+
+happyResume i tk st sts stk = pop_items st sts stk
+ where
+ pop_items st sts stk
+ | HappyShift new_state <- happyDecodeAction (happyNextAction CATCH_TOK st)
+ = DEBUG_TRACE("shifting catch token " ++ show (Happy_GHC_Exts.I# st)
+ ++ " -> " ++ show (Happy_GHC_Exts.I# new_state) ++ "\n")
+ discard_input_until_exp i tk new_state (HappyCons st sts) (MK_ERROR_TOKEN(i) `HappyStk` stk)
+ | DEBUG_TRACE("can't shift catch in " ++ show (Happy_GHC_Exts.I# st) ++ ", ") True
+ , (Happy_GHC_Exts.I# n_starts) <- happy_n_starts, LT(st, n_starts)
+ = DEBUG_TRACE("because it is a start state. no resumption.\n")
+ happyAbort
+ | (HappyCons st1 sts1) <- sts, _ `HappyStk` stk1 <- stk
+ = DEBUG_TRACE("discarding.\n")
+ pop_items st1 sts1 stk1
+ discard_input_until_exp i tk st sts stk
+ | ultimately_fails i st sts
+ = DEBUG_TRACE("discard token in state " ++ show (Happy_GHC_Exts.I# st)
+ ++ ": " ++ show (Happy_GHC_Exts.I# i) ++ "\n")
+ happyLex (\_eof_tk -> happyAbort)
+ (\i tk -> discard_input_until_exp i tk st sts stk) -- not eof
+ | otherwise
+ = DEBUG_TRACE("found expected token in state " ++ show (Happy_GHC_Exts.I# st)
+ ++ ": " ++ show (Happy_GHC_Exts.I# i) ++ "\n")
+ (happyDoAction i tk st sts stk)
+
+ ultimately_fails i 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") True
+ HappyAccept -> DEBUG_TRACE("accept.\n") False
+ HappyShift _ -> DEBUG_TRACE("shift.\n") False
+ HappyReduce r -> case happySimulateReduce r st sts of
+ HappyCons st1 sts1 -> ultimately_fails i st1 sts1
+
+happySimulateReduce r st sts =
+ DEBUG_TRACE("simulate reduction of rule " ++ show r ++ ", ")
+ let (Happy_GHC_Exts.I# nt, Happy_GHC_Exts.I# len) = indexRuleArr happyRuleArr 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 i = happyTokenStrings Prelude.!! (i Prelude.- 2)
+happyExpectedTokens st sts =
+ DEBUG_TRACE("constructing expected tokens.\n")
+ 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
+ = ((-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)
+ | 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:
 

packages/backend-lalr/src/Happy/Backend/LALR.hs

@@ -19,14 +19,16 @@ magicFilter magicName = case magicName of
  in filter_output
 
 importsToInject :: Bool -> String
-importsToInject debug = concat ["\n", import_array, import_bits, import_glaexts, debug_imports, applicative_imports]
+importsToInject debug = concat ["\n", import_array, import_list, import_bits, import_glaexts, debug_imports, applicative_imports]
  where
  debug_imports | debug = import_debug
  | otherwise = ""
  applicative_imports = import_applicative
 
  import_glaexts = "import qualified GHC.Exts as Happy_GHC_Exts\n"
+ import_ghcstack = "import qualified GHC.Stack as Happy_GHC_Stack\n"
  import_array = "import qualified Data.Array as Happy_Data_Array\n"
+ import_list = "import qualified Data.List as Happy_Data_List\n"
  import_bits = "import qualified Data.Bits as Bits\n"
  import_debug = "import qualified System.IO as Happy_System_IO\n" ++
  "import qualified System.IO.Unsafe as Happy_System_IO_Unsafe\n" ++