Commit 4f2e93bc authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Catch errors in pattern matching for unboxed tuples

When fiddling with pattern-matching for unboxed tuples, I'd messed up
the slightly-tricky tests for pattern matching on unboxed tuples, notably
	case (# foo, bar #) of r -> ...r...

The fix is in TcPat, and test are tcfail115, tcfail120, and tc209
parent 5d675b1a
......@@ -26,17 +26,16 @@ import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
tcLookupClass, tcLookupDataCon, tcLookupId, refineEnvironment,
tcMetaTy )
import TcMType ( newFlexiTyVarTy, arityErr, tcInstSkolTyVars, newBoxyTyVar, zonkTcType )
import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType,
import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, BoxyType,
SkolemInfo(PatSkol),
BoxySigmaType, BoxyRhoType,
BoxySigmaType, BoxyRhoType, argTypeKind, typeKind,
pprSkolTvBinding, isRefineableTy, isRigidTy, tcTyVarsOfTypes, mkTyVarTy, lookupTyVar,
emptyTvSubst, substTyVar, substTy, mkTopTvSubst, zipTopTvSubst, zipOpenTvSubst,
mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy,
mkFunTy, mkFunTys, exactTyVarsOfTypes,
tidyOpenType, tidyOpenTypes )
mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy, isArgTypeKind, isUnboxedTupleType,
mkFunTy, mkFunTys, exactTyVarsOfTypes, tidyOpenType, tidyOpenTypes )
import VarSet ( elemVarSet, mkVarSet )
import Kind ( liftedTypeKind, openTypeKind )
import TcUnify ( boxySplitTyConApp, boxySplitListTy,
import TcUnify ( boxySplitTyConApp, boxySplitListTy, unifyType,
unBox, stripBoxyType, zapToMonotype,
boxyMatchTypes, boxyUnify, boxyUnifyList, checkSigTyVarsWrt )
import TcHsType ( UserTypeCtxt(..), tcPatSig )
......@@ -157,7 +156,7 @@ patSigCtxt other = LamPatSigCtxt
\begin{code}
tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId
tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty
= do { pat_ty' <- unBox pat_ty
= do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name
-- We have an undecorated binder, so we do rule ABS1,
-- by unboxing the boxy type, forcing any un-filled-in
-- boxes to become monotypes
......@@ -175,7 +174,7 @@ tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
; return (mkLocalId mono_name mono_ty) }
| otherwise
= do { pat_ty' <- unBox pat_ty
= do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name
; mono_name <- newLocalName bndr_name
; return (mkLocalId mono_name pat_ty') }
......@@ -189,6 +188,31 @@ bindInstsOfPatId id thing_inside
= do { (res, lie) <- getLIE thing_inside
; binds <- bindInstsOfLocalFuns lie [id]
; return (res, binds) }
-------------------
unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
-- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind;
-- that is, it can't be an unboxed tuple. For example,
-- case (f x) of r -> ...
-- should fail if 'f' returns an unboxed tuple.
unBoxArgType ty pp_this
= do { ty' <- unBox ty -- Returns a zonked type
-- Neither conditional is strictly necesssary (the unify alone will do)
-- but they improve error messages, and allocate fewer tyvars
; if isUnboxedTupleType ty' then
failWithTc msg
else if isArgTypeKind (typeKind ty') then
return ty'
else do -- OpenTypeKind, so constrain it
{ ty2 <- newFlexiTyVarTy argTypeKind
; unifyType ty' ty2
; return ty' }}
where
msg = pp_this <+> ptext SLIT("cannot be bound to an unboxed tuple")
\end{code}
......@@ -304,7 +328,7 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
; return (LazyPat pat', [], res) }
tc_pat pstate (WildPat _) pat_ty thing_inside
= do { pat_ty' <- unBox pat_ty -- Make sure it's filled in with monotypes
= do { pat_ty' <- unBoxWildCardType pat_ty -- Make sure it's filled in with monotypes
; res <- thing_inside pstate
; return (WildPat pat_ty', [], res) }
......
......@@ -88,7 +88,7 @@ module TcType (
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
unliftedTypeKind, liftedTypeKind, unboxedTypeKind,
unliftedTypeKind, liftedTypeKind, unboxedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isArgTypeKind, isSubKind, defaultKind,
......@@ -132,7 +132,7 @@ import TypeRep ( Type(..), funTyCon ) -- friend
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, PredType(..),
ThetaType, unliftedTypeKind, unboxedTypeKind,
ThetaType, unliftedTypeKind, unboxedTypeKind, argTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
isLiftedTypeKind, isUnliftedTypeKind,
mkArrowKinds, mkForAllTy, mkForAllTys,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment