Merge pull request #296 from haskell/less-partial

Get rid of some partiality in the attribute grammar mangler

lib/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 }

lib/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)
 
 -----------------------------------------------------------------

lib/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,23 @@ 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 (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
 
 >          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 +83,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,17 +96,16 @@ 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))
 >                                             (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
+>                      map     (\(MkAgSubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules
 
 >        subProductionRules = concat $ map formatSubRules prods
 
@@ -114,8 +120,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)

lib/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 )

lib/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.