projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcPat.lhs
diff --git
a/compiler/typecheck/TcPat.lhs
b/compiler/typecheck/TcPat.lhs
index
097402f
..
9c6a0dc
100644
(file)
--- a/
compiler/typecheck/TcPat.lhs
+++ b/
compiler/typecheck/TcPat.lhs
@@
-6,6
+6,13
@@
TcPat: Typechecking patterns
\begin{code}
TcPat: Typechecking patterns
\begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
@@
-31,6
+38,7
@@
import TcHsType
import TysWiredIn
import TcGadt
import Type
import TysWiredIn
import TcGadt
import Type
+import Coercion
import StaticFlags
import TyCon
import DataCon
import StaticFlags
import TyCon
import DataCon
@@
-59,7
+67,8
@@
tcLetPat :: (Name -> Maybe TcRhoType)
-> TcM (LPat TcId, a)
tcLetPat sig_fn pat pat_ty thing_inside
= do { let init_state = PS { pat_ctxt = LetPat sig_fn,
-> TcM (LPat TcId, a)
tcLetPat sig_fn pat pat_ty thing_inside
= do { let init_state = PS { pat_ctxt = LetPat sig_fn,
- pat_reft = emptyRefinement }
+ pat_reft = emptyRefinement,
+ pat_eqs = False }
; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state (\ _ -> thing_inside)
-- Don't know how to deal with pattern-bound existentials yet
; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state (\ _ -> thing_inside)
-- Don't know how to deal with pattern-bound existentials yet
@@
-104,11
+113,13
@@
tc_lam_pats :: [(LPat Name,BoxySigmaType)]
-> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type
-> TcM ([LPat TcId], a)
tc_lam_pats pat_ty_prs (reft, res_ty) thing_inside
-> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type
-> TcM ([LPat TcId], a)
tc_lam_pats pat_ty_prs (reft, res_ty) thing_inside
- = do { let init_state = PS { pat_ctxt = LamPat, pat_reft = reft }
+ = do { let init_state = PS { pat_ctxt = LamPat, pat_reft = reft, pat_eqs = False }
; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
- refineEnvironment (pat_reft pstate') $
- thing_inside (pat_reft pstate', res_ty)
+ refineEnvironment (pat_reft pstate') (pat_eqs pstate') $
+ if (pat_eqs pstate' && (not $ isRigidTy res_ty))
+ then failWithTc (nonRigidResult res_ty)
+ else thing_inside (pat_reft pstate', res_ty)
; let tys = map snd pat_ty_prs
; tcCheckExistentialPat pats' ex_tvs tys res_ty
; let tys = map snd pat_ty_prs
; tcCheckExistentialPat pats' ex_tvs tys res_ty
@@
-138,7
+149,9
@@
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
data PatState = PS {
pat_ctxt :: PatCtxt,
data PatState = PS {
pat_ctxt :: PatCtxt,
- pat_reft :: Refinement -- Binds rigid TcTyVars to their refinements
+ pat_reft :: Refinement, -- Binds rigid TcTyVars to their refinements
+ pat_eqs :: Bool -- <=> there are GADT equational constraints
+ -- for refinement
}
data PatCtxt
}
data PatCtxt
@@
-434,9
+447,15
@@
tc_pat pstate pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_insi
------------------------
-- Literal patterns
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
------------------------
-- Literal patterns
tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
- = do { boxyUnify (hsLitType simple_lit) pat_ty
+ = do { let lit_ty = hsLitType simple_lit
+ ; coi <- boxyUnify lit_ty pat_ty
+ -- coi is of kind: lit_ty ~ pat_ty
; res <- thing_inside pstate
; res <- thing_inside pstate
- ; returnM (LitPat simple_lit, [], res) }
+ ; span <- getSrcSpanM
+ -- pattern coercions have to
+ -- be of kind: pat_ty ~ lit_ty
+ -- hence, sym coi
+ ; returnM (wrapPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, [], res) }
------------------------
-- Overloaded patterns: n, and n+k
------------------------
-- Overloaded patterns: n, and n+k
@@
-544,10
+563,10
@@
further type refinement is local to the alternative.
tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
-> BoxySigmaType -- Type of the pattern
tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
-> BoxySigmaType -- Type of the pattern
- -> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
+ -> HsConPatDetails Name -> (PatState -> TcM a)
-> TcM (Pat TcId, [TcTyVar], a)
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-> TcM (Pat TcId, [TcTyVar], a)
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
- = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
+ = do { let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con
skol_info = PatSkol data_con
origin = SigOrigin skol_info
skol_info = PatSkol data_con
origin = SigOrigin skol_info
@@
-558,12
+577,12
@@
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
eq_spec' = substEqSpec tenv eq_spec
; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
eq_spec' = substEqSpec tenv eq_spec
- theta' = substTheta tenv theta
+ theta' = substTheta tenv (eq_theta ++ dict_theta)
arg_tys' = substTys tenv arg_tys
; co_vars <- newCoVars eq_spec' -- Make coercion variables
; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
arg_tys' = substTys tenv arg_tys
; co_vars <- newCoVars eq_spec' -- Make coercion variables
; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
-
+
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
@@
-622,8
+641,7
@@
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
tcConArgs :: DataCon -> [TcSigmaType]
tcConArgs :: DataCon -> [TcSigmaType]
- -> Checker (HsConDetails Name (LPat Name))
- (HsConDetails Id (LPat Id))
+ -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
= do { checkTc (con_arity == no_of_args) -- Check correct arity
tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
= do { checkTc (con_arity == no_of_args) -- Check correct arity
@@
-648,16
+666,15
@@
tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
= pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments
tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside
= pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments
-tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside
+tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
= do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
= do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
- ; return (RecCon rpats', tvs, res) }
+ ; return (RecCon (HsRecFields rpats' dd), tvs, res) }
where
where
- -- doc comments are typechecked to Nothing here
tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
- tc_field (HsRecField field_lbl pat _) pstate thing_inside
+ tc_field (HsRecField field_lbl pat pun) pstate thing_inside
= do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
= do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
- ; return (mkRecField sel_id pat', tvs, res) }
+ ; return (HsRecField sel_id pat' pun, tvs, res) }
find_field_ty :: FieldLabel -> TcM (Id, TcType)
find_field_ty field_lbl
find_field_ty :: FieldLabel -> TcM (Id, TcType)
find_field_ty field_lbl
@@
-727,6
+744,7
@@
refineAlt :: DataCon -- For tracing only
-> TcM PatState
refineAlt con pstate ex_tvs [] pat_ty
-> TcM PatState
refineAlt con pstate ex_tvs [] pat_ty
+ | null $ dataConEqTheta con
= return pstate -- Common case: no equational constraints
refineAlt con pstate ex_tvs co_vars pat_ty
= return pstate -- Common case: no equational constraints
refineAlt con pstate ex_tvs co_vars pat_ty
@@
-753,7
+771,7
@@
refineAlt con pstate ex_tvs co_vars pat_ty
; case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
Failed msg -> failWithTc (inaccessibleAlt msg) ;
Succeeded reft -> do { traceTc trace_msg
; case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
Failed msg -> failWithTc (inaccessibleAlt msg) ;
Succeeded reft -> do { traceTc trace_msg
- ; return (pstate { pat_reft = reft }) }
+ ; return (pstate { pat_reft = reft, pat_eqs = (pat_eqs pstate || not (null $ dataConEqTheta con)) }) }
-- DO NOT refine the envt right away, because we
-- might be inside a lazy pattern. Instead, refine pstate
where
-- DO NOT refine the envt right away, because we
-- might be inside a lazy pattern. Instead, refine pstate
where
@@
-922,6
+940,7
@@
patCtxt pat = Just (hang (ptext SLIT("In the pattern:"))
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
text "I can't handle pattern bindings for existentially-quantified constructors.",
existentialExplode pat
= hang (vcat [text "My brain just exploded.",
text "I can't handle pattern bindings for existentially-quantified constructors.",
+ text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
text "In the binding group for"])
4 (ppr pat)
text "In the binding group for"])
4 (ppr pat)
@@
-966,6
+985,16
@@
nonRigidMatch con
= hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
= hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+nonRigidResult res_ty
+ = hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty))
+ 2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+
inaccessibleAlt msg
= hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
\end{code}
inaccessibleAlt msg
= hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
\end{code}
+
+\begin{code}
+wrapPatCoI :: CoercionI -> Pat a -> TcType -> Pat a
+wrapPatCoI IdCo pat ty = pat
+wrapPatCoI (ACo co) pat ty = CoPat (WpCo co) pat ty
+\end{code}