X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=56c525831e7a95b6495a7e2ca4d1d39250e7325b;hb=40f5a0759bd07308009c3ae8956dfa061c684ebd;hp=4c56b083bbbd39c0b5066dd88284568c5d3b9c63;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 4c56b08..56c5258 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -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, - 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 ) @@ -129,7 +128,7 @@ tcCheckExistentialPat (LetPat _) pats ex_tvs pat_tys body_ty = 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 { @@ -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} @@ -278,7 +302,7 @@ tc_pat pstate (BangPat pat) pat_ty thing_inside = 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 @@ -293,12 +317,18 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside 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) } @@ -404,6 +434,8 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside ; 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} @@ -683,8 +715,7 @@ newLitInst orig lit res_ty -- Make a LitInst = 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)) } @@ -774,19 +805,18 @@ existentialExplode pats 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