Draft: Introduce new %error handler mode and catch for resumable parsing

.gitignore

@@ -4,6 +4,9 @@ dist-newstyle
 cabal-dev
 .cabal-sandbox
 cabal.sandbox.config
+cabal.project.local
 .*.swp
 .*.swo
-/.vscode/
+/.vscode/
+packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.hs
+packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.hs

happy.cabal

@@ -151,7 +151,7 @@ executable happy
                  happy-backend-glr == 2.0
 
   default-language: Haskell98
-  default-extensions: CPP, MagicHash, FlexibleContexts, NamedFieldPuns
+  default-extensions: CPP, MagicHash, FlexibleContexts, NamedFieldPuns, PatternGuards
   ghc-options: -Wall
   other-modules:
         Paths_happy

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

@@ -307,6 +307,8 @@ It also shares identical reduction values as CAFs
 >   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     -> ""

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

@@ -19,16 +19,18 @@ magicFilter magicName = case magicName of
       in filter_output
 
 importsToInject :: Bool -> Bool -> String
-importsToInject ghc debug = concat ["\n", import_array, import_bits, glaexts_import, debug_imports, applicative_imports]
+importsToInject ghc debug = concat ["\n", import_array, import_list, import_bits, glaexts_import, debug_imports, applicative_imports]
     where
-      glaexts_import | ghc       = import_glaexts
+      glaexts_import | ghc       = import_glaexts ++ import_ghcstack
                      | otherwise = ""
       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" ++
@@ -49,4 +51,4 @@ defines debug array ghc coerce = unlines [ "#define " ++ d ++ " 1" | d <- vars_t
     , [ "HAPPY_ARRAY"  | array ]
     , [ "HAPPY_GHC"    | ghc ]
     , [ "HAPPY_COERCE" | coerce ]
-    ]
+    ]

packages/codegen-common/src/Happy/CodeGen/Common/Options.lhs

@@ -5,21 +5,29 @@ The CommonOptions data type.
 -----------------------------------------------------------------------------
 
 > module Happy.CodeGen.Common.Options (
->       ErrorHandlerType(..),
->       CommonOptions(..)
+>       ErrorHandlerInfo(..), CommonOptions(..)
 >       ) where
 
-> data ErrorHandlerType
->   = ErrorHandlerTypeDefault
->   | ErrorHandlerTypeExpList
-
+> data ErrorHandlerInfo
+>   = DefaultErrorHandler
+>   -- ^ Default handler `happyError`.
+>   | CustomErrorHandler String
+>   -- ^ Call this handler on error.
+>   | ResumptiveErrorHandler String {- abort -} String {- addMessage -}
+>   -- ^ `ResumptiveErrorHandler abort reportError`:
+>   --   Calls non-fatal `reportError ... resume` with resumption `resume` to
+>   --   get more errors, ultimately failing with `abort` when parse can't be
+>   --   resumed.
+>
 > data CommonOptions
 >       = CommonOptions {
 >               token_type        :: String,
 >               imported_identity :: Bool,
 >               monad             :: (Bool,String,String,String,String),
 >               expect            :: Maybe Int,
 >               lexer             :: Maybe (String,String),
->               error_handler     :: Maybe String,
->               error_sig         :: ErrorHandlerType
+>               error_handler     :: ErrorHandlerInfo,
+>               error_expected    :: Bool
+>                 -- ^ Error handler expects a `[String]` as arg after current
+>                 -- token carrying the pretty-printed expected tokens.
 >       }

packages/frontend/happy-frontend.cabal

@@ -61,7 +61,7 @@ library
                        happy-grammar == 2.0
 
   default-language:    Haskell98
-  default-extensions:  CPP, MagicHash, FlexibleContexts
+  default-extensions:  CPP, MagicHash, FlexibleContexts, PatternGuards
   ghc-options: -Wall
   other-modules:
         Happy.Frontend.ParseMonad

packages/frontend/src/Happy/Frontend/AbsSyn.lhs

@@ -10,13 +10,13 @@ Here is the abstract syntax of the language we parse.
 >       BookendedAbsSyn(..),
 >       AbsSyn(..), Directive(..),
 >       getTokenType, getTokenSpec, getParserNames, getLexer,
->       getImportedIdentity, getMonad, getError,
->       getPrios, getPrioNames, getExpect, getErrorHandlerType,
+>       getImportedIdentity, getMonad, ErrorHandlerInfo(..), getError,
+>       getPrios, getPrioNames, getExpect, getErrorHandlerExpectedList,
 >       getAttributes, getAttributetype,
 >       Rule(..), Prod(..), Term(..), Prec(..)
 >  ) where
 
-> import Happy.CodeGen.Common.Options (ErrorHandlerType(..))
+> import Happy.CodeGen.Common.Options (ErrorHandlerInfo(..))
 
 > data BookendedAbsSyn
 >     = BookendedAbsSyn
@@ -66,17 +66,17 @@ generate some error messages.
 >       | TokenSpec     [(a,String)]            -- %token
 >       | TokenName     String (Maybe String) Bool -- %name/%partial (True <=> %partial)
 >       | TokenLexer    String String           -- %lexer
->       | TokenErrorHandlerType String          -- %errorhandlertype
 >       | TokenImportedIdentity                                 -- %importedidentity
 >       | TokenMonad    String String String String -- %monad
 >       | TokenNonassoc [String]                -- %nonassoc
 >       | TokenRight    [String]                -- %right
 >       | TokenLeft     [String]                -- %left
 >       | TokenExpect   Int                     -- %expect
->       | TokenError    String                  -- %error
+>       | TokenError    String (Maybe String)   -- %error
+>       | TokenErrorExpected                    -- %error.expected
 >       | TokenAttributetype String             -- %attributetype
 >       | TokenAttribute String String          -- %attribute
->   deriving Show
+>   deriving (Eq, Show)
 
 > getTokenType :: [Directive t] -> String
 > getTokenType ds
@@ -134,22 +134,17 @@ generate some error messages.
 >                 []  -> Nothing
 >                 _   -> error "multiple expect directives"
 
-> getError :: [Directive t] -> Maybe String
+> getError :: [Directive t] -> ErrorHandlerInfo
 > getError ds
->       = case [ a | (TokenError a) <- ds ] of
->               [t] -> Just t
->               []  -> Nothing
+>       = case [ (a, mb_b) | (TokenError a mb_b) <- ds ] of
+>               []                        -> DefaultErrorHandler
+>               [(a,Nothing)]             -> CustomErrorHandler a
+>               [(abort,Just addMessage)] -> ResumptiveErrorHandler abort addMessage
 >               _   -> error "multiple error directives"
 
-> getErrorHandlerType :: [Directive t] -> ErrorHandlerType
-> getErrorHandlerType ds
->       = case [ a | (TokenErrorHandlerType a) <- ds ] of
->               [t] -> case t of
->                        "explist" -> ErrorHandlerTypeExpList
->                        "default" -> ErrorHandlerTypeDefault
->                        _ -> error "unsupported %errorhandlertype value"
->               []  -> ErrorHandlerTypeDefault
->               _   -> error "multiple errorhandlertype directives"
+> getErrorHandlerExpectedList :: Eq t => [Directive t] -> Bool
+> getErrorHandlerExpectedList ds
+>       = TokenErrorExpected `elem` ds
 
 > getAttributes :: [Directive t] -> [(String, String)]
 > getAttributes ds

packages/frontend/src/Happy/Frontend/Lexer.lhs

@@ -37,7 +37,6 @@ The lexer.
 >       | TokSpecId_Token       -- %token
 >       | TokSpecId_Name        -- %name
 >       | TokSpecId_Partial     -- %partial
->       | TokSpecId_ErrorHandlerType    -- %errorhandlertype
 >       | TokSpecId_Lexer       -- %lexer
 >       | TokSpecId_ImportedIdentity -- %importedidentity
 >       | TokSpecId_Monad       -- %monad
@@ -48,6 +47,7 @@ The lexer.
 >       | TokSpecId_Shift       -- %shift
 >       | TokSpecId_Expect      -- %expect
 >       | TokSpecId_Error       -- %error
+>       | TokSpecId_ErrorExpected -- %error.expected
 >       | TokSpecId_Attributetype -- %attributetype
 >       | TokSpecId_Attribute   -- %attribute
 >       | TokCodeQuote          -- stuff inside { .. }
@@ -103,42 +103,45 @@ followed by a special identifier.
 > lexPercent :: (Token -> Pfunc a) -> [Char] -> Int -> ParseResult a
 > lexPercent cont s = case s of
 >       '%':rest -> cont (TokenKW TokDoublePercent) rest
->       't':'o':'k':'e':'n':'t':'y':'p':'e':rest ->
+>       't':'o':'k':'e':'n':'t':'y':'p':'e':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_TokenType) rest
->       't':'o':'k':'e':'n':rest ->
+>       't':'o':'k':'e':'n':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Token) rest
->       'n':'a':'m':'e':rest ->
+>       'n':'a':'m':'e':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Name) rest
->       'p':'a':'r':'t':'i':'a':'l':rest ->
+>       'p':'a':'r':'t':'i':'a':'l':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Partial) rest
->       'i':'m':'p':'o':'r':'t':'e':'d':'i':'d':'e':'n':'t':'i':'t':'y':rest ->
+>       'i':'m':'p':'o':'r':'t':'e':'d':'i':'d':'e':'n':'t':'i':'t':'y':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_ImportedIdentity) rest
->       'm':'o':'n':'a':'d':rest ->
+>       'm':'o':'n':'a':'d':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Monad) rest
->       'l':'e':'x':'e':'r':rest ->
+>       'l':'e':'x':'e':'r':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Lexer) rest
->       'n':'o':'n':'a':'s':'s':'o':'c':rest ->
+>       'n':'o':'n':'a':'s':'s':'o':'c':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Nonassoc) rest
->       'l':'e':'f':'t':rest ->
+>       'l':'e':'f':'t':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Left) rest
->       'r':'i':'g':'h':'t':rest ->
+>       'r':'i':'g':'h':'t':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Right) rest
->       'p':'r':'e':'c':rest ->
+>       'p':'r':'e':'c':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Prec) rest
->       's':'h':'i':'f':'t':rest ->
+>       's':'h':'i':'f':'t':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Shift) rest
->       'e':'x':'p':'e':'c':'t':rest ->
+>       'e':'x':'p':'e':'c':'t':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Expect) rest
->       'e':'r':'r':'o':'r':'h':'a':'n':'d':'l':'e':'r':'t':'y':'p':'e':rest ->
->               cont (TokenKW TokSpecId_ErrorHandlerType) rest
->       'e':'r':'r':'o':'r':rest ->
+>       'e':'r':'r':'o':'r':'.':'e':'x':'p':'e':'c':'t':'e':'d':rest | end_of_id rest ->
+>               cont (TokenKW TokSpecId_ErrorExpected) rest
+>       'e':'r':'r':'o':'r':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Error) rest
->       'a':'t':'t':'r':'i':'b':'u':'t':'e':'t':'y':'p':'e':rest ->
+>       'a':'t':'t':'r':'i':'b':'u':'t':'e':'t':'y':'p':'e':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Attributetype) rest
->       'a':'t':'t':'r':'i':'b':'u':'t':'e':rest ->
+>       'a':'t':'t':'r':'i':'b':'u':'t':'e':rest | end_of_id rest ->
 >               cont (TokenKW TokSpecId_Attribute) rest
 >       _ -> lexError ("unrecognised directive: %" ++
 >                               takeWhile (not.isSpace) s) s
+>    where
+>       end_of_id (c:_) = not (isAlphaNum c)
+>       end_of_id []    = True
 
 > lexColon :: (Token -> Pfunc a) -> [Char] -> Int -> ParseResult a
 > lexColon cont (':':rest) = cont (TokenKW TokDoubleColon) rest

packages/frontend/src/Happy/Frontend/Mangler.lhs

@@ -69,25 +69,31 @@ This bit is a real mess, mainly because of the error message support.
 >       starts'     = case getParserNames dirs of
 >                       [] -> [TokenName "happyParse" Nothing False]
 >                       ns -> ns
+>       error_resumptive | ResumptiveErrorHandler{} <- getError dirs = True
+>                        | otherwise                                 = False
 >
 >       start_strs  = [ startName++'_':p  | (TokenName p _ _) <- starts' ]
 
 Build up a mapping from name values to strings.
 
 >       name_env = (errorTok, errorName) :
+>                  (catchTok, catchName) :
 >                  (dummyTok, dummyName) :
 >                  zip start_names    start_strs ++
 >                  zip nonterm_names  nonterm_strs ++
 >                  zip terminal_names terminal_strs
 
 >       lookupName :: String -> [Name]
->       lookupName n = [ t | (t,r) <- name_env, r == n ]
+>       lookupName n = [ t | (t,r) <- name_env, r == n
+>                          , t /= catchTok || error_resumptive ]
+>                            -- hide catchName unless %errorresumptive is active
+>                            -- issue93.y uses catch as a nonterminal, we should not steal it
 
 >       mapToName str' =
 >             case lookupName str' of
 >                [a]   -> return a
 >                []    -> do addErr ("unknown identifier '" ++ str' ++ "'")
->                            return errorTok
+>                            return errorTok -- SG: What a confusing use of errorTok.. Use dummyTok?
 >                (a:_) -> do addErr ("multiple use of '" ++ str' ++ "'")
 >                            return a
 
@@ -229,7 +235,7 @@ Get the token specs in terms of Names.
 >               lookupProdNo      = (prod_array !),
 >               lookupProdsOfName = lookup_prods,
 >               token_specs       = tokspec,
->               terminals         = errorTok : terminal_names,
+>               terminals         = errorTok : catchTok : terminal_names,
 >               non_terminals     = start_names ++ nonterm_names,
 >                                       -- INCLUDES the %start tokens
 >               starts            = zip4 parser_names start_names start_toks
@@ -248,7 +254,7 @@ Get the token specs in terms of Names.
 >               monad             = getMonad dirs,
 >               lexer             = getLexer dirs,
 >               error_handler     = getError dirs,
->               error_sig         = getErrorHandlerType dirs,
+>               error_expected    = getErrorHandlerExpectedList dirs,
 >               token_type        = getTokenType dirs,
 >               expect            = getExpect dirs
 >       })

packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly

@@ -33,7 +33,7 @@ The parser.
 >       spec_shift      { TokenKW      TokSpecId_Shift }
 >       spec_expect     { TokenKW      TokSpecId_Expect }
 >       spec_error      { TokenKW      TokSpecId_Error }
->       spec_errorhandlertype   { TokenKW      TokSpecId_ErrorHandlerType }
+>       spec_errorexpected  { TokenKW      TokSpecId_ErrorExpected }
 >       spec_attribute  { TokenKW      TokSpecId_Attribute }
 >       spec_attributetype      { TokenKW      TokSpecId_Attributetype }
 >       code            { TokenInfo $$ TokCodeQuote }
@@ -104,11 +104,11 @@ The parser.
 >       | spec_shift                    { PrecShift }
 >       |                               { PrecNone }
 
-> tokInfos :: { [Directive String] } 
+> tokInfos :: { [Directive String] }
 >       : tokInfos tokInfo              { $2 : $1 }
 >       | tokInfo                       { [$1] }
 
-> tokInfo :: { Directive String } 
+> tokInfo :: { Directive String }
 >       : spec_tokentype code           { TokenType $2 }
 >       | spec_token tokenSpecs         { TokenSpec $2 }
 >       | spec_name id optStart         { TokenName $2 $3 False }
@@ -123,8 +123,8 @@ The parser.
 >       | spec_right ids                { TokenRight $2 }
 >       | spec_left ids                 { TokenLeft $2 }
 >       | spec_expect int               { TokenExpect $2 }
->       | spec_error code               { TokenError $2 }
->       | spec_errorhandlertype id              { TokenErrorHandlerType $2 }
+>       | spec_error code optCode       { TokenError $2 $3 }
+>       | spec_errorexpected            { TokenErrorExpected }
 >       | spec_attributetype code       { TokenAttributetype $2 }
 >       | spec_attribute id code        { TokenAttribute $2 $3 }
 

packages/frontend/src/Happy/Frontend/Parser/Oracle.hs

@@ -86,12 +86,17 @@ optTokInfoP = withToken match where
   match (TokenKW TokSpecId_Expect) =
     Consume `andThenJust`
     pure TokenExpect <*> numP
-  match (TokenKW TokSpecId_Error) =
-    Consume `andThenJust`
-    pure TokenError <*> codeP
-  match (TokenKW TokSpecId_ErrorHandlerType) =
+  match (TokenKW TokSpecId_ErrorExpected) =
     Consume `andThenJust`
-    pure TokenErrorHandlerType <*> idtP
+    pure TokenErrorExpected
+  match (TokenKW TokSpecId_Error) =
+    Consume `andThenJust` do
+      codes <- manyP optCodeP
+      case codes of
+        [c1]             -> return $ TokenError c1 Nothing
+        [c1, c2]         -> return $ TokenError c1 (Just c2)
+        [] -> parseError "Expected a code block"
+        _  -> parseError "Too many code blocks"
   match (TokenKW TokSpecId_Attributetype) =
     Consume `andThenJust`
     pure TokenAttributetype <*> codeP

packages/grammar/src/Happy/Grammar.lhs

@@ -11,7 +11,8 @@ The Grammar data type.
 >       Priority(..),
 >       Assoc(..),
 >
->       errorName, errorTok, startName, dummyName, firstStartTok, dummyTok,
+>       errorName, errorTok, catchName, catchTok,
+>       startName, dummyName, firstStartTok, dummyTok,
 >       eofName, epsilonTok,
 >
 >       mapDollarDollar
@@ -111,15 +112,17 @@ In normal and GHC-based parsers, these numbers are also used in the
 generated grammar itself, except that the error token is mapped to -1.
 For array-based parsers, see the note in Tabular/LALR.lhs.
 
-> startName, eofName, errorName, dummyName :: String
+> startName, eofName, errorName, catchName, dummyName :: String
 > startName = "%start" -- with a suffix, like %start_1, %start_2 etc.
 > eofName   = "%eof"
 > errorName = "error"
+> catchName = "catch"
 > dummyName = "%dummy"  -- shouldn't occur in the grammar anywhere
 
-> firstStartTok, dummyTok, errorTok, epsilonTok :: Name
-> firstStartTok   = 3
-> dummyTok        = 2
+> firstStartTok, dummyTok, errorTok, catchTok, epsilonTok :: Name
+> firstStartTok   = 4
+> dummyTok        = 3
+> catchTok        = 2
 > errorTok        = 1
 > epsilonTok      = 0