diff --git a/happy.cabal b/happy.cabal index a2904506..39f3bf36 100644 --- a/happy.cabal +++ b/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 diff --git a/packages/backend-lalr/data/HappyTemplate.hs b/packages/backend-lalr/data/HappyTemplate.hs index ee6fa735..f175779e 100644 --- a/packages/backend-lalr/data/HappyTemplate.hs +++ b/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 diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 47db3b6e..51206219 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/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,9 +737,8 @@ 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 @@ -752,7 +746,7 @@ action array indexed by (terminal * last_state) + state > . 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 " , " diff --git a/packages/codegen-common/src/Happy/CodeGen/Common/Options.lhs b/packages/codegen-common/src/Happy/CodeGen/Common/Options.lhs index ef925f91..42e19d2c 100644 --- a/packages/codegen-common/src/Happy/CodeGen/Common/Options.lhs +++ b/packages/codegen-common/src/Happy/CodeGen/Common/Options.lhs @@ -5,14 +5,20 @@ 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, @@ -20,12 +26,8 @@ The CommonOptions data type. > 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. > } diff --git a/packages/frontend/happy-frontend.cabal b/packages/frontend/happy-frontend.cabal index 517796ac..b42a0134 100644 --- a/packages/frontend/happy-frontend.cabal +++ b/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 diff --git a/packages/frontend/src/Happy/Frontend/AbsSyn.lhs b/packages/frontend/src/Happy/Frontend/AbsSyn.lhs index 6f0841b7..c055922a 100644 --- a/packages/frontend/src/Happy/Frontend/AbsSyn.lhs +++ b/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 diff --git a/packages/frontend/src/Happy/Frontend/Lexer.lhs b/packages/frontend/src/Happy/Frontend/Lexer.lhs index e3440b65..d51060db 100644 --- a/packages/frontend/src/Happy/Frontend/Lexer.lhs +++ b/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 -> diff --git a/packages/frontend/src/Happy/Frontend/Mangler.lhs b/packages/frontend/src/Happy/Frontend/Mangler.lhs index cc67254d..2372f1ef 100644 --- a/packages/frontend/src/Happy/Frontend/Mangler.lhs +++ b/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 > }) diff --git a/packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly b/packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly index 7f9d07fa..2fc315e3 100644 --- a/packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly +++ b/packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly @@ -33,8 +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_errorresumptive { TokenKW TokSpecId_ErrorResumptive } +> spec_errorexpected { TokenKW TokSpecId_ErrorExpected } > spec_attribute { TokenKW TokSpecId_Attribute } > spec_attributetype { TokenKW TokSpecId_Attributetype } > code { TokenInfo $$ TokCodeQuote } @@ -124,9 +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_errorresumptive { TokenErrorResumptive } +> | spec_error code code { TokenError $2 $3 } +> | spec_errorexpected { TokenErrorExpected } > | spec_attributetype code { TokenAttributetype $2 } > | spec_attribute id code { TokenAttribute $2 $3 } diff --git a/packages/frontend/src/Happy/Frontend/Parser/Oracle.hs b/packages/frontend/src/Happy/Frontend/Parser/Oracle.hs index a0777300..ca6ede62 100644 --- a/packages/frontend/src/Happy/Frontend/Parser/Oracle.hs +++ b/packages/frontend/src/Happy/Frontend/Parser/Oracle.hs @@ -86,15 +86,17 @@ optTokInfoP = withToken match where match (TokenKW TokSpecId_Expect) = Consume `andThenJust` pure TokenExpect <*> numP - match (TokenKW TokSpecId_ErrorHandlerType) = + match (TokenKW TokSpecId_ErrorExpected) = Consume `andThenJust` - pure TokenErrorHandlerType <*> idtP - match (TokenKW TokSpecId_ErrorResumptive) = - Consume `andThenJust` - pure TokenErrorResumptive + pure TokenErrorExpected match (TokenKW TokSpecId_Error) = - Consume `andThenJust` - pure TokenError <*> codeP + 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 diff --git a/tests/monaderror-explist.y b/tests/monaderror-explist.y index 3f027ef6..dd84d23c 100644 --- a/tests/monaderror-explist.y +++ b/tests/monaderror-explist.y @@ -14,8 +14,8 @@ import Data.List (isPrefixOf) %name parseFoo %tokentype { Token } -%errorhandlertype explist %error { handleErrorExpList } +%error.expected %monad { ParseM } { (>>=) } { return } diff --git a/tests/monaderror-resume.y b/tests/monaderror-resume.y index 578f7d73..29a0e079 100644 --- a/tests/monaderror-resume.y +++ b/tests/monaderror-resume.y @@ -13,9 +13,8 @@ import System.Exit %name parseStmts Stmts %name parseExp Exp %tokentype { Token } -%errorresumptive -- the entire point of this test -%errorhandlertype explist -- as in monaderror-explist.y -%error { handleError } +%error { \_ -> abort } { reportError } -- the entire point of this test +%error.expected -- as in monaderror-explist.y %monad { ParseM } { (>>=) } { return } @@ -76,13 +75,10 @@ instance Show ParseError where recordParseError :: [String] -> ParseM () recordParseError expected = recordError [ParseError expected] -handleError :: [Token] -> [String] -> ([Token] -> ParseM (Maybe a)) -> ParseM a -handleError ts expected resume = do +reportError :: [Token] -> [String] -> ([Token] -> ParseM a) -> ParseM a +reportError ts expected resume = do recordParseError expected - mb_ast <- resume ts - case mb_ast of - Just ast -> return ast - Nothing -> abort -- abort after parsing with no AST when resumption is impossible + resume ts lexer :: String -> [Token] lexer [] = []