Simulate reductions and overhaul expected token generation

packages/backend-lalr/data/HappyTemplate.hs

@@ -112,7 +112,7 @@ happyDoAction i tk st =
               ",\taction: ")
   case happyDecodeAction (happyNextAction i st) of
     HappyFail   -> DEBUG_TRACE("failing.\n")
-                   happyFail st i tk st
+                   happyFail i tk st
     HappyAccept -> DEBUG_TRACE("accept.\n")
                    happyAccept i tk st
     HappyReduce rule -> DEBUG_TRACE("reduce (rule " ++ show IBOX(rule) ++ ")")
@@ -139,6 +139,7 @@ data HappyAction
   | HappyAccept
   | HappyReduce FAST_INT -- rule number
   | HappyShift FAST_INT  -- new state
+  deriving Show
 
 {-# INLINE happyDecodeAction #-}
 happyDecodeAction ILIT(0)  = HappyFail
@@ -159,8 +160,21 @@ happyIndexGotoTable nt st = indexOffAddr happyTable off
 #ifdef HAPPY_GHC
 indexOffAddr (HappyA# arr) off =
   Happy_GHC_Exts.int32ToInt# (Happy_GHC_Exts.indexInt32OffAddr# arr off)
+
+#ifdef HAPPY_ARRAY
+indexRuleArr arr r = (IBOX(nt), IBOX(len))
+  where
+    IBOX(n_starts) = happy_n_starts
+    offs = TIMES(MINUS(r,n_starts),ILIT(2))
+    nt = indexOffAddr arr offs
+    len = indexOffAddr arr PLUS(offs,ILIT(1))
+#endif
 #else
 indexOffAddr arr off = arr Happy_Data_Array.! off
+
+#ifdef HAPPY_ARRAY
+indexRuleArr arr nt = arr Happy_Data_Array.! nt
+#endif
 #endif
 
 {-# INLINE happyLt #-}
@@ -308,18 +322,17 @@ happyTryFixup i tk HAPPYSTATE(action) sts stk =
   --     `tk`. Hence we don't change `tk` in the call here
 
 -- parse error if we are in fixup and fail again
-happyFixupFailed state_num tk st sts (x `HappyStk` stk) =
+happyFixupFailed tk st sts (x `HappyStk` stk) =
   let i = GET_ERROR_TOKEN(x) in
   DEBUG_TRACE("`error` fixup failed.\n")
 #if defined(HAPPY_ARRAY)
-  -- TODO: Walk the stack instead of looking only at the top state_num
-  happyError_ i tk (happyExpListPerState (IBOX(state_num))) (happyResume i tk st sts stk)
+  happyError_ i tk (map happyTokenToString (happyExpectedTokens st sts)) (happyResume i tk st sts stk)
 #else
-  happyError_ i tk (happyExpListPerState (IBOX(state_num))) (happyResume i tk st sts stk)
+  happyError_ i tk [] (happyReturn1 Nothing)
 #endif
 
-happyFail state_num ERROR_TOK = happyFixupFailed state_num
-happyFail _         i         = happyTryFixup i
+happyFail ERROR_TOK = happyFixupFailed
+happyFail i         = happyTryFixup i
 
 #if defined(HAPPY_ARRAY)
 happyResume i tk st sts stk = pop_items st sts stk
@@ -335,24 +348,71 @@ happyResume i tk st sts stk = pop_items st sts stk
       | CONS(st1,sts1) <- sts, _ `HappyStk` stk1 <- stk
       = DEBUG_TRACE("discarding.\n")
         pop_items st1 sts1 stk1
---    discard_input_until_exp :: Happy_GHC_Exts.Int# -> Token -> Happy_GHC_Exts.Int#  -> _
     discard_input_until_exp i tk st sts stk
-      | HappyFail <- happyDecodeAction (happyNextAction i st)
+      | ultimately_fails i st sts
       = DEBUG_TRACE("discard token in state " ++ show IBOX(st) ++ ": " ++ show IBOX(i) ++ "\n")
         happyLex (\_eof_tk -> happyReturn1 Nothing)
                  (\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))
-#else
-happyResume (i :: FAST_INT) tk st sts stk = happyReturn1 Nothing
+    ultimately_fails i st sts =
+      DEBUG_TRACE("trying token " ++ show IBOX(i) ++ " in state " ++ show IBOX(st) ++ ": ")
+      case happyDecodeAction (happyNextAction i st) of
+        HappyFail     -> DEBUG_TRACE("fail.\n")   True
+        HappyAccept   -> DEBUG_TRACE("accept.\n") False
+        HappyShift _  -> DEBUG_TRACE("shift.\n")  False
+        HappyReduce r -> case happySimulateReduce r st sts of
+          CONS(st1,sts1) -> ultimately_fails i st1 sts1
+
+happySimulateReduce r st sts =
+  DEBUG_TRACE("simulate reduction of rule " ++ show IBOX(r) ++ ", ")
+  let (IBOX(nt), IBOX(len)) = indexRuleArr happyRuleArr r in
+  DEBUG_TRACE("nt " ++ show IBOX(nt) ++ ", len: " ++ show IBOX(len) ++ ", new_st ")
+  let sts1@CONS(st1,_) = happyDrop len CONS(st,sts)
+      new_st = happyIndexGotoTable nt st1 in
+  DEBUG_TRACE(show IBOX(new_st) ++ ".\n")
+  CONS(new_st, sts1)
+
+happyTokenToString i = happyTokenStrings Prelude.!! (i Prelude.- 2)
+happyExpectedTokens st sts =
+  DEBUG_TRACE("constructing expected tokens.\n")
+  search_shifts st sts []
+  where
+    search_shifts st sts shifts = foldr (add_action st sts) shifts (distinct_actions st)
+    add_action st sts (IBOX(i), IBOX(act)) shifts =
+      DEBUG_TRACE("found action in state " ++ show IBOX(st) ++ ", input " ++ show IBOX(i) ++ ", " ++ show (happyDecodeAction act) ++ "\n")
+      case happyDecodeAction act of
+        HappyFail     -> shifts
+        HappyAccept   -> shifts -- This would always be %eof or error... Not helpful
+        HappyShift _  -> Happy_Data_List.insert IBOX(i) shifts
+        HappyReduce r -> case happySimulateReduce r st sts of
+          CONS(st1,sts1) -> search_shifts st1 sts1 shifts
+    distinct_actions st
+      = ((-1), IBOX(indexOffAddr happyDefActions st))
+      : [ (i, act) | i <- [begin_i..happy_n_terms], act <- get_act row_off i ]
+      where
+        row_off = indexOffAddr happyActOffsets st
+        begin_i = 2 -- +2: errorTok,catchTok
+    get_act off IBOX(i)
+      | let off_i = PLUS(off,i)
+      , GTE(off_i,ILIT(0))
+      , EQ(indexOffAddr happyCheck off_i,i)
+      = [IBOX(indexOffAddr happyTable off_i)]
+      | otherwise
+      = []
+
 #endif
 
 
 -- Internal happy errors:
 
+#if defined(HAPPY_GHC)
+notHappyAtAll :: Happy_GHC_Stack.HasCallStack => a
+#else
 notHappyAtAll :: a
+#endif
 notHappyAtAll = Prelude.error "Internal Happy error\n"
 
 -----------------------------------------------------------------------------

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/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs

@@ -604,24 +604,16 @@ machinery to discard states in the parser...
 >    produceActionTable TargetArrayBased
 >       = produceActionArray
 >       . produceReduceArray
+>       . produceRuleArray
 >       . str "happy_n_terms = " . shows n_terminals . str " :: Prelude.Int\n"
 >       . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Prelude.Int\n\n"
+>       . str "happy_n_starts = " . shows n_starts . str " :: Prelude.Int\n\n"
 >
 >    produceExpToksPerState
 >       = produceExpToksArray
->       . str "{-# NOINLINE happyExpListPerState #-}\n"
->       . str "happyExpListPerState st =\n"
->       . str "    token_strs_expected\n"
->       . str "  where token_strs = " . shows (elems token_names') . str "\n"
->       . str "        bit_start = st Prelude.* " . shows nr_tokens . str "\n"
->       . str "        bit_end = (st Prelude.+ 1) Prelude.* " . shows nr_tokens . str "\n"
->       . str "        read_bit = readArrayBit happyExpToks\n"
->       . str "        bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]\n"
->       . str "        bits_indexed = Prelude.zip bits [0.."
->                                        . shows (nr_tokens - 1) . str "]\n"
->       . str "        token_strs_expected = Prelude.concatMap f bits_indexed\n"
->       . str "        f (Prelude.False, _) = []\n"
->       . str "        f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n"
+>       . str "{-# NOINLINE happyTokenStrings #-}\n"
+>       . 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
@@ -635,7 +627,7 @@ machinery to discard states in the parser...
 >       . (if ghc
 >              then str " x = happyTcHack x "
 >              else str " _ = ")
->       . mkAction (showInt state) default_act
+>       . mkAction default_act
 >       . str "\n\n"
 >
 >       where gotos = goto' ! state
@@ -649,7 +641,7 @@ machinery to discard states in the parser...
 >
 >             producePossiblyFailingAction t action'
 >               = actionFunction t
->               . mkAction (showInt state) action'
+>               . mkAction action'
 >               . str "\n"
 >
 >             produceGotos (t, Goto i)
@@ -750,15 +742,33 @@ action array indexed by (terminal * last_state) + state
 >
 >    table_size = length table - 1
 >
->    produceReduceArray
->       = {- str "happyReduceArr :: Array Int a\n" -}
+>    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 ("
 >               . 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
+>       | ghc
+>       = str "happyRuleArr :: HappyAddr\n"
+>       . str "happyRuleArr = HappyA# \"" -- "
+>       . hexChars (concatMap (\(nt,len) -> [nt,len]) ruleArrElems)
+>       . str "\"#\n\n" --"
+>       | otherwise
+>       = str "happyRuleArr :: Happy_Data_Array.Array Int (Int,Int)\n"
+>       . str "happyRuleArr = Happy_Data_Array.array ("
+>               . shows (n_starts :: Int) -- omit the %start reductions
+>               . str ", "
+>               . shows n_rules
+>               . str ") [\n"
+>       . interleave' ",\n" (zipWith showRuleArrElem [n_starts..n_rules] ruleArrElems)
+>       . str "\n\t]\n\n"
+>
+>    ruleArrElems = map (\(Production nt toks _code _prio) -> (nt-first_nonterm',length toks)) (drop n_starts prods)
 
 >    n_rules = length prods - 1 :: Int
 
@@ -922,9 +932,9 @@ directive determines the API of the provided function.
 >       str "(\\tokens explist resume -> " .
 >       (if use_monad then str ""
 >                     else str "HappyIdentity Prelude.$ ") .
->       str (case error_handler' of Just h -> h; Nothing -> "happyError") . str " " .
->       str (case (error_handler', lexer') of (Nothing, Just _) -> ""
->                                             _                 -> "tokens ") .
+>       (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 "
@@ -934,6 +944,10 @@ directive determines the API of the provided function.
 >    reduceArrElem n
 >      = str "\t(" . shows n . str " , "
 >      . str "happyReduce_" . shows n . char ')'
+>
+>    showRuleArrElem r (nt, len)
+>      = str "\t(" . shows r . str " , ("
+>      . shows nt . str "," . shows len . str ") )"
 
 -----------------------------------------------------------------------------
 -- Produce the parser entry and exit points
@@ -1042,13 +1056,13 @@ vars used in this piece of code.
 > actionVal LR'Fail             = 0
 > actionVal LR'MustFail         = 0
 
-> mkAction :: (String -> String) -> LRAction -> String -> String
-> mkAction _          (LR'Shift i _)       = str "happyShift " . mkActionName i
-> mkAction _          LR'Accept            = str "happyAccept"
-> mkAction show_state LR'Fail              = str "happyFail " . show_state
-> mkAction show_state LR'MustFail          = str "happyFail " . show_state
-> mkAction _          (LR'Reduce i _)      = str "happyReduce_" . shows i
-> mkAction show_state (LR'Multiple _ a)    = mkAction show_state a
+> mkAction :: LRAction -> String -> String
+> mkAction (LR'Shift i _)       = str "happyShift " . mkActionName i
+> mkAction LR'Accept            = str "happyAccept"
+> mkAction LR'Fail              = str "happyFail"
+> mkAction LR'MustFail          = str "happyFail"
+> mkAction (LR'Reduce i _)      = str "happyReduce_" . shows i
+> mkAction (LR'Multiple _ a)    = mkAction a
 
 > mkActionName :: Int -> String -> String
 > mkActionName i                = str "action_" . shows i

tests/monaderror-resume.y

@@ -10,7 +10,8 @@ import Data.Char
 import System.Exit
 }
 
-%name parseStmts
+%name parseStmts Stmts
+%name parseExp Exp
 %tokentype { Token }
 %errorresumptive          -- the entire point of this test
 %errorhandlertype explist -- as in monaderror-explist.y
@@ -29,7 +30,6 @@ Stmts : {- empty -}           { [] }
       | Stmt                  { [$1] }
       | Stmts ';' Stmt        { $1 ++ [$3] }
       | catch ';' Stmt %shift { [$3] } -- Could insert error AST token here in place of $1
-      | catch                 { [] }   -- Catch-all at the end
 
 Stmt : Exp { ExpStmt $1 }
 
@@ -98,12 +98,10 @@ main = do
   test "1+1;1" $ \(_,mb_ast) -> mb_ast == Just [ExpStmt (One `Plus` One), ExpStmt One]
   test "1++1;1" $ \(errs,_) -> errs == [ParseError ["'1'"]]
   test "1++1;+" $ \(errs,_) -> errs == [ParseError ["'1'"], ParseError ["'1'"]]
-  test "11;1" $ \(errs,_) -> errs == [ParseError []]
-    -- urgh, `Exp -> '1' .` is purely a reduction action.
-    -- We must walk the stack to get better messages
-  test "11;++" $ \(errs,_) -> errs == [ParseError [], ParseError ["'1'"]]
-    -- urgh, `Exp -> '1' .` is purely a reduction action.
-    -- We must walk the stack to get better messages
+  test "11;1" $ \(errs,_) -> errs == [ParseError ["';'"]]
+  test "11;++" $ \(errs,_) -> errs == [ParseError ["';'"], ParseError ["'1'"]]
+  test "11;1++" $ \(errs,_) -> errs == [ParseError ["';'"], ParseError ["'1'"]]
+  testExp "11" $ \(errs,_) -> errs == [ParseError ["'+'"]]
   where
     test inp p = do
       putStrLn $ "testing " ++ inp
@@ -112,4 +110,11 @@ main = do
       when (not (p res)) $ do
         print res
         exitWith (ExitFailure 1)
+    testExp inp p = do
+      putStrLn $ "testing Exp " ++ inp
+      let tokens = lexer inp
+      let res = runValidate $ parseExp tokens
+      when (not (p res)) $ do
+        print res
+        exitWith (ExitFailure 1)
 }