-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
+module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcExpr( tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho)
import HsSyn
import TcHsSyn
\begin{code}
tcLetPat :: (Name -> Maybe TcRhoType)
-> LPat Name -> BoxySigmaType
- -> TcM a
+ -> TcM a
-> TcM (LPat TcId, a)
tcLetPat sig_fn pat pat_ty thing_inside
= do { let init_state = PS { pat_ctxt = LetPat sig_fn,
-- 5. Check that no existentials escape
tcLamPats pats tys res_ty thing_inside
- = tc_lam_pats (zipEqual "tcLamPats" pats tys)
+ = tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys)
(emptyRefinement, res_ty) thing_inside
tcLamPat :: LPat Name -> BoxySigmaType
-> (Refinement,BoxyRhoType) -- Result type
-> ((Refinement,BoxyRhoType) -> TcM a) -- Checker for body, given its result type
-> TcM (LPat TcId, a)
-tcLamPat pat pat_ty res_ty thing_inside
- = do { ([pat'],thing) <- tc_lam_pats [(pat, pat_ty)] res_ty thing_inside
+
+tcProcPat = tc_lam_pat ProcPat
+tcLamPat = tc_lam_pat LamPat
+
+tc_lam_pat ctxt pat pat_ty res_ty thing_inside
+ = do { ([pat'],thing) <- tc_lam_pats ctxt [(pat, pat_ty)] res_ty thing_inside
; return (pat', thing) }
-----------------
-tc_lam_pats :: [(LPat Name,BoxySigmaType)]
+tc_lam_pats :: PatCtxt
+ -> [(LPat Name,BoxySigmaType)]
-> (Refinement,BoxyRhoType) -- Result type
-> ((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, pat_eqs = False }
+tc_lam_pats ctxt pat_ty_prs (reft, res_ty) thing_inside
+ = do { let init_state = PS { pat_ctxt = ctxt, pat_reft = reft, pat_eqs = False }
; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
refineEnvironment (pat_reft pstate') (pat_eqs pstate') $
data PatCtxt
= LamPat
+ | ProcPat -- The pattern in (proc pat -> ...)
+ -- see Note [Arrows and patterns]
| LetPat (Name -> Maybe TcRhoType) -- Used for let(rec) bindings
patSigCtxt :: PatState -> UserTypeCtxt
\begin{code}
tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId
-tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty
- = do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name
- -- We have an undecorated binder, so we do rule ABS1,
- -- by unboxing the boxy type, forcing any un-filled-in
- -- boxes to become monotypes
- -- NB that pat_ty' can still be a polytype:
- -- data T = MkT (forall a. a->a)
- -- f t = case t of { MkT g -> ... }
- -- Here, the 'g' must get type (forall a. a->a) from the
- -- MkT context
- ; return (Id.mkLocalId bndr_name pat_ty') }
-
tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
| Just mono_ty <- lookup_sig bndr_name
= do { mono_name <- newLocalName bndr_name
; mono_name <- newLocalName bndr_name
; return (Id.mkLocalId mono_name pat_ty') }
+tcPatBndr (PS { pat_ctxt = _lam_or_proc }) bndr_name pat_ty
+ = do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name
+ -- We have an undecorated binder, so we do rule ABS1,
+ -- by unboxing the boxy type, forcing any un-filled-in
+ -- boxes to become monotypes
+ -- NB that pat_ty' can still be a polytype:
+ -- data T = MkT (forall a. a->a)
+ -- f t = case t of { MkT g -> ... }
+ -- Here, the 'g' must get type (forall a. a->a) from the
+ -- MkT context
+ ; return (Id.mkLocalId bndr_name pat_ty') }
+
-------------------
bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId)
-------------------
unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
+unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat)
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
-- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind;
--------------------
tc_pat :: PatState
- -> Pat Name -> BoxySigmaType -- Fully refined result type
- -> (PatState -> TcM a) -- Thing inside
- -> TcM (Pat TcId, -- Translated pattern
- [TcTyVar], -- Existential binders
- a) -- Result of thing inside
+ -> Pat Name
+ -> BoxySigmaType -- Fully refined result type
+ -> (PatState -> TcM a) -- Thing inside
+ -> TcM (Pat TcId, -- Translated pattern
+ [TcTyVar], -- Existential binders
+ a) -- Result of thing inside
tc_pat pstate (VarPat name) pat_ty thing_inside
= do { id <- tcPatBndr pstate name pat_ty
-- If you fix it, don't forget the bindInstsOfPatIds!
; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }
+tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside
+ = do { -- morally, expr must have type
+ -- `forall a1...aN. OPT' -> B`
+ -- where overall_pat_ty is an instance of OPT'.
+ -- Here, we infer a rho type for it,
+ -- which replaces the leading foralls and constraints
+ -- with fresh unification variables.
+ (expr',expr'_inferred) <- tcInferRho expr
+ -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty`
+ ; let expr'_expected = \ pat_ty -> (mkFunTy overall_pat_ty pat_ty)
+ -- tcSubExp: expected first, offered second
+ -- returns coercion
+ --
+ -- NOTE: this forces pat_ty to be a monotype (because we use a unification
+ -- variable to find it). this means that in an example like
+ -- (view -> f) where view :: _ -> forall b. b
+ -- we will only be able to use view at one instantation in the
+ -- rest of the view
+ ; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty ->
+ tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred
+
+ -- pattern must have pat_ty
+ ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
+ -- this should get zonked later on, but we unBox it here
+ -- so that we do the same checks as above
+ ; annotation_ty <- unBoxViewPatType overall_pat_ty orig
+ ; return (ViewPat (mkLHsWrap expr_coerc expr') pat' annotation_ty, tvs, res) }
+
-- Type signatures in patterns
-- See Note [Pattern coercions] below
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
------------------------
-- Overloaded patterns: n, and n+k
-tc_pat pstate pat@(NPat over_lit mb_neg eq _) pat_ty thing_inside
+tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside
= do { let orig = LiteralOrigin over_lit
; lit' <- tcOverloadedLit orig over_lit pat_ty
; eq' <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
; return (Just neg') }
; res <- thing_inside pstate
- ; returnM (NPat lit' mb_neg' eq' pat_ty, [], res) }
+ ; returnM (NPat lit' mb_neg' eq', [], res) }
tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
= do { bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
-> 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, 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
+ full_theta = eq_theta ++ dict_theta
-- Instantiate the constructor type variables [a->ty]
+ -- This may involve doing a family-instance coercion, and building a wrapper
; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
+ ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
+ -- pat_ty /= pat_ty iff coi /= IdCo
+ wrap_res_pat res_pat
+ = mkCoPatCoI coi (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty
+
+ -- Add the stupid theta
+ ; addDataConStupidTheta data_con ctxt_res_tys
+
; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad,
-- not from ex_tvs
; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
- eq_spec' = substEqSpec tenv eq_spec
- theta' = substTheta tenv (eq_theta ++ dict_theta)
- arg_tys' = substTys tenv arg_tys
-
+ arg_tys' = substTys tenv arg_tys
+
+ ; if null ex_tvs && null eq_spec && null full_theta
+ then do { -- The common case; no class bindings etc (see Note [Arrows and patterns])
+ (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys'
+ arg_pats pstate thing_inside
+ ; let res_pat = ConPatOut { pat_con = L con_span data_con,
+ pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds,
+ pat_args = arg_pats', pat_ty = pat_ty' }
+
+ ; return (wrap_res_pat res_pat, inner_tvs, res) }
+
+ else do -- The general case, with existential, and local equality constraints
+ { let eq_spec' = substEqSpec tenv eq_spec
+ theta' = substTheta tenv full_theta
+ ctxt = pat_ctxt pstate
+ ; checkTc (case ctxt of { ProcPat -> False; other -> True })
+ (existentialProcPat data_con)
; co_vars <- newCoVars eq_spec' -- Make coercion variables
+ ; traceTc (text "tcConPat: refineAlt")
; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty
+ ; traceTc (text "tcConPat: refineAlt done!")
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
; loc <- getInstLoc origin
; dicts <- newDictBndrs loc theta'
; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate')
- ex_tvs' dicts lie_req
-
- ; addDataConStupidTheta data_con ctxt_res_tys
+ ex_tvs' dicts lie_req
- ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
- -- pat_ty /= pat_ty iff coi /= IdCo
- res_pat = ConPatOut { pat_con = L con_span data_con,
+ ; let res_pat = ConPatOut { pat_con = L con_span data_con,
pat_tvs = ex_tvs' ++ co_vars,
pat_dicts = map instToVar dicts,
pat_binds = dict_binds,
pat_args = arg_pats', pat_ty = pat_ty' }
- ; return
- (mkCoPatCoI coi
- (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty,
- ex_tvs' ++ inner_tvs, res)
- }
+ ; return (wrap_res_pat res_pat, ex_tvs' ++ inner_tvs, res)
+ } }
where
-- Split against the family tycon if the pattern constructor
-- belongs to a family instance tycon.
con_arity = dataConSourceArity data_con
no_of_args = length arg_pats
-tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
+tcConArgs data_con arg_tys (InfixCon p1 p2) pstate thing_inside
= do { checkTc (con_arity == 2) -- Check correct arity
(arityErr "Constructor" data_con con_arity 2)
+ ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check
; ([p1',p2'], tvs, res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
pstate thing_inside
; return (InfixCon p1' p2', tvs, res) }
inst_theta = substTheta tenv stupid_theta
\end{code}
+Note [Arrows and patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+(Oct 07) Arrow noation has the odd property that it involves "holes in the scope".
+For example:
+ expr :: Arrow a => a () Int
+ expr = proc (y,z) -> do
+ x <- term -< y
+ expr' -< x
+
+Here the 'proc (y,z)' binding scopes over the arrow tails but not the
+arrow body (e.g 'term'). As things stand (bogusly) all the
+constraints from the proc body are gathered together, so constraints
+from 'term' will be seen by the tcPat for (y,z). But we must *not*
+bind constraints from 'term' here, becuase the desugarer will not make
+these bindings scope over 'term'.
+
+The Right Thing is not to confuse these constraints together. But for
+now the Easy Thing is to ensure that we do not have existential or
+GADT constraints in a 'proc', and to short-cut the constraint
+simplification for such vanilla patterns so that it binds no
+constraints. Hence the 'fast path' in tcConPat; but it's also a good
+plan for ordinary vanilla patterns to bypass the constraint
+simplification step.
+
%************************************************************************
%* *
-> HsOverLit Name
-> BoxyRhoType
-> TcM (HsOverLit TcId)
-tcOverloadedLit orig lit@(HsIntegral i fi) res_ty
+tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty
| not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
-- Reason: If we do, tcSimplify will call lookupInst, which
-- will call tcSyntaxName, which does unification,
-- ToDo: noLoc sadness
= do { integer_ty <- tcMetaTy integerTyConName
; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
- ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty)))) }
+ ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) }
| Just expr <- shortCutIntLit i res_ty
- = return (HsIntegral i expr)
+ = return (HsIntegral i expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
- ; return (HsIntegral i expr) }
+ ; return (HsIntegral i expr res_ty) }
-tcOverloadedLit orig lit@(HsFractional r fr) res_ty
+tcOverloadedLit orig lit@(HsFractional r fr _) res_ty
| not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
= do { rat_ty <- tcMetaTy rationalTyConName
; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
-- we're instantiating an overloaded function here,
-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
-- However this'll be picked up by tcSyntaxOp if necessary
- ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty)))) }
+ ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) }
| Just expr <- shortCutFracLit r res_ty
- = return (HsFractional r expr)
+ = return (HsFractional r expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
- ; return (HsFractional r expr) }
+ ; return (HsFractional r expr res_ty) }
-tcOverloadedLit orig lit@(HsIsString s fr) res_ty
+tcOverloadedLit orig lit@(HsIsString s fr _) res_ty
| not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case
= do { str_ty <- tcMetaTy stringTyConName
; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
- ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) }
+ ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) }
| Just expr <- shortCutStringLit s res_ty
- = return (HsIsString s expr)
+ = return (HsIsString s expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
- ; return (HsIsString s expr) }
+ ; return (HsIsString s expr res_ty) }
newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
newLitInst orig lit res_ty -- Make a LitInst
polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
= hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
- 4 (ppr sig_ty)
+ 2 (ppr sig_ty)
badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
+existentialProcPat :: DataCon -> SDoc
+existentialProcPat con
+ = hang (ptext SLIT("Illegal constructor") <+> quotes (ppr con) <+> ptext SLIT("in a 'proc' pattern"))
+ 2 (ptext SLIT("Proc patterns cannot use existentials or GADTs"))
+
lazyPatErr pat tvs
= failWithTc $
hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))