instToId, tcInstStupidTheta, tcSyntaxName
)
import Id ( Id, idType, mkLocalId )
+import Var ( tyVarName )
import Name ( Name )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
-import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv3,
+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,
+ SkolemInfo(PatSkol), isSkolemTyVar, isMetaTyVar, pprSkolemTyVar,
TvSubst, mkTvSubst, substTyVar, substTy, MetaDetails(..),
mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy )
import VarEnv ( mkVarEnv ) -- ugly
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 TyCon ( TyCon )
import PrelNames ( eqStringName, eqName, geName, negateName, minusName,
integralClassName )
import BasicTypes ( isBoxed )
-import SrcLoc ( Located(..), SrcSpan, noLoc, unLoc, getLoc )
+import SrcLoc ( Located(..), SrcSpan, noLoc, unLoc )
import Maybes ( catMaybes )
import ErrUtils ( Message )
import Outputable
%************************************************************************
\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.
(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)
- <- tcExtendTyVarEnv3 tv_binds $
+ <- tcExtendTyVarEnv2 tv_binds $
tc_lpat ctxt pat (Check sig_ty') thing_inside
; return (SigPatOut pat' sig_ty, tvs, res) }
-> 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]