[project @ 2004-10-11 16:16:20 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index c038f7e..625bd12 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -22,7 +22,7 @@ import Name           ( Name )
 import TcSimplify      ( tcSimplifyCheck, bindInstsOfLocalFuns )
 import TcEnv           ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv,
                          tcLookupClass, tcLookupDataCon, tcLookupId )
-import TcMType                 ( newTyFlexiVarTy, arityErr, tcSkolTyVars, isRigidType )
+import TcMType                 ( newTyFlexiVarTy, arityErr, tcSkolTyVars )
 import TcType          ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
                          SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar, 
                          mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
@@ -385,15 +385,18 @@ tcConPat ctxt data_con tycon ty_args arg_pats thing_inside
              arg_tys' = substTys tenv arg_tys
              res_tys' = substTys tenv res_tys
        ; dicts <- newDicts (SigOrigin rigid_info) theta'
-       ; tcInstStupidTheta data_con tv_tys'
 
        -- Do type refinement!
        ; traceTc (text "tcGadtPat" <+> vcat [ppr data_con, ppr tvs', ppr arg_tys', ppr res_tys', 
                                              text "ty-args:" <+> ppr ty_args ])
        ; refineAlt ctxt data_con tvs' ty_args res_tys' $ do    
 
-       { ((arg_pats', inner_tvs, res), lie_req) 
-               <- getLIE (tcConArgs ctxt data_con arg_pats arg_tys' thing_inside)
+       { ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
+               do { tcInstStupidTheta data_con tv_tys'
+                       -- The stupid-theta mentions the newly-bound tyvars, so
+                       -- it must live inside the getLIE, so that the
+                       --  tcSimplifyCheck will apply the type refinement to it
+                  ; tcConArgs ctxt data_con arg_pats arg_tys' thing_inside }
 
        ; dict_binds <- tcSimplifyCheck doc tvs' dicts lie_req
 
@@ -492,8 +495,8 @@ refineAlt ctxt con ex_tvs ctxt_tys pat_tys thing_inside
                      | otherwise         = tcMatchTys
        ; case refiner ex_tvs old_subst pat_tys ctxt_tys of
                Failed msg -> failWithTc (inaccessibleAlt msg)
-               Succeeded new_subst -> do
-       { traceTc (text "refineTypes:match" <+> ppr con <+> ppr new_subst)
+               Succeeded new_subst -> do {
+         traceTc (text "refineTypes:match" <+> ppr con <+> ppr new_subst)
        ; setTypeRefinement new_subst thing_inside } }
 
   where