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,
- 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 )
= failWithTc (existentialExplode pats)
tcCheckExistentialPat ctxt pats ex_tvs pat_tys body_ty
- = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys) $
+ = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty) $
checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
data PatState = PS {
\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
; 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') }
= 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}
= do { (pat', tvs, res) <- tc_lpat pstate pat pat_ty thing_inside
; return (BangPat pat', tvs, res) }
--- There's a wrinkle with irrefuatable patterns, namely that we
+-- There's a wrinkle with irrefutable patterns, namely that we
-- must not propagate type refinement from them. For example
-- data T a where { T1 :: Int -> T Int; ... }
-- f :: T a -> Int -> a
thing_inside pstate
-- Ignore refined pstate',
-- revert to pstate
+ -- Check no existentials
; if (null pat_tvs) then return ()
else lazyPatErr lpat pat_tvs
+
+ -- Check that the pattern has a lifted type
+ ; pat_tv <- newBoxyTyVar liftedTypeKind
+ ; boxyUnify pat_ty (mkTyVarTy pat_tv)
+
; 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) }
; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
+
+tc_pat _ _other_pat _ _ = panic "tc_pat" -- DictPat, ConPatOut, SigPatOut, VarPatOut
\end{code}
= do { loc <- getInstLoc orig
; res_tau <- zapToMonotype res_ty
; new_uniq <- newUnique
- ; let
- lit_nm = mkSystemVarName new_uniq FSLIT("lit")
+ ; let lit_nm = mkSystemVarName new_uniq FSLIT("lit")
lit_inst = LitInst lit_nm lit res_tau loc
; extendLIE lit_inst
; return (HsVar (instToId lit_inst)) }
text "In the binding group for"])
4 (vcat (map ppr pats))
-sigPatCtxt bound_ids bound_tvs tys tidy_env
- = -- tys is (body_ty : pat_tys)
- mapM zonkTcType tys `thenM` \ tys' ->
- let
- (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
- (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys'
- in
- returnM (env1,
+sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env
+ = do { pat_tys' <- mapM zonkTcType pat_tys
+ ; body_ty' <- zonkTcType body_ty
+ ; let (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
+ (env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
+ (env3, tidy_body_ty) = tidyOpenType env2 body_ty'
+ ; return (env3,
sep [ptext SLIT("When checking an existential match that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
ptext SLIT("The body has type:") <+> ppr tidy_body_ty
- ])
+ ]) }
where
show_ids = filter is_interesting bound_ids
is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
projects / ghc-hetmet.git / blobdiff