[project @ 2005-03-18 13:37:27 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 0ae7013..a6d9d1d 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -18,14 +18,15 @@ import Inst         ( InstOrigin(..),
                          instToId, tcInstStupidTheta, tcSyntaxName
                        )
 import Id              ( Id, idType, mkLocalId )
+import Var             ( tyVarName )
 import Name            ( Name )
 import TcSimplify      ( tcSimplifyCheck, bindInstsOfLocalFuns )
 import TcEnv           ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
                          tcLookupClass, tcLookupDataCon, tcLookupId )
 import TcMType                 ( newTyFlexiVarTy, arityErr, tcSkolTyVars, readMetaTyVar )
 import TcType          ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst,
-                         SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar, 
-                         TvSubst, mkTvSubst, substTyVar, substTy, MetaDetails(..),
+                         SkolemInfo(PatSkol), isSkolemTyVar, isMetaTyVar, pprTcTyVar, 
+                         TvSubst, mkOpenTvSubst, substTyVar, substTy, MetaDetails(..),
                          mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
 import VarEnv          ( mkVarEnv )    -- ugly
 import Kind            ( argTypeKind, liftedTypeKind )
@@ -33,9 +34,9 @@ import TcUnify                ( tcSubPat, Expected(..), zapExpectedType,
                          zapExpectedTo, zapToListTy, zapToTyConApp )  
 import TcHsType                ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType )
 import TysWiredIn      ( stringTy, parrTyCon, tupleTyCon )
-import Unify           ( MaybeErr(..), gadtRefineTys, gadtMatchTys )
+import Unify           ( MaybeErr(..), gadtRefineTys, BindFlag(..) )
 import Type            ( substTys, substTheta )
-import CmdLineOpts     ( opt_IrrefutableTuples )
+import StaticFlags     ( opt_IrrefutableTuples )
 import TyCon           ( TyCon )
 import DataCon         ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys,
                          dataConFieldLabels, dataConSourceArity, dataConSig )
@@ -117,15 +118,12 @@ tcCheckPats ctxt pats tys thing_inside    -- A trivial wrapper
 %************************************************************************
 
 \begin{code}
-data PatCtxt = LamPat Bool     -- Used for lambda, case, do-notation etc
+data PatCtxt = LamPat          -- 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
 
 -------------------
 tcPatBndr :: PatCtxt -> Name -> Expected TcSigmaType -> TcM TcId
-tcPatBndr (LamPat _) bndr_name pat_ty
+tcPatBndr LamPat bndr_name pat_ty
   = do { pat_ty' <- zapExpectedType pat_ty argTypeKind
                -- If pat_ty is Expected, this returns the appropriate
                -- SigmaType.  In Infer mode, we create a fresh type variable.
@@ -245,7 +243,7 @@ tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside
          (sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
        ; tcSubPat sig_ty pat_ty
        ; subst <- refineTyVars sig_tvs -- See note [Type matching]
-       ; let tv_binds = [(tv, substTyVar subst  tv) | tv <- sig_tvs]
+       ; let tv_binds = [(tyVarName tv, substTyVar subst tv) | tv <- sig_tvs]
              sig_ty'  = substTy subst sig_ty
        ; (pat', tvs, res) 
              <- tcExtendTyVarEnv2 tv_binds $
@@ -500,17 +498,15 @@ refineAlt :: PatCtxt -> DataCon
            -> TcM a -> TcM a
 refineAlt ctxt con ex_tvs ctxt_tys pat_tys thing_inside 
   = do { old_subst <- getTypeRefinement
-       ; let refiner | can_i_refine ctxt = gadtRefineTys
-                     | otherwise         = gadtMatchTys
-       ; case refiner ex_tvs old_subst pat_tys ctxt_tys of
+       ; case gadtRefineTys bind_fn 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)
        ; setTypeRefinement new_subst thing_inside } }
 
   where
-    can_i_refine (LamPat can_refine) = can_refine
-    can_i_refine other_ctxt         = False
+    bind_fn tv | isMetaTyVar tv = WildCard     -- Wobbly types behave as wild cards
+              | otherwise      = BindMe
 \end{code}
 
 Note [Type matching]
@@ -539,7 +535,7 @@ refineTyVars :: [TcTyVar]   -- Newly instantiated meta-tyvars of the function
 -- Just one level of de-wobblification though.  What a hack! 
 refineTyVars tvs
   = do { mb_prs <- mapM mk_pr tvs
-       ; return (mkTvSubst (mkVarEnv (catMaybes mb_prs))) }
+       ; return (mkOpenTvSubst (mkVarEnv (catMaybes mb_prs))) }
   where
     mk_pr tv = do { details <- readMetaTyVar tv
                  ; case details of
@@ -638,9 +634,7 @@ badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
 lazyPatErr pat tvs
   = failWithTc $
     hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables"))
-       2 (vcat (map get tvs))
-  where
-   get tv = ASSERT( isSkolemTyVar tv ) pprSkolemTyVar tv
+       2 (vcat (map pprTcTyVar tvs))
 
 inaccessibleAlt msg
   = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg