[project @ 2004-12-21 12:09:14 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 2f583bb..77de074 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -40,7 +40,7 @@ import DataCon                ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys
 import PrelNames       ( eqStringName, eqName, geName, negateName, minusName, 
                          integralClassName )
 import BasicTypes      ( isBoxed )
-import SrcLoc          ( Located(..), noLoc, unLoc )
+import SrcLoc          ( Located(..), SrcSpan, noLoc, unLoc, getLoc )
 import ErrUtils                ( Message )
 import Outputable
 import FastString
@@ -114,7 +114,8 @@ tcCheckPats ctxt pats tys thing_inside      -- A trivial wrapper
 %************************************************************************
 
 \begin{code}
-data PatCtxt = LamPat Bool | LetPat TcSigFun
+data PatCtxt = LamPat Bool     -- Used for lambda, case, do-notation etc
+            | LetPat TcSigFun  -- Used for let(rec) bindings
        -- True <=> we are checking the case expression, 
        --              so can do full-blown refinement
        -- False <=> inferring, do no refinement
@@ -283,7 +284,7 @@ tc_pat ctxt pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
   = do { data_con <- tcLookupDataCon con_name
        ; let tycon = dataConTyCon data_con
        ; ty_args <- zapToTyConApp tycon pat_ty
-       ; (pat', tvs, res) <- tcConPat ctxt data_con tycon ty_args arg_pats thing_inside
+       ; (pat', tvs, res) <- tcConPat ctxt con_span data_con tycon ty_args arg_pats thing_inside
        ; return (pat', tvs, res) }
 
 
@@ -361,16 +362,16 @@ tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pa
 %************************************************************************
 
 \begin{code}
-tcConPat :: PatCtxt -> DataCon -> TyCon -> [TcTauType] 
+tcConPat :: PatCtxt -> SrcSpan -> DataCon -> TyCon -> [TcTauType] 
         -> HsConDetails Name (LPat Name) -> TcM a
         -> TcM (Pat TcId, [TcTyVar], a)
-tcConPat ctxt data_con tycon ty_args arg_pats thing_inside
+tcConPat ctxt span data_con tycon ty_args arg_pats thing_inside
   | isVanillaDataCon data_con
   = do { let arg_tys = dataConInstOrigArgTys data_con ty_args
        ; tcInstStupidTheta data_con ty_args
        ; traceTc (text "tcConPat" <+> vcat [ppr data_con, ppr ty_args, ppr arg_tys])
        ; (arg_pats', tvs, res) <- tcConArgs ctxt data_con arg_pats arg_tys thing_inside
-       ; return (ConPatOut data_con [] [] emptyLHsBinds 
+       ; return (ConPatOut (L span data_con) [] [] emptyLHsBinds 
                            arg_pats' (mkTyConApp tycon ty_args),
                  tvs, res) }
 
@@ -385,19 +386,22 @@ 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
 
-       ; return (ConPatOut data_con 
+       ; return (ConPatOut (L span data_con)
                            tvs' (map instToId dicts) dict_binds
                            arg_pats' (mkTyConApp tycon ty_args),
                  tvs' ++ inner_tvs, res) } }