[project @ 2002-04-02 13:21:36 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcRules.lhs
index 7aefcac..cf2f5b0 100644 (file)
@@ -11,46 +11,23 @@ module TcRules ( tcIfaceRules, tcSourceRules ) where
 import HsSyn           ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys )
 import CoreSyn         ( CoreRule(..) )
 import RnHsSyn         ( RenamedRuleDecl )
-import HscTypes                ( PackageRuleBase )
 import TcHsSyn         ( TypecheckedRuleDecl, mkHsLet )
 import TcMonad
 import TcSimplify      ( tcSimplifyToDicts, tcSimplifyInferCheck )
 import TcMType         ( newTyVarTy )
 import TcType          ( tyVarsOfTypes, openTypeKind )
-import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar, tcDelay )
+import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar )
 import TcMonoType      ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
-import TcExpr          ( tcExpr )
-import TcEnv           ( RecTcEnv, tcExtendLocalValEnv, isLocalThing )
-import Rules           ( extendRuleBase )
-import Inst            ( LIE, plusLIEs, instToId )
-import Id              ( idName, idType, mkLocalId )
-import Module          ( Module )
-import List            ( partition )
+import TcExpr          ( tcMonoExpr )
+import TcEnv           ( tcExtendLocalValEnv, tcLookupId )
+import Inst            ( LIE, plusLIEs, emptyLIE, instToId )
+import Id              ( idType, mkLocalId )
 import Outputable
 \end{code}
 
 \begin{code}
-tcIfaceRules :: RecTcEnv -> PackageRuleBase -> Module -> [RenamedRuleDecl] 
-            -> TcM (PackageRuleBase, [TypecheckedRuleDecl])
-tcIfaceRules unf_env pkg_rule_base mod decls 
-  = tcDelay unf_env doc [] (
-       -- We need the recursive env because the built-in rules show up as
-       -- IfaceOut rules, sot they get typechecked by tcIfaceRules 
-       mapTc tcIfaceRule decls
-    )                          `thenTc` \ new_rules ->
-    let
-       (local_rules, imported_rules) = partition is_local new_rules
-       new_rule_base = foldl add pkg_rule_base imported_rules
-    in
-    returnTc (new_rule_base, local_rules)
-  where
-    doc = text "tcIfaceRules"
-    add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
-
-       -- When relinking this module from its interface-file decls
-       -- we'll have IfaceRules that are in fact local to this module
-    is_local (IfaceRuleOut n _) = isLocalThing mod n
-    is_local other             = True
+tcIfaceRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl]
+tcIfaceRules decls = mapTc tcIfaceRule decls
 
 tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
   -- No zonking necessary!
@@ -72,6 +49,11 @@ tcSourceRules decls
   = mapAndUnzipTc tcSourceRule decls   `thenTc` \ (lies, decls') ->
     returnTc (plusLIEs lies, decls')
 
+tcSourceRule (IfaceRuleOut fun rule)   -- Built-in rules come this way
+                                       -- if they are from the module being compiled
+  = tcLookupId fun                     `thenTc` \ fun' ->
+    returnTc (emptyLIE, IfaceRuleOut fun' rule)   
+
 tcSourceRule (HsRule name act vars lhs rhs src_loc)
   = tcAddSrcLoc src_loc                                $
     tcAddErrCtxt (ruleCtxt name)                       $
@@ -81,12 +63,12 @@ tcSourceRule (HsRule name act vars lhs rhs src_loc)
     tcAddScopedTyVars (collectRuleBndrSigTys vars) (
 
                -- Ditto forall'd variables
-       mapNF_Tc new_id vars                                    `thenNF_Tc` \ ids ->
-       tcExtendLocalValEnv [(idName id, id) | id <- ids]       $
+       mapNF_Tc new_id vars                            `thenNF_Tc` \ ids ->
+       tcExtendLocalValEnv ids                         $
        
                -- Now LHS and RHS
-       tcExpr lhs rule_ty                                      `thenTc` \ (lhs', lhs_lie) ->
-       tcExpr rhs rule_ty                                      `thenTc` \ (rhs', rhs_lie) ->
+       tcMonoExpr lhs rule_ty                          `thenTc` \ (lhs', lhs_lie) ->
+       tcMonoExpr rhs rule_ty                          `thenTc` \ (rhs', rhs_lie) ->
        
        returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
     )                                          `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->