[add rule creation and printing routines to E.Rules
John Meacham <john@repetae.net>**20060210021032] hunk ./E/Rules.hs 16
+    makeRule,
hunk ./E/Rules.hs 22
-import Data.Typeable
hunk ./E/Rules.hs 23
+import Data.Typeable
+import List
hunk ./E/Rules.hs 31
+import Doc.DocLike
+import Doc.PPrint
+import Doc.Pretty
hunk ./E/Rules.hs 38
-import Support.FreeVars
+import E.TypeCheck
hunk ./E/Rules.hs 40
-import Util.HasSize
hunk ./E/Rules.hs 43
+import qualified CharIO
hunk ./E/Rules.hs 45
+import Support.CanType
+import Support.FreeVars
+import Util.HasSize
hunk ./E/Rules.hs 121
-
+{-
hunk ./E/Rules.hs 126
-
+-}
hunk ./E/Rules.hs 129
+printRule Rule {ruleName = n, ruleBinds = vs, ruleBody = e2, ruleHead = head, ruleArgs = args } = do
+    let e1 = foldl EAp (EVar head) args
+    let p v = parens $ pprint v <> text "::" <> pprint (getType v)
+    putDocMLn CharIO.putStr $  (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "." <> text "\n"
+    let ty = pprint $ getType e1 -- case inferType dataTable [] e1 of
+        ty2 = pprint $ getType e2
+    putDocMLn CharIO.putStr (indent 2 (pprint e1))
+    putDocMLn CharIO.putStr $ text " ====>"
+    putDocMLn CharIO.putStr (indent 2 (pprint e2))
+    putDocMLn CharIO.putStr (indent 2 (text "::" <+> ty))
+    putDocMLn CharIO.putStr (indent 2 (text "::" <+> ty2))
+
hunk ./E/Rules.hs 209
+
+makeRule ::
+    String      -- ^ the rule name
+    -> [TVr]    -- ^ the free variables
+    -> TVr      -- ^ the head
+    -> [E]      -- ^ the args
+    -> E        -- ^ the body
+    -> Rules
+makeRule name fvs head args body = fromRules [rule] where
+    rule = emptyRule {  ruleHead = head, ruleBinds = fvs, ruleArgs = args, ruleNArgs = length args, ruleBody = body, ruleName = toAtom $ "Rule." ++ name }
+
hunk ./FrontEnd/Desugar.hs 37
-module FrontEnd.Desugar ( doToExp, desugarHsModule, desugarHsStmt) where
+module FrontEnd.Desugar ( doToExp, desugarHsModule, desugarHsStmt, desugarHsExp) where
hunk ./FrontEnd/Desugar.hs 154
+desugarHsExp :: Monad m => HsExp -> m HsExp
+desugarHsExp s = return $ fst $ runPatSM (0::Int, undefined) $ desugarExp s
+
+
hunk ./Main.hs 185
+    {-
hunk ./Main.hs 188
-        putStrLn $ render $  (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "." <> text "\n"
+        putDocM putStr $ (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "." <> text "\n"
hunk ./Main.hs 195
-        putStrLn (render $ indent 2 (pprint e1))
-        putStrLn $ text " ====>"
-        putStrLn (render $ indent 2 (pprint e2))
-        putStrLn (render $ indent 2 (text "::" <+> ty))
-        putStrLn (render $ indent 2 (text "::" <+> ty2))
+        putDocM putStr (indent 2 (pprint e1))
+        putDocM putStr $ text " ====>"
+        putDocM putStr (indent 2 (pprint e2))
+        putDocM putStr (indent 2 (text "::" <+> ty))
+        putDocM putStr (indent 2 (text "::" <+> ty2))
+        -}
+    let nrules = mconcat [ makeRule n vs head args e2 | (n,vs,e1,e2) <- rs, let (EVar head,args) = fromAp e1 ]
hunk ./Main.hs 208
-    rules <- createInstanceRules (hoClassHierarchy ho' `mappend` hoClassHierarchy initialHo)   (Map.fromList [ (x,(y,z)) | (x,y,z) <- ds] `mappend` hoEs ho)
+    rules' <- createInstanceRules (hoClassHierarchy ho' `mappend` hoClassHierarchy initialHo)   (Map.fromList [ (x,(y,z)) | (x,y,z) <- ds] `mappend` hoEs ho)
+    let rules = rules' `mappend` nrules
hunk ./Main.hs 691
+