From 52a2cb2ca848411dedfa536af62db4de54386070 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 13 Sep 2024 16:47:27 -0400 Subject: [PATCH] Pull attribute extra info out from the rest of the grammar Only some backends support it --- app/Main.lhs | 3 +- .../src/Happy/Backend/LALR/ProduceCode.lhs | 27 ++++++++------ lib/frontend/src/Happy/Frontend/AbsSyn.lhs | 13 +++++-- .../Happy/Frontend/AttrGrammar/Mangler.lhs | 6 ++-- lib/frontend/src/Happy/Frontend/Mangler.lhs | 36 +++++++++---------- lib/grammar/src/Happy/Grammar.lhs | 7 +++- 6 files changed, 57 insertions(+), 35 deletions(-) diff --git a/app/Main.lhs b/app/Main.lhs index 9dbe8c46..2d77a8fd 100644 --- a/app/Main.lhs +++ b/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 diff --git a/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index f074b6f2..71b3d4b2 100644 --- a/lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/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 diff --git a/lib/frontend/src/Happy/Frontend/AbsSyn.lhs b/lib/frontend/src/Happy/Frontend/AbsSyn.lhs index 888ee080..c02492e8 100644 --- a/lib/frontend/src/Happy/Frontend/AbsSyn.lhs +++ b/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" diff --git a/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs b/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs index 324bd485..50a11e8f 100644 --- a/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs +++ b/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 diff --git a/lib/frontend/src/Happy/Frontend/Mangler.lhs b/lib/frontend/src/Happy/Frontend/Mangler.lhs index 16b705b7..f8a0de19 100644 --- a/lib/frontend/src/Happy/Frontend/Mangler.lhs +++ b/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,9 +134,6 @@ 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 > @@ -139,7 +141,7 @@ Translate the rules from string to name-based. > 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. diff --git a/lib/grammar/src/Happy/Grammar.lhs b/lib/grammar/src/Happy/Grammar.lhs index dbbb6a4a..e27b4ebd 100644 --- a/lib/grammar/src/Happy/Grammar.lhs +++ b/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 > }