import TcUnify
import TcHsType
import TysWiredIn
-import Type
import Coercion
import StaticFlags
import TyCon
import DataCon
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
-import DynFlags ( DynFlag( Opt_GADTs ) )
+import DynFlags
import SrcLoc
import ErrUtils
import Util
-import Maybes
import Outputable
import FastString
-import Monad
+import Control.Monad
\end{code}
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
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")
-- Check no existentials
; 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) }
failWithTc (badSigPat pat_ty)
; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
tc_lpat pat inner_ty pstate thing_inside
- ; return (SigPatOut pat' inner_ty, tvs, res) }
+ ; return (SigPatOut pat' inner_ty, tvs, res) }
+
+-- Use this when we add pattern coercions back in
+-- return (mkCoPatCoI (mkSymCoI coi) (SigPatOut pat' inner_ty) pat_ty
+-- , tvs, res) }
tc_pat _ pat@(TypePat _) _ _
= failWithTc (badTypePat pat)
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
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))