Reduce the amount of CPP for attribute grammar support #257
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,143 @@ | ||
| /----------------------------------------------------------------------------- | ||
| Special processing for attribute grammars for the Mangler. We re-parse | ||
| the body of the code block and output the nasty-looking record | ||
| manipulation and let binding goop | ||
|
|
||
| (c) 1993-2001 Andy Gill, Simon Marlow | ||
| ----------------------------------------------------------------------------- | ||
|
|
||
| > module Happy.Frontend.AttrGrammar.Mangler (rewriteAttributeGrammar) where | ||
|
|
||
| > import Happy.Grammar | ||
| > import Happy.Frontend.ParseMonad.Class | ||
| > import Happy.Frontend.AttrGrammar | ||
| > import Happy.Frontend.AttrGrammar.Parser | ||
| > import Happy.Frontend.Mangler.Monad | ||
| > import Data.List ( findIndices, groupBy, intersperse, nub ) | ||
|
|
||
| > import Data.List ( sortBy ) | ||
| > import Data.Maybe ( fromMaybe ) | ||
|
|
||
| > import Control.Monad | ||
|
|
||
| > rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int]) | ||
| > rewriteAttributeGrammar arity lhs nonterm_names code attrs = | ||
|
|
||
| first we need to parse the body of the code block | ||
|
|
||
| > case runFromStartP agParser code 0 of | ||
| > Left msg -> do addErr ("error in attribute grammar rules: "++msg) | ||
| > return ("",[]) | ||
| > Right rules -> | ||
|
|
||
| now we break the rules into three lists, one for synthesized attributes, | ||
| one for inherited attributes, and one for conditionals | ||
|
|
||
| > let (selfRules,subRules,conditions) = partitionRules [] [] [] rules | ||
| > attrNames = map fst attrs | ||
| > defaultAttr = head attrNames | ||
|
|
||
| now check that $i references are in range | ||
|
|
||
| > in do let prods = mentionedProductions rules | ||
| > mapM_ checkArity prods | ||
|
|
||
| and output the rules | ||
|
|
||
| > rulesStr <- formatRules arity attrNames defaultAttr | ||
| > allSubProductions selfRules | ||
| > subRules conditions | ||
|
|
||
| return the munged code body and all sub-productions mentioned | ||
|
|
||
| > return (rulesStr,nub (allSubProductions++prods)) | ||
|
|
||
|
|
||
| > where partitionRules a b c [] = (a,b,c) | ||
| > partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (SubAssign (arity,attr) toks : b) c xs | ||
| > partitionRules a b c (x@(SelfAssign _ _ ) : xs) = partitionRules (x:a) b c xs | ||
| > partitionRules a b c (x@(SubAssign _ _) : xs) = partitionRules a (x:b) c xs | ||
| > partitionRules a b c (x@(Conditional _) : xs) = partitionRules a b (x:c) xs | ||
|
|
||
| > allSubProductions = map (+1) (findIndices (`elem` nonterm_names) lhs) | ||
|
|
||
| > mentionedProductions rules = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ] | ||
|
|
||
| > getTokens (SelfAssign _ toks) = toks | ||
| > getTokens (SubAssign _ toks) = toks | ||
| > getTokens (Conditional toks) = toks | ||
| > getTokens (RightmostAssign _ toks) = toks | ||
| > | ||
| > checkArity x = when (x > arity) $ addErr (show x++" out of range") | ||
|
|
||
|
|
||
| ------------------------------------------------------------------------------------ | ||
| -- Actually emit the code for the record bindings and conditionals | ||
| -- | ||
|
|
||
| > formatRules :: Int -> [String] -> String -> [Name] | ||
| > -> [AgRule] -> [AgRule] -> [AgRule] | ||
| > -> M String | ||
|
|
||
| > formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $ | ||
| > concat [ "\\happyInhAttrs -> let { " | ||
| > , "happySelfAttrs = happyInhAttrs",formattedSelfRules | ||
| > , subProductionRules | ||
| > , "; happyConditions = ", formattedConditions | ||
| > , " } in (happyConditions,happySelfAttrs)" | ||
| > ] | ||
| > | ||
| > where formattedSelfRules = case selfRules of [] -> []; _ -> "{ "++formattedSelfRules'++" }" | ||
| > formattedSelfRules' = concat $ intersperse ", " $ map formatSelfRule selfRules | ||
| > formatSelfRule (SelfAssign [] toks) = defaultAttr++" = "++(formatTokens toks) | ||
| > formatSelfRule (SelfAssign attr toks) = attr++" = "++(formatTokens toks) | ||
| > formatSelfRule _ = error "formatSelfRule: Not a self rule" | ||
|
|
||
| > subRulesMap :: [(Int,[(String,[AgToken])])] | ||
| > subRulesMap = map (\l -> foldr (\ (_,x) (i,xs) -> (i,x:xs)) | ||
| > (fst $ head l,[snd $ head l]) | ||
| > (tail l) ) . | ||
| > groupBy (\x y -> (fst x) == (fst y)) . | ||
| > sortBy (\x y -> compare (fst x) (fst y)) . | ||
| > map (\(SubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules | ||
|
|
||
| > subProductionRules = concat $ map formatSubRules prods | ||
|
|
||
| > formatSubRules i = | ||
| > let attrs = fromMaybe [] . lookup i $ subRulesMap | ||
| > attrUpdates' = concat $ intersperse ", " $ map (formatSubRule i) attrs | ||
| > attrUpdates = case attrUpdates' of [] -> []; x -> "{ "++x++" }" | ||
| > in concat ["; (happyConditions_",show i,",happySubAttrs_",show i,") = ",mkHappyVar i | ||
| > ," happyEmptyAttrs" | ||
| > , attrUpdates | ||
| > ] | ||
| > | ||
| > formattedConditions = concat $ intersperse " Prelude.++ " $ localConditions : (map (\i -> "happyConditions_"++(show i)) prods) | ||
| > localConditions = "["++(concat $ intersperse ", " $ map formatCondition conditions)++"]" | ||
| > formatCondition (Conditional toks) = formatTokens toks | ||
| > formatCondition _ = error "formatCondition: Not a condition" | ||
|
|
||
| > formatSubRule _ ([],toks) = defaultAttr++" = "++(formatTokens toks) | ||
| > formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks) | ||
|
|
||
| > formatTokens tokens = concat (map formatToken tokens) | ||
|
|
||
| > formatToken AgTok_LBrace = "{ " | ||
| > formatToken AgTok_RBrace = "} " | ||
| > formatToken AgTok_Where = "where " | ||
| > formatToken AgTok_Semicolon = "; " | ||
| > formatToken AgTok_Eq = "=" | ||
| > formatToken (AgTok_SelfRef []) = "("++defaultAttr++" happySelfAttrs) " | ||
| > formatToken (AgTok_SelfRef x) = "("++x++" happySelfAttrs) " | ||
| > formatToken (AgTok_RightmostRef x) = formatToken (AgTok_SubRef (arity,x)) | ||
| > formatToken (AgTok_SubRef (i,[])) | ||
| > | i `elem` prods = "("++defaultAttr++" happySubAttrs_"++(show i)++") " | ||
| > | otherwise = mkHappyVar i ++ " " | ||
| > formatToken (AgTok_SubRef (i,x)) | ||
| > | i `elem` prods = "("++x++" happySubAttrs_"++(show i)++") " | ||
| > | otherwise = error ("lhs "++(show i)++" is not a non-terminal") | ||
| > formatToken (AgTok_Unknown x) = x++" " | ||
| > formatToken AgTok_EOF = error "formatToken AgTok_EOF" | ||
|
|
||
| > mkHappyVar :: Int -> String | ||
| > mkHappyVar n = "happy_var_" ++ show n |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,22 @@ | ||
| ----------------------------------------------------------------------------- | ||
| Monad for error handling for the mangler | ||
|
|
||
| Pulled out so it can be shared with the attribute grammar part of the | ||
| mangler too. | ||
|
|
||
| (c) 1993-2001 Andy Gill, Simon Marlow | ||
| ----------------------------------------------------------------------------- | ||
|
|
||
| > module Happy.Frontend.Mangler.Monad | ||
| > ( ErrMsg | ||
| > , M | ||
| > , addErr | ||
| > ) where | ||
|
|
||
| > import Control.Monad.Writer ( Writer, MonadWriter(..) ) | ||
|
|
||
| > type ErrMsg = String | ||
| > type M a = Writer [ErrMsg] a | ||
|
|
||
| > addErr :: ErrMsg -> M () | ||
| > addErr e = tell [e] |
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Should mention the other behavioral thing this flag does.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
I would have the flag the other way round, so it would then be "Build a version of happy for boot-strapping. The generated binary will not have support for attribute grammars."
See #256 (comment).
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
It's going to be confusing either way because
bootstrapcan be interpreted either as "bootstrapped" or "for bootstrapping", which are opposite in meaning.Any ideas for a less ambiguous name?
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Well that is a preexisting issue; I am happy to change it but seems like it should be done separately. Does all the new things from this PR look good?