[project @ 2001-08-28 10:06:29 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 69d462b..d041fc9 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -15,17 +15,16 @@ import HscTypes             ( PackageRuleBase )
 import TcHsSyn         ( TypecheckedRuleDecl, mkHsLet )
 import TcMonad
 import TcSimplify      ( tcSimplifyToDicts, tcSimplifyInferCheck )
-import TcType          ( zonkTcTyVarToTyVar, newTyVarTy )
+import TcMType         ( newTyVarTy )
+import TcType          ( tyVarsOfTypes, openTypeKind )
 import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar )
-import TcMonoType      ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
+import TcMonoType      ( kcHsSigTypes, tcHsSigType, UserTypeCtxt(..), tcScopedTyVars )
 import TcExpr          ( tcExpr )
-import TcEnv           ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
+import TcEnv           ( tcExtendLocalValEnv, isLocalThing )
 import Rules           ( extendRuleBase )
 import Inst            ( LIE, plusLIEs, instToId )
-import Id              ( idName, mkVanillaId )
+import Id              ( idName, idType, mkLocalId )
 import Module          ( Module )
-import VarSet
-import Type            ( tyVarsOfType, openTypeKind )
 import List            ( partition )
 import Outputable
 \end{code}
@@ -74,8 +73,7 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
     newTyVarTy openTypeKind                            `thenNF_Tc` \ rule_ty ->
 
        -- Deal with the tyvars mentioned in signatures
-    tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys)      `thenTc` \ sig_tyvars ->
-    tcExtendTyVarEnv sig_tyvars (
+    tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys)      (
 
                -- Ditto forall'd variables
        mapNF_Tc new_id vars                                    `thenNF_Tc` \ ids ->
@@ -85,12 +83,11 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
        tcExpr lhs rule_ty                                      `thenTc` \ (lhs', lhs_lie) ->
        tcExpr rhs rule_ty                                      `thenTc` \ (rhs', rhs_lie) ->
        
-       returnTc (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie)
-    )                                          `thenTc` \ (sig_tyvars, ids, lhs', rhs', lhs_lie, rhs_lie) ->
+       returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
+    )                                          `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
 
                -- Check that LHS has no overloading at all
     tcSimplifyToDicts lhs_lie                  `thenTc` \ (lhs_dicts, lhs_binds) ->
-    checkSigTyVars sig_tyvars emptyVarSet      `thenTc_`
 
        -- Gather the template variables and tyvars
     let
@@ -106,16 +103,29 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
        --      b) We'd like to make available the dictionaries bound 
        --         on the LHS in the RHS, so quantifying over them is good
        --         See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
+
+       -- We initially quantify over any tyvars free in *either* the rule
+       -- *or* the bound variables.  The latter is important.  Consider
+       --      ss (x,(y,z)) = (x,z)
+       --      RULE:  forall v. fst (ss v) = fst v
+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))
+       --
+       -- It's still conceivable that there may be type variables mentioned
+       -- 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 = tyVarsOfTypes (rule_ty : map idType tpl_ids)
     in
 
        -- RHS can be a bit more lenient.  In particular,
        -- we let constant dictionaries etc float outwards
+       --
+       -- 
     tcSimplifyInferCheck (text "tcRule")
-                        (varSetElems (tyVarsOfType rule_ty))
-                        lhs_dicts rhs_lie      `thenTc` \ (forall_tvs', lie', rhs_binds) ->
+                        forall_tvs
+                        lhs_dicts rhs_lie      `thenTc` \ (forall_tvs1, lie', rhs_binds) ->
 
-    mapTc zonkTcTyVarToTyVar forall_tvs'               `thenTc` \ tvs ->
-    returnTc (lie', HsRule     name tvs
+    returnTc (lie', HsRule     name forall_tvs1
                                (map RuleBndr tpl_ids)  -- yuk
                                (mkHsLet lhs_binds lhs')
                                (mkHsLet rhs_binds rhs')
@@ -123,10 +133,10 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
   where
     sig_tys = [t | RuleBndrSig _ t <- vars]
 
-    new_id (RuleBndr var)         = newTyVarTy openTypeKind    `thenNF_Tc` \ ty ->
-                                    returnNF_Tc (mkVanillaId var ty)
-    new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
-                                    returnNF_Tc (mkVanillaId var ty)
+    new_id (RuleBndr var)         = newTyVarTy openTypeKind                    `thenNF_Tc` \ ty ->
+                                    returnNF_Tc (mkLocalId var 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") <+> 
                doubleQuotes (ptext name)