%shift pragma for lowest priority rules

doc/happy.xml

@@ -876,6 +876,25 @@ Exp   : let var '=' Exp in Exp  { Let $2 $4 $6 }
 	would normally be the precedence of '-') with the precedence
 	of <literal>NEG</literal>.</para>
       </sect2>
+
+      <sect2 id="shift-directive">
+        <title>The %shift directive for lowest precedence rules</title>
+        <para>
+          Rules annotated with the <literal>%shift</literal> directive
+          have the lowest possible precedence and are non-associative.
+          A shift/reduce conflict that involves such a rule is resolved as a shift.
+
+          One can think of <literal>%shift</literal> as
+          <literal>%prec SHIFT</literal> such that <literal>SHIFT</literal>
+          has lower precedence than any other token.
+        </para>
+        <para>
+          This is useful in conjunction with
+          <literal>%expect 0</literal> to explicitly point out all rules in the grammar that
+          result in conflicts, and thereby resolve such conflicts.
+        </para>
+      </sect2>
+
     </sect1>
 
     <sect1 id="sec-type-signatures">

happy.cabal

@@ -148,6 +148,7 @@ extra-source-files:
         tests/typeclass_monad002.ly
         tests/typeclass_monad_lexer.y
         tests/rank2.y
+        tests/shift01.y
 
 source-repository head
   type:     git

src/AbsSyn.lhs

@@ -12,7 +12,7 @@ Here is the abstract syntax of the language we parse.
 >       getImportedIdentity, getMonad, getError,
 >       getPrios, getPrioNames, getExpect, getErrorHandlerType,
 >       getAttributes, getAttributetype,
->       Rule(..), Prod(..), Term(..)
+>       Rule(..), Prod(..), Term(..), Prec(..)
 >  ) where
 
 > data AbsSyn
@@ -34,13 +34,17 @@ Here is the abstract syntax of the language we parse.
 >         [Term]               -- terms that make up the rule
 >         String               -- code body that runs when the rule reduces
 >         Int                  -- line number
->         (Maybe String)       -- inline precedence annotation for the rule
+>         Prec                 -- inline precedence annotation for the rule
 
 > data Term
 >     = App
 >         String               -- name of the term
 >         [Term]               -- parameter arguments (usually this is empty)
 
+> data Prec
+>     = PrecNone               -- no user-specified precedence
+>     | PrecShift              -- %shift
+>     | PrecId String          -- %prec ID
 
 
 #ifdef DEBUG

src/Grammar.lhs

@@ -106,7 +106,7 @@ Here is our mid-section datatype
 
 #endif
 
-> data Priority = No | Prio Assoc Int
+> data Priority = No | Prio Assoc Int | PrioLowest
 
 #ifdef DEBUG
 
@@ -283,17 +283,20 @@ Translate the rules from string to name-based.
 >                             return (Production nt lhs' code' No)
 >               Right p -> return (Production nt lhs' code' p)
 >
->       mkPrec :: [Name] -> Maybe String -> Either String Priority
->       mkPrec lhs prio =
->             case prio of
->               Nothing -> case filter (flip elem terminal_names) lhs of
+>       mkPrec :: [Name] -> Prec -> Either String Priority
+>       mkPrec lhs PrecNone =
+>         case filter (flip elem terminal_names) lhs of
 >                            [] -> Right No
 >                            xs -> case lookup (last xs) prios of
 >                                    Nothing -> Right No
 >                                    Just p  -> Right p
->               Just s -> case lookup s prioByString of
+>       mkPrec _ (PrecId s) =
+>         case lookup s prioByString of
 >                           Nothing -> Left s
 >                           Just p -> Right p
+>
+>       mkPrec _ PrecShift = Right PrioLowest
+>
 >   -- in
 
 >   rules1 <- mapM convNT rules

src/LALR.lhs

@@ -561,6 +561,9 @@ NOTE: on (LR'Multiple as a) handling
 >       res a@(LR'Shift {}) b@(LR'Reduce {}) = res b a
 >       res a@(LR'Reduce _ p) b@(LR'Shift _ p')
 >               = case (p,p') of
+>                      (PrioLowest,PrioLowest) -> LR'MustFail
+>                      (_,PrioLowest) -> a
+>                      (PrioLowest,_) -> b
 >                      (No,_) -> LR'Multiple [a] b      -- shift wins
 >                      (_,No) -> LR'Multiple [a] b      -- shift wins
 >                      (Prio c i, Prio _ j)
@@ -573,6 +576,10 @@ NOTE: on (LR'Multiple as a) handling
 >                                     None       -> LR'MustFail
 >       res a@(LR'Reduce r p) b@(LR'Reduce r' p')
 >               = case (p,p') of
+>                      (PrioLowest,PrioLowest) ->
+>                        LR'Multiple [a] b      -- give to earlier rule?
+>                      (_,PrioLowest) -> a
+>                      (PrioLowest,_) -> b
 >                      (No,_) -> LR'Multiple [a] b      -- give to earlier rule?
 >                      (_,No) -> LR'Multiple [a] b
 >                      (Prio _ i, Prio _ j)

src/Lexer.lhs

@@ -45,6 +45,7 @@ The lexer.
 >       | TokSpecId_Left        -- %left
 >       | TokSpecId_Right       -- %right
 >       | TokSpecId_Prec        -- %prec
+>       | TokSpecId_Shift       -- %shift
 >       | TokSpecId_Expect      -- %expect
 >       | TokSpecId_Error       -- %error
 >       | TokSpecId_Attributetype -- %attributetype
@@ -132,6 +133,8 @@ followed by a special identifier.
 >               returnToken cont (TokenKW TokSpecId_Right) rest
 >       'p':'r':'e':'c':rest ->
 >               returnToken cont (TokenKW TokSpecId_Prec) rest
+>       's':'h':'i':'f':'t':rest ->
+>               returnToken cont (TokenKW TokSpecId_Shift) rest
 >       'e':'x':'p':'e':'c':'t':rest ->
 >               returnToken cont (TokenKW TokSpecId_Expect) rest
 >       'e':'r':'r':'o':'r':'h':'a':'n':'d':'l':'e':'r':'t':'y':'p':'e':rest ->

src/ParamRules.hs

@@ -27,7 +27,7 @@ newtype Funs  = Funs (M.Map RuleName Rule)
 data Rule1    = Rule1 RuleName [Prod1] (Maybe (String, Subst))
 
 -- | Similar to 'Prod', but `Term`'s have been flattened into `RuleName`'s
-data Prod1    = Prod1 [RuleName] String Int (Maybe String)
+data Prod1    = Prod1 [RuleName] String Int Prec
 
 inst_name :: Inst -> RuleName
 inst_name (Inst f [])  = f

src/Parser.ly

@@ -29,6 +29,7 @@ The parser.
 >       spec_left       { TokenKW      TokSpecId_Left }
 >       spec_right      { TokenKW      TokSpecId_Right }
 >       spec_prec       { TokenKW      TokSpecId_Prec }
+>       spec_shift      { TokenKW      TokSpecId_Shift }
 >       spec_expect     { TokenKW      TokSpecId_Expect }
 >       spec_error      { TokenKW      TokSpecId_Error }
 >       spec_errorhandlertype   { TokenKW      TokSpecId_ErrorHandlerType }
@@ -95,9 +96,10 @@ The parser.
 >       : term                           { [$1] }
 >       | comma_terms "," term           { $3 : $1 }
 
-> prec :: { Maybe String }
->       : spec_prec id                  { Just $2 }
->       |                               { Nothing }
+> prec :: { Prec }
+>       : spec_prec id                  { PrecId $2 }
+>       | spec_shift                    { PrecShift }
+>       |                               { PrecNone }
 
 > tokInfos :: { [Directive String] } 
 >       : tokInfos tokInfo              { $2 : $1 }

src/PrettyGrammar.hs

@@ -29,10 +29,14 @@ ppRule (Rule name _ prods _) = text name
   starts = text "  :" : repeat (text "  |")
 
 ppProd :: Prod -> Doc
-ppProd (Prod ts _ _ p) = psDoc <+> precDoc
+ppProd (Prod ts _ _ p) = psDoc <+> ppPrec p
   where
   psDoc   = if null ts then text "{- empty -}" else hsep (map ppTerm ts)
-  precDoc = maybe empty (\x -> text "%prec" <+> text x) p
+
+ppPrec :: Prec -> Doc
+ppPrec PrecNone   = empty
+ppPrec PrecShift  = text "%shift"
+ppPrec (PrecId x) = text "%prec" <+> text x
 
 ppTerm :: Term -> Doc
 ppTerm (App x ts) = text x <> ppTuple (map ppTerm ts)

tests/Makefile

@@ -29,7 +29,7 @@ TESTS = Test.ly TestMulti.ly TestPrecedence.ly bug001.ly \
 	AttrGrammar001.y AttrGrammar002.y \
 	test_rules.y monaderror.y monaderror-explist.y \
 	typeclass_monad001.y typeclass_monad002.ly typeclass_monad_lexer.y \
-	rank2.y
+	rank2.y shift01.y
 
 ERROR_TESTS = error001.y
 

tests/shift01.y

@@ -0,0 +1,30 @@
+-- Testing the %shift directive
+
+{
+module Main where
+
+import System.IO
+import Data.Char
+}
+
+%expect 0    -- We must resolve the conflicts with %shift
+%name group_a
+%tokentype { Token }
+
+%token 'A' { A }
+
+%%
+exp : exp 'A'       %shift { $1 ++ ",A" }
+    | exp 'A' 'A'          { $1 ++ ",2A" }
+    |                      { "S" }
+
+{
+main =
+  if group_a [A, A, A] == "S,2A,A"
+    then return ()
+    else error "bad parse"
+
+data Token = A
+
+happyError _ = error "parse error"
+}