2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcPat]{Typechecking patterns}
7 module TcPat ( tcPat, tcVarPat, 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, newMethodWithGivenTy, newOverloadedLit,
21 newDicts, instToIdBndr
23 import Name ( Name, getOccName, getSrcLoc )
24 import FieldLabel ( fieldLabelName )
25 import TcEnv ( tcLookupValue,
26 tcLookupValueByKey, newLocalId, badCon
28 import TcType ( TcType, TcTyVar, tcInstTyVars )
29 import TcMonoType ( tcHsType )
30 import TcUnify ( unifyTauTy, unifyListTy,
31 unifyTupleTy, unifyUnboxedTupleTy
35 import CmdLineOpts ( opt_IrrefutableTuples )
36 import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity )
37 import Id ( Id, mkUserId, idType, isDataConId_maybe )
38 import Type ( Type, isTauTy, substTopTy, substTopTheta, mkTyConApp )
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 )
46 import Util ( zipEqual )
51 %************************************************************************
53 \subsection{Variable patterns}
55 %************************************************************************
58 tcVarPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic*
59 -- Id for variables with a type signature
62 -> TcType -- Expected type, derived from the context
63 -- In the case of a function with a rank-2 signature,
64 -- this type might be a forall type.
65 -- INVARIANT: if it is, the foralls will always be visible,
66 -- not hidden inside a mutable type variable
68 -> TcM s TcId -- The monomorphic Id; this is put in the pattern itself
70 tcVarPat sig_fn binder_name pat_ty
71 = case sig_fn binder_name of
72 Nothing -> -- Need to make a new, monomorphic, Id
73 -- The binder_name is already being used for the polymorphic Id
74 newLocalId (getOccName binder_name) pat_ty loc `thenNF_Tc` \ bndr_id ->
77 Just bndr_id -> tcAddSrcLoc loc $
78 unifyTauTy (idType bndr_id) pat_ty `thenTc_`
81 loc = getSrcLoc binder_name
85 %************************************************************************
87 \subsection{Typechecking patterns}
89 %************************************************************************
92 tcPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic*
93 -- Id for variables with a type signature
95 -> TcType -- Expected type; see invariant in tcVarPat
97 LIE, -- Required by n+k and literal pats
98 Bag TcTyVar, -- TyVars bound by the pattern
99 -- These are just the existentially-bound ones.
100 -- Any tyvars bound by *type signatures* in the
101 -- patterns are brought into scope before we begin.
102 Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under
103 -- which it occurs in the pattern
104 -- The two aren't the same because we conjure up a new
105 -- local name for each variable.
106 LIE) -- Dicts or methods [see below] bound by the pattern
107 -- from existential constructor patterns
111 %************************************************************************
113 \subsection{Variables, wildcards, lazy pats, as-pats}
115 %************************************************************************
118 tcPat sig_fn (VarPatIn name) pat_ty
119 = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
120 returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
122 tcPat sig_fn (LazyPatIn pat) pat_ty
123 = tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
124 returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
126 tcPat sig_fn pat_in@(AsPatIn name pat) pat_ty
127 = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
128 tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
129 tcAddErrCtxt (patCtxt pat_in) $
130 returnTc (AsPat bndr_id pat', lie_req,
131 tvs, (name, bndr_id) `consBag` ids, lie_avail)
133 tcPat sig_fn WildPatIn pat_ty
134 = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
136 tcPat sig_fn (NegPatIn pat) pat_ty
137 = tcPat sig_fn (negate_lit pat) pat_ty
139 negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
140 negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
141 negate_lit _ = panic "TcPat:negate_pat"
143 tcPat sig_fn (ParPatIn parend_pat) pat_ty
144 = tcPat sig_fn parend_pat pat_ty
146 tcPat sig_fn (SigPatIn pat sig) pat_ty
147 = tcHsType sig `thenTc` \ sig_ty ->
149 -- Check that the signature isn't a polymorphic one, which
150 -- we don't permit (at present, anyway)
151 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
153 unifyTauTy pat_ty sig_ty `thenTc_`
154 tcPat sig_fn pat sig_ty
157 %************************************************************************
159 \subsection{Explicit lists and tuples}
161 %************************************************************************
164 tcPat sig_fn pat_in@(ListPatIn pats) pat_ty
165 = tcAddErrCtxt (patCtxt pat_in) $
166 unifyListTy pat_ty `thenTc` \ elem_ty ->
167 tcPats sig_fn pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
168 returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
170 tcPat sig_fn pat_in@(TuplePatIn pats boxed) pat_ty
171 = tcAddErrCtxt (patCtxt pat_in) $
174 then unifyTupleTy arity pat_ty
175 else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys ->
177 tcPats sig_fn pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
179 -- possibly do the "make all tuple-pats irrefutable" test:
181 unmangled_result = TuplePat pats' boxed
183 -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
184 -- so that we can experiment with lazy tuple-matching.
185 -- This is a pretty odd place to make the switch, but
186 -- it was easy to do.
188 possibly_mangled_result
189 | opt_IrrefutableTuples && boxed = LazyPat unmangled_result
190 | otherwise = unmangled_result
192 returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
197 %************************************************************************
199 \subsection{Other constructors}
202 %************************************************************************
205 tcPat sig_fn pat@(ConPatIn name arg_pats) pat_ty
206 = tcConPat sig_fn pat name arg_pats pat_ty
208 tcPat sig_fn pat@(ConOpPatIn pat1 op _ pat2) pat_ty
209 = tcConPat sig_fn pat op [pat1, pat2] pat_ty
213 %************************************************************************
217 %************************************************************************
220 tcPat sig_fn pat@(RecPatIn name rpats) pat_ty
221 = tcAddErrCtxt (patCtxt pat) $
223 -- Check the constructor itself
224 tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
226 field_tys = zipEqual "tcPat"
227 (map fieldLabelName (dataConFieldLabels data_con))
232 tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
234 returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
236 listToBag ex_tvs `unionBags` tvs,
238 lie_avail1 `plusLIE` lie_avail2)
241 tc_fields field_tys []
242 = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
244 tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
245 | null matching_fields
246 = addErrTc (badFieldCon name field_label) `thenNF_Tc_`
247 tc_fields field_tys rpats
250 = ASSERT( null extras )
251 tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
253 tcLookupValue field_label `thenNF_Tc` \ sel_id ->
254 tcPat sig_fn rhs_pat rhs_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
256 returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
257 lie_req1 `plusLIE` lie_req2,
258 tvs1 `unionBags` tvs2,
259 ids1 `unionBags` ids2,
260 lie_avail1 `plusLIE` lie_avail2)
262 matching_fields = [ty | (f,ty) <- field_tys, f == field_label]
263 (rhs_ty : extras) = matching_fields
266 %************************************************************************
268 \subsection{Non-overloaded literals}
270 %************************************************************************
273 tcPat sig_fn (LitPatIn lit@(HsChar _)) pat_ty = tcSimpleLitPat lit charTy pat_ty
274 tcPat sig_fn (LitPatIn lit@(HsIntPrim _)) pat_ty = tcSimpleLitPat lit intPrimTy pat_ty
275 tcPat sig_fn (LitPatIn lit@(HsCharPrim _)) pat_ty = tcSimpleLitPat lit charPrimTy pat_ty
276 tcPat sig_fn (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy pat_ty
277 tcPat sig_fn (LitPatIn lit@(HsFloatPrim _)) pat_ty = tcSimpleLitPat lit floatPrimTy pat_ty
278 tcPat sig_fn (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
280 tcPat sig_fn (LitPatIn lit@(HsLitLit s)) pat_ty = tcSimpleLitPat lit intTy pat_ty
281 -- This one looks weird!
284 %************************************************************************
286 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
288 %************************************************************************
291 tcPat sig_fn pat@(LitPatIn lit@(HsString str)) pat_ty
292 = unifyTauTy pat_ty stringTy `thenTc_`
293 tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
294 newMethod (PatOrigin pat) sel_id [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
296 comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
298 returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
301 tcPat sig_fn pat@(LitPatIn lit@(HsInt i)) pat_ty
302 = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
304 tcPat sig_fn pat@(LitPatIn lit@(HsFrac f)) pat_ty
305 = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
308 tcPat sig_fn pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
309 = tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
310 tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
311 tcLookupValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
313 newOverloadedLit origin
314 (OverloadedIntegral i) pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
316 newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) ->
317 newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) ->
319 returnTc (NPlusKPat bndr_id lit pat_ty
320 (SectionR (HsVar ge_id) over_lit_expr)
321 (SectionR (HsVar minus_id) over_lit_expr),
322 lie1 `plusLIE` lie2 `plusLIE` lie3,
323 emptyBag, unitBag (name, bndr_id), emptyLIE)
325 origin = PatOrigin pat
327 tcPat sig_fn (NPlusKPatIn pat other) pat_ty
328 = panic "TcPat:NPlusKPat: not an HsInt literal"
331 %************************************************************************
333 \subsection{Lists of patterns}
335 %************************************************************************
340 tcPats :: (Name -> Maybe TcId) -- Info about signatures
341 -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
343 LIE, -- Required by n+k and literal pats
345 Bag (Name, TcId), -- Ids bound by the pattern
346 LIE) -- Dicts bound by the pattern
348 tcPats sig_fn [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
350 tcPats sig_fn (ty:tys) (pat:pats)
351 = tcPat sig_fn ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) ->
352 tcPats sig_fn tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
354 returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
355 tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
356 lie_avail1 `plusLIE` lie_avail2)
359 ------------------------------------------------------
361 tcSimpleLitPat lit lit_ty pat_ty
362 = unifyTauTy pat_ty lit_ty `thenTc_`
363 returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
366 tcOverloadedLitPat pat lit over_lit pat_ty
367 = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
368 tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
369 newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) ->
371 returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
374 emptyBag, emptyBag, emptyLIE)
376 origin = PatOrigin pat
379 ------------------------------------------------------
381 tcConstructor pat con_name pat_ty
382 = -- Check that it's a constructor
383 tcLookupValue con_name `thenNF_Tc` \ con_id ->
384 case isDataConId_maybe con_id of {
385 Nothing -> failWithTc (badCon con_id);
390 (tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
391 -- Ignore the theta; overloaded constructors only
392 -- behave differently when called, not when used for
395 tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
397 ex_theta' = substTopTheta tenv ex_theta
398 arg_tys' = map (substTopTy tenv) arg_tys
400 n_ex_tvs = length ex_tvs
401 ex_tvs' = take n_ex_tvs all_tvs'
402 result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
404 newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) ->
406 -- Check overall type matches
407 unifyTauTy pat_ty result_ty `thenTc_`
409 returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
413 ------------------------------------------------------
415 tcConPat sig_fn pat con_name arg_pats pat_ty
416 = tcAddErrCtxt (patCtxt pat) $
418 -- Check the constructor itself
419 tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
421 -- Check correct arity
423 con_arity = dataConSourceArity data_con
424 no_of_args = length arg_pats
426 checkTc (con_arity == no_of_args)
427 (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
430 tcPats sig_fn arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
432 returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
434 listToBag ex_tvs' `unionBags` tvs,
436 lie_avail1 `plusLIE` lie_avail2)
440 %************************************************************************
442 \subsection{Errors and contexts}
444 %************************************************************************
447 patCtxt pat = hang (ptext SLIT("In the pattern:"))
450 recordLabel field_label
451 = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
452 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
454 recordRhs field_label pat
455 = hang (ptext SLIT("In the record field pattern"))
456 4 (sep [ppr field_label, char '=', ppr pat])
458 badFieldCon :: Name -> Name -> SDoc
459 badFieldCon con field
460 = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
461 ptext SLIT("does not have field"), quotes (ppr field)]
463 polyPatSig :: TcType -> SDoc
465 = hang (ptext SLIT("Polymorphic type signature in pattern"))