projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Refactor (again) the handling of default methods
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcPat.lhs
diff --git
a/compiler/typecheck/TcPat.lhs
b/compiler/typecheck/TcPat.lhs
index
b8bbed7
..
5592b80
100644
(file)
--- a/
compiler/typecheck/TcPat.lhs
+++ b/
compiler/typecheck/TcPat.lhs
@@
-30,20
+30,19
@@
import VarSet
import TcUnify
import TcHsType
import TysWiredIn
import TcUnify
import TcHsType
import TysWiredIn
-import Type
import Coercion
import StaticFlags
import TyCon
import DataCon
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import Coercion
import StaticFlags
import TyCon
import DataCon
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
+import DynFlags ( DynFlag( Opt_GADTs ) )
import SrcLoc
import ErrUtils
import Util
import SrcLoc
import ErrUtils
import Util
-import Maybes
import Outputable
import FastString
import Outputable
import FastString
-import Monad
+import Control.Monad
\end{code}
\end{code}
@@
-180,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
@@
-237,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")
@@
-364,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) }
@@
-427,11
+429,15
@@
tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
= do { (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty
pat_ty
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
= do { (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty
pat_ty
- ; unless (isIdentityCoercion coi) $
+ ; unless (isIdentityCoI coi) $
failWithTc (badSigPat pat_ty)
; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
tc_lpat pat inner_ty pstate thing_inside
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)
tc_pat _ pat@(TypePat _) _ _
= failWithTc (badTypePat pat)
@@
-626,7
+632,7
@@
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
unwrap_ty res_pat
-- Add the stupid theta
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
; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
-- Get location from monad, not from ex_tvs
@@
-670,6
+676,12
@@
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
pstate' | no_equalities = pstate
| otherwise = pstate { pat_eqs = True }
pstate' | no_equalities = pstate
| otherwise = pstate { pat_eqs = True }
+ ; gadts_on <- doptM Opt_GADTs
+ ; checkTc (no_equalities || gadts_on)
+ (ptext (sLit "A pattern match on a GADT requires -XGADTs"))
+ -- Trac #2905 decided that a *pattern-match* of a GADT
+ -- should require the GADT language flag
+
; unless no_equalities $ checkTc (isRigidTy pat_ty) $
nonRigidMatch (pat_ctxt pstate) data_con
; unless no_equalities $ checkTc (isRigidTy pat_ty) $
nonRigidMatch (pat_ctxt pstate) data_con
@@
-702,7
+714,7
@@
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
; let instTys' = substTys subst instTys
; cois <- boxyUnifyList instTys' scrutinee_arg_tys
; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
; let instTys' = substTys subst instTys
; cois <- boxyUnifyList instTys' scrutinee_arg_tys
- ; let coi = if isIdentityCoercion coi1
+ ; let coi = if isIdentityCoI coi1
then -- pat_ty was splittable
-- => boxyUnifyList had real work to do
mkTyConAppCoI fam_tycon instTys' cois
then -- pat_ty was splittable
-- => boxyUnifyList had real work to do
mkTyConAppCoI fam_tycon instTys' cois
@@
-978,7
+990,7
@@
patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
existentialExplode :: LPat Name -> SDoc
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
existentialExplode :: LPat Name -> SDoc
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
- text "I can't handle pattern bindings for existentially-quantified constructors.",
+ text "I can't handle pattern bindings for existential or GADT data constructors.",
text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
text "In the binding group for"])
4 (ppr pat)
text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
text "In the binding group for"])
4 (ppr pat)
@@
-1030,9
+1042,15
@@
existentialProcPat con
lazyPatErr :: Pat name -> [TcTyVar] -> TcM ()
lazyPatErr _ tvs
= failWithTc $
lazyPatErr :: Pat name -> [TcTyVar] -> TcM ()
lazyPatErr _ tvs
= failWithTc $
- hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
+ hang (ptext (sLit "A lazy (~) pattern cannot match existential or GADT data constructors"))
2 (vcat (map pprSkolTvBinding tvs))
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))