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" ++