Pull attribute extra info out from the rest of the grammar

Only some backends support it

app/Main.lhs

@@ -82,7 +82,7 @@ Parse, using bootstrapping parser.
 
 Mangle the syntax into something useful.
 
->       (g, common_options) <- case {-# SCC "Mangler" #-} mangler fl_name abssyn of
+>       (g, mAg, common_options) <- case {-# SCC "Mangler" #-} mangler fl_name abssyn of
 >               Left  s  -> die (unlines s ++ "\n")
 >               Right gd -> return gd
 
@@ -254,6 +254,7 @@ and generate the code.
 >           let
 >               outfile = produceParser
 >                           g
+>                           mAg
 >                           common_options
 >                           action
 >                           goto

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

@@ -29,6 +29,7 @@ The code generator.
 Produce the complete output file.
 
 > produceParser :: Grammar                      -- grammar info
+>               -> Maybe AttributeGrammarExtras
 >               -> Pragmas                      -- pragmas supplied in the .y-file
 >               -> ActionTable                  -- action table
 >               -> GotoTable                    -- goto table
@@ -50,9 +51,8 @@ Produce the complete output file.
 >               , token_names = token_names'
 >               , token_specs = token_rep
 >               , starts = starts'
->               , attributetype = attributetype'
->               , attributes = attributes'
 >               })
+>               mAg
 >               (Pragmas
 >               { lexer = lexer'
 >               , imported_identity = imported_identity'
@@ -77,7 +77,10 @@ Produce the complete output file.
 >       . produceMonadStuff
 >       . produceEntries
 >       . produceStrict strict
->       . produceAttributes attributes' attributetype' . nl
+>       . (case mAg of
+>            Nothing -> id
+>            Just ag -> produceAttributes ag)
+>       . nl
 >       . maybestr module_trailer . nl
 >       ) ""
 >  where
@@ -728,11 +731,13 @@ directive determines the API of the provided function.
 
 >    produceEntries
 >       = interleave "\n\n" (map produceEntry (zip starts' [0..]))
->       . if null attributes' then id else produceAttrEntries starts'
+>       . case mAg of
+>           Nothing -> id
+>           Just ag -> produceAttrEntries ag starts'
 
 >    produceEntry :: ((String, t0, Int, t1), Int) -> String -> String
 >    produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no)
->       = (if null attributes' then str name else str "do_" . str name)
+>       = (if isNothing mAg then str name else str "do_" . str name)
 >       . maybe_tks
 >       . str " = "
 >       . str unmonad
@@ -754,7 +759,7 @@ directive determines the API of the provided function.
 >       unmonad | use_monad = ""
 >                 | otherwise = "happyRunIdentity "
 
->    produceAttrEntries starts''
+>    produceAttrEntries ag starts''
 >       = interleave "\n\n" (map f starts'')
 >     where
 >       f = case (use_monad,lexer') of
@@ -763,7 +768,7 @@ directive determines the API of the provided function.
 >             (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer"
 >             (False,Nothing)-> \(name,_,_,_) -> regularAE name
 >
->       defaultAttr = fst (head attributes')
+>       defaultAttr = fst (head $ attributes ag)
 >
 >       monadAndLexerAE name
 >         = str name . str " = "
@@ -790,9 +795,11 @@ directive determines the API of the provided function.
 ----------------------------------------------------------------------------
 -- Produce attributes declaration for attribute grammars
 
-> produceAttributes :: [(String, String)] -> String -> String -> String
-> produceAttributes [] _ = id
-> produceAttributes attrs attributeType
+> produceAttributes :: AttributeGrammarExtras -> String -> String
+> produceAttributes AttributeGrammarExtras {
+>         attributes = attrs,
+>         attributetype = attributeType
+>     }
 >     = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl
 >     . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl
 

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

@@ -12,11 +12,11 @@ Here is the abstract syntax of the language we parse.
 >       getTokenType, getTokenSpec, getParserNames, getLexer,
 >       getImportedIdentity, getMonad, getError,
 >       getPrios, getPrioNames, getExpect, getErrorHandlerType,
->       getAttributes, getAttributetype,
+>       getAttributes, getAttributetype, getAttributeGrammarExtras,
 >       Rule(..), Prod(..), Term(..), Prec(..)
 >  ) where
 
-> import Happy.Grammar (ErrorHandlerType(..))
+> import Happy.Grammar (ErrorHandlerType(..), AttributeGrammarExtras(..))
 
 > data BookendedAbsSyn
 >     = BookendedAbsSyn
@@ -161,3 +161,12 @@ generate some error messages.
 >                  [t] -> Just t
 >                  []  -> Nothing
 >                  _   -> error "multiple attributetype directives"
+
+> getAttributeGrammarExtras :: [Directive t] -> Maybe AttributeGrammarExtras
+> getAttributeGrammarExtras ds = case (getAttributes ds, getAttributetype ds) of
+>   ([], Nothing) -> Nothing
+>   (as, Just at) -> Just $ AttributeGrammarExtras {
+>           attributes = as,
+>           attributetype = at
+>       }
+>   (_ : _, Nothing) -> error "attributes found without attribute type directive"

lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs

@@ -21,8 +21,8 @@ manipulation and let binding goop
 
 > import Control.Monad
 
-> rewriteAttributeGrammar :: [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
-> rewriteAttributeGrammar lhs nonterm_names code attrs =
+> rewriteAttributeGrammar :: [Name] -> [Name] -> String -> AttributeGrammarExtras -> M (String,[Int])
+> rewriteAttributeGrammar lhs nonterm_names code ag =
 
    first we need to parse the body of the code block
 
@@ -38,7 +38,7 @@ manipulation and let binding goop
 >                  , subRules :: [AgSubAssign]
 >                  , conditions :: [AgConditional]
 >                  ) = partitionRules [] [] [] rules
->                attrNames = map fst attrs
+>                attrNames = map fst $ attributes ag
 >                defaultAttr = head attrNames
 
    now check that $i references are in range

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

@@ -18,7 +18,6 @@ Mangler converts AbsSyn to Grammar
 > import Data.Array ( Array, (!), accumArray, array, listArray )
 > import Data.Char  ( isAlphaNum, isDigit, isLower )
 > import Data.List  ( zip4, sortBy )
-> import Data.Maybe ( fromMaybe )
 > import Data.Ord
 
 > import Control.Monad.Writer ( Writer, mapWriter, runWriter )
@@ -28,14 +27,20 @@ Mangler converts AbsSyn to Grammar
 
 This bit is a real mess, mainly because of the error message support.
 
-> mangler :: FilePath -> AbsSyn -> Either [ErrMsg] (Grammar, Pragmas)
-> mangler file abssyn
->   | null errs = Right gd
+> mangler :: FilePath -> AbsSyn -> Either [ErrMsg] (Grammar, Maybe AttributeGrammarExtras, Pragmas)
+> mangler file abssyn@(AbsSyn dirs _)
+>   | null errs = Right (gd, mAg, ps)
 >   | otherwise = Left errs
->   where (gd, errs) = runWriter (manglerM file abssyn)
-
-> manglerM :: FilePath -> AbsSyn -> M (Grammar, Pragmas)
-> manglerM file (AbsSyn dirs rules') =
+>   where mAg = getAttributeGrammarExtras dirs
+>         ((gd, ps), errs) = runWriter (manglerM (checkCode mAg) file abssyn)
+
+> manglerM
+>   :: ([Name] -> [Name] -> String -> M (String,[Int]))
+>   -- ^ Function to check elimination rules
+>   -> FilePath
+>   -> AbsSyn
+>   -> M (Grammar, Pragmas)
+> manglerM checkCode file (AbsSyn dirs rules') =
 >   -- add filename to all error messages
 >   mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do
 
@@ -129,17 +134,14 @@ Translate the rules from string to name-based.
 >         = do nt' <- mapToName nt
 >              return (nt', prods, ty)
 >
->       attrs = getAttributes dirs
->       attrType = fromMaybe "HappyAttrs" (getAttributetype dirs)
->
 >       transRule (nt, prods, _ty)
 >         = mapM (finishRule nt) prods
 >
 >       finishRule :: Name -> Prod1 -> Writer [ErrMsg] Production
 >       finishRule nt (Prod1 lhs code line prec)
 >         = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do
 >           lhs' <- mapM mapToName lhs
->           code' <- checkCode lhs' nonterm_names code attrs
+>           code' <- checkCode lhs' nonterm_names code
 >           case mkPrec lhs' prec of
 >               Left s  -> do addErr ("Undeclared precedence token: " ++ s)
 >                             return (Production nt lhs' code' No)
@@ -234,9 +236,7 @@ Get the token specs in terms of Names.
 >               first_nonterm     = first_nt,
 >               first_term        = first_t,
 >               eof_term          = last terminal_names,
->               priorities        = prios,
->               attributes        = attrs,
->               attributetype     = attrType
+>               priorities        = prios
 >       },
 >       Pragmas {
 >               imported_identity                 = getImportedIdentity dirs,
@@ -284,9 +284,9 @@ So is this.
 -- If any attribute directives were used, we are in an attribute grammar, so
 -- go do special processing.  If not, pass on to the regular processing routine
 
-> checkCode :: [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
-> checkCode lhs _             code []    = doCheckCode (length lhs) code
-> checkCode lhs nonterm_names code attrs = rewriteAttributeGrammar lhs nonterm_names code attrs
+> checkCode :: Maybe AttributeGrammarExtras -> [Name] -> [Name] -> String -> M (String,[Int])
+> checkCode Nothing  lhs _             code = doCheckCode (length lhs) code
+> checkCode (Just a) lhs nonterm_names code = rewriteAttributeGrammar lhs nonterm_names code a
 
 -----------------------------------------------------------------------------
 -- Check for every $i that i is <= the arity of the rule.

lib/grammar/src/Happy/Grammar.lhs

@@ -9,6 +9,7 @@ The Grammar data type.
 >       Name,
 >
 >       Production(..), Grammar(..),
+>       AttributeGrammarExtras(..),
 >       Priority(..),
 >       Assoc(..),
 >       Pragmas(..), ErrorHandlerType(..),
@@ -41,7 +42,11 @@ The Grammar data type.
 >               first_nonterm     :: Name,
 >               first_term        :: Name,
 >               eof_term          :: Name,
->               priorities        :: [(Name,Priority)],
+>               priorities        :: [(Name,Priority)]
+>       }
+
+> data AttributeGrammarExtras
+>       = AttributeGrammarExtras {
 >               attributes        :: [(String,String)],
 >               attributetype     :: String
 >       }