[project @ 2001-11-19 16:34:12 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRules.lhs

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index c7e77a9..7aefcac 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -8,39 +8,43 @@ module TcRules ( tcIfaceRules, tcSourceRules ) where
 
 #include "HsVersions.h"
 
-import HsSyn           ( RuleDecl(..), RuleBndr(..) )
+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 TcType          ( newTyVarTy )
-import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar )
-import TcMonoType      ( kcHsSigTypes, tcHsSigType, tcScopedTyVars, checkSigTyVars )
+import TcMType         ( newTyVarTy )
+import TcType          ( tyVarsOfTypes, openTypeKind )
+import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar, tcDelay )
+import TcMonoType      ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
 import TcExpr          ( tcExpr )
-import TcEnv           ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
+import TcEnv           ( RecTcEnv, tcExtendLocalValEnv, isLocalThing )
 import Rules           ( extendRuleBase )
 import Inst            ( LIE, plusLIEs, instToId )
 import Id              ( idName, idType, mkLocalId )
 import Module          ( Module )
-import VarSet
-import Type            ( tyVarsOfTypes, openTypeKind )
 import List            ( partition )
 import Outputable
 \end{code}
 
 \begin{code}
-tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl] 
+tcIfaceRules :: RecTcEnv -> PackageRuleBase -> Module -> [RenamedRuleDecl] 
             -> TcM (PackageRuleBase, [TypecheckedRuleDecl])
-tcIfaceRules pkg_rule_base mod decls 
-  = mapTc tcIfaceRule decls            `thenTc` \ new_rules ->
+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
@@ -50,31 +54,31 @@ tcIfaceRules pkg_rule_base mod decls
 
 tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
   -- No zonking necessary!
-tcIfaceRule rule@(IfaceRule name vars fun args rhs src_loc)
+tcIfaceRule (IfaceRule name act vars fun args rhs src_loc)
   = tcAddSrcLoc src_loc                $
     tcAddErrCtxt (ruleCtxt name)       $
     tcVar fun                          `thenTc` \ fun' ->
     tcCoreLamBndrs vars                        $ \ vars' ->
     mapTc tcCoreExpr args              `thenTc` \ args' ->
     tcCoreExpr rhs                     `thenTc` \ rhs' ->
-    let
-       new_rule :: TypecheckedRuleDecl
-       new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs')
-    in
-    returnTc new_rule
+    returnTc (IfaceRuleOut fun' (Rule name act vars' args' rhs'))
+
+tcIfaceRule (IfaceRuleOut fun rule)    -- Built-in rules come this way
+  = tcVar fun                          `thenTc` \ fun' ->
+    returnTc (IfaceRuleOut fun' rule)   
 
 tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
 tcSourceRules decls
   = mapAndUnzipTc tcSourceRule decls   `thenTc` \ (lies, decls') ->
     returnTc (plusLIEs lies, decls')
 
-tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
+tcSourceRule (HsRule name act vars lhs rhs src_loc)
   = tcAddSrcLoc src_loc                                $
     tcAddErrCtxt (ruleCtxt name)                       $
     newTyVarTy openTypeKind                            `thenNF_Tc` \ rule_ty ->
 
        -- Deal with the tyvars mentioned in signatures
-    tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys)      (
+    tcAddScopedTyVars (collectRuleBndrSigTys vars) (
 
                -- Ditto forall'd variables
        mapNF_Tc new_id vars                                    `thenNF_Tc` \ ids ->
@@ -115,7 +119,7 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
        -- in the LHS, but not in the type of the lhs, nor in the binders.
        -- They'll get zapped to (), but that's over-constraining really.
        -- Let's see if we get a problem.
-       forall_tvs = varSetElems (tyVarsOfTypes (rule_ty : map idType tpl_ids))
+       forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
     in
 
        -- RHS can be a bit more lenient.  In particular,
@@ -126,17 +130,15 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
                         forall_tvs
                         lhs_dicts rhs_lie      `thenTc` \ (forall_tvs1, lie', rhs_binds) ->
 
-    returnTc (lie', HsRule     name forall_tvs1
-                               (map RuleBndr tpl_ids)  -- yuk
+    returnTc (lie', HsRule     name act
+                               (map RuleBndr (forall_tvs1 ++ tpl_ids)) -- yuk
                                (mkHsLet lhs_binds lhs')
                                (mkHsLet rhs_binds rhs')
                                src_loc)
   where
-    sig_tys = [t | RuleBndrSig _ t <- vars]
-
-    new_id (RuleBndr var)         = newTyVarTy openTypeKind    `thenNF_Tc` \ ty ->
+    new_id (RuleBndr var)         = newTyVarTy openTypeKind                    `thenNF_Tc` \ ty ->
                                     returnNF_Tc (mkLocalId var ty)
-    new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
+    new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty       `thenTc` \ ty ->
                                     returnNF_Tc (mkLocalId var ty)
 
 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>