projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix Trac #3346: tcSimplify for LHS of RULES with type equalities
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcPat.lhs
diff --git
a/compiler/typecheck/TcPat.lhs
b/compiler/typecheck/TcPat.lhs
index
82ac5e3
..
3423196
100644
(file)
--- a/
compiler/typecheck/TcPat.lhs
+++ b/
compiler/typecheck/TcPat.lhs
@@
-30,7
+30,6
@@
import VarSet
import TcUnify
import TcHsType
import TysWiredIn
import TcUnify
import TcHsType
import TysWiredIn
-import Type
import Coercion
import StaticFlags
import TyCon
import Coercion
import StaticFlags
import TyCon
@@
-41,7
+40,6
@@
import DynFlags ( DynFlag( Opt_GADTs ) )
import SrcLoc
import ErrUtils
import Util
import SrcLoc
import ErrUtils
import Util
-import Maybes
import Outputable
import FastString
import Monad
import Outputable
import FastString
import Monad
@@
-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
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 (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
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")
; 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
-- 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
-- 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) }
; return (LazyPat pat', [], res) }
@@
-1040,6
+1041,12
@@
lazyPatErr _ tvs
hang (ptext (sLit "A lazy (~) pattern cannot match existential or GADT data constructors"))
2 (vcat (map pprSkolTvBinding 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))
nonRigidMatch :: PatCtxt -> DataCon -> SDoc
nonRigidMatch ctxt con
= hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))