Better abort/report factoring

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-lalr/data/HappyTemplate.hs

@@ -83,7 +83,7 @@ happyTrace string expr = Happy_System_IO_Unsafe.unsafePerformIO $ do
 #endif
 
 infixr 9 `HappyStk`
-data HappyStk a = HappyStk a (HappyStk a)
+data HappyStk a = HappyStk !a (HappyStk a)
 
 -----------------------------------------------------------------------------
 -- starting the parse
@@ -326,9 +326,9 @@ happyFixupFailed tk st sts (x `HappyStk` stk) =
   let i = GET_ERROR_TOKEN(x) in
   DEBUG_TRACE("`error` fixup failed.\n")
 #if defined(HAPPY_ARRAY)
-  happyError_ i tk (map happyTokenToString (happyExpectedTokens st sts)) (happyResume i tk st sts stk)
+  happyReport i tk (map happyTokenToString (happyExpectedTokens st sts)) (happyResume i tk st sts stk)
 #else
-  happyError_ i tk [] (happyReturn1 Nothing)
+  happyReport i tk [] happyAbort
 #endif
 
 happyFail ERROR_TOK = happyFixupFailed
@@ -344,19 +344,18 @@ happyResume i tk st sts stk = pop_items st sts stk
       | DEBUG_TRACE("can't shift catch in " ++ show IBOX(st) ++ ", ") True
       , IBOX(n_starts) <- happy_n_starts, LT(st, n_starts)
       = DEBUG_TRACE("because it is a start state. no resumption.\n")
-        happyReturn1 Nothing
+        happyAbort
       | CONS(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 IBOX(st) ++ ": " ++ show IBOX(i) ++ "\n")
-        happyLex (\_eof_tk -> happyReturn1 Nothing)
+        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 IBOX(st) ++ ": " ++ show IBOX(i) ++ "\n")
-        happyFmap1 (\a -> a `happySeq` Just a)
-                   (DO_ACTION(st,i,tk,sts,stk))
+        DO_ACTION(st,i,tk,sts,stk)
     ultimately_fails i st sts =
       DEBUG_TRACE("trying token " ++ show IBOX(i) ++ " in state " ++ show IBOX(st) ++ ": ")
       case happyDecodeAction (happyNextAction i st) of

packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs

@@ -64,8 +64,7 @@ Produce the complete output file.
 >               , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return)
 >               , token_type = token_type'
 >               , error_handler = error_handler'
->               , error_sig = error_sig'
->               , error_resumptive = error_resumptive'
+>               , error_expected = error_expected'
 >               })
 >               action goto lang_exts module_header module_trailer
 >               target coerce ghc strict
@@ -452,10 +451,10 @@ The token conversion function.
 >       . str "happyNewToken action sts stk = happyLex (\\tk -> " . eofAction . str ") ("
 >             . str "\\i tk -> " . doAction . str " sts stk)\n"
 >       . str "\n"
->       . str "happyError_ " . eofTok . str " tk explist resume tks = happyError' tks explist resume\n"
->       . str "happyError_ _ tk explist resume tks = happyError' (tk:tks) explist resume\n"
+>       . str "happyReport " . eofTok . str " tk explist resume tks = happyReport' tks explist resume\n"
+>       . str "happyReport _ tk explist resume tks = happyReport' (tk:tks) explist resume\n"
 >             -- when the token is EOF, tk == _|_ (notHappyAtAll)
->             -- so we must not pass it to happyError'
+>             -- so we must not pass it to happyReport'
 >       . str "\n";
 
 >       Just (lexer'',eof') ->
@@ -493,9 +492,9 @@ The token conversion function.
 >       . str "happyNewToken action sts stk = happyLex (\\tk -> " . eofAction . str ") ("
 >             . str "\\i tk -> " . doAction . str " sts stk)\n"
 >       . str "\n"
->       . str "happyError_ " . eofTok . str " = happyError'\n"
->       . str "happyError_ _ = happyError'\n"
->             -- superfluous pattern match needed to force happyError_ to
+>       . str "happyReport " . eofTok . str " = happyReport'\n"
+>       . str "happyReport _ = happyReport'\n"
+>             -- superfluous pattern match needed to force happyReport to
 >             -- have the correct type.
 >       . str "\n";
 >       }
@@ -615,10 +614,6 @@ machinery to discard states in the parser...
 >       . str "happyTokenStrings = " . shows (drop (fst_term - 1) (elems token_names')) . str "\n"
 >                                            -- fst_term - 1: fst_term includes eofToken, but that is last in the list.
 >       . str "\n"
->       where (first_token, last_token) = bounds token_names'
->             nr_tokens = last_token - first_token + 1
->               -- NB: This number includes non-terminals as well as special
->               -- terminals (`error`,`%dummy`,...). Hence the need to adjust.
 >
 >    produceStateFunction goto' (state, acts)
 >       = foldr (.) id (map produceActions assocs_acts)
@@ -742,17 +737,16 @@ action array indexed by (terminal * last_state) + state
 >
 >    table_size = length table - 1
 >
->    produceReduceArray -- rule number to (non-terminal number, rule length)
->       = {- str "happyReduceArr :: Happy_Data_Array.Array Prelude.Int (Prelude.Int,Prelude.Int)\n" -}
->         str "happyReduceArr = Happy_Data_Array.array ("
+>    produceReduceArray
+>       = str "happyReduceArr = Happy_Data_Array.array ("
 >               . shows (n_starts :: Int) -- omit the %start reductions
 >               . str ", "
 >               . shows n_rules
 >               . str ") [\n"
 >       . interleave' ",\n" (map reduceArrElem [n_starts..n_rules])
 >       . str "\n\t]\n\n"
 >
->    produceRuleArray
+>    produceRuleArray -- rule number to (non-terminal number, rule length)
 >       | ghc
 >       = str "happyRuleArr :: HappyAddr\n"
 >       . str "happyRuleArr = HappyA# \"" -- "
@@ -867,14 +861,21 @@ MonadStuff:
 >                . str "happyReturn1 :: " . pcont . str " => a -> b -> " . ptyAt (str "a") . str "\n"
 >                . str "happyReturn1 = \\a tks -> " . brack monad_return
 >                . str " a\n"
->                . str "happyError' :: " . pcont . str " => "
+>                . str "happyReport' :: " . pcont . str " => "
 >                . str "[" . token . str "] -> "
 >                . str "[Prelude.String] -> ("
 >                . str "[" . token . str "] -> "
->                . ptyAt (str "(Maybe a)") . str ") -> "
+>                . ptyAt (str "a") . str ") -> "
 >                . ptyAt (str "a")
 >                . str "\n"
->                . str "happyError' = " . errorHandler . str "\n"
+>                . str "happyReport' = " . callReportError . str "\n"
+>                . str "\n"
+>                . str "happyAbort :: " . pcont . str " => "
+>                . str "[" . token . str "] -> "
+>                . ptyAt (str "a")
+>                . str "\n"
+>                . str "happyAbort = " . str abort_handler . str "\n"
+>                . str "\n"
 >               _ ->
 >                let
 >                  happyParseSig
@@ -915,31 +916,49 @@ MonadStuff:
 >                . str "happyFmap1 f m = happyThen m (\\a -> happyReturn (f a))\n"
 >                . str "happyReturn1 :: " . pcont . str " => a -> " . ptyAt (str "a") . str "\n"
 >                . str "happyReturn1 = happyReturn\n"
->                . str "happyError' :: " . pcont . str " => "
+>                . str "happyReport' :: " . pcont . str " => "
 >                . token . str " -> "
 >                . str "[Prelude.String] -> "
->                . ptyAt (str "(Maybe a)") . str " -> "
+>                . ptyAt (str "a") . str " -> "
 >                . ptyAt (str "a")
 >                . str "\n"
->                . str "happyError' = " . errorHandler . str "\n"
+>                . str "happyReport' = " . callReportError . str "\n"
+>                . str "\n"
+>                . str "happyAbort :: " . pcont . str " => "
+>                . ptyAt (str "a")
+>                . str "\n"
+>                . str "happyAbort = " . str abort_handler . str "\n"
+>                . str "\n"
 
+The error handler takes up to three arguments.
 An error handler specified with %error is passed the current token
-when used with %lexer, but happyError (the old way but kept for
-compatibility) is not passed the current token. Also, the %errorhandlertype
-directive determines the API of the provided function.
-
->    errorHandler =
->       str "(\\tokens explist resume -> " .
+when used with %lexer as the first argument, but happyError (the old way but kept for
+compatibility) is not passed the current token.
+Furthermore, the second argument is the list of expected tokens
+in the presence of the %error.expected directive.
+The last argument is the "resumption", a continuation that tries to find
+an item on the stack taking a @catch@ terminal where parsing may resume,
+in the presence of the two-argument form of the %error directive.
+
+>    callReportError = -- this one wraps around report_error_handler to expose a unified interface
+>       str "(\\tokens expected resume -> " .
 >       (if use_monad then str ""
 >                     else str "HappyIdentity Prelude.$ ") .
->       (case error_handler' of Just h -> brack h . str " "; Nothing -> str "happyError ") .
->       (case (error_handler', lexer') of (Nothing, Just _) -> id
->                                         _                 -> str "tokens ") .
->       (case error_sig' of ErrorHandlerTypeExpList -> str "explist "
->                           ErrorHandlerTypeDefault -> str "") .
->       (if error_resumptive' then str "resume "
->                             else str "") .
+>       report_error_handler .
+>       (case (error_handler', lexer') of (DefaultErrorHandler, Just _) -> id
+>                                         _                             -> str " tokens") .
+>       (if error_expected' then str " expected"
+>                           else id) .
+>       (case error_handler' of ResumptiveErrorHandler{} -> str " resume"
+>                               _                        -> id) .
 >       str ")"
+>    report_error_handler = case error_handler' of
+>       DefaultErrorHandler                  -> str "happyError"
+>       CustomErrorHandler h                 -> brack h
+>       ResumptiveErrorHandler _abort report -> brack report
+>    abort_handler = case error_handler' of
+>       ResumptiveErrorHandler abort _report -> abort
+>       _                                    -> "error \"Called abort handler in non-resumptive parser\""
 
 >    reduceArrElem n
 >      = str "\t(" . shows n . str " , "

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

@@ -5,27 +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,
->                 -- ^ ErrorHandlerTypExpList: error handler expects a
->                 --   `[String]` as first arg with the pretty-printed expected
->                 --   tokens
->               error_resumptive  :: Bool
->                 -- ^ `True` => The error handler expects a `resume`
->                 -- continuation as last argument.
+>               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, getErrorResumptive,
+>       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
@@ -72,12 +72,11 @@ generate some error messages.
 >       | TokenRight    [String]                -- %right
 >       | TokenLeft     [String]                -- %left
 >       | TokenExpect   Int                     -- %expect
->       | TokenError    String                  -- %error
->       | TokenErrorHandlerType String          -- %errorhandlertype
->       | TokenErrorResumptive                  -- %resumptive
+>       | 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
@@ -135,25 +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"
-
-> getErrorResumptive :: [Directive t] -> Bool
-> getErrorResumptive ds = not (null [ () | TokenErrorResumptive <- ds ])
+> 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

@@ -47,8 +47,7 @@ The lexer.
 >       | TokSpecId_Shift       -- %shift
 >       | TokSpecId_Expect      -- %expect
 >       | TokSpecId_Error       -- %error
->       | TokSpecId_ErrorHandlerType -- %errorhandlertype
->       | TokSpecId_ErrorResumptive  -- %errorresumptive
+>       | TokSpecId_ErrorExpected -- %error.expected
 >       | TokSpecId_Attributetype -- %attributetype
 >       | TokSpecId_Attribute   -- %attribute
 >       | TokCodeQuote          -- stuff inside { .. }
@@ -130,10 +129,8 @@ followed by a special identifier.
 >               cont (TokenKW TokSpecId_Shift) 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 | end_of_id rest ->
->               cont (TokenKW TokSpecId_ErrorHandlerType) rest
->       'e':'r':'r':'o':'r':'r':'e':'s':'u':'m':'p':'t':'i':'v':'e':rest | end_of_id rest ->
->               cont (TokenKW TokSpecId_ErrorResumptive) 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 | end_of_id rest ->

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

@@ -69,7 +69,8 @@ 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' = getErrorResumptive dirs
+>       error_resumptive | ResumptiveErrorHandler{} <- getError dirs = True
+>                        | otherwise                                 = False
 >
 >       start_strs  = [ startName++'_':p  | (TokenName p _ _) <- starts' ]
 
@@ -84,7 +85,7 @@ Build up a mapping from name values to strings.
 
 >       lookupName :: String -> [Name]
 >       lookupName n = [ t | (t,r) <- name_env, r == n
->                          , t /= catchTok || error_resumptive' ]
+>                          , t /= catchTok || error_resumptive ]
 >                            -- hide catchName unless %errorresumptive is active
 >                            -- issue93.y uses catch as a nonterminal, we should not steal it
 
@@ -253,8 +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_resumptive  = error_resumptive',
+>               error_expected    = getErrorHandlerExpectedList dirs,
 >               token_type        = getTokenType dirs,
 >               expect            = getExpect dirs
 >       })