From e3579a539e61c95951f3b6730f8c76cb3c49194f Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 13 Sep 2024 12:43:46 -0400 Subject: [PATCH 1/2] Get rid of some partiality in the attribute grammar mangler --- .../frontend/boot-src/AttrGrammarParser.ly | 6 +-- .../src/Happy/Frontend/AttrGrammar.lhs | 26 +++++++++-- .../Happy/Frontend/AttrGrammar/Mangler.lhs | 46 +++++++++++-------- .../src/Happy/Frontend/AttrGrammar/Parser.hs | 6 +-- .../frontend/src/Happy/Frontend/Mangler.lhs | 8 ++-- 5 files changed, 60 insertions(+), 32 deletions(-) diff --git a/packages/frontend/boot-src/AttrGrammarParser.ly b/packages/frontend/boot-src/AttrGrammarParser.ly index 50f7f240..28b048a0 100644 --- a/packages/frontend/boot-src/AttrGrammarParser.ly +++ b/packages/frontend/boot-src/AttrGrammarParser.ly @@ -39,10 +39,10 @@ or a conditional statement. > | { [] } > rule :: { AgRule } -> : selfRef "=" code { SelfAssign (selfRefVal $1) $3 } -> | subRef "=" code { SubAssign (subRefVal $1) $3 } +> : selfRef "=" code { SelfAssign $ MkAgSelfAssign (selfRefVal $1) $3 } +> | subRef "=" code { SubAssign $ MkAgSubAssign (subRefVal $1) $3 } > | rightRef "=" code { RightmostAssign (rightRefVal $1) $3 } -> | where code { Conditional $2 } +> | where code { Conditional $ MkAgConditional $2 } > code :: { [AgToken] } > : "{" code0 "}" code { [$1] ++ $2 ++ [$3] ++ $4 } diff --git a/packages/frontend/src/Happy/Frontend/AttrGrammar.lhs b/packages/frontend/src/Happy/Frontend/AttrGrammar.lhs index ac5d100d..5bd203a0 100644 --- a/packages/frontend/src/Happy/Frontend/AttrGrammar.lhs +++ b/packages/frontend/src/Happy/Frontend/AttrGrammar.lhs @@ -1,6 +1,12 @@ > module Happy.Frontend.AttrGrammar > ( AgToken (..) + > , AgRule (..) + +> , AgSelfAssign(..) +> , AgSubAssign(..) +> , AgConditional(..) + > , HasLexer (..) > , agLexAll > , subRefVal @@ -35,10 +41,24 @@ > rightRefVal _ = error "rightRefVal: Bad value" > data AgRule -> = SelfAssign String [AgToken] -> | SubAssign (Int,String) [AgToken] +> = SelfAssign AgSelfAssign +> | SubAssign AgSubAssign > | RightmostAssign String [AgToken] -> | Conditional [AgToken] +> -- ^ Syntactic sugar +> | Conditional AgConditional +> deriving (Show,Eq,Ord) + +We will partition the rule types and handle them separately, so we want +a separate data type for each core rule type. We don't need one for +`RightmostAssign` because it is syntactic sugar. + +> data AgSelfAssign = MkAgSelfAssign String [AgToken] +> deriving (Show,Eq,Ord) + +> data AgSubAssign = MkAgSubAssign (Int, String) [AgToken] +> deriving (Show,Eq,Ord) + +> data AgConditional = MkAgConditional [AgToken] > deriving (Show,Eq,Ord) ----------------------------------------------------------------- diff --git a/packages/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs b/packages/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs index 5f0d0a2a..01406b20 100644 --- a/packages/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs +++ b/packages/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs @@ -6,6 +6,7 @@ manipulation and let binding goop (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- +> {-# LANGUAGE PatternSignatures #-} > module Happy.Frontend.AttrGrammar.Mangler (rewriteAttributeGrammar) where > import Happy.Grammar @@ -20,8 +21,8 @@ manipulation and let binding goop > import Control.Monad -> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int]) -> rewriteAttributeGrammar arity lhs nonterm_names code attrs = +> rewriteAttributeGrammar :: [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int]) +> rewriteAttributeGrammar lhs nonterm_names code attrs = first we need to parse the body of the code block @@ -33,7 +34,10 @@ manipulation and let binding goop 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 +> let ( selfRules :: [AgSelfAssign] +> , subRules :: [AgSubAssign] +> , conditions :: [AgConditional] +> ) = partitionRules [] [] [] rules > attrNames = map fst attrs > defaultAttr = head attrNames @@ -53,20 +57,26 @@ manipulation and let binding goop > 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 +> where arity = length lhs + +> partitionRules a b c [] = (a,b,c) +> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules +> a +> (MkAgSubAssign (arity,attr) toks : b) +> c +> xs +> partitionRules a b c (SelfAssign x : xs) = partitionRules (x:a) b c xs +> partitionRules a b c (SubAssign x : xs) = partitionRules a (x:b) c xs +> partitionRules a b c (Conditional x : 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 +> getTokens (SelfAssign (MkAgSelfAssign _ toks)) = toks +> getTokens (SubAssign (MkAgSubAssign _ toks)) = toks +> getTokens (Conditional (MkAgConditional toks)) = toks +> getTokens (RightmostAssign _ toks) = toks > > checkArity x = when (x > arity) $ addErr (show x++" out of range") @@ -76,7 +86,7 @@ manipulation and let binding goop -- > formatRules :: Int -> [String] -> String -> [Name] -> -> [AgRule] -> [AgRule] -> [AgRule] +> -> [AgSelfAssign] -> [AgSubAssign] -> [AgConditional] > -> M String > formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $ @@ -89,9 +99,8 @@ manipulation and let binding goop > > 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" +> formatSelfRule (MkAgSelfAssign [] toks) = defaultAttr++" = "++(formatTokens toks) +> formatSelfRule (MkAgSelfAssign attr toks) = attr++" = "++(formatTokens toks) > subRulesMap :: [(Int,[(String,[AgToken])])] > subRulesMap = map (\l -> foldr (\ (_,x) (i,xs) -> (i,x:xs)) @@ -99,7 +108,7 @@ manipulation and let binding goop > (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 +> map (\(MkAgSubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules > subProductionRules = concat $ map formatSubRules prods @@ -114,8 +123,7 @@ manipulation and let binding goop > > 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" +> formatCondition (MkAgConditional toks) = formatTokens toks > formatSubRule _ ([],toks) = defaultAttr++" = "++(formatTokens toks) > formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks) diff --git a/packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.hs b/packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.hs index 2a930f5c..437fd960 100644 --- a/packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.hs +++ b/packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.hs @@ -169,7 +169,7 @@ happyReduction_5 happy_x_3 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut7 happy_x_3 of { (HappyWrap7 happy_var_3) -> happyIn6 - (SelfAssign (selfRefVal happy_var_1) happy_var_3 + (SelfAssign $ MkAgSelfAssign (selfRefVal happy_var_1) happy_var_3 )}} happyReduce_6 :: () => Happy_GHC_Exts.Int# -> AgToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -180,7 +180,7 @@ happyReduction_6 happy_x_3 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut7 happy_x_3 of { (HappyWrap7 happy_var_3) -> happyIn6 - (SubAssign (subRefVal happy_var_1) happy_var_3 + (SubAssign $ MkAgSubAssign (subRefVal happy_var_1) happy_var_3 )}} happyReduce_7 :: () => Happy_GHC_Exts.Int# -> AgToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) @@ -200,7 +200,7 @@ happyReduction_8 happy_x_2 happy_x_1 = case happyOut7 happy_x_2 of { (HappyWrap7 happy_var_2) -> happyIn6 - (Conditional happy_var_2 + (Conditional $ MkAgConditional happy_var_2 )} happyReduce_9 :: () => Happy_GHC_Exts.Int# -> AgToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) diff --git a/packages/frontend/src/Happy/Frontend/Mangler.lhs b/packages/frontend/src/Happy/Frontend/Mangler.lhs index 625a27bf..f5fd59e3 100644 --- a/packages/frontend/src/Happy/Frontend/Mangler.lhs +++ b/packages/frontend/src/Happy/Frontend/Mangler.lhs @@ -139,7 +139,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 (length lhs) lhs' nonterm_names code attrs +> code' <- checkCode lhs' nonterm_names code attrs > case mkPrec lhs' prec of > Left s -> do addErr ("Undeclared precedence token: " ++ s) > return (Production nt lhs' code' No) @@ -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 :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int]) -> checkCode arity _ _ code [] = doCheckCode arity code -> checkCode arity lhs nonterm_names code attrs = rewriteAttributeGrammar arity lhs nonterm_names code attrs +> 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 ----------------------------------------------------------------------------- -- Check for every $i that i is <= the arity of the rule. From f0cbec9662ec575e773111201506df85c498e3a3 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 16 Sep 2024 11:18:08 -0400 Subject: [PATCH 2/2] Fix alignment --- lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs | 7 ++----- lib/frontend/src/Happy/Frontend/Mangler.lhs | 2 +- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs b/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs index 01406b20..c223cc1e 100644 --- a/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs +++ b/lib/frontend/src/Happy/Frontend/AttrGrammar/Mangler.lhs @@ -60,11 +60,8 @@ manipulation and let binding goop > where arity = length lhs > partitionRules a b c [] = (a,b,c) -> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules -> a -> (MkAgSubAssign (arity,attr) toks : b) -> c -> xs +> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (x:b) c xs +> where x = MkAgSubAssign (arity,attr) toks > partitionRules a b c (SelfAssign x : xs) = partitionRules (x:a) b c xs > partitionRules a b c (SubAssign x : xs) = partitionRules a (x:b) c xs > partitionRules a b c (Conditional x : xs) = partitionRules a b (x:c) xs diff --git a/lib/frontend/src/Happy/Frontend/Mangler.lhs b/lib/frontend/src/Happy/Frontend/Mangler.lhs index f5fd59e3..16b705b7 100644 --- a/lib/frontend/src/Happy/Frontend/Mangler.lhs +++ b/lib/frontend/src/Happy/Frontend/Mangler.lhs @@ -285,7 +285,7 @@ So is this. -- 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 _ code [] = doCheckCode (length lhs) code > checkCode lhs nonterm_names code attrs = rewriteAttributeGrammar lhs nonterm_names code attrs -----------------------------------------------------------------------------