TcPat.lhs 15.5 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
%
\section[TcPat]{Typechecking patterns}

\begin{code}
7
module TcPat ( tcPat, tcPatBndr_NoSigs, badFieldCon, polyPatSig ) where
8

9
#include "HsVersions.h"
10

11
12
import {-# SOURCE #-}	TcExpr( tcExpr )

13
import HsSyn		( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
14
import RnHsSyn		( RenamedPat )
15
import TcHsSyn		( TcPat, TcId )
16

17
import TcMonad
18
import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
19
			  emptyLIE, plusLIE, LIE,
20
			  newMethod, newOverloadedLit, 
21
			  newDicts, instToIdBndr
22
			)
23
import Name		( Name, getOccName, getSrcLoc )
24
import FieldLabel	( fieldLabelName )
25
26
import TcEnv		( tcLookupValue, 
			  tcLookupValueByKey, newLocalId, badCon
27
28
			)
import TcType 		( TcType, TcTyVar, tcInstTyVars )
29
import TcMonoType	( tcHsType )
30
31
32
import TcUnify 		( unifyTauTy, unifyListTy,
			  unifyTupleTy, unifyUnboxedTupleTy
			)
33
34
35

import Bag		( Bag )
import CmdLineOpts	( opt_IrrefutableTuples )
36
import DataCon		( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity )
37
38
39
import Id		( Id, idType, isDataConId_maybe )
import Type		( Type, isTauTy, mkTyConApp )
import Subst		( substTy, substTheta )
40
41
42
import TysPrim		( charPrimTy, intPrimTy, floatPrimTy,
			  doublePrimTy, addrPrimTy
			)
43
44
45
46
47
import TysWiredIn	( charTy, stringTy, intTy )
import SrcLoc		( SrcLoc )
import Unique		( eqClassOpKey, geClassOpKey, minusClassOpKey )
import Bag
import Util		( zipEqual )
sof's avatar
sof committed
48
import Outputable
49
\end{code}
50

51
52
53
54
55
56
57
58

%************************************************************************
%*									*
\subsection{Variable patterns}
%*									*
%************************************************************************

\begin{code}
59
60
61
62
63
64
-- This is the right function to pass to tcPat when there are no signatures
tcPatBndr_NoSigs binder_name pat_ty
  =  	-- Need to make a new, monomorphic, Id
	-- The binder_name is already being used for the polymorphic Id
     newLocalId (getOccName binder_name) pat_ty loc	`thenNF_Tc` \ bndr_id ->
     returnTc bndr_id
65
66
 where
   loc = getSrcLoc binder_name
67
68
69
70
71
72
73
74
75
\end{code}


%************************************************************************
%*									*
\subsection{Typechecking patterns}
%*									*
%************************************************************************

76
\begin{code}
77
78
79
tcPat :: (Name -> TcType -> TcM s TcId)	-- How to construct a suitable (monomorphic)
					-- Id for variables found in the pattern
			         	-- The TcType is the expected type, see note below
80
      -> RenamedPat
81
82
83
84
85
86
87

      -> TcType		-- Expected type derived from the context
			--	In the case of a function with a rank-2 signature,
			--	this type might be a forall type.
			--	INVARIANT: if it is, the foralls will always be visible,
			--	not hidden inside a mutable type variable

88
89
90
91
92
93
94
      -> TcM s (TcPat, 
		LIE,			-- Required by n+k and literal pats
		Bag TcTyVar,	-- TyVars bound by the pattern
					-- 	These are just the existentially-bound ones.
					--	Any tyvars bound by *type signatures* in the
					-- 	patterns are brought into scope before we begin.
		Bag (Name, TcId),	-- Ids bound by the pattern, along with the Name under
95
96
97
					--	which it occurs in the pattern
					-- 	The two aren't the same because we conjure up a new
					-- 	local name for each variable.
98
99
		LIE)			-- Dicts or methods [see below] bound by the pattern
					-- 	from existential constructor patterns
100
101
\end{code}

102

103
104
105
106
107
108
109
%************************************************************************
%*									*
\subsection{Variables, wildcards, lazy pats, as-pats}
%*									*
%************************************************************************

\begin{code}
110
111
tcPat tc_bndr (VarPatIn name) pat_ty
  = tc_bndr name pat_ty		`thenTc` \ bndr_id ->
112
    returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
113

114
115
tcPat tc_bndr (LazyPatIn pat) pat_ty
  = tcPat tc_bndr pat pat_ty		`thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
116
    returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
117

118
119
120
tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
  = tc_bndr name pat_ty			`thenTc` \ bndr_id ->
    tcPat tc_bndr pat pat_ty		`thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
121
    tcAddErrCtxt (patCtxt pat_in) 	$
122
123
    returnTc (AsPat bndr_id pat', lie_req, 
	      tvs, (name, bndr_id) `consBag` ids, lie_avail)
124

125
tcPat tc_bndr WildPatIn pat_ty
126
  = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
127

128
129
tcPat tc_bndr (NegPatIn pat) pat_ty
  = tcPat tc_bndr (negate_lit pat) pat_ty
130
  where
131
132
133
134
135
136
    negate_lit (LitPatIn (HsInt  i))       = LitPatIn (HsInt  (-i))
    negate_lit (LitPatIn (HsIntPrim i))    = LitPatIn (HsIntPrim (-i))
    negate_lit (LitPatIn (HsFrac f))       = LitPatIn (HsFrac (-f))
    negate_lit (LitPatIn (HsFloatPrim f))  = LitPatIn (HsFloatPrim (-f))
    negate_lit (LitPatIn (HsDoublePrim f)) = LitPatIn (HsDoublePrim (-f))
    negate_lit _                           = panic "TcPat:negate_pat"
137

138
139
tcPat tc_bndr (ParPatIn parend_pat) pat_ty
  = tcPat tc_bndr parend_pat pat_ty
140

141
tcPat tc_bndr (SigPatIn pat sig) pat_ty
142
143
144
145
146
147
148
  = tcHsType sig					`thenTc` \ sig_ty ->

	-- Check that the signature isn't a polymorphic one, which
	-- we don't permit (at present, anyway)
    checkTc (isTauTy sig_ty) (polyPatSig sig_ty)	`thenTc_`

    unifyTauTy pat_ty sig_ty	`thenTc_`
149
    tcPat tc_bndr pat sig_ty
150
151
152
153
154
155
156
157
158
\end{code}

%************************************************************************
%*									*
\subsection{Explicit lists and tuples}
%*									*
%************************************************************************

\begin{code}
159
tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
160
161
  = tcAddErrCtxt (patCtxt pat_in)		$
    unifyListTy pat_ty				`thenTc` \ elem_ty ->
162
    tcPats tc_bndr pats (repeat elem_ty)	`thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
163
    returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
164

165
tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty
166
  = tcAddErrCtxt (patCtxt pat_in)	$
167

168
169
170
    (if boxed
     then unifyTupleTy        arity pat_ty
     else unifyUnboxedTupleTy arity pat_ty)	`thenTc` \ arg_tys ->
171

172
    tcPats tc_bndr pats arg_tys 	 		`thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
173
174
175

	-- possibly do the "make all tuple-pats irrefutable" test:
    let
176
	unmangled_result = TuplePat pats' boxed
177
178
179
180
181

	-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
	-- so that we can experiment with lazy tuple-matching.
	-- This is a pretty odd place to make the switch, but
	-- it was easy to do.
182

183
	possibly_mangled_result
184
185
	  | opt_IrrefutableTuples && boxed = LazyPat unmangled_result
	  | otherwise			   = unmangled_result
186
    in
187
188
189
    returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
  where
    arity = length pats
190
191
192
193
194
195
196
\end{code}

%************************************************************************
%*									*
\subsection{Other constructors}
%*									*

197
%************************************************************************
198
199

\begin{code}
200
201
tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
  = tcConPat tc_bndr pat name arg_pats pat_ty
202

203
204
tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
  = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
205
206
\end{code}

207

208
209
210
211
212
213
214
%************************************************************************
%*									*
\subsection{Records}
%*									*
%************************************************************************

\begin{code}
215
tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
216
  = tcAddErrCtxt (patCtxt pat)	$
217

218
219
220
221
222
223
 	-- Check the constructor itself
    tcConstructor pat name pat_ty	`thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
    let
	field_tys = zipEqual "tcPat" 
			     (map fieldLabelName (dataConFieldLabels data_con))
			     arg_tys
224
225
    in

226
227
	-- Check the fields
    tc_fields field_tys rpats		`thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
228

229
230
231
232
233
    returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
	      lie_req,
	      listToBag ex_tvs `unionBags` tvs,
	      ids,
	      lie_avail1 `plusLIE` lie_avail2)
234
235

  where
236
237
238
239
240
241
242
243
244
245
246
247
    tc_fields field_tys []
      = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)

    tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
      | null matching_fields
      = addErrTc (badFieldCon name field_label)		`thenNF_Tc_`
	tc_fields field_tys rpats

      | otherwise
      = ASSERT( null extras )
	tc_fields field_tys rpats	`thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->

248
	tcLookupValue field_label	`thenNF_Tc` \ sel_id ->
249
	tcPat tc_bndr rhs_pat rhs_ty	`thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
250
251
252
253
254
255
256
257
258

	returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
		  lie_req1 `plusLIE` lie_req2,
		  tvs1 `unionBags` tvs2,
		  ids1 `unionBags` ids2,
		  lie_avail1 `plusLIE` lie_avail2)
      where
 	matching_fields   = [ty | (f,ty) <- field_tys, f == field_label]
	(rhs_ty : extras) = matching_fields
259
260
\end{code}

261
262
263
264
265
266
267
%************************************************************************
%*									*
\subsection{Non-overloaded literals}
%*									*
%************************************************************************

\begin{code}
268
269
270
271
272
273
274
275
tcPat tc_bndr (LitPatIn lit@(HsChar _))       pat_ty = tcSimpleLitPat lit charTy       pat_ty
tcPat tc_bndr (LitPatIn lit@(HsIntPrim _))    pat_ty = tcSimpleLitPat lit intPrimTy    pat_ty
tcPat tc_bndr (LitPatIn lit@(HsCharPrim _))   pat_ty = tcSimpleLitPat lit charPrimTy   pat_ty
tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy   pat_ty
tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _))  pat_ty = tcSimpleLitPat lit floatPrimTy  pat_ty
tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty

tcPat tc_bndr (LitPatIn lit@(HsLitLit s))     pat_ty = tcSimpleLitPat lit intTy pat_ty
276
	-- This one looks weird!
277
278
279
280
281
282
283
284
285
\end{code}

%************************************************************************
%*									*
\subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
%*									*
%************************************************************************

\begin{code}
286
tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty
287
  = unifyTauTy pat_ty stringTy			`thenTc_` 
288
289
    tcLookupValueByKey eqClassOpKey		`thenNF_Tc` \ sel_id ->
    newMethod (PatOrigin pat) sel_id [stringTy]	`thenNF_Tc` \ (lie, eq_id) ->
290
291
292
293
    let
	comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
    in
    returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
294
295


296
tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty
297
  = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
298

299
tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty
300
  = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
301

302

303
304
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
  = tc_bndr name pat_ty				`thenTc` \ bndr_id ->
305
306
    tcLookupValueByKey geClassOpKey		`thenNF_Tc` \ ge_sel_id ->
    tcLookupValueByKey minusClassOpKey		`thenNF_Tc` \ minus_sel_id ->
307
308

    newOverloadedLit origin
309
		     (OverloadedIntegral i) pat_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
310

311
312
    newMethod origin ge_sel_id    [pat_ty]	`thenNF_Tc` \ (lie2, ge_id) ->
    newMethod origin minus_sel_id [pat_ty]	`thenNF_Tc` \ (lie3, minus_id) ->
313

314
    returnTc (NPlusKPat bndr_id lit pat_ty
sof's avatar
sof committed
315
316
			(SectionR (HsVar ge_id) over_lit_expr)
			(SectionR (HsVar minus_id) over_lit_expr),
317
	      lie1 `plusLIE` lie2 `plusLIE` lie3,
318
	      emptyBag, unitBag (name, bndr_id), emptyLIE)
319
  where
320
    origin = PatOrigin pat
321

322
tcPat tc_bndr (NPlusKPatIn pat other) pat_ty
323
  = panic "TcPat:NPlusKPat: not an HsInt literal"
324
325
326
327
328
329
330
331
\end{code}

%************************************************************************
%*									*
\subsection{Lists of patterns}
%*									*
%************************************************************************

332
333
Helper functions

334
\begin{code}
335
336
tcPats :: (Name -> TcType -> TcM s TcId)	-- How to deal with variables
       -> [RenamedPat] -> [TcType]		-- Excess 'expected types' discarded
337
338
339
340
341
       -> TcM s ([TcPat], 
		 LIE,				-- Required by n+k and literal pats
		 Bag TcTyVar,
		 Bag (Name, TcId),	-- Ids bound by the pattern
		 LIE)				-- Dicts bound by the pattern
342

343
tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
344

345
346
347
tcPats tc_bndr (ty:tys) (pat:pats)
  = tcPat tc_bndr ty pat		`thenTc` \ (pat',  lie_req1, tvs1, ids1, lie_avail1) ->
    tcPats tc_bndr tys pats	`thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
348
349
350
351
352

    returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
	      tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, 
	      lie_avail1 `plusLIE` lie_avail2)
\end{code}
353

354
355
356
357
358
------------------------------------------------------
\begin{code}
tcSimpleLitPat lit lit_ty pat_ty
  = unifyTauTy pat_ty lit_ty	`thenTc_` 
    returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
359
360


361
362
tcOverloadedLitPat pat lit over_lit pat_ty
  = newOverloadedLit (PatOrigin pat) over_lit pat_ty	`thenNF_Tc` \ (over_lit_expr, lie1) ->
363
364
    tcLookupValueByKey eqClassOpKey			`thenNF_Tc` \ eq_sel_id ->
    newMethod origin eq_sel_id [pat_ty]			`thenNF_Tc` \ (lie2, eq_id) ->
365

366
367
368
369
370
371
372
    returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
				     over_lit_expr),
	      lie1 `plusLIE` lie2,
	      emptyBag, emptyBag, emptyLIE)
  where
    origin = PatOrigin pat
\end{code}
373

374
------------------------------------------------------
375
\begin{code}
376
377
tcConstructor pat con_name pat_ty
  = 	-- Check that it's a constructor
378
    tcLookupValue con_name		`thenNF_Tc` \ con_id ->
379
380
381
382
383
384
385
386
    case isDataConId_maybe con_id of {
	Nothing -> failWithTc (badCon con_id);
 	Just data_con ->

	-- Instantiate it
    let 
	(tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
	     -- Ignore the theta; overloaded constructors only
387
388
	     -- behave differently when called, not when used for
	     -- matching.
389
390
391
    in
    tcInstTyVars (ex_tvs ++ tvs)	`thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
    let
392
393
	ex_theta' = substTheta tenv ex_theta
	arg_tys'  = map (substTy tenv) arg_tys
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409

	n_ex_tvs  = length ex_tvs
	ex_tvs'   = take n_ex_tvs all_tvs'
	result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
    in
    newDicts (PatOrigin pat) ex_theta'	`thenNF_Tc` \ (lie_avail, dicts) ->

	-- Check overall type matches
    unifyTauTy pat_ty result_ty		`thenTc_`

    returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
    }
\end{code}	      

------------------------------------------------------
\begin{code}
410
tcConPat tc_bndr pat con_name arg_pats pat_ty
411
412
413
414
415
416
  = tcAddErrCtxt (patCtxt pat)	$

	-- Check the constructor itself
    tcConstructor pat con_name pat_ty	`thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->

	-- Check correct arity
417
    let
418
419
	con_arity  = dataConSourceArity data_con
	no_of_args = length arg_pats
420
    in
421
    checkTc (con_arity == no_of_args)
422
423
424
	    (arityErr "Constructor" data_con con_arity no_of_args)	`thenTc_`

	-- Check arguments
425
    tcPats tc_bndr arg_pats arg_tys'	`thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
426

427
428
429
430
431
    returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
	      lie_req,
	      listToBag ex_tvs' `unionBags` tvs,
	      ids,
	      lie_avail1 `plusLIE` lie_avail2)
432
433
434
\end{code}


435
436
437
438
439
440
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

441
\begin{code}
442
443
patCtxt pat = hang (ptext SLIT("In the pattern:")) 
		 4 (ppr pat)
444

445
446
recordLabel field_label
  = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
sof's avatar
sof committed
447
	 4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
448

449
recordRhs field_label pat
sof's avatar
sof committed
450
  = hang (ptext SLIT("In the record field pattern"))
451
	 4 (sep [ppr field_label, char '=', ppr pat])
452

453
454
badFieldCon :: Name -> Name -> SDoc
badFieldCon con field
455
  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
456
	  ptext SLIT("does not have field"), quotes (ppr field)]
457
458
459
460
461

polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
  = hang (ptext SLIT("Polymorphic type signature in pattern"))
	 4 (ppr sig_ty)
462
\end{code}
463