Auto-resolve shift/reduce conflicts involving the catch token

When the current token is the catch token, we never reduce; we only ever
shift. Hence it does not make sense to report shift/reduce conflicts
involving the catch token: Error resumption mode will only ever try to
shift it.

The solution implemented in this patch is not to generate conflicting
LR'Reduce actions in the first place by deleting the catch token from
the lookahead sets of LR1 items.

happy.cabal

@@ -1,5 +1,5 @@
 name: happy
-version: 2.1.2
+version: 2.1.3
 license: BSD2
 license-file: LICENSE
 copyright: (c) Andy Gill, Simon Marlow
@@ -139,7 +139,7 @@ executable happy
                  array,
                  containers >= 0.4.2,
                  mtl >= 2.2.1,
-                 happy-lib == 2.1.2
+                 happy-lib == 2.1.3
 
   default-language: Haskell98
   default-extensions: CPP, MagicHash, FlexibleContexts, NamedFieldPuns

lib/grammar/src/Happy/Grammar.lhs

@@ -175,6 +175,10 @@ For array-based parsers, see the note in Tabular/LALR.lhs.
 > catchName = "catch"
 > dummyName = "%dummy"  -- shouldn't occur in the grammar anywhere
 
+TODO: Should rename firstStartTok to firstStartName!
+It denotes the *Name* of the first start non-terminal and semantically has
+nothing to do with Tokens at all.
+
 > firstStartTok, dummyTok, errorTok, catchTok, epsilonTok :: Name
 > firstStartTok   = MkName 4
 > dummyTok        = MkName 3

lib/happy-lib.cabal

@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: happy-lib
-version: 2.1.2
+version: 2.1.3
 license: BSD-2-Clause
 copyright: (c) Andy Gill, Simon Marlow
 author: Andy Gill and Simon Marlow

lib/tabular/src/Happy/Tabular/LALR.lhs

@@ -125,12 +125,12 @@ using a memo table so that no work is repeated.
 > closure0 :: Grammar e -> (Name -> RuleList) -> Set Lr0Item -> Set Lr0Item
 > closure0 g closureOfNT set = Set.foldr addRules Set.empty set
 >    where
->       fst_term = first_term g
+>       last_nonterm = MkName $ getName (first_term g) - 1
 >       addRules rule set' = Set.union (Set.fromList (rule : closureOfRule rule)) set'
 >
 >       closureOfRule (Lr0 rule dot) =
 >           case findRule g rule dot of
->               (Just nt) | nt >= firstStartTok && nt < fst_term
+>               (Just nt) | nt >= firstStartTok && nt <= last_nonterm
 >                  -> closureOfNT nt
 >               _  -> []
 
@@ -141,7 +141,7 @@ Generating the closure of a set of LR(1) items
 > closure1 g first set
 >       = fst (mkClosure (\(_,new) _ -> null new) addItems ([],set))
 >       where
->       fst_term = first_term g
+>       last_nonterm = MkName $ getName (first_term g) - 1
 
 >       addItems :: ([Lr1Item],[Lr1Item]) -> ([Lr1Item],[Lr1Item])
 >       addItems (old_items, new_items) = (new_old_items, new_new_items)
@@ -153,11 +153,11 @@ Generating the closure of a set of LR(1) items
 
 >               fn :: Lr1Item -> [Lr1Item]
 >               fn (Lr1 rule dot as) = case drop dot lhs of
->                       (b:beta) | b >= firstStartTok && b < fst_term ->
->                           let terms = unionNameMap
->                                               (\a -> first (beta ++ [a])) as
+>                       (nt:beta) | nt >= firstStartTok && nt <= last_nonterm ->
+>                           let terms = NameSet.delete catchTok $ -- the catch token is always shifted and never reduced (see pop_items)
+>                                       unionNameMap (\a -> first (beta ++ [a])) as
 >                           in
->                           [ (Lr1 rule' 0 terms) | rule' <- lookupProdsOfName g b ]
+>                           [ (Lr1 rule' 0 terms) | rule' <- lookupProdsOfName g nt ]
 >                       _ -> []
 >                   where Production _name lhs _ _ = lookupProdNo g rule
 

tests/catch-shift-reduce.y

@@ -0,0 +1,57 @@
+{
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+-- For ancient GHC 7.0.4
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Main where
+
+import Control.Monad (when)
+import Data.IORef
+import Data.Char
+import System.Exit
+}
+
+%name parseExp Exp
+%tokentype { Token }
+%error { abort } { reportError }
+
+%monad { ParseM } { (>>=) } { return }
+
+%token
+  '1' { TOne }
+  '+' { TPlus }
+  '(' { TOpen }
+  ')' { TClose }
+
+%right '+'
+%expect 0     -- The point of this test: The List productions should expose a shift/reduce conflict because of catch
+
+%%
+
+Close :: { String }
+Close : ')'   { ")" }
+      | catch { "catch" }
+
+Exp :: { String }
+Exp : catch          { "catch" }
+    | '1'            { "1"}
+    | '(' List Close { "(" ++ $2 ++ $3 }
+
+List :: { String }
+     : Exp '+' { $1 ++ "+" }
+     | Exp '+' Exp { $1 ++ "+" ++ $3 }
+
+{
+data Token = TOne | TPlus | TComma | TOpen | TClose
+
+type ParseM = Maybe
+
+abort :: [Token] -> ParseM a
+abort = undefined
+
+reportError :: [Token] -> ([Token] -> ParseM a) -> ParseM a
+reportError = undefined
+
+main :: IO ()
+main = return ()
+}