X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=8c73fa9708cfa736517929799a95fc38a3e818d6;hb=f04dead93a15af1cb818172f207b8a81d2c81298;hp=82ac5e3596a53c1558c6800ed3f58f2b7b09a5fd;hpb=d95190caa3e09b33bca8544051043954ebd89c73;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 82ac5e3..8c73fa9 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -30,7 +30,6 @@ import VarSet import TcUnify import TcHsType import TysWiredIn -import Type import Coercion import StaticFlags import TyCon @@ -41,10 +40,9 @@ import DynFlags ( DynFlag( Opt_GADTs ) ) import SrcLoc import ErrUtils import Util -import Maybes import Outputable import FastString -import Monad +import Control.Monad \end{code} @@ -181,7 +179,7 @@ tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty | Just mono_ty <- lookup_sig bndr_name = do { mono_name <- newLocalName bndr_name - ; boxyUnify mono_ty pat_ty + ; _ <- boxyUnify mono_ty pat_ty ; return (Id.mkLocalId mono_name mono_ty) } | otherwise @@ -238,7 +236,7 @@ unBoxArgType ty pp_this return ty' else do -- OpenTypeKind, so constrain it { ty2 <- newFlexiTyVarTy argTypeKind - ; unifyType ty' ty2 + ; _ <- unifyType ty' ty2 ; return ty' }} where msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple") @@ -365,12 +363,15 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside -- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns] -- Check no existentials - ; if (null pat_tvs) then return () - else lazyPatErr lpat pat_tvs + ; unless (null pat_tvs) $ lazyPatErr lpat pat_tvs + + -- Check there are no unlifted types under the lazy pattern + ; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $ + lazyUnliftedPatErr lpat -- Check that the pattern has a lifted type ; pat_tv <- newBoxyTyVar liftedTypeKind - ; boxyUnify pat_ty (mkTyVarTy pat_tv) + ; _ <- boxyUnify pat_ty (mkTyVarTy pat_tv) ; return (LazyPat pat', [], res) } @@ -627,7 +628,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside unwrap_ty res_pat -- Add the stupid theta - ; addDataConStupidTheta data_con ctxt_res_tys + ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad, not from ex_tvs @@ -1040,6 +1041,12 @@ lazyPatErr _ tvs hang (ptext (sLit "A lazy (~) pattern cannot match existential or GADT data constructors")) 2 (vcat (map pprSkolTvBinding tvs)) +lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () +lazyUnliftedPatErr pat + = failWithTc $ + hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types")) + 2 (ppr pat) + nonRigidMatch :: PatCtxt -> DataCon -> SDoc nonRigidMatch ctxt con = hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))