[allow multiple rules in one declaration, METARULES pragma added
John Meacham <john@repetae.net>**20060425043900] hunk ./E/FromHs.hs 309
-convertRules tiData classHierarchy assumps dataTable hsDecls = concatMapM f hsDecls where
-    f pr@HsPragmaRules {} = do
-        let ce = convertE tiData classHierarchy assumps dataTable (hsDeclSrcLoc pr)
-        e1 <- ce (hsDeclLeftExpr pr)
-        e2 <- ce (hsDeclRightExpr pr)
+convertRules tiData classHierarchy assumps dataTable hsDecls = concatMapM g hsDecls where
+    g (HsPragmaRules rs) = mapM f rs
+    g _ = return []
+    f pr = do
+        let ce = convertE tiData classHierarchy assumps dataTable (hsRuleSrcLoc pr)
+        e1 <- ce (hsRuleLeftExpr pr)
+        e2 <- ce (hsRuleRightExpr pr)
hunk ./E/FromHs.hs 321
-            cs <- flip mapM [toTVr assumps (toName Val v) | (v,_) <- hsDeclFreeVars pr ] $ \tvr -> do
+            cs <- flip mapM [toTVr assumps (toName Val v) | (v,_) <- hsRuleFreeVars pr ] $ \tvr -> do
hunk ./E/FromHs.hs 331
-        return [(hsDeclString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)]
-    f _ = return []
+        return (hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)
hunk ./FrontEnd/HsParser.ly 58
->       PRAGMARULES { PragmaRules }
+>       PRAGMARULES { PragmaRules $$ }
hunk ./FrontEnd/HsParser.ly 299
-
-
->       | srcloc PRAGMARULES STRING mfreevars exp '=' exp PRAGMAEND
->                       { HsPragmaRules { hsDeclSrcLoc = $1, hsDeclString = $3, hsDeclFreeVars = $4, hsDeclLeftExpr = $5, hsDeclRightExpr = $7 } }
+>       | PRAGMARULES layout_on rules close PRAGMAEND
+>               { HsPragmaRules $ map (\x -> x { hsRuleIsMeta = $1 }) (reverse $3) }
hunk ./FrontEnd/HsParser.ly 305
+> rule :: { HsRule }
+>       : srcloc STRING mfreevars exp '=' exp
+>          { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6 } }
+
+> rules :: { [HsRule] }
+>       : rules optsemi rule  { $3 : $1 }
+>       | rule optsemi           { [$1] }
+
+
hunk ./FrontEnd/HsPretty.hs 260
+ppHsRule prules@HsRule {} = text (show (hsRuleString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest  where
+    vars = hsep (map ppHsTName $ hsRuleFreeVars prules)
+    rest = ppHsExp (hsRuleLeftExpr prules) <+> text "=" <+> ppHsExp (hsRuleRightExpr prules)
+
hunk ./FrontEnd/HsPretty.hs 265
-ppHsDecl prules@HsPragmaRules {} = text ("{-# RULES " ++ show (hsDeclString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest $$ text "#-}" where
-    vars = hsep (map ppHsTName $ hsDeclFreeVars prules)
-    rest = ppHsExp (hsDeclLeftExpr prules) <+> text "=" <+> ppHsExp (hsDeclRightExpr prules)
+ppHsDecl (HsPragmaRules rs@(HsRule { hsRuleIsMeta = False }:_)) = text "{-# RULES" $$ nest 4 (myVcat (map ppHsRule rs)) $$ text "#-}"
+ppHsDecl (HsPragmaRules rs@(HsRule { hsRuleIsMeta = True }:_)) = text "{-# METARULES" $$ nest 4 (myVcat (map ppHsRule rs)) $$ text "#-}"
+--ppHsDecl prules@HsPragmaRules {} = text ("{-# RULES " ++ show (hsDeclString prules)) <+> text "forall" <+> vars <+> text "." $$ nest 4 rest $$ text "#-}" where
+--    vars = hsep (map ppHsTName $ hsDeclFreeVars prules)
+--    rest = ppHsExp (hsDeclLeftExpr prules) <+> text "=" <+> ppHsExp (hsDeclRightExpr prules)
hunk ./FrontEnd/HsSyn.hs 145
-    srcLoc HsPragmaRules { hsDeclSrcLoc = sl } = sl
+    srcLoc (HsPragmaRules rs) = srcLoc rs
hunk ./FrontEnd/HsSyn.hs 155
+instance HasLocation HsRule where
+    srcLoc HsRule { hsRuleSrcLoc = sl } = sl
hunk ./FrontEnd/HsSyn.hs 177
-	 | HsPragmaRules { hsDeclUniq :: (Module,Int), hsDeclSrcLoc :: SrcLoc, hsDeclString :: String, hsDeclFreeVars :: [(HsName,Maybe HsType)], hsDeclLeftExpr :: HsExp, hsDeclRightExpr :: HsExp }
+	 | HsPragmaRules [HsRule]
hunk ./FrontEnd/HsSyn.hs 182
+
+data HsRule = HsRule {
+    hsRuleUniq :: (Module,Int),
+    hsRuleSrcLoc :: SrcLoc,
+    hsRuleIsMeta :: Bool,
+    hsRuleString :: String,
+    hsRuleFreeVars :: [(HsName,Maybe HsType)],
+    hsRuleLeftExpr :: HsExp,
+    hsRuleRightExpr :: HsExp
+    }
+  deriving(Data,Typeable,Eq,Show)
+
hunk ./FrontEnd/Infix.hs 143
-    prules@HsPragmaRules { hsDeclLeftExpr = e1, hsDeclRightExpr = e2} ->
-        prules { hsDeclLeftExpr = fst $ processExp infixMap e1, hsDeclRightExpr = fst $ processExp infixMap e2 }
+    HsPragmaRules rs -> HsPragmaRules $ map proc_rule rs
hunk ./FrontEnd/Infix.hs 147
+        proc_rule prules@HsRule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2} =
+             prules { hsRuleLeftExpr = fst $ processExp infixMap e1, hsRuleRightExpr = fst $ processExp infixMap e2 }
hunk ./FrontEnd/Lexer.hs 43
-        | PragmaRules
+        | PragmaRules Bool
hunk ./FrontEnd/Lexer.hs 606
-    (["RULES"],PragmaRules),
+    (["RULES"],PragmaRules False),
+    (["METARULES"],PragmaRules True),
hunk ./FrontEnd/Rename.hs 373
-renameHsDecl prules@HsPragmaRules { hsDeclSrcLoc = srcLoc, hsDeclFreeVars = fvs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2 } subTable = do
-    setSrcLoc srcLoc
-    subTable' <- updateSubTableWithHsNames subTable (fsts fvs)
-    subTable'' <- updateSubTableWithHsTypes subTable (catMaybes $ snds fvs)
-    fvs' <- sequence [ liftM2 (,) (renameAny x subTable') (renameAny y subTable'')| (x,y) <- fvs]
-    e1' <- renameHsExp e1 subTable'
-    e2' <- renameHsExp e2 subTable'
-    m <- getCurrentModule
-    i <- newUniq
-    return prules {  hsDeclUniq = (m,i), hsDeclFreeVars = fvs', hsDeclLeftExpr = e1', hsDeclRightExpr = e2' }
+renameHsDecl (HsPragmaRules rs) subTable = do
+    rs' <- mapM (`renameHsRule` subTable) rs
+    return $ HsPragmaRules rs'
hunk ./FrontEnd/Rename.hs 386
+renameHsRule prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } subTable = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsNames subTable (fsts fvs)
+    subTable'' <- updateSubTableWithHsTypes subTable (catMaybes $ snds fvs)
+    fvs' <- sequence [ liftM2 (,) (renameAny x subTable') (renameAny y subTable'')| (x,y) <- fvs]
+    e1' <- renameHsExp e1 subTable'
+    e2' <- renameHsExp e2 subTable'
+    m <- getCurrentModule
+    i <- newUniq
+    return prules {  hsRuleUniq = (m,i), hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }
hunk ./FrontEnd/Tc/Main.hs 553
+tcPragmaDecl (HsPragmaRules rs) = do
+    rs' <- mapM tcRule rs
+    return [HsPragmaRules rs']
hunk ./FrontEnd/Tc/Main.hs 557
-tcPragmaDecl prule@HsPragmaRules { hsDeclUniq = uniq, hsDeclFreeVars = vs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2, hsDeclSrcLoc = sloc } =
-    withContext (locMsg sloc "in the RULES pragma" $ hsDeclString prule) ans where
+
+tcPragmaDecl fd@(HsForeignDecl _ _ _ _ n qt) = do
+    kt <- getKindEnv
+    s <- hsQualTypeToSigma kt qt
+    addToCollectedEnv (Map.singleton (toName Val n) s)
+    return [fd]
+
+tcPragmaDecl _ = return []
+
+tcRule prule@HsRule { hsRuleUniq = uniq, hsRuleFreeVars = vs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2, hsRuleSrcLoc = sloc } =
+    withContext (locMsg sloc "in the RULES pragma" $ hsRuleString prule) ans where
hunk ./FrontEnd/Tc/Main.hs 590
-            return [prule { hsDeclLeftExpr = e1, hsDeclRightExpr = e2 }]
+            return prule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2 }
hunk ./FrontEnd/Tc/Main.hs 603
-tcPragmaDecl fd@(HsForeignDecl _ _ _ _ n qt) = do
-    kt <- getKindEnv
-    s <- hsQualTypeToSigma kt qt
-    addToCollectedEnv (Map.singleton (toName Val n) s)
-    return [fd]
-
-tcPragmaDecl _ = return []
-
hunk ./FrontEnd/TypeSyns.hs 145
-renameHsDecl prules@HsPragmaRules { hsDeclSrcLoc = srcLoc, hsDeclFreeVars = fvs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2 } subTable = withSrcLoc srcLoc $ do
-    fvs' <- sequence [ fmapM (`renameHsType` subTable) t  >>= return . (,) n | (n,t) <- fvs]
-    e1' <- renameHsExp e1 subTable
-    e2' <- renameHsExp e2 subTable
-    return prules {  hsDeclFreeVars = fvs', hsDeclLeftExpr = e1', hsDeclRightExpr = e2' }
+renameHsDecl (HsPragmaRules rs) subTable = do
+    rs' <- mapM (`renameHsRule` subTable) rs
+    return $ HsPragmaRules rs'
hunk ./FrontEnd/TypeSyns.hs 154
+renameHsRule prules@HsRule { hsRuleSrcLoc = srcLoc, hsRuleFreeVars = fvs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } subTable = withSrcLoc srcLoc $ do
+    fvs' <- sequence [ fmapM (`renameHsType` subTable) t  >>= return . (,) n | (n,t) <- fvs]
+    e1' <- renameHsExp e1 subTable
+    e2' <- renameHsExp e2 subTable
+    return prules {  hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }
+