[project @ 2001-05-04 08:10:30 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 6a2a0b3..b8f5bb8 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -14,19 +14,18 @@ import RnHsSyn              ( RenamedRuleDecl )
 import HscTypes                ( PackageRuleBase )
 import TcHsSyn         ( TypecheckedRuleDecl, mkHsLet )
 import TcMonad
-import TcSimplify      ( tcSimplifyToDicts, tcSimplifyAndCheck )
-import TcType          ( zonkTcTypes, zonkTcTyVarToTyVar, newTyVarTy )
+import TcSimplify      ( tcSimplifyToDicts, tcSimplifyInferCheck )
+import TcType          ( zonkTcTyVarToTyVar, newTyVarTy )
 import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar )
 import TcMonoType      ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
 import TcExpr          ( tcExpr )
 import TcEnv           ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
 import Rules           ( extendRuleBase )
 import Inst            ( LIE, plusLIEs, instToId )
-import Id              ( idType, idName, mkVanillaId )
+import Id              ( idName, idType, mkLocalId )
 import Module          ( Module )
 import VarSet
 import Type            ( tyVarsOfTypes, openTypeKind )
-import Bag             ( bagToList )
 import List            ( partition )
 import Outputable
 \end{code}
@@ -51,15 +50,18 @@ tcIfaceRules pkg_rule_base mod decls
 
 tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
   -- No zonking necessary!
-tcIfaceRule (IfaceRule name vars fun args rhs src_loc)
+tcIfaceRule rule@(IfaceRule name 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' ->
-    returnTc (IfaceRuleOut fun' (Rule name vars' args' rhs'))
-
+    let
+       new_rule :: TypecheckedRuleDecl
+       new_rule = IfaceRuleOut fun' (Rule name vars' args' rhs')
+    in
+    returnTc new_rule
 
 tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
 tcSourceRules decls
@@ -87,12 +89,12 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
     )                                          `thenTc` \ (sig_tyvars, 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_`
+    tcSimplifyToDicts lhs_lie                  `thenTc` \ (lhs_dicts, lhs_binds) ->
+    checkSigTyVars sig_tyvars emptyVarSet      `thenTc_`
 
        -- Gather the template variables and tyvars
     let
-       tpl_ids = map instToId (bagToList lhs_dicts) ++ ids
+       tpl_ids = map instToId lhs_dicts ++ ids
 
        -- IMPORTANT!  We *quantify* over any dicts that appear in the LHS
        -- Reason: 
@@ -104,19 +106,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
-    in
 
-       -- Gather type variables to quantify over
-       -- and turn them into real TyVars (just as in TcBinds.tcBindWithSigs)
-    zonkTcTypes (rule_ty : map idType tpl_ids)                         `thenNF_Tc` \ zonked_tys ->
-    mapTc zonkTcTyVarToTyVar (varSetElems (tyVarsOfTypes zonked_tys))  `thenTc` \ tvs ->
+       -- 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 = varSetElems (tyVarsOfTypes (rule_ty : map idType tpl_ids))
+    in
 
        -- RHS can be a bit more lenient.  In particular,
        -- we let constant dictionaries etc float outwards
-    tcSimplifyAndCheck (text "tcRule") (mkVarSet tvs)
-                      lhs_dicts rhs_lie                `thenTc` \ (lie', rhs_binds) ->
+       --
+       -- 
+    tcSimplifyInferCheck (text "tcRule")
+                        forall_tvs
+                        lhs_dicts rhs_lie      `thenTc` \ (forall_tvs1, lie', rhs_binds) ->
 
-    returnTc (lie', HsRule     name tvs
+    returnTc (lie', HsRule     name forall_tvs1
                                (map RuleBndr tpl_ids)  -- yuk
                                (mkHsLet lhs_binds lhs')
                                (mkHsLet rhs_binds rhs')
@@ -125,9 +137,9 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
     sig_tys = [t | RuleBndrSig _ t <- vars]
 
     new_id (RuleBndr var)         = newTyVarTy openTypeKind    `thenNF_Tc` \ ty ->
-                                    returnNF_Tc (mkVanillaId var ty)
+                                    returnNF_Tc (mkLocalId var ty)
     new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
-                                    returnNF_Tc (mkVanillaId var ty)
+                                    returnNF_Tc (mkLocalId var ty)
 
 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> 
                doubleQuotes (ptext name)