2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcPat]{Typechecking patterns}
7 module TcPat ( tcPat, tcPatBndr_NoSigs, badFieldCon, polyPatSig ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} TcExpr( tcExpr )
13 import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
14 import RnHsSyn ( RenamedPat )
15 import TcHsSyn ( TcPat, TcId )
18 import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
19 emptyLIE, plusLIE, LIE,
20 newMethod, newOverloadedLit, newDicts, newClassDicts
22 import Name ( Name, getOccName, getSrcLoc )
23 import FieldLabel ( fieldLabelName )
24 import TcEnv ( tcLookupValue, tcLookupClassByKey,
25 tcLookupValueByKey, newLocalId, badCon
27 import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
28 import TcMonoType ( tcHsSigType )
29 import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy )
31 import CmdLineOpts ( opt_IrrefutableTuples )
32 import DataCon ( DataCon, dataConSig, dataConFieldLabels,
35 import Id ( Id, idType, isDataConWrapId_maybe )
36 import Type ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind )
37 import PprType ( {- instance Outputable Type -} )
38 import Subst ( substTy, substClasses )
39 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
40 doublePrimTy, addrPrimTy
42 import TysWiredIn ( charTy, stringTy, intTy )
43 import SrcLoc ( SrcLoc )
44 import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey,
47 import BasicTypes ( isBoxed )
49 import Util ( zipEqual )
54 %************************************************************************
56 \subsection{Variable patterns}
58 %************************************************************************
61 -- This is the right function to pass to tcPat when there are no signatures
62 tcPatBndr_NoSigs binder_name pat_ty
63 = -- Need to make a new, monomorphic, Id
64 -- The binder_name is already being used for the polymorphic Id
65 newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id ->
68 loc = getSrcLoc binder_name
72 %************************************************************************
74 \subsection{Typechecking patterns}
76 %************************************************************************
79 tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorphic)
80 -- Id for variables found in the pattern
81 -- The TcType is the expected type, see note below
84 -> TcType -- Expected type derived from the context
85 -- In the case of a function with a rank-2 signature,
86 -- this type might be a forall type.
87 -- INVARIANT: if it is, the foralls will always be visible,
88 -- not hidden inside a mutable type variable
91 LIE, -- Required by n+k and literal pats
92 Bag TcTyVar, -- TyVars bound by the pattern
93 -- These are just the existentially-bound ones.
94 -- Any tyvars bound by *type signatures* in the
95 -- patterns are brought into scope before we begin.
96 Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under
97 -- which it occurs in the pattern
98 -- The two aren't the same because we conjure up a new
99 -- local name for each variable.
100 LIE) -- Dicts or methods [see below] bound by the pattern
101 -- from existential constructor patterns
105 %************************************************************************
107 \subsection{Variables, wildcards, lazy pats, as-pats}
109 %************************************************************************
112 tcPat tc_bndr (VarPatIn name) pat_ty
113 = tc_bndr name pat_ty `thenTc` \ bndr_id ->
114 returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
116 tcPat tc_bndr (LazyPatIn pat) pat_ty
117 = tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
118 returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
120 tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
121 = tc_bndr name pat_ty `thenTc` \ bndr_id ->
122 tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
123 tcAddErrCtxt (patCtxt pat_in) $
124 returnTc (AsPat bndr_id pat', lie_req,
125 tvs, (name, bndr_id) `consBag` ids, lie_avail)
127 tcPat tc_bndr WildPatIn pat_ty
128 = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
130 tcPat tc_bndr (NegPatIn pat) pat_ty
131 = tcPat tc_bndr (negate_lit pat) pat_ty
133 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
134 negate_lit (LitPatIn (HsIntPrim i)) = LitPatIn (HsIntPrim (-i))
135 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
136 negate_lit (LitPatIn (HsFloatPrim f)) = LitPatIn (HsFloatPrim (-f))
137 negate_lit (LitPatIn (HsDoublePrim f)) = LitPatIn (HsDoublePrim (-f))
138 negate_lit _ = panic "TcPat:negate_pat"
140 tcPat tc_bndr (ParPatIn parend_pat) pat_ty
141 = tcPat tc_bndr parend_pat pat_ty
143 tcPat tc_bndr (SigPatIn pat sig) pat_ty
144 = tcHsSigType sig `thenTc` \ sig_ty ->
146 -- Check that the signature isn't a polymorphic one, which
147 -- we don't permit (at present, anyway)
148 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
150 unifyTauTy pat_ty sig_ty `thenTc_`
151 tcPat tc_bndr pat sig_ty
154 %************************************************************************
156 \subsection{Explicit lists and tuples}
158 %************************************************************************
161 tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
162 = tcAddErrCtxt (patCtxt pat_in) $
163 unifyListTy pat_ty `thenTc` \ elem_ty ->
164 tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
165 returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
167 tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
168 = tcAddErrCtxt (patCtxt pat_in) $
170 unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys ->
171 tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
173 -- possibly do the "make all tuple-pats irrefutable" test:
175 unmangled_result = TuplePat pats' boxity
177 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
178 -- so that we can experiment with lazy tuple-matching.
179 -- This is a pretty odd place to make the switch, but
180 -- it was easy to do.
182 possibly_mangled_result
183 | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
184 | otherwise = unmangled_result
186 returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
191 %************************************************************************
193 \subsection{Other constructors}
196 %************************************************************************
199 tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
200 = tcConPat tc_bndr pat name arg_pats pat_ty
202 tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
203 = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
207 %************************************************************************
211 %************************************************************************
214 tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
215 = tcAddErrCtxt (patCtxt pat) $
217 -- Check the constructor itself
218 tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
220 field_tys = zipEqual "tcPat"
221 (map fieldLabelName (dataConFieldLabels data_con))
226 tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
228 returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
230 listToBag ex_tvs `unionBags` tvs,
232 lie_avail1 `plusLIE` lie_avail2)
235 tc_fields field_tys []
236 = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
238 tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
239 = tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
241 (case [ty | (f,ty) <- field_tys, f == field_label] of
243 -- No matching field; chances are this field label comes from some
244 -- other record type (or maybe none). As well as reporting an
245 -- error we still want to typecheck the pattern, principally to
246 -- make sure that all the variables it binds are put into the
247 -- environment, else the type checker crashes later:
248 -- f (R { foo = (a,b) }) = a+b
249 -- If foo isn't one of R's fields, we don't want to crash when
250 -- typechecking the "a+b".
251 [] -> addErrTc (badFieldCon name field_label) `thenNF_Tc_`
252 newTyVarTy boxedTypeKind `thenNF_Tc_`
253 returnTc (error "Bogus selector Id", pat_ty)
255 -- The normal case, when the field comes from the right constructor
257 ASSERT( null extras )
258 tcLookupValue field_label `thenNF_Tc` \ sel_id ->
259 returnTc (sel_id, pat_ty)
260 ) `thenTc` \ (sel_id, pat_ty) ->
262 tcPat tc_bndr rhs_pat pat_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
264 returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
265 lie_req1 `plusLIE` lie_req2,
266 tvs1 `unionBags` tvs2,
267 ids1 `unionBags` ids2,
268 lie_avail1 `plusLIE` lie_avail2)
271 %************************************************************************
273 \subsection{Non-overloaded literals}
275 %************************************************************************
278 tcPat tc_bndr (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty
279 tcPat tc_bndr (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty
280 tcPat tc_bndr (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty
281 tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty
282 tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
283 tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
285 tcPat tc_bndr (LitPatIn lit@(HsLitLit s)) pat_ty
286 -- cf tcExpr on LitLits
287 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
288 newDicts (LitLitOrigin (_UNPK_ s))
289 [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) ->
290 returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
293 %************************************************************************
295 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
297 %************************************************************************
300 tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty
301 = unifyTauTy pat_ty stringTy `thenTc_`
302 tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
303 newMethod (PatOrigin pat) sel_id [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
305 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
307 returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
310 tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty
311 = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
313 tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty
314 = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
317 tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
318 = tc_bndr name pat_ty `thenTc` \ bndr_id ->
319 tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
320 tcLookupValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
322 newOverloadedLit origin
323 (OverloadedIntegral i) pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
325 newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) ->
326 newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) ->
328 returnTc (NPlusKPat bndr_id lit pat_ty
329 (SectionR (HsVar ge_id) over_lit_expr)
330 (SectionR (HsVar minus_id) over_lit_expr),
331 lie1 `plusLIE` lie2 `plusLIE` lie3,
332 emptyBag, unitBag (name, bndr_id), emptyLIE)
334 origin = PatOrigin pat
336 tcPat tc_bndr (NPlusKPatIn pat other) pat_ty
337 = panic "TcPat:NPlusKPat: not an HsInt literal"
340 %************************************************************************
342 \subsection{Lists of patterns}
344 %************************************************************************
349 tcPats :: (Name -> TcType -> TcM s TcId) -- How to deal with variables
350 -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
352 LIE, -- Required by n+k and literal pats
354 Bag (Name, TcId), -- Ids bound by the pattern
355 LIE) -- Dicts bound by the pattern
357 tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
359 tcPats tc_bndr (ty:tys) (pat:pats)
360 = tcPat tc_bndr ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) ->
361 tcPats tc_bndr tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
363 returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
364 tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
365 lie_avail1 `plusLIE` lie_avail2)
368 ------------------------------------------------------
370 tcSimpleLitPat lit lit_ty pat_ty
371 = unifyTauTy pat_ty lit_ty `thenTc_`
372 returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
375 tcOverloadedLitPat pat lit over_lit pat_ty
376 = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
377 tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
378 newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) ->
380 returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
383 emptyBag, emptyBag, emptyLIE)
385 origin = PatOrigin pat
388 ------------------------------------------------------
390 tcConstructor pat con_name pat_ty
391 = -- Check that it's a constructor
392 tcLookupValue con_name `thenNF_Tc` \ con_id ->
393 case isDataConWrapId_maybe con_id of {
394 Nothing -> failWithTc (badCon con_id);
399 (tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
400 -- Ignore the theta; overloaded constructors only
401 -- behave differently when called, not when used for
404 tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
406 ex_theta' = substClasses tenv ex_theta
407 arg_tys' = map (substTy tenv) arg_tys
409 n_ex_tvs = length ex_tvs
410 ex_tvs' = take n_ex_tvs all_tvs'
411 result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
413 newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) ->
415 -- Check overall type matches
416 unifyTauTy pat_ty result_ty `thenTc_`
418 returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
422 ------------------------------------------------------
424 tcConPat tc_bndr pat con_name arg_pats pat_ty
425 = tcAddErrCtxt (patCtxt pat) $
427 -- Check the constructor itself
428 tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
430 -- Check correct arity
432 con_arity = dataConSourceArity data_con
433 no_of_args = length arg_pats
435 checkTc (con_arity == no_of_args)
436 (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
439 tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
441 returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
443 listToBag ex_tvs' `unionBags` tvs,
445 lie_avail1 `plusLIE` lie_avail2)
449 %************************************************************************
451 \subsection{Errors and contexts}
453 %************************************************************************
456 patCtxt pat = hang (ptext SLIT("In the pattern:"))
459 recordLabel field_label
460 = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
461 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
463 recordRhs field_label pat
464 = hang (ptext SLIT("In the record field pattern"))
465 4 (sep [ppr field_label, char '=', ppr pat])
467 badFieldCon :: Name -> Name -> SDoc
468 badFieldCon con field
469 = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
470 ptext SLIT("does not have field"), quotes (ppr field)]
472 polyPatSig :: TcType -> SDoc
474 = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))