Expected list of tokens provided by `%errordefaulthandler explist` only lists shift tokens of most recent state

Here's a reproducer exhibiting two issues:

{
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
-- For ancient GHC 7.0.4
{-# LANGUAGE MultiParamTypeClasses #-}
module Main where

import Control.Monad (when)
import Data.Char
import System.Exit
}

%name parseStmts
%tokentype { Token }
%errorhandlertype explist
%error { handleError }

%monad { ParseM } { (>>=) } { return }

%token
  '1' { TOne }
  '+' { TPlus }
  ';' { TSemi }

%%

Stmts : {- empty -}    { [] }
      | Stmt           { [$1] }
      | Stmts ';' Stmt { $1 ++ [$3] }

Stmt : Exp { ExpStmt $1 }

Exp : '1'                { One }
    | Exp '+' Exp %shift { Plus $1 $3 }

{
data Token = TOne | TPlus | TSemi
  deriving (Eq,Show)

type Stmts = [Stmt]
data Stmt = ExpStmt Exp
  deriving (Eq, Show)
data Exp = One | Plus Exp Exp
  deriving (Eq, Show)

type ParseM = Either ParseError

data ParseError
        = ParseError [String]
    deriving Eq
instance Show ParseError where
  show (ParseError exp) = "Parse error. Expected: " ++ show exp

recordParseError :: [String] -> ParseM a
recordParseError expected = Left (ParseError expected)

handleError :: [Token] -> [String] -> ParseM a
handleError ts expected = recordParseError expected

lexer :: String -> [Token]
lexer [] = []
lexer (c:cs)
    | isSpace c = lexer cs
    | c == '1'  = TOne:(lexer cs)
    | c == '+'  = TPlus:(lexer cs)
    | c == ';'  = TSemi:(lexer cs)
    | otherwise = error "lexer error"

main :: IO ()
main = do
  test "11" $ \res -> res == Left (ParseError ["';'","'+'"])
  where
    test inp p = do
      putStrLn $ "testing " ++ inp
      let tokens = lexer inp
      let res = parseStmts tokens
      when (not (p res)) $ do
        print res
        exitWith (ExitFailure 1)
}

Note that it tests an input 11 which leads to a syntax error after the first 1 and checks whether both ; and + were listed as expected tokens. But if you compile and run it,

$ happy issue265.y && ghc issue265.hs && issue265
testing 11
Left Parse error. Expected: ["';'"]

You can see that it only suggests ;. That is due to two separate issues:

In order to generate smaller code, happy replaces erroring default actions with the most common reduction (see getDefault). After we shift the first 1 and detect the error, we end up default-reducing all the way back up to Stmts -> Stmts . ';' Stmt, which neglects the item Exp -> Exp . '+' Exp.
Even if getDefault was "fixed", we'd be stuck in the reduction state Exp -> 1 ., where there is no expected shift token whatsoever. That points out another flaw: The implementation of %errorhandlertype explist is insufficient, because it only reports the tokens to be shifted for the topmost state on the stack. This strategy isn't so bad, but we'd better walk the whole state stack as if we successfully reduced and collect all shiftable tokens we encounter on the way (so it's rather not simply "walking the stack" I'm afraid). It ought to be possible to simulate this to get quite context-sensitive expected token lists. The next best solution would be to consider the set of tokens of the topmost state with a shift or a reduce action.

Of course, (2) is infeasible for non-array-based parsers, or at least would require quite a bit of extra code.

haskell / happy

Expected list of tokens provided by `%errordefaulthandler explist` only lists shift tokens of most recent state #265